album.el

   1 ;;; album.el --- Photo album utility
   2
   3 ;; Copyright (C) 2005 MORIOKA Tomohiko
   4
   5 ;; Keywords: Photo, image, album, HTML, WWW
   6
   7 ;; This file is part of Album.
   8
   9 ;; Album is free software; you can redistribute it and/or modify it
  10 ;; under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; Album is distributed in the hope that it will be useful, but
  15 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17 ;; General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; It requires `convert' and `identify' of ImageMagick.
  27
  28 ;;; Code:
  29
  30 (defun album-make-spec-by-width (width limit spec-name)
  31   (when (> width limit)
  32     (let ((percent (floor (/ (* limit 100.0) width))))
  33       (vector percent spec-name
  34               (/ (* width percent) 100.0)
  35               (/ (* height percent) 100.0)))))
  36
  37 (defun album-make-spec-by-height (height limit spec-name)
  38   (when (> height limit)
  39     (let ((percent (floor (/ (* limit 100.0) height))))
  40       (vector percent spec-name
  41               (/ (* width percent) 100.0)
  42               (/ (* height percent) 100.0)))))
  43
  44 (defun album-write-html (dest-dir
  45                          prev-file file next-file
  46                          prev-grade grade next-grade
  47                          lang image-url-prefix)
  48   (with-temp-buffer
  49     (insert
  50      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
  51             \"http://www.w3.org/TR/html4/loose.dtd\">\n")
  52     (insert "<html")
  53     (if lang
  54         (insert (format " lang=\"%s\"" lang)))
  55     (insert " />\n")
  56     (insert "<head>\n")
  57     (insert (format "<title>%s</title>\n" file))
  58     (insert "</head>\n")
  59     (insert "<body>\n")
  60     (insert (format "<h1>%s</h1>\n" file))
  61
  62     (if prev-file
  63         (insert (format "<a href=\"%s.html\">" prev-file)))
  64     (insert "[Previous]")
  65     (if prev-file
  66         (insert "</a>"))
  67     (insert "\n")
  68
  69     (if next-file
  70         (insert (format "<a href=\"%s.html\">" next-file)))
  71     (insert "[Next]")
  72     (if next-file
  73         (insert "</a>"))
  74     (insert "\n")
  75
  76     (if prev-grade
  77         (insert (format "<a href=\"../%s/%s.html\">"
  78                         prev-grade
  79                         file)))
  80     (insert "[Smaller]")
  81     (if prev-grade
  82         (insert "</a>"))
  83     (insert "\n")
  84
  85     (if next-grade
  86         (insert (format "<a href=\"../%s/%s.html\">"
  87                         next-grade
  88                         file)))
  89     (insert "[Larger]")
  90     (if next-grade
  91         (insert "</a>"))
  92     (insert "\n")
  93
  94     (insert "
  95 <hr>
  96 ")
  97     (insert "<a href=\"")
  98     (insert
  99      (if next-grade
 100           (format "../%s/%s.html" next-grade file)
 101        (concat "../fullsize/" file ".jpg")))
 102     (insert "\">")
 103     (insert (format "<img alt=\"%s\" src=\"%s.jpg\">"
 104                     file
 105                     (if image-url-prefix
 106                         (format "%s/%s/%s"
 107                                 image-url-prefix grade file)
 108                       file)))
 109     (insert "</a>
 110
 111 <hr>
 112
 113 <a href=\"../index.html\">[index]</a>
 114
 115 </body>
 116 </html>
 117 ")
 118     (unless (file-exists-p
 119              (expand-file-name (symbol-name grade) dest-dir))
 120       (make-directory
 121        (expand-file-name (symbol-name grade) dest-dir)))
 122     (write-region (point-min)(point-max)
 123                   (expand-file-name
 124                    (concat file ".html")
 125                    (expand-file-name (symbol-name grade)
 126                                      dest-dir)))))
 127
 128 (defun album-convert-image (image-dest-dir
 129                             prev-file file next-file
 130                             lang image-url-prefix
 131                             html-dest-dir)
 132   (setq file (expand-file-name file))
 133   (unless html-dest-dir
 134     (setq html-dest-dir image-dest-dir))
 135   (let* ((ret
 136           (with-temp-buffer
 137             (call-process "identify" nil t t file)
 138             (goto-char (point-min))
 139             (and (re-search-forward " \\([0-9]+\\)x\\([0-9]+\\) " nil t)
 140                  (cons (string-to-number (match-string 1))
 141                        (string-to-number (match-string 2))))))
 142          (width (car ret))
 143          (height (cdr ret))
 144          prev-grade
 145          rest dest)
 146     (cond ((>= width height)
 147            (when (setq ret (album-make-spec-by-width width 2048 'QXGA))
 148              (setq dest (cons ret dest)))
 149            (when (setq ret (album-make-spec-by-width width 1600 'UXGA))
 150              (setq dest (cons ret dest)))
 151            (when (setq ret (album-make-spec-by-width width 1400 'SXGA+))
 152              (setq dest (cons ret dest)))
 153            (when (setq ret (album-make-spec-by-width width 1280 'SXGA))
 154              (setq dest (cons ret dest)))
 155            (when (setq ret (album-make-spec-by-width width 1024 'XGA))
 156              (setq dest (cons ret dest)))
 157            (when (setq ret (album-make-spec-by-width width 800 'SVGA))
 158              (setq dest (cons ret dest)))
 159            (when (setq ret (album-make-spec-by-width width 640 'VGA))
 160              (setq dest (cons ret dest)))
 161            (when (setq ret (album-make-spec-by-width width 320 'QVGA))
 162              (setq dest (cons ret dest)))
 163            (when (setq ret (album-make-spec-by-width width 160 'thumbnail))
 164              (setq dest (cons ret dest)))
 165            )
 166           (t
 167            (when (setq ret (album-make-spec-by-height height 1536 'QXGA))
 168              (setq dest (cons ret dest)))
 169            (when (setq ret (album-make-spec-by-height height 1200 'UXGA))
 170              (setq dest (cons ret dest)))
 171            (when (setq ret (album-make-spec-by-height height 1050 'SXGA+))
 172              (setq dest (cons ret dest)))
 173            (when (setq ret (album-make-spec-by-height height 960 'SXGA))
 174              (setq dest (cons ret dest)))
 175            (when (setq ret (album-make-spec-by-height height 768 'XGA))
 176              (setq dest (cons ret dest)))
 177            (when (setq ret (album-make-spec-by-height height 600 'SVGA))
 178              (setq dest (cons ret dest)))
 179            (when (setq ret (album-make-spec-by-height height 480 'VGA))
 180              (setq dest (cons ret dest)))
 181            (when (setq ret (album-make-spec-by-height height 240 'QVGA))
 182              (setq dest (cons ret dest)))
 183            (when (setq ret (album-make-spec-by-height height 160 'thumbnail))
 184              (setq dest (cons ret dest)))
 185            ))
 186     (unless (file-exists-p
 187              (expand-file-name "thumbnail" image-dest-dir))
 188       (make-directory
 189        (expand-file-name "thumbnail" image-dest-dir)))
 190     (call-process "convert" nil nil nil
 191                   "-resize" (format "%d%%" (aref (car dest) 0))
 192                   file
 193                   (expand-file-name
 194                    (concat
 195                     (file-name-sans-extension
 196                      (file-name-nondirectory file)) ".jpg")
 197                    (expand-file-name
 198                     "thumbnail"
 199                     image-dest-dir)))
 200     (setq rest (cdr dest))
 201     (while rest
 202       (setq spec (car rest))
 203       (album-write-html html-dest-dir
 204                         (if prev-file
 205                             (file-name-sans-extension
 206                              (file-name-nondirectory prev-file)))
 207                         (file-name-sans-extension
 208                          (file-name-nondirectory file))
 209                         (if next-file
 210                             (file-name-sans-extension
 211                              (file-name-nondirectory next-file)))
 212                         prev-grade
 213                         (aref spec 1)
 214                         (if (nth 1 rest)
 215                             (aref (nth 1 rest) 1))
 216                         lang image-url-prefix)
 217       (call-process "convert" nil nil nil
 218                     "-resize" (format "%d%%" (aref spec 0))
 219                     file
 220                     (expand-file-name
 221                      (concat
 222                       (file-name-sans-extension
 223                        (file-name-nondirectory file)) ".jpg")
 224                      (expand-file-name
 225                       (symbol-name (aref spec 1))
 226                       image-dest-dir)))
 227       (setq prev-grade (aref spec 1))
 228       (setq rest (cdr rest)))
 229     (unless (file-exists-p
 230              (expand-file-name "fullsize" image-dest-dir))
 231       (make-directory
 232        (expand-file-name "fullsize" image-dest-dir)))
 233     (if (string= (downcase (file-name-extension file))
 234                  "jpg")
 235         (call-process "ln" nil nil nil
 236                       "-f"
 237                       file
 238                       (expand-file-name "fullsize" image-dest-dir))
 239       (call-process "convert" nil nil nil
 240                     file
 241                     (expand-file-name
 242                      (concat
 243                       (file-name-sans-extension
 244                        (file-name-nondirectory file)) ".jpg")
 245                      (expand-file-name "fullsize" image-dest-dir))))
 246     dest))
 247
 248 (defun album-convert-images (image-dest-dir source-images
 249                              &optional lang title parent-url
 250                              image-url-prefix html-dest-dir)
 251   (unless html-dest-dir
 252     (setq html-dest-dir image-dest-dir))
 253   ;; (if (and (consp (car source-images))
 254   ;;          (null (cdr source-images)))
 255   ;;     (setq source-images (car source-images)))
 256   (album-make-thumbnails html-dest-dir source-images
 257                          lang title image-url-prefix parent-url)
 258   (let (file prev-file)
 259     (while source-images
 260       (setq file (car source-images))
 261       (album-convert-image image-dest-dir
 262                            prev-file file (nth 1 source-images)
 263                            lang image-url-prefix html-dest-dir)
 264       (setq prev-file file
 265             source-images (cdr source-images)))))
 266
 267 (defun album-make-thumbnails (html-dest-dir
 268                               source-images
 269                               lang title image-url-prefix parent-url)
 270   (unless title
 271     (setq title
 272           (file-name-nondirectory
 273            (if (eq (aref html-dest-dir (1- (length html-dest-dir))) ?/)
 274                (substring html-dest-dir 0 (1- (length html-dest-dir)))
 275              html-dest-dir))))
 276   (let (file)
 277     (with-temp-buffer
 278       (insert
 279        "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
 280             \"http://www.w3.org/TR/html4/loose.dtd\">\n")
 281       (insert "<html")
 282       (if lang
 283           (insert (format " lang=\"%s\"" lang)))
 284       (insert ">\n")
 285       (insert "<head>\n")
 286       (insert (format "<title>%s</title>\n" title))
 287       (insert "</head>\n")
 288       (insert "<body>\n")
 289       (insert (format "<h1>%s</h1>\n" title))
 290
 291     (insert "
 292 <hr>
 293 ")
 294     (dolist (image-file source-images)
 295       (setq file (file-name-sans-extension
 296                   (file-name-nondirectory image-file)))
 297       (insert "<a href=\"VGA/")
 298       (insert file)
 299       (insert ".html\">")
 300       (insert (format "<img alt=\"%s\" src=\"thumbnail/%s.jpg\">"
 301                       file
 302                       (if image-url-prefix
 303                           (format "%s/%s/%s"
 304                                   image-url-prefix grade file)
 305                         file)))
 306       (insert "</a>\n"))
 307     (insert "
 308
 309 <hr>
 310 ")
 311     (if parent-url
 312         (insert (format "[<a href=\"%s\">Return</a>]\n" parent-url)))
 313
 314     (insert "
 315 </body>
 316 </html>
 317 ")
 318     (write-region (point-min)(point-max)
 319                   (expand-file-name "index.html" html-dest-dir)))))
 320
 321 (defun album-convert-directory (image-dest-dir source-dir
 322                                 &optional
 323                                 patterns
 324                                 lang title parent-url
 325                                 image-url-prefix html-dest-dir)
 326   (let (files)
 327     (if patterns
 328         (dolist (pat patterns)
 329           (setq files
 330                 (append files
 331                         (directory-files source-dir 'full pat))))
 332       (setq files
 333             (let (case-fold-search)
 334               (directory-files
 335                source-dir 'full
 336                ".+\\.\\(tiff\\|TIFF\\|jpg\\|JPG\\|jpeg\\|JPEG\\|gif\\|GIF\\|png\\|PNG\\)$"))))
 337     (album-convert-images image-dest-dir files
 338                           lang title parent-url
 339                           image-url-prefix html-dest-dir)))
 340
 341
 342 (provide 'album)
 343
 344 ;;; album.el ends here