From 64bf28e26648cecf3026b5c678ecf88b79a9578d Mon Sep 17 00:00:00 2001
From: MORIOKA Tomohiko <tomo.git@chise.org>
Date: Wed, 29 Jun 2016 18:06:50 +0900
Subject: [PATCH 1/1] New file.

---
 concord-images.el |  105 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 105 insertions(+)
 create mode 100644 concord-images.el

diff --git a/concord-images.el b/concord-images.el
new file mode 100644
index 0000000..3290595
--- /dev/null
+++ b/concord-images.el
@@ -0,0 +1,105 @@
+(concord-assign-genre 'image-resource "/usr/local/var/photo/db")
+
+(defun concord-images-encode-url-as-id (url)
+  (let (ret)
+    (cond
+     ((string-match "^http://hng\\.chise\\.org/images/iiif/" url)
+      (setq ret (substring url (match-end 0)))
+      (if (string-match "\\.[a-zA-Z0-9]+$" ret)
+	  (substring ret 0 (match-beginning 0))
+	ret)
+      )
+     ((string-match "^http://hng\\.chise\\.org/images/" url)
+      (setq ret (substring url (match-end 0)))
+      (if (string-match "\\.[a-zA-Z0-9]+$" ret)
+	  (substring ret 0 (match-beginning 0))
+	ret)
+      )
+     ((string-match "^http://" url)
+      (substring url (match-end 0))
+      )
+     (t
+      url))))
+
+(defun concord-images-add-url (url &optional iiif iip)
+  (let (img-id img-cobj)
+    (unless (setq img-cobj (concord-decode-object '=location url
+						  'image-resource))
+      (setq img-id (intern (concord-images-encode-url-as-id url)))
+      (setq img-cobj (concord-make-object 'image-resource img-id))
+      (concord-object-put img-cobj '=location url)
+      (when iiif
+	(concord-object-put img-cobj '=location@iiif iiif)
+	(with-temp-buffer
+	  (call-process
+	   "curl" nil (current-buffer) nil
+	   "--silent"
+	   (concat iiif "/info.json"))
+	  (goto-char (point-min))
+	  (when (re-search-forward
+		 "^[ \t]*\"width\"[ \t]*:[ \t]*\\([0-9]+\\)" nil t)
+	    (concord-object-put img-cobj 'width (string-to-int
+						 (match-string 1))))
+	  (when (re-search-forward
+		 "^[ \t]*\"height\"[ \t]*:[ \t]*\\([0-9]+\\)" nil t)
+	    (concord-object-put img-cobj 'height (string-to-int
+						  (match-string 1))))
+	  ))
+      (when iip
+	(concord-object-put img-cobj '=location@iip iip))
+      )
+    img-cobj))
+
+(defun concord-images-add-iiif (url)
+  (let (img-id img-cobj)
+    (unless (setq img-cobj (concord-decode-object '=location url
+						  'image-resource))
+      (setq img-id (intern (concord-images-encode-url-as-id url)))
+      (setq img-cobj (concord-make-object 'image-resource img-id))
+      (concord-object-put img-cobj '=location@iiif url))
+    img-cobj))
+
+(defun concord-images-add-segments (base-cobj x y width height)
+  (let ((base-id (concord-object-get base-cobj '=id))
+	base-width base-width-f base-height-f
+	base-iiif-url
+	seg-id seg-iiif-url seg-cobj
+	base-iip-url
+	rel-x rel-y rel-w rel-h)
+    (setq seg-id (intern (format "%s/xywh=%d,%d,%d,%d"
+				 base-id
+				 x y width height)))
+    (unless (setq seg-cobj (concord-decode-object '=id seg-id
+						  'image-resource))
+      (setq seg-cobj (concord-make-object 'image-resource seg-id))
+      (setq base-iiif-url (concord-object-get base-cobj '=location@iiif))
+      (concord-object-put seg-cobj '=location
+			  (format "%s#xywh=%d,%d,%d,%d"
+				  (concord-object-get base-cobj '=location)
+				  x y width height))
+      (concord-object-put seg-cobj 'offset-x x)
+      (concord-object-put seg-cobj 'offset-y y)
+      (concord-object-put seg-cobj 'width width)
+      (concord-object-put seg-cobj 'height height)
+      (setq seg-iiif-url (format "%s/%d,%d,%d,%d/full/0/default.jpg"
+				 base-iiif-url x y width height))
+      (concord-object-put seg-cobj '=location@iiif seg-iiif-url)
+      (when (setq base-iip-url (concord-object-get base-cobj '=location@iip))
+	(setq base-width (concord-object-get base-cobj 'width)
+	      base-width-f (float base-width)
+	      base-height-f (float (concord-object-get base-cobj 'height)))
+	(setq rel-x (/ x base-width-f)
+	      rel-y (/ y base-height-f)
+	      rel-w (/ width base-width-f)
+	      rel-h (/ height base-height-f))
+	(if (string-match "&CVT=jpeg" base-iip-url)
+	    (setq base-iip-url (substring base-iip-url 0 (match-beginning 0))))
+	(concord-object-put
+	 seg-cobj '=location@iip
+	 (format "%s&RGN=%f,%f,%f,%f&WID=%d&CVT=jpeg"
+		 base-iip-url rel-x rel-y rel-w rel-h width)))
+      (concord-object-adjoin* seg-cobj '<-image-segment base-cobj)
+      )
+    seg-cobj))
+
+(provide 'concord-images)
-- 
1.7.10.4