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 lang image-url-prefix
  45                          prev-file file next-file
  46                          prev-grade grade next-grade)
  47   (with-temp-buffer
  48     (insert
  49      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
  50             \"http://www.w3.org/TR/html4/loose.dtd\">\n")
  51     (insert "<html")
  52     (if lang
  53         (insert (format " lang=\"%s\"" lang)))
  54     (insert " />\n")
  55     (insert "<head>\n")
  56     (insert (format "<title>%s</title>\n" file))
  57     (insert "</head>\n")
  58     (insert "<body>\n")
  59     (insert (format "<h1>%s</h1>\n" file))
  60
  61     (if prev-file
  62         (insert (format "<a href=\"%s.html\">" prev-file)))
  63     (insert "[Previous]")
  64     (if prev-file
  65         (insert "</a>"))
  66     (insert "\n")
  67
  68     (if next-file
  69         (insert (format "<a href=\"%s.html\">" next-file)))
  70     (insert "[Next]")
  71     (if next-file
  72         (insert "</a>"))
  73     (insert "\n")
  74
  75     (if prev-grade
  76         (insert (format "<a href=\"../%s/%s.html\">"
  77                         prev-grade
  78                         file)))
  79     (insert "[Smaller]")
  80     (if prev-grade
  81         (insert "</a>"))
  82     (insert "\n")
  83
  84     (if next-grade
  85         (insert (format "<a href=\"../%s/%s.html\">"
  86                         next-grade
  87                         file)))
  88     (insert "[Larger]")
  89     (if next-grade
  90         (insert "</a>"))
  91     (insert "\n")
  92
  93     (insert "
  94 <hr>
  95 ")
  96     (insert "<a href=\"")
  97     (insert
  98      (if next-grade
  99           (format "../%s/%s.html" next-grade file)
 100        (concat "../fullsize/" file ".jpg")))
 101     (insert "\">")
 102     (insert (format "<img alt=\"%s\" src=\"%s.jpg\">"
 103                     file
 104                     (if image-url-prefix
 105                         (format "%s/%s/%s"
 106                                 image-url-prefix grade file)
 107                       file)))
 108     (insert "</a>
 109
 110 <hr>
 111
 112 <a href=\"../index.html\">[index]</a>
 113
 114 </body>
 115 </html>
 116 ")
 117     (unless (file-exists-p
 118              (expand-file-name (symbol-name grade) dest-dir))
 119       (make-directory
 120        (expand-file-name (symbol-name grade) dest-dir)))
 121     (write-region (point-min)(point-max)
 122                   (expand-file-name
 123                    (concat file ".html")
 124                    (expand-file-name (symbol-name grade)
 125                                      dest-dir)))))
 126
 127 (defun album-convert-image (image-dest-dir html-dest-dir lang
 128                                            image-url-prefix
 129                                            prev-file file next-file)
 130   (setq file (expand-file-name file))
 131   (unless html-dest-dir
 132     (setq html-dest-dir image-dest-dir))
 133   (let* ((ret
 134           (with-temp-buffer
 135             (call-process "identify" nil t t file)
 136             (goto-char (point-min))
 137             (and (re-search-forward " \\([0-9]+\\)x\\([0-9]+\\) " nil t)
 138                  (cons (string-to-number (match-string 1))
 139                        (string-to-number (match-string 2))))))
 140          (width (car ret))
 141          (height (cdr ret))
 142          prev-grade
 143          rest dest)
 144     (cond ((>= width height)
 145            (when (setq ret (album-make-spec-by-width width 2048 'QXGA))
 146              (setq dest (cons ret dest)))
 147            (when (setq ret (album-make-spec-by-width width 1600 'UXGA))
 148              (setq dest (cons ret dest)))
 149            (when (setq ret (album-make-spec-by-width width 1400 'SXGA+))
 150              (setq dest (cons ret dest)))
 151            (when (setq ret (album-make-spec-by-width width 1280 'SXGA))
 152              (setq dest (cons ret dest)))
 153            (when (setq ret (album-make-spec-by-width width 1024 'XGA))
 154              (setq dest (cons ret dest)))
 155            (when (setq ret (album-make-spec-by-width width 800 'SVGA))
 156              (setq dest (cons ret dest)))
 157            (when (setq ret (album-make-spec-by-width width 640 'VGA))
 158              (setq dest (cons ret dest)))
 159            (when (setq ret (album-make-spec-by-width width 160 'thumbnail))
 160              (setq dest (cons ret dest)))
 161            )
 162           (t
 163            (when (setq ret (album-make-spec-by-height height 1536 'QXGA))
 164              (setq dest (cons ret dest)))
 165            (when (setq ret (album-make-spec-by-height height 1200 'UXGA))
 166              (setq dest (cons ret dest)))
 167            (when (setq ret (album-make-spec-by-height height 1050 'SXGA+))
 168              (setq dest (cons ret dest)))
 169            (when (setq ret (album-make-spec-by-height height 960 'SXGA))
 170              (setq dest (cons ret dest)))
 171            (when (setq ret (album-make-spec-by-height height 768 'XGA))
 172              (setq dest (cons ret dest)))
 173            (when (setq ret (album-make-spec-by-height height 600 'SVGA))
 174              (setq dest (cons ret dest)))
 175            (when (setq ret (album-make-spec-by-height height 480 'VGA))
 176              (setq dest (cons ret dest)))
 177            (when (setq ret (album-make-spec-by-height height 160 'thumbnail))
 178              (setq dest (cons ret dest)))
 179            ))
 180     (unless (file-exists-p
 181              (expand-file-name "thumbnail" image-dest-dir))
 182       (make-directory
 183        (expand-file-name "thumbnail" image-dest-dir)))
 184     (call-process "convert" nil nil nil
 185                   "-resize" (format "%d%%" (aref (car dest) 0))
 186                   file
 187                   (expand-file-name
 188                    (concat
 189                     (file-name-sans-extension
 190                      (file-name-nondirectory file)) ".jpg")
 191                    (expand-file-name
 192                     "thumbnail"
 193                     image-dest-dir)))
 194     (setq rest (cdr dest))
 195     (while rest
 196       (setq spec (car rest))
 197       (album-write-html html-dest-dir lang image-url-prefix
 198                         (if prev-file
 199                             (file-name-sans-extension
 200                              (file-name-nondirectory prev-file)))
 201                         (file-name-sans-extension
 202                          (file-name-nondirectory file))
 203                         (if next-file
 204                             (file-name-sans-extension
 205                              (file-name-nondirectory next-file)))
 206                         prev-grade
 207                         (aref spec 1)
 208                         (if (nth 1 rest)
 209                             (aref (nth 1 rest) 1)))
 210       (call-process "convert" nil nil nil
 211                     "-resize" (format "%d%%" (aref spec 0))
 212                     file
 213                     (expand-file-name
 214                      (concat
 215                       (file-name-sans-extension
 216                        (file-name-nondirectory file)) ".jpg")
 217                      (expand-file-name
 218                       (symbol-name (aref spec 1))
 219                       image-dest-dir)))
 220       (setq prev-grade (aref spec 1))
 221       (setq rest (cdr rest)))
 222     (unless (file-exists-p
 223              (expand-file-name "fullsize" image-dest-dir))
 224       (make-directory
 225        (expand-file-name "fullsize" image-dest-dir)))
 226     (if (string= (downcase (file-name-extension file))
 227                  "jpg")
 228         (call-process "ln" nil nil nil
 229                       "-f"
 230                       file
 231                       (expand-file-name "fullsize" image-dest-dir))
 232       (call-process "convert" nil nil nil
 233                     file
 234                     (expand-file-name
 235                      (concat
 236                       (file-name-sans-extension
 237                        (file-name-nondirectory file)) ".jpg")
 238                      (expand-file-name "fullsize" image-dest-dir))))
 239     dest))
 240
 241 (defun album-convert-images (image-dest-dir html-dest-dir lang
 242                                             image-url-prefix
 243                                             &rest source-images)
 244   (unless html-dest-dir
 245     (setq html-dest-dir image-dest-dir))
 246   (if (and (consp (car source-images))
 247            (null (cdr source-images)))
 248       (setq source-images (car source-images)))
 249   (album-make-thumbnails html-dest-dir lang image-url-prefix
 250                          source-images)
 251   (let (file prev-file)
 252     (while source-images
 253       (setq file (car source-images))
 254       (album-convert-image image-dest-dir html-dest-dir lang
 255                            image-url-prefix
 256                            prev-file file (nth 1 source-images))
 257       (setq prev-file file
 258             source-images (cdr source-images)))))
 259
 260 (defun album-make-thumbnails (html-dest-dir lang image-url-prefix
 261                                             source-images)
 262   (let ((album
 263          (file-name-nondirectory
 264           (if (eq (aref html-dest-dir (1- (length html-dest-dir))) ?/)
 265               (substring html-dest-dir 0 (1- (length html-dest-dir)))
 266             html-dest-dir)))
 267         file)
 268     (with-temp-buffer
 269       (insert
 270        "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
 271             \"http://www.w3.org/TR/html4/loose.dtd\">\n")
 272       (insert "<html")
 273       (if lang
 274           (insert (format " lang=\"%s\"" lang)))
 275       (insert ">\n")
 276       (insert "<head>\n")
 277       (insert (format "<title>%s</title>\n" album))
 278       (insert "</head>\n")
 279       (insert "<body>\n")
 280       (insert (format "<h1>%s</h1>\n" album))
 281
 282     (insert "
 283 <hr>
 284 ")
 285     (dolist (image-file source-images)
 286       (setq file (file-name-sans-extension
 287                   (file-name-nondirectory image-file)))
 288       (insert "<a href=\"VGA/")
 289       (insert file)
 290       (insert ".html\">")
 291       (insert (format "<img alt=\"%s\" src=\"thumbnail/%s.jpg\">"
 292                       file
 293                       (if image-url-prefix
 294                           (format "%s/%s/%s"
 295                                   image-url-prefix grade file)
 296                         file)))
 297       (insert "</a>\n"))
 298     (insert "
 299
 300 <hr>
 301
 302 </body>
 303 </html>
 304 ")
 305     (write-region (point-min)(point-max)
 306                   (expand-file-name "index.html" html-dest-dir)))))
 307
 308 (defun album-convert-directory (image-dest-dir html-dest-dir lang
 309                                                image-url-prefix
 310                                                source-dir &rest patterns)
 311   (let (files)
 312     (if patterns
 313         (dolist (pat patterns)
 314           (setq files
 315                 (append files
 316                         (directory-files source-dir 'full pat))))
 317       (setq files
 318             (let (case-fold-search)
 319               (directory-files
 320                source-dir 'full
 321                ".+\\.\\(tiff\\|jpg\\|JPG\\|jpeg\\|gif\\|png\\)$"))))
 322     (album-convert-images image-dest-dir html-dest-dir lang
 323                           image-url-prefix files)))
 324
 325
 326 (provide 'album)
 327
 328 ;;; album.el ends here