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 next-grade)
  16   (with-temp-buffer
  17     (insert
  18      "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
  19             \"http://www.w3.org/TR/html4/loose.dtd\">\n")
  20     (insert "<head>\n")
  21     (insert (format "<title>%s</title>\n"
  22                     (file-name-nondirectory file-base)))
  23     (insert "</head>\n")
  24     (insert "<body>\n")
  25     (insert (format "<h1>%s</h1>\n"
  26                     (file-name-nondirectory file-base)))
  27     (insert "
  28 <hr>
  29 ")
  30     (insert "<a href=\"")
  31     (insert
  32      (if next-grade
  33           (format "../%s/%s.html"
  34                   next-grade
  35                   (file-name-nondirectory file-base))
  36        (concat "../fullsize/"
  37                (file-name-nondirectory file-base) ".jpg")))
  38     (insert "\">")
  39     (insert (format "<img alt=\"%s\" src=\"%s.jpg\">"
  40                     (file-name-nondirectory file-base)
  41                     (file-name-nondirectory file-base)))
  42     (insert "</a>
  43
  44 <hr>
  45
  46 </body>
  47 </html>
  48 ")
  49     (unless (file-exists-p
  50              (expand-file-name (symbol-name grade)
  51                                (file-name-directory file-base)))
  52       (make-directory
  53        (expand-file-name (symbol-name grade)
  54                          (file-name-directory file-base))))
  55     (write-region (point-min)(point-max)
  56                   (format "%s%s/%s.html"
  57                           (file-name-directory file-base)
  58                           grade
  59                           (file-name-nondirectory file-base)))))
  60
  61 (defun www-image-convert-images (filename)
  62   (let* ((ret
  63           (with-temp-buffer
  64             (call-process "identify" nil t t filename)
  65             (goto-char (point-min))
  66             (and (re-search-forward " \\([0-9]+\\)x\\([0-9]+\\) " nil t)
  67                  (cons (string-to-number (match-string 1))
  68                        (string-to-number (match-string 2))))))
  69          (width (car ret))
  70          (height (cdr ret))
  71          rest dest)
  72     (cond ((>= width height)
  73            (when (setq ret (www-image-make-spec-by-width width 2048 'QXGA))
  74              (setq dest (cons ret dest)))
  75            (when (setq ret (www-image-make-spec-by-width width 1600 'UXGA))
  76              (setq dest (cons ret dest)))
  77            (when (setq ret (www-image-make-spec-by-width width 1400 'SXGA+))
  78              (setq dest (cons ret dest)))
  79            (when (setq ret (www-image-make-spec-by-width width 1280 'SXGA))
  80              (setq dest (cons ret dest)))
  81            (when (setq ret (www-image-make-spec-by-width width 1024 'XGA))
  82              (setq dest (cons ret dest)))
  83            (when (setq ret (www-image-make-spec-by-width width 800 'SVGA))
  84              (setq dest (cons ret dest)))
  85            (when (setq ret (www-image-make-spec-by-width width 640 'VGA))
  86              (setq dest (cons ret dest)))
  87            )
  88           (t
  89            (when (setq ret (www-image-make-spec-by-height height 1536 'QXGA))
  90              (setq dest (cons ret dest)))
  91            (when (setq ret (www-image-make-spec-by-height height 1200 'UXGA))
  92              (setq dest (cons ret dest)))
  93            (when (setq ret (www-image-make-spec-by-height height 1050 'SXGA+))
  94              (setq dest (cons ret dest)))
  95            (when (setq ret (www-image-make-spec-by-height height 960 'SXGA))
  96              (setq dest (cons ret dest)))
  97            (when (setq ret (www-image-make-spec-by-height height 768 'XGA))
  98              (setq dest (cons ret dest)))
  99            (when (setq ret (www-image-make-spec-by-height height 600 'SVGA))
 100              (setq dest (cons ret dest)))
 101            (when (setq ret (www-image-make-spec-by-height height 480 'VGA))
 102              (setq dest (cons ret dest)))
 103            ))
 104     (setq rest dest)
 105     (while rest
 106       (setq spec (car rest))
 107       (www-image-write-html (file-name-sans-extension filename)
 108                             (aref spec 1)
 109                             (if (nth 1 rest)
 110                                 (aref (nth 1 rest) 1)))
 111       (call-process "convert" nil nil nil
 112                     "-resize" (format "%d%%" (aref spec 0))
 113                     filename
 114                     (format "%s/%s/%s.jpg"
 115                             (file-name-directory filename)
 116                             (aref spec 1)
 117                             (file-name-sans-extension
 118                              (file-name-nondirectory filename))))
 119       (setq rest (cdr rest)))
 120     (unless (file-exists-p
 121              (expand-file-name "fullsize"
 122                                (file-name-directory filename)))
 123       (make-directory
 124        (expand-file-name "fullsize"
 125                          (file-name-directory filename))))
 126     (call-process "convert" nil nil nil
 127                   filename
 128                   (format "%s/fullsize/%s.jpg"
 129                           (file-name-directory filename)
 130                           (file-name-sans-extension
 131                            (file-name-nondirectory filename))))
 132     dest))
 133
 134 (dolist (file
 135          (directory-files
 136           "/archives/RAID2/koukotsu/TAKUHON/" t "\\.TIF$"))
 137   (www-image-convert-images file))