(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 prev-file next-file prev-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))) (if prev-file (insert (format "" (file-name-sans-extension (file-name-nondirectory prev-file))))) (insert "[Previous]") (if prev-file (insert "")) (insert "\n") (if next-file (insert (format "" (file-name-sans-extension (file-name-nondirectory next-file))))) (insert "[Next]") (if next-file (insert "")) (insert "\n") (if prev-grade (insert (format "" prev-grade (file-name-nondirectory file-base)))) (insert "[Smaller]") (if prev-grade (insert "")) (insert "\n") (if next-grade (insert (format "" next-grade (file-name-nondirectory file-base)))) (insert "[Larger]") (if next-grade (insert "")) (insert "\n") (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 &optional prev-file next-file) (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)) prev-grade 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) prev-file next-file prev-grade (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 prev-grade (aref spec 1)) (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)) (let ((rest (append (directory-files "/archives/RAID2/koukotsu/TAKUHON/" t "^[^0-9].*\\.TIF$") (directory-files "/archives/RAID2/koukotsu/TAKUHON/" t "^[0-9].*\\.TIF$")) ;; (directory-files ;; "/archives/RAID2/koukotsu/TAKUHON/" t "\\.TIF$") ) file prev-file) (while rest (setq file (car rest)) (www-image-convert-images file prev-file (nth 1 rest)) (setq prev-file file rest (cdr rest))))