X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=album.el;h=b3323078b24b5a9cfbb3745409e57eeec6f642e3;hb=784f92d8626114de34439f035ea40c0998c42058;hp=529c188a702dd588484e43b15482991214a75637;hpb=722a5b3b3a52342b0d29bab46952b2c0075cb205;p=elisp%2Falbum.git diff --git a/album.el b/album.el index 529c188..b332307 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,37 @@ ;;; 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 image-url-prefix +;; (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) (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))) @@ -105,6 +110,8 @@

+[index] + ") @@ -118,8 +125,10 @@ (expand-file-name (symbol-name grade) dest-dir))))) -(defun album-convert-image (image-dest-dir html-dest-dir image-url-prefix - 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)) @@ -132,67 +141,112 @@ (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) + ;; (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))) + ;; (when (setq ret (album-make-spec-by-width width 320 'QVGA)) + ;; (setq dest (cons ret dest))) + ;; (when (setq ret (album-make-spec-by-width width 160 'thumbnail)) + ;; (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))) + ;; (when (setq ret (album-make-spec-by-height height 240 'QVGA)) + ;; (setq dest (cons ret dest))) + ;; (when (setq ret (album-make-spec-by-height height 160 'thumbnail)) + ;; (setq dest (cons ret dest))) + ;; )) + (unless (file-exists-p + (expand-file-name "thumbnail" image-dest-dir)) + (make-directory + (expand-file-name "thumbnail" image-dest-dir))) + (call-process "convert" nil nil nil + "-resize" "160x160>" ; (format "%d%%" (aref (car dest) 0)) + file + (expand-file-name + (concat + (file-name-sans-extension + (file-name-nondirectory file)) ".jpg") + (expand-file-name + "thumbnail" + image-dest-dir))) + (setq rest specs) + ;; (setq rest (cdr dest)) (while rest (setq spec (car rest)) - (album-write-html html-dest-dir image-url-prefix - (if prev-file - (file-name-sans-extension - (file-name-nondirectory prev-file))) + (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 "%d%%" (aref spec 0)) + (format "%dx%d>" (nth 1 spec)(nth 2 spec)) + file + (expand-file-name + (concat (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)) - image-dest-dir))) - (setq prev-grade (aref spec 1)) + (file-name-nondirectory file)) ".jpg") + (expand-file-name + (symbol-name (car spec) ; (aref spec 1) + ) + image-dest-dir))) + ;; (setq prev-grade (aref spec 1)) + (setq prev-grade (car spec)) + ) (setq rest (cdr rest))) (unless (file-exists-p (expand-file-name "fullsize" image-dest-dir)) @@ -213,24 +267,84 @@ (expand-file-name "fullsize" image-dest-dir)))) dest)) -(defun album-convert-images (image-dest-dir html-dest-dir - image-url-prefix - &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 image-dest-dir html-dest-dir - image-url-prefix - 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 (image-dest-dir html-dest-dir - image-url-prefix - 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) @@ -241,9 +355,10 @@ (let (case-fold-search) (directory-files source-dir 'full - ".+\\.\$tiff\\|jpg\\|JPG\\|jpeg\\|gif\\|png\$$")))) - (album-convert-images image-dest-dir html-dest-dir - image-url-prefix files))) + ".+\\.\$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))) (provide 'album)