X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=album.el;h=a50670b42b9d0f871e4bcc5ed67609eb13bb6839;hb=887eb63ca7a5981c0dadf60c6a17fee51d2303cd;hp=4ab34eb0a4749894b7bc309decf039845a8faec2;hpb=ecc538b9fbc92251aa538954b0ea10e4c5d4d1e8;p=elisp%2Falbum.git diff --git a/album.el b/album.el index 4ab34eb..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,23 +27,11 @@ ;;; 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 lang image-url-prefix +(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 "%s\n" file)) (insert "\n") (insert "\n") - (insert (format "

%s

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

%s

\n" file)) (if prev-file (insert (format "" prev-file))) @@ -97,14 +85,21 @@ (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 + (insert (format "\"%s\"" + (or image-url + (concat file ".jpg")) (if image-url-prefix - (format "%s/%s/%s" - image-url-prefix grade file) - file))) + (format "%s%s/%s" + (file-name-as-directory image-url-prefix) + grade + (or image-url file)) + (or image-url (concat file ".jpg"))))) (insert "
@@ -124,9 +119,10 @@ (expand-file-name (symbol-name grade) dest-dir))))) -(defun album-convert-image (image-dest-dir html-dest-dir lang - 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)) @@ -139,50 +135,27 @@ (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))) - (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 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" (format "%d%%" (aref (car dest) 0)) + "-resize" "160x160>" file (expand-file-name (concat @@ -191,33 +164,38 @@ (expand-file-name "thumbnail" image-dest-dir))) - (setq rest (cdr dest)) + (setq rest specs) (while rest (setq spec (car rest)) - (album-write-html html-dest-dir lang 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 "%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)) + image-dest-dir))) + (setq prev-grade (car spec))) (setq rest (cdr rest))) (unless (file-exists-p (expand-file-name "fullsize" image-dest-dir)) @@ -238,33 +216,35 @@ (expand-file-name "fullsize" image-dest-dir)))) dest)) -(defun album-convert-images (image-dest-dir html-dest-dir lang - image-url-prefix - &rest 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 lang image-url-prefix - source-images) + ;; (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 lang - 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-make-thumbnails (html-dest-dir lang image-url-prefix - source-images) - (let ((album - (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))) - file) +(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 (format "%s\n" album)) + (insert (format "%s\n" title)) (insert "\n") (insert "\n") - (insert (format "

%s

\n" album)) + (insert (format "

%s

\n" title)) (insert "
@@ -298,16 +278,22 @@ (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 html-dest-dir lang - image-url-prefix - source-dir &rest patterns) +(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) @@ -318,9 +304,81 @@ (let (case-fold-search) (directory-files source-dir 'full - ".+\\.\\(tiff\\|jpg\\|JPG\\|jpeg\\|gif\\|png\\)$")))) - (album-convert-images image-dest-dir html-dest-dir lang - 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))) + +(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)