projects / elisp / album.git / commitdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | patch | inline | side by side (initial)
New file.
authortomo <tomo>
Fri, 15 Apr 2005 13:45:21 +0000 (13:45 +0000)
committertomo <tomo>
Fri, 15 Apr 2005 13:45:21 +0000 (13:45 +0000)
ChangeLog [new file with mode: 0644] patch | blob
www-image.el [new file with mode: 0644] patch | blob

diff --git a/ChangeLog b/ChangeLog
new file mode 100644 (file)
index 0000000..405ba52
--- /dev/null
+++ b/ChangeLog
@@ -0,0 +1,4 @@
+2005-04-13  MORIOKA Tomohiko  <tomo@kanji.zinbun.kyoto-u.ac.jp>
+
+       * www-image.el: New file.
+
diff --git a/www-image.el b/www-image.el
new file mode 100644 (file)
index 0000000..d6b397b
--- /dev/null
+++ b/www-image.el
@@ -0,0 +1,137 @@
+(defun www-image-make-spec-by-width (width limit spec-name)
+  (when (> width limit)
+    (let ((percent (floor (/ (* limit 100.0) width))))
+      (vector percent spec-name
+             (/ (* width percent) 100.0)
+             (/ (* height percent) 100.0)))))
+
+(defun www-image-make-spec-by-height (height limit spec-name)
+  (when (> height limit)
+    (let ((percent (floor (/ (* limit 100.0) height))))
+      (vector percent spec-name
+             (/ (* width percent) 100.0)
+             (/ (* height percent) 100.0)))))
+
+(defun www-image-write-html (file-base grade next-grade)
+  (with-temp-buffer
+    (insert
+     "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
+            \"http://www.w3.org/TR/html4/loose.dtd\">\n")
+    (insert "<head>\n")
+    (insert (format "<title>%s</title>\n"
+                   (file-name-nondirectory file-base)))
+    (insert "</head>\n")
+    (insert "<body>\n")
+    (insert (format "<h1>%s</h1>\n"
+                   (file-name-nondirectory file-base)))
+    (insert "
+<hr>
+")
+    (insert "<a href=\"")
+    (insert
+     (if next-grade
+         (format "../%s/%s.html"
+                 next-grade
+                 (file-name-nondirectory file-base))
+       (concat "../fullsize/"
+              (file-name-nondirectory file-base) ".jpg")))
+    (insert "\">")
+    (insert (format "<img alt=\"%s\" src=\"%s.jpg\">"
+                   (file-name-nondirectory file-base)
+                   (file-name-nondirectory file-base)))
+    (insert "</a>
+
+<hr>
+
+</body>
+</html>
+")
+    (unless (file-exists-p
+            (expand-file-name (symbol-name grade)
+                              (file-name-directory file-base)))
+      (make-directory
+       (expand-file-name (symbol-name grade)
+                        (file-name-directory file-base))))
+    (write-region (point-min)(point-max)
+                 (format "%s%s/%s.html"
+                         (file-name-directory file-base)
+                         grade
+                         (file-name-nondirectory file-base)))))
+
+(defun www-image-convert-images (filename)
+  (let* ((ret
+         (with-temp-buffer
+           (call-process "identify" nil t t filename)
+           (goto-char (point-min))
+           (and (re-search-forward " \\([0-9]+\\)x\\([0-9]+\\) " nil t)
+                (cons (string-to-number (match-string 1))
+                      (string-to-number (match-string 2))))))
+        (width (car ret))
+        (height (cdr ret))
+        rest dest)
+    (cond ((>= width height)
+          (when (setq ret (www-image-make-spec-by-width width 2048 'QXGA))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-width width 1600 'UXGA))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-width width 1400 'SXGA+))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-width width 1280 'SXGA))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-width width 1024 'XGA))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-width width 800 'SVGA))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-width width 640 'VGA))
+            (setq dest (cons ret dest)))
+          )
+         (t
+          (when (setq ret (www-image-make-spec-by-height height 1536 'QXGA))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-height height 1200 'UXGA))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-height height 1050 'SXGA+))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-height height 960 'SXGA))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-height height 768 'XGA))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-height height 600 'SVGA))
+            (setq dest (cons ret dest)))
+          (when (setq ret (www-image-make-spec-by-height height 480 'VGA))
+            (setq dest (cons ret dest)))
+          ))
+    (setq rest dest)
+    (while rest
+      (setq spec (car rest))
+      (www-image-write-html (file-name-sans-extension filename)
+                           (aref spec 1)
+                           (if (nth 1 rest)
+                               (aref (nth 1 rest) 1)))
+      (call-process "convert" nil nil nil
+                   "-resize" (format "%d%%" (aref spec 0))
+                   filename
+                   (format "%s/%s/%s.jpg"
+                           (file-name-directory filename)
+                           (aref spec 1)
+                           (file-name-sans-extension
+                            (file-name-nondirectory filename))))
+      (setq rest (cdr rest)))
+    (unless (file-exists-p
+            (expand-file-name "fullsize"
+                              (file-name-directory filename)))
+      (make-directory
+       (expand-file-name "fullsize"
+                        (file-name-directory filename))))
+    (call-process "convert" nil nil nil
+                 filename
+                 (format "%s/fullsize/%s.jpg"
+                         (file-name-directory filename)
+                         (file-name-sans-extension
+                          (file-name-nondirectory filename))))
+    dest))
+
+(dolist (file
+        (directory-files
+         "/archives/RAID2/koukotsu/TAKUHON/" t "\\.TIF$"))
+  (www-image-convert-images file))