--- /dev/null
+;;; album.el --- Photo album utility
+
+;; Copyright (C) 2004 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:
+
+;; This facility is documented in the Emacs Manual.
+
+;;; 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)
+ (with-temp-buffer
+ (insert
+ "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
+ \"http://www.w3.org/TR/html4/loose.dtd\">\n")
+ (insert "<head>\n")
+ (insert (format "<title>%s</title>\n" file))
+ (insert "</head>\n")
+ (insert "<body>\n")
+ (insert (format "<h1>%s</h1>\n" file))
+
+ (if prev-file
+ (insert (format "<a href=\"%s.html\">" prev-file)))
+ (insert "[Previous]")
+ (if prev-file
+ (insert "</a>"))
+ (insert "\n")
+
+ (if next-file
+ (insert (format "<a href=\"%s.html\">" next-file)))
+ (insert "[Next]")
+ (if next-file
+ (insert "</a>"))
+ (insert "\n")
+
+ (if prev-grade
+ (insert (format "<a href=\"../%s/%s.html\">"
+ prev-grade
+ file)))
+ (insert "[Smaller]")
+ (if prev-grade
+ (insert "</a>"))
+ (insert "\n")
+
+ (if next-grade
+ (insert (format "<a href=\"../%s/%s.html\">"
+ next-grade
+ file)))
+ (insert "[Larger]")
+ (if next-grade
+ (insert "</a>"))
+ (insert "\n")
+
+ (insert "
+<hr>
+")
+ (insert "<a href=\"")
+ (insert
+ (if next-grade
+ (format "../%s/%s.html" next-grade file)
+ (concat "../fullsize/" file ".jpg")))
+ (insert "\">")
+ (insert (format "<img alt=\"%s\" src=\"%s.jpg\">" file file))
+ (insert "</a>
+
+<hr>
+
+</body>
+</html>
+")
+ (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-images (dest-dir prev-file file next-file)
+ (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))
+ 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))
+ (make-directory
+ (expand-file-name "fullsize" 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" dest-dir)))
+ dest))
+
+;;; album.el ends here
+++ /dev/null
-(defun www-image-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 www-image-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 www-image-write-html (dest-dir
- prev-file file next-file
- prev-grade grade next-grade)
- (with-temp-buffer
- (insert
- "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
- \"http://www.w3.org/TR/html4/loose.dtd\">\n")
- (insert "<head>\n")
- (insert (format "<title>%s</title>\n" file))
- (insert "</head>\n")
- (insert "<body>\n")
- (insert (format "<h1>%s</h1>\n" file))
-
- (if prev-file
- (insert (format "<a href=\"%s.html\">" prev-file)))
- (insert "[Previous]")
- (if prev-file
- (insert "</a>"))
- (insert "\n")
-
- (if next-file
- (insert (format "<a href=\"%s.html\">" next-file)))
- (insert "[Next]")
- (if next-file
- (insert "</a>"))
- (insert "\n")
-
- (if prev-grade
- (insert (format "<a href=\"../%s/%s.html\">"
- prev-grade
- file)))
- (insert "[Smaller]")
- (if prev-grade
- (insert "</a>"))
- (insert "\n")
-
- (if next-grade
- (insert (format "<a href=\"../%s/%s.html\">"
- next-grade
- file)))
- (insert "[Larger]")
- (if next-grade
- (insert "</a>"))
- (insert "\n")
-
- (insert "
-<hr>
-")
- (insert "<a href=\"")
- (insert
- (if next-grade
- (format "../%s/%s.html" next-grade file)
- (concat "../fullsize/" file ".jpg")))
- (insert "\">")
- (insert (format "<img alt=\"%s\" src=\"%s.jpg\">" file file))
- (insert "</a>
-
-<hr>
-
-</body>
-</html>
-")
- (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 www-image-convert-images (dest-dir
- prev-file file next-file)
- (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))
- prev-grade
- rest dest)
- (cond ((>= width height)
- (when (setq ret (www-image-make-spec-by-width width 2048 'QXGA))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-width width 1600 'UXGA))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-width width 1400 'SXGA+))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-width width 1280 'SXGA))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-width width 1024 'XGA))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-width width 800 'SVGA))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-width width 640 'VGA))
- (setq dest (cons ret dest)))
- )
- (t
- (when (setq ret (www-image-make-spec-by-height height 1536 'QXGA))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-height height 1200 'UXGA))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-height height 1050 'SXGA+))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-height height 960 'SXGA))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-height height 768 'XGA))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-height height 600 'SVGA))
- (setq dest (cons ret dest)))
- (when (setq ret (www-image-make-spec-by-height height 480 'VGA))
- (setq dest (cons ret dest)))
- ))
- (setq rest dest)
- (while rest
- (setq spec (car rest))
- (www-image-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))
- (make-directory
- (expand-file-name "fullsize" 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" dest-dir)))
- dest))
-
-(let ((rest
- (append
- (directory-files
- "/archives/RAID2/koukotsu/TAKUHON/original/" 'full "^[^0-9].*\\.TIF$")
- (directory-files
- "/archives/RAID2/koukotsu/TAKUHON/original/" 'full "^[0-9].*\\.TIF$"))
- ;; (directory-files
- ;; "/archives/RAID2/koukotsu/TAKUHON/" t "\\.TIF$")
- )
- file prev-file)
- (while rest
- (setq file (car rest))
- (www-image-convert-images
- "/archives/RAID2/koukotsu/TAKUHON/"
- prev-file file (nth 1 rest))
- (setq prev-file file
- rest (cdr rest))))
projects / elisp / album.git / commitdiff