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