;;; album.el --- Photo album utility
-;; Copyright (C) 2005 MORIOKA Tomohiko
+;; Copyright (C) 2005,2006 MORIOKA Tomohiko
;; Keywords: Photo, image, album, HTML, WWW
;;; 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
"<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
\"http://www.w3.org/TR/html4/loose.dtd\">\n")
+ (insert "<html")
+ (if lang
+ (insert (format " lang=\"%s\"" lang)))
+ (insert " />\n")
(insert "<head>\n")
(insert (format "<title>%s</title>\n" file))
(insert "</head>\n")
(insert "<body>\n")
- (insert (format "<h1>%s</h1>\n" file))
+ ;; (insert (format "<h1>%s</h1>\n" file))
(if prev-file
(insert (format "<a href=\"%s.html\">" prev-file)))
(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 "<img alt=\"%s\" src=\"%s.jpg\">" file file))
+ (insert (format "<img alt=\"%s\" src=\"%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 "</a>
<hr>
+<a href=\"../index.html\">[index]</a>
+
</body>
</html>
")
(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)
(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-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
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
+ \"http://www.w3.org/TR/html4/loose.dtd\">\n")
+ (insert "<html")
+ (if lang
+ (insert (format " lang=\"%s\"" lang)))
+ (insert ">\n")
+ (insert "<head>\n")
+ (insert (format "<title>%s</title>\n" title))
+ (insert "</head>\n")
+ (insert "<body>\n")
+ (insert (format "<h1>%s</h1>\n" title))
+
+ (insert "
+<hr>
+")
+ (dolist (image-file source-images)
+ (setq file (file-name-sans-extension
+ (file-name-nondirectory image-file)))
+ (insert "<a href=\"VGA/")
+ (insert file)
+ (insert ".html\">")
+ (insert (format "<img alt=\"%s\" src=\"thumbnail/%s.jpg\">"
+ file
+ (if image-url-prefix
+ (format "%s/%s/%s"
+ image-url-prefix grade file)
+ file)))
+ (insert "</a>\n"))
+ (insert "
+
+<hr>
+")
+ (if parent-url
+ (insert (format "[<a href=\"%s\">Return</a>]\n" parent-url)))
+
+ (insert "
+</body>
+</html>
+")
+ (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
projects / elisp / album.git / blobdiff