X-Git-Url: http://git.chise.org/gitweb/?p=elisp%2Falbum.git;a=blobdiff_plain;f=album.el;h=a50670b42b9d0f871e4bcc5ed67609eb13bb6839;hp=0d7ac012f6e9c174a5ebfb6dc3304d22a5efa155;hb=12644c947ac6397c80c006f0406785298c5bcd87;hpb=d921439af45af559c6c2c3b73ece324c1e998371 diff --git a/album.el b/album.el index 0d7ac01..a50670b 100644 --- a/album.el +++ b/album.el @@ -1,6 +1,6 @@ ;;; album.el --- Photo album utility -;; Copyright (C) 2005 MORIOKA Tomohiko +;; Copyright (C) 2005,2006 MORIOKA Tomohiko ;; Keywords: Photo, image, album, HTML, WWW @@ -27,32 +27,24 @@ ;;; Code: -(defun album-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 album-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 album-write-html (dest-dir prev-file file next-file - prev-grade grade next-grade) + prev-grade grade next-grade + lang image-url-prefix + &optional image-url) (with-temp-buffer (insert "\n") + (insert "\n") (insert "\n") (insert (format "%s\n" file)) (insert "\n") (insert "\n") - (insert (format "

%s

\n" file)) + ;; (insert (format "

%s

\n" file)) (if prev-file (insert (format "" prev-file))) @@ -93,13 +85,27 @@ (insert (if next-grade (format "../%s/%s.html" next-grade file) - (concat "../fullsize/" file ".jpg"))) + (if image-url + (concat (file-name-as-directory image-url-prefix) + "fullsize/" + image-url) + (concat "../fullsize/" file ".jpg")))) (insert "\">") - (insert (format " $\"%s\"$ " file file)) + (insert (format " $\"%s\"$ " + (or image-url + (concat file ".jpg")) + (if image-url-prefix + (format "%s%s/%s" + (file-name-as-directory image-url-prefix) + grade + (or image-url file)) + (or image-url (concat file ".jpg"))))) (insert "

+[index] + ") @@ -113,7 +119,13 @@ (expand-file-name (symbol-name grade) dest-dir))))) -(defun album-convert-image (dest-dir prev-file file next-file) +(defun album-convert-image (image-dest-dir + prev-file file next-file + lang image-url-prefix + html-dest-dir) + (setq file (expand-file-name file)) + (unless html-dest-dir + (setq html-dest-dir image-dest-dir)) (let* ((ret (with-temp-buffer (call-process "identify" nil t t file) @@ -123,102 +135,250 @@ (string-to-number (match-string 2)))))) (width (car ret)) (height (cdr ret)) + (specs '((QVGA 320 240) + (VGA 640 480) + (SVGA 800 600) + (XGA 1024 768) + (WXGA 1280 768) + (SXGA 1280 1024) + (SXGA+ 1400 1050) + (WSXGA+ 1680 1050) + (UXGA 1600 1200) + (WUXGA 1920 1200) + (QXGA 2048 1536) + (WQXGA 2560 1600) + )) prev-grade rest dest) - (cond ((>= width height) - (when (setq ret (album-make-spec-by-width width 2048 'QXGA)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-width width 1600 'UXGA)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-width width 1400 'SXGA+)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-width width 1280 'SXGA)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-width width 1024 'XGA)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-width width 800 'SVGA)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-width width 640 'VGA)) - (setq dest (cons ret dest))) - ) - (t - (when (setq ret (album-make-spec-by-height height 1536 'QXGA)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-height height 1200 'UXGA)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-height height 1050 'SXGA+)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-height height 960 'SXGA)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-height height 768 'XGA)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-height height 600 'SVGA)) - (setq dest (cons ret dest))) - (when (setq ret (album-make-spec-by-height height 480 'VGA)) - (setq dest (cons ret dest))) - )) - (setq rest dest) - (while rest - (setq spec (car rest)) - (album-write-html dest-dir - (if prev-file - (file-name-sans-extension - (file-name-nondirectory prev-file))) - (file-name-sans-extension - (file-name-nondirectory file)) - (if next-file - (file-name-sans-extension - (file-name-nondirectory next-file))) - prev-grade - (aref spec 1) - (if (nth 1 rest) - (aref (nth 1 rest) 1))) - (call-process "convert" nil nil nil - "-resize" (format "%d%%" (aref spec 0)) - file - (expand-file-name - (concat - (file-name-sans-extension - (file-name-nondirectory file)) ".jpg") - (expand-file-name - (symbol-name (aref spec 1)) - dest-dir))) - (setq prev-grade (aref spec 1)) - (setq rest (cdr rest))) (unless (file-exists-p - (expand-file-name "fullsize" dest-dir)) + (expand-file-name "thumbnail" image-dest-dir)) (make-directory - (expand-file-name "fullsize" dest-dir))) + (expand-file-name "thumbnail" image-dest-dir))) (call-process "convert" nil nil nil + "-resize" "160x160>" file (expand-file-name (concat (file-name-sans-extension (file-name-nondirectory file)) ".jpg") - (expand-file-name "fullsize" dest-dir))) + (expand-file-name + "thumbnail" + image-dest-dir))) + (setq rest specs) + (while rest + (setq spec (car rest)) + (when (or (> width (nth 1 spec)) + (> height (nth 2 spec))) + (album-write-html html-dest-dir + (if prev-file + (file-name-sans-extension + (file-name-nondirectory prev-file))) + (file-name-sans-extension + (file-name-nondirectory file)) + (if next-file + (file-name-sans-extension + (file-name-nondirectory next-file))) + prev-grade + (car spec) ; (aref spec 1) + (if (nth 1 rest) + ;; (aref (nth 1 rest) 1) + (car (nth 1 rest)) + ) + lang image-url-prefix) + (call-process "convert" nil nil nil + "-resize" (format "%dx%d>" (nth 1 spec)(nth 2 spec)) + file + (expand-file-name + (concat + (file-name-sans-extension + (file-name-nondirectory file)) ".jpg") + (expand-file-name + (symbol-name (car spec)) + image-dest-dir))) + (setq prev-grade (car spec))) + (setq rest (cdr rest))) + (unless (file-exists-p + (expand-file-name "fullsize" image-dest-dir)) + (make-directory + (expand-file-name "fullsize" image-dest-dir))) + (if (string= (downcase (file-name-extension file)) + "jpg") + (call-process "ln" nil nil nil + "-f" + file + (expand-file-name "fullsize" image-dest-dir)) + (call-process "convert" nil nil nil + file + (expand-file-name + (concat + (file-name-sans-extension + (file-name-nondirectory file)) ".jpg") + (expand-file-name "fullsize" image-dest-dir)))) dest)) -(defun album-convert-images (dest-dir &rest source-images) - (if (and (consp (car source-images)) - (null (cdr source-images))) - (setq source-images (car source-images))) +(defun album-convert-images (image-dest-dir source-images + &optional lang title parent-url + image-url-prefix html-dest-dir) + (unless html-dest-dir + (setq html-dest-dir image-dest-dir)) + ;; (if (and (consp (car source-images)) + ;; (null (cdr source-images))) + ;; (setq source-images (car source-images))) + (album-make-thumbnails html-dest-dir source-images + lang title image-url-prefix parent-url) (let (file prev-file) (while source-images (setq file (car source-images)) - (album-convert-image dest-dir - prev-file file (nth 1 source-images)) + (album-convert-image image-dest-dir + prev-file file (nth 1 source-images) + lang image-url-prefix html-dest-dir) (setq prev-file file source-images (cdr source-images))))) -(defun album-convert-directory (dest-dir source-dir &rest patterns) +(defun album-make-thumbnails (html-dest-dir + source-images + lang title image-url-prefix parent-url) + (unless title + (setq title + (file-name-nondirectory + (if (eq (aref html-dest-dir (1- (length html-dest-dir))) ?/) + (substring html-dest-dir 0 (1- (length html-dest-dir))) + html-dest-dir)))) + (let (file) + (with-temp-buffer + (insert + "\n") + (insert "\n") + (insert "\n") + (insert (format "%s\n" title)) + (insert "\n") + (insert "\n") + (insert (format "

%s

\n" title)) + + (insert " +

+") + (dolist (image-file source-images) + (setq file (file-name-sans-extension + (file-name-nondirectory image-file))) + (insert "") + (insert (format " $\"%s\"$ " + file + (if image-url-prefix + (format "%s/%s/%s" + image-url-prefix grade file) + file))) + (insert "\n")) + (insert " + +

+") + (if parent-url + (insert (format "[Return]\n" parent-url))) + + (insert " + + +") + (write-region (point-min)(point-max) + (expand-file-name "index.html" html-dest-dir))))) + +(defun album-convert-directory (image-dest-dir source-dir + &optional + patterns + lang title parent-url + image-url-prefix html-dest-dir) (let (files) (if patterns (dolist (pat patterns) (setq files (append files (directory-files source-dir 'full pat)))) - (setq files (directory-files source-dir 'full))) - (album-convert-images dest-dir files))) + (setq files + (let (case-fold-search) + (directory-files + source-dir 'full + ".+\\.\$tiff\\|TIFF\\|jpg\\|JPG\\|jpeg\\|JPEG\\|gif\\|GIF\\|png\\|PNG\$$")))) + (album-convert-images image-dest-dir files + lang title parent-url + image-url-prefix html-dest-dir))) + +(defun album-make-selection-1 (image-dest-dir + prev-file file next-file + lang image-url-prefix + html-dest-dir + &optional image-url-spec) + (setq file (expand-file-name file)) + (unless html-dest-dir + (setq html-dest-dir image-dest-dir)) + (let* ((specs '((QVGA 320 240) + (VGA 640 480) + (SVGA 800 600) + (XGA 1024 768) + (WXGA 1280 768) + (SXGA 1280 1024) + (SXGA+ 1400 1050) + (WSXGA+ 1680 1050) + (UXGA 1600 1200) + (WUXGA 1920 1200) + (QXGA 2048 1536) + (WQXGA 2560 1600) + )) + prev-grade + rest dest) + (setq rest specs) + (while rest + (setq spec (car rest)) + (album-write-html html-dest-dir + (if prev-file + (file-name-sans-extension + (file-name-nondirectory prev-file))) + (file-name-sans-extension + (file-name-nondirectory file)) + (if next-file + (file-name-sans-extension + (file-name-nondirectory next-file))) + prev-grade + (car spec) + (if (nth 1 rest) + (car (nth 1 rest))) + lang + (if image-url-spec + (nth 1 image-url-spec) + image-url-prefix) + (if image-url-spec + (nth 2 image-url-spec)) + ) + (setq prev-grade (car spec)) + (setq rest (cdr rest))) + dest)) + +(defun album-make-selection (image-dest-dir source-images + &optional lang title parent-url + image-url-prefix html-dest-dir) + (unless html-dest-dir + (setq html-dest-dir image-dest-dir)) + ;; (album-make-thumbnails html-dest-dir source-images + ;; lang title image-url-prefix parent-url) + (let ((i 1) + image-url-spec prev-file) + (while source-images + (setq image-url-spec (car source-images)) + (setq file (format "%d" i)) + (album-make-selection-1 image-dest-dir + prev-file file (if (nth 1 source-images) + (format "%d" (1+ i))) + lang image-url-prefix html-dest-dir + image-url-spec) + (setq prev-file file + source-images (cdr source-images)) + (setq i (1+ i))))) (provide 'album)