;;; album.el --- Photo album utility
;; Copyright (C) 2005,2006 MORIOKA Tomohiko
;; Keywords: Photo, image, album, HTML, WWW
;; This file is part of Album.
;; Album is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; Album is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; It requires `convert' and `identify' of ImageMagick.
;;; Code:
(defun album-write-html (dest-dir
prev-file file next-file
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))
(if prev-file
(insert (format "" prev-file)))
(insert "[Previous]")
(if prev-file
(insert ""))
(insert "\n")
(if next-file
(insert (format "" next-file)))
(insert "[Next]")
(if next-file
(insert ""))
(insert "\n")
(if prev-grade
(insert (format ""
prev-grade
file)))
(insert "[Smaller]")
(if prev-grade
(insert ""))
(insert "\n")
(if next-grade
(insert (format ""
next-grade
file)))
(insert "[Larger]")
(if next-grade
(insert ""))
(insert "\n")
(insert "
")
(insert "")
(insert (format ""
(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]
")
(unless (file-exists-p
(expand-file-name (symbol-name grade) dest-dir))
(make-directory
(expand-file-name (symbol-name grade) dest-dir)))
(write-region (point-min)(point-max)
(expand-file-name
(concat file ".html")
(expand-file-name (symbol-name grade)
dest-dir)))))
(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)
(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))
(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)
(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>"
file
(expand-file-name
(concat
(file-name-sans-extension
(file-name-nondirectory file)) ".jpg")
(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 (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
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
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 ""
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
(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)
;;; album.el ends here