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