album.el

   1 ;;; album.el --- Photo album utility
   2
   3 ;; Copyright (C) 2005,2006 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          (specs '((QVGA          320  240)
 145                   (VGA           640  480)
 146                   (SVGA          800  600)
 147                   (XGA          1024  768)
 148                   (WXGA         1280  768)
 149                   (SXGA         1280 1024)
 150                   (SXGA+        1400 1050)
 151                   (WSXGA+       1680 1050)
 152                   (UXGA         1600 1200)
 153                   (WUXGA        1920 1200)
 154                   (QXGA         2048 1536)
 155                   (WQXGA        2560 1600)
 156                   ))
 157          prev-grade
 158          rest dest)
 159     ;; (cond ((>= width height)
 160     ;;        (when (setq ret (album-make-spec-by-width width 2048 'QXGA))
 161     ;;          (setq dest (cons ret dest)))
 162     ;;        (when (setq ret (album-make-spec-by-width width 1600 'UXGA))
 163     ;;          (setq dest (cons ret dest)))
 164     ;;        (when (setq ret (album-make-spec-by-width width 1400 'SXGA+))
 165     ;;          (setq dest (cons ret dest)))
 166     ;;        (when (setq ret (album-make-spec-by-width width 1280 'SXGA))
 167     ;;          (setq dest (cons ret dest)))
 168     ;;        (when (setq ret (album-make-spec-by-width width 1024 'XGA))
 169     ;;          (setq dest (cons ret dest)))
 170     ;;        (when (setq ret (album-make-spec-by-width width 800 'SVGA))
 171     ;;          (setq dest (cons ret dest)))
 172     ;;        (when (setq ret (album-make-spec-by-width width 640 'VGA))
 173     ;;          (setq dest (cons ret dest)))
 174     ;;        (when (setq ret (album-make-spec-by-width width 320 'QVGA))
 175     ;;          (setq dest (cons ret dest)))
 176     ;;        (when (setq ret (album-make-spec-by-width width 160 'thumbnail))
 177     ;;          (setq dest (cons ret dest)))
 178     ;;        )
 179     ;;       (t
 180     ;;        (when (setq ret (album-make-spec-by-height height 1536 'QXGA))
 181     ;;          (setq dest (cons ret dest)))
 182     ;;        (when (setq ret (album-make-spec-by-height height 1200 'UXGA))
 183     ;;          (setq dest (cons ret dest)))
 184     ;;        (when (setq ret (album-make-spec-by-height height 1050 'SXGA+))
 185     ;;          (setq dest (cons ret dest)))
 186     ;;        (when (setq ret (album-make-spec-by-height height 960 'SXGA))
 187     ;;          (setq dest (cons ret dest)))
 188     ;;        (when (setq ret (album-make-spec-by-height height 768 'XGA))
 189     ;;          (setq dest (cons ret dest)))
 190     ;;        (when (setq ret (album-make-spec-by-height height 600 'SVGA))
 191     ;;          (setq dest (cons ret dest)))
 192     ;;        (when (setq ret (album-make-spec-by-height height 480 'VGA))
 193     ;;          (setq dest (cons ret dest)))
 194     ;;        (when (setq ret (album-make-spec-by-height height 240 'QVGA))
 195     ;;          (setq dest (cons ret dest)))
 196     ;;        (when (setq ret (album-make-spec-by-height height 160 'thumbnail))
 197     ;;          (setq dest (cons ret dest)))
 198     ;;        ))
 199     (unless (file-exists-p
 200              (expand-file-name "thumbnail" image-dest-dir))
 201       (make-directory
 202        (expand-file-name "thumbnail" image-dest-dir)))
 203     (call-process "convert" nil nil nil
 204                   "-resize" "160x160>" ; (format "%d%%" (aref (car dest) 0))
 205                   file
 206                   (expand-file-name
 207                    (concat
 208                     (file-name-sans-extension
 209                      (file-name-nondirectory file)) ".jpg")
 210                    (expand-file-name
 211                     "thumbnail"
 212                     image-dest-dir)))
 213     (setq rest specs)
 214     ;; (setq rest (cdr dest))
 215     (while rest
 216       (setq spec (car rest))
 217       (when (or (> width (nth 1 spec))
 218                 (> height (nth 2 spec)))
 219         (album-write-html html-dest-dir
 220                           (if prev-file
 221                               (file-name-sans-extension
 222                                (file-name-nondirectory prev-file)))
 223                           (file-name-sans-extension
 224                            (file-name-nondirectory file))
 225                           (if next-file
 226                               (file-name-sans-extension
 227                                (file-name-nondirectory next-file)))
 228                           prev-grade
 229                           (car spec) ; (aref spec 1)
 230                           (if (nth 1 rest)
 231                               ;; (aref (nth 1 rest) 1)
 232                               (car (nth 1 rest))
 233                             )
 234                           lang image-url-prefix)
 235         (call-process "convert" nil nil nil
 236                       "-resize" ; (format "%d%%" (aref spec 0))
 237                       (format "%dx%d>" (nth 1 spec)(nth 2 spec))
 238                       file
 239                       (expand-file-name
 240                        (concat
 241                         (file-name-sans-extension
 242                          (file-name-nondirectory file)) ".jpg")
 243                        (expand-file-name
 244                         (symbol-name (car spec) ; (aref spec 1)
 245                                      )
 246                         image-dest-dir)))
 247         ;; (setq prev-grade (aref spec 1))
 248         (setq prev-grade (car spec))
 249         )
 250       (setq rest (cdr rest)))
 251     (unless (file-exists-p
 252              (expand-file-name "fullsize" image-dest-dir))
 253       (make-directory
 254        (expand-file-name "fullsize" image-dest-dir)))
 255     (if (string= (downcase (file-name-extension file))
 256                  "jpg")
 257         (call-process "ln" nil nil nil
 258                       "-f"
 259                       file
 260                       (expand-file-name "fullsize" image-dest-dir))
 261       (call-process "convert" nil nil nil
 262                     file
 263                     (expand-file-name
 264                      (concat
 265                       (file-name-sans-extension
 266                        (file-name-nondirectory file)) ".jpg")
 267                      (expand-file-name "fullsize" image-dest-dir))))
 268     dest))
 269
 270 (defun album-convert-images (image-dest-dir source-images
 271                              &optional lang title parent-url
 272                              image-url-prefix html-dest-dir)
 273   (unless html-dest-dir
 274     (setq html-dest-dir image-dest-dir))
 275   ;; (if (and (consp (car source-images))
 276   ;;          (null (cdr source-images)))
 277   ;;     (setq source-images (car source-images)))
 278   (album-make-thumbnails html-dest-dir source-images
 279                          lang title image-url-prefix parent-url)
 280   (let (file prev-file)
 281     (while source-images
 282       (setq file (car source-images))
 283       (album-convert-image image-dest-dir
 284                            prev-file file (nth 1 source-images)
 285                            lang image-url-prefix html-dest-dir)
 286       (setq prev-file file
 287             source-images (cdr source-images)))))
 288
 289 (defun album-make-thumbnails (html-dest-dir
 290                               source-images
 291                               lang title image-url-prefix parent-url)
 292   (unless title
 293     (setq title
 294           (file-name-nondirectory
 295            (if (eq (aref html-dest-dir (1- (length html-dest-dir))) ?/)
 296                (substring html-dest-dir 0 (1- (length html-dest-dir)))
 297              html-dest-dir))))
 298   (let (file)
 299     (with-temp-buffer
 300       (insert
 301        "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
 302             \"http://www.w3.org/TR/html4/loose.dtd\">\n")
 303       (insert "<html")
 304       (if lang
 305           (insert (format " lang=\"%s\"" lang)))
 306       (insert ">\n")
 307       (insert "<head>\n")
 308       (insert (format "<title>%s</title>\n" title))
 309       (insert "</head>\n")
 310       (insert "<body>\n")
 311       (insert (format "<h1>%s</h1>\n" title))
 312
 313     (insert "
 314 <hr>
 315 ")
 316     (dolist (image-file source-images)
 317       (setq file (file-name-sans-extension
 318                   (file-name-nondirectory image-file)))
 319       (insert "<a href=\"VGA/")
 320       (insert file)
 321       (insert ".html\">")
 322       (insert (format "<img alt=\"%s\" src=\"thumbnail/%s.jpg\">"
 323                       file
 324                       (if image-url-prefix
 325                           (format "%s/%s/%s"
 326                                   image-url-prefix grade file)
 327                         file)))
 328       (insert "</a>\n"))
 329     (insert "
 330
 331 <hr>
 332 ")
 333     (if parent-url
 334         (insert (format "[<a href=\"%s\">Return</a>]\n" parent-url)))
 335
 336     (insert "
 337 </body>
 338 </html>
 339 ")
 340     (write-region (point-min)(point-max)
 341                   (expand-file-name "index.html" html-dest-dir)))))
 342
 343 (defun album-convert-directory (image-dest-dir source-dir
 344                                 &optional
 345                                 patterns
 346                                 lang title parent-url
 347                                 image-url-prefix html-dest-dir)
 348   (let (files)
 349     (if patterns
 350         (dolist (pat patterns)
 351           (setq files
 352                 (append files
 353                         (directory-files source-dir 'full pat))))
 354       (setq files
 355             (let (case-fold-search)
 356               (directory-files
 357                source-dir 'full
 358                ".+\\.\\(tiff\\|TIFF\\|jpg\\|JPG\\|jpeg\\|JPEG\\|gif\\|GIF\\|png\\|PNG\\)$"))))
 359     (album-convert-images image-dest-dir files
 360                           lang title parent-url
 361                           image-url-prefix html-dest-dir)))
 362
 363
 364 (provide 'album)
 365
 366 ;;; album.el ends here