www-image.el

   1 (defun www-image-make-spec-by-width (width limit spec-name)
   2   (when (> width limit)
   3     (let ((percent (floor (/ (* limit 100.0) width))))
   4       (vector percent spec-name
   5               (/ (* width percent) 100.0)
   6               (/ (* height percent) 100.0)))))
   7
   8 (defun www-image-make-spec-by-height (height limit spec-name)
   9   (when (> height limit)
  10     (let ((percent (floor (/ (* limit 100.0) height))))
  11       (vector percent spec-name
  12               (/ (* width percent) 100.0)
  13               (/ (* height percent) 100.0)))))
  14
  15 (defun www-image-write-html (file-base grade
  16                                        prev-file next-file
  17                                        prev-grade next-grade)
  18   (with-temp-buffer
  19     (insert
  20      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
  21             \"http://www.w3.org/TR/html4/loose.dtd\">\n")
  22     (insert "<head>\n")
  23     (insert (format "<title>%s</title>\n"
  24                     (file-name-nondirectory file-base)))
  25     (insert "</head>\n")
  26     (insert "<body>\n")
  27     (insert (format "<h1>%s</h1>\n"
  28                     (file-name-nondirectory file-base)))
  29
  30     (if prev-file
  31         (insert (format "<a href=\"%s.html\">"
  32                         (file-name-sans-extension
  33                          (file-name-nondirectory prev-file)))))
  34     (insert "[Previous]")
  35     (if prev-file
  36         (insert "</a>"))
  37     (insert "\n")
  38
  39     (if next-file
  40         (insert (format "<a href=\"%s.html\">"
  41                         (file-name-sans-extension
  42                          (file-name-nondirectory next-file)))))
  43     (insert "[Next]")
  44     (if next-file
  45         (insert "</a>"))
  46     (insert "\n")
  47
  48     (if prev-grade
  49         (insert (format "<a href=\"../%s/%s.html\">"
  50                         prev-grade
  51                         (file-name-nondirectory file-base))))
  52     (insert "[Smaller]")
  53     (if prev-grade
  54         (insert "</a>"))
  55     (insert "\n")
  56
  57     (if next-grade
  58         (insert (format "<a href=\"../%s/%s.html\">"
  59                         next-grade
  60                         (file-name-nondirectory file-base))))
  61     (insert "[Larger]")
  62     (if next-grade
  63         (insert "</a>"))
  64     (insert "\n")
  65
  66     (insert "
  67 <hr>
  68 ")
  69     (insert "<a href=\"")
  70     (insert
  71      (if next-grade
  72           (format "../%s/%s.html"
  73                   next-grade
  74                   (file-name-nondirectory file-base))
  75        (concat "../fullsize/"
  76                (file-name-nondirectory file-base) ".jpg")))
  77     (insert "\">")
  78     (insert (format "<img alt=\"%s\" src=\"%s.jpg\">"
  79                     (file-name-nondirectory file-base)
  80                     (file-name-nondirectory file-base)))
  81     (insert "</a>
  82
  83 <hr>
  84
  85 </body>
  86 </html>
  87 ")
  88     (unless (file-exists-p
  89              (expand-file-name (symbol-name grade)
  90                                (file-name-directory file-base)))
  91       (make-directory
  92        (expand-file-name (symbol-name grade)
  93                          (file-name-directory file-base))))
  94     (write-region (point-min)(point-max)
  95                   (format "%s%s/%s.html"
  96                           (file-name-directory file-base)
  97                           grade
  98                           (file-name-nondirectory file-base)))))
  99
 100 (defun www-image-convert-images (filename &optional prev-file next-file)
 101   (let* ((ret
 102           (with-temp-buffer
 103             (call-process "identify" nil t t filename)
 104             (goto-char (point-min))
 105             (and (re-search-forward " \\([0-9]+\\)x\\([0-9]+\\) " nil t)
 106                  (cons (string-to-number (match-string 1))
 107                        (string-to-number (match-string 2))))))
 108          (width (car ret))
 109          (height (cdr ret))
 110          prev-grade
 111          rest dest)
 112     (cond ((>= width height)
 113            (when (setq ret (www-image-make-spec-by-width width 2048 'QXGA))
 114              (setq dest (cons ret dest)))
 115            (when (setq ret (www-image-make-spec-by-width width 1600 'UXGA))
 116              (setq dest (cons ret dest)))
 117            (when (setq ret (www-image-make-spec-by-width width 1400 'SXGA+))
 118              (setq dest (cons ret dest)))
 119            (when (setq ret (www-image-make-spec-by-width width 1280 'SXGA))
 120              (setq dest (cons ret dest)))
 121            (when (setq ret (www-image-make-spec-by-width width 1024 'XGA))
 122              (setq dest (cons ret dest)))
 123            (when (setq ret (www-image-make-spec-by-width width 800 'SVGA))
 124              (setq dest (cons ret dest)))
 125            (when (setq ret (www-image-make-spec-by-width width 640 'VGA))
 126              (setq dest (cons ret dest)))
 127            )
 128           (t
 129            (when (setq ret (www-image-make-spec-by-height height 1536 'QXGA))
 130              (setq dest (cons ret dest)))
 131            (when (setq ret (www-image-make-spec-by-height height 1200 'UXGA))
 132              (setq dest (cons ret dest)))
 133            (when (setq ret (www-image-make-spec-by-height height 1050 'SXGA+))
 134              (setq dest (cons ret dest)))
 135            (when (setq ret (www-image-make-spec-by-height height 960 'SXGA))
 136              (setq dest (cons ret dest)))
 137            (when (setq ret (www-image-make-spec-by-height height 768 'XGA))
 138              (setq dest (cons ret dest)))
 139            (when (setq ret (www-image-make-spec-by-height height 600 'SVGA))
 140              (setq dest (cons ret dest)))
 141            (when (setq ret (www-image-make-spec-by-height height 480 'VGA))
 142              (setq dest (cons ret dest)))
 143            ))
 144     (setq rest dest)
 145     (while rest
 146       (setq spec (car rest))
 147       (www-image-write-html (file-name-sans-extension filename)
 148                             (aref spec 1)
 149                             prev-file next-file
 150                             prev-grade
 151                             (if (nth 1 rest)
 152                                 (aref (nth 1 rest) 1)))
 153       (call-process "convert" nil nil nil
 154                     "-resize" (format "%d%%" (aref spec 0))
 155                     filename
 156                     (format "%s/%s/%s.jpg"
 157                             (file-name-directory filename)
 158                             (aref spec 1)
 159                             (file-name-sans-extension
 160                              (file-name-nondirectory filename))))
 161       (setq prev-grade (aref spec 1))
 162       (setq rest (cdr rest)))
 163     (unless (file-exists-p
 164              (expand-file-name "fullsize"
 165                                (file-name-directory filename)))
 166       (make-directory
 167        (expand-file-name "fullsize"
 168                          (file-name-directory filename))))
 169     (call-process "convert" nil nil nil
 170                   filename
 171                   (format "%s/fullsize/%s.jpg"
 172                           (file-name-directory filename)
 173                           (file-name-sans-extension
 174                            (file-name-nondirectory filename))))
 175     dest))
 176
 177 (let ((rest
 178        (append
 179         (directory-files
 180          "/archives/RAID2/koukotsu/TAKUHON/" t "^[^0-9].*\\.TIF$")
 181         (directory-files
 182          "/archives/RAID2/koukotsu/TAKUHON/" t "^[0-9].*\\.TIF$"))
 183        ;; (directory-files
 184        ;;  "/archives/RAID2/koukotsu/TAKUHON/" t "\\.TIF$")
 185        )
 186       file prev-file)
 187   (while rest
 188     (setq file (car rest))
 189     (www-image-convert-images file prev-file (nth 1 rest))
 190     (setq prev-file file
 191           rest (cdr rest))))