From 6ae6da90f6cc2e120c06987bea5209f20afd5d4a Mon Sep 17 00:00:00 2001 From: tomo Date: Fri, 15 Apr 2005 13:45:21 +0000 Subject: [PATCH] New file. --- ChangeLog | 4 ++ www-image.el | 137 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 141 insertions(+) create mode 100644 ChangeLog create mode 100644 www-image.el diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..405ba52 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,4 @@ +2005-04-13 MORIOKA Tomohiko + + * www-image.el: New file. + diff --git a/www-image.el b/www-image.el new file mode 100644 index 0000000..d6b397b --- /dev/null +++ b/www-image.el @@ -0,0 +1,137 @@ +(defun www-image-make-spec-by-width (width limit spec-name) + (when (> width limit) + (let ((percent (floor (/ (* limit 100.0) width)))) + (vector percent spec-name + (/ (* width percent) 100.0) + (/ (* height percent) 100.0))))) + +(defun www-image-make-spec-by-height (height limit spec-name) + (when (> height limit) + (let ((percent (floor (/ (* limit 100.0) height)))) + (vector percent spec-name + (/ (* width percent) 100.0) + (/ (* height percent) 100.0))))) + +(defun www-image-write-html (file-base grade next-grade) + (with-temp-buffer + (insert + "\n") + (insert "\n") + (insert (format "%s\n" + (file-name-nondirectory file-base))) + (insert "\n") + (insert "\n") + (insert (format "

%s

\n" + (file-name-nondirectory file-base))) + (insert " +

+") + (insert "") + (insert (format " $\"%s\"$ " + (file-name-nondirectory file-base) + (file-name-nondirectory file-base))) + (insert " + +

+ + + +") + (unless (file-exists-p + (expand-file-name (symbol-name grade) + (file-name-directory file-base))) + (make-directory + (expand-file-name (symbol-name grade) + (file-name-directory file-base)))) + (write-region (point-min)(point-max) + (format "%s%s/%s.html" + (file-name-directory file-base) + grade + (file-name-nondirectory file-base))))) + +(defun www-image-convert-images (filename) + (let* ((ret + (with-temp-buffer + (call-process "identify" nil t t filename) + (goto-char (point-min)) + (and (re-search-forward " \$[0-9]+\$x\$[0-9]+\$ " nil t) + (cons (string-to-number (match-string 1)) + (string-to-number (match-string 2)))))) + (width (car ret)) + (height (cdr ret)) + rest dest) + (cond ((>= width height) + (when (setq ret (www-image-make-spec-by-width width 2048 'QXGA)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-width width 1600 'UXGA)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-width width 1400 'SXGA+)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-width width 1280 'SXGA)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-width width 1024 'XGA)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-width width 800 'SVGA)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-width width 640 'VGA)) + (setq dest (cons ret dest))) + ) + (t + (when (setq ret (www-image-make-spec-by-height height 1536 'QXGA)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-height height 1200 'UXGA)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-height height 1050 'SXGA+)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-height height 960 'SXGA)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-height height 768 'XGA)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-height height 600 'SVGA)) + (setq dest (cons ret dest))) + (when (setq ret (www-image-make-spec-by-height height 480 'VGA)) + (setq dest (cons ret dest))) + )) + (setq rest dest) + (while rest + (setq spec (car rest)) + (www-image-write-html (file-name-sans-extension filename) + (aref spec 1) + (if (nth 1 rest) + (aref (nth 1 rest) 1))) + (call-process "convert" nil nil nil + "-resize" (format "%d%%" (aref spec 0)) + filename + (format "%s/%s/%s.jpg" + (file-name-directory filename) + (aref spec 1) + (file-name-sans-extension + (file-name-nondirectory filename)))) + (setq rest (cdr rest))) + (unless (file-exists-p + (expand-file-name "fullsize" + (file-name-directory filename))) + (make-directory + (expand-file-name "fullsize" + (file-name-directory filename)))) + (call-process "convert" nil nil nil + filename + (format "%s/fullsize/%s.jpg" + (file-name-directory filename) + (file-name-sans-extension + (file-name-nondirectory filename)))) + dest)) + +(dolist (file + (directory-files + "/archives/RAID2/koukotsu/TAKUHON/" t "\\.TIF$")) + (www-image-convert-images file)) -- 1.7.10.4