concord-images.el

   1 (concord-assign-genre 'image-resource "/usr/local/var/photo/db")
   2
   3 (defun concord-images-encode-url-as-id (url &optional base)
   4   (let (ret)
   5     (cond
   6      ((and base
   7            (string-match (concat "^" (regexp-quote base)) url))
   8       (setq ret (substring url (match-end 0)))
   9       (if (string-match "\\.[a-zA-Z0-9]+$" ret)
  10           (substring ret 0 (match-beginning 0))
  11         ret)
  12       )
  13      ((string-match "^http://\\(hng\\|image\\)\\.\\(chise\\.org\\|kanji\\.zinbun\\.kyoto-u\\.ac\\.jp\\)/images/iiif/" url)
  14       (setq ret (substring url (match-end 0)))
  15       (if (string-match "\\.[a-zA-Z0-9]+$" ret)
  16           (substring ret 0 (match-beginning 0))
  17         ret)
  18       )
  19      ((string-match "^http://\\(hng\\|image\\)\\.\\(chise\\.org\\|kanji\\.zinbun\\.kyoto-u\\.ac\\.jp\\)/images/" url)
  20       (setq ret (substring url (match-end 0)))
  21       (if (string-match "\\.[a-zA-Z0-9]+$" ret)
  22           (substring ret 0 (match-beginning 0))
  23         ret)
  24       )
  25      ((string-match "^http://" url)
  26       (substring url (match-end 0))
  27       )
  28      (t
  29       url))))
  30
  31 (defun concord-images-add-url (url &optional iiif iip base prefix prefer-iiif)
  32   (let (img-id img-cobj)
  33     (unless (setq img-cobj (concord-decode-object '=location url
  34                                                   'image-resource))
  35       (setq img-id
  36             (intern
  37              (concat prefix
  38                      (if prefer-iiif
  39                          (concord-images-encode-url-as-id iiif base)
  40                        (concord-images-encode-url-as-id url base)))))
  41       (setq img-cobj (concord-make-object 'image-resource img-id))
  42       (concord-object-put img-cobj '=location url)
  43       (when iiif
  44         (concord-object-put img-cobj '=location@iiif iiif)
  45         (with-temp-buffer
  46           (call-process
  47            "curl" nil (current-buffer) nil
  48            "--silent"
  49            (concat iiif "/info.json"))
  50           (goto-char (point-min))
  51           (when (re-search-forward
  52                  "^[ \t]*\"width\"[ \t]*:[ \t]*\\([0-9]+\\)" nil t)
  53             (concord-object-put img-cobj 'image-width
  54                                 (string-to-int (match-string 1))))
  55           (when (re-search-forward
  56                  "^[ \t]*\"height\"[ \t]*:[ \t]*\\([0-9]+\\)" nil t)
  57             (concord-object-put img-cobj 'image-height
  58                                 (string-to-int (match-string 1))))
  59           ))
  60       (when iip
  61         (concord-object-put img-cobj '=location@iip iip))
  62       )
  63     img-cobj))
  64
  65 (defun concord-images-add-iiif (url &optional base)
  66   (let (img-id img-cobj)
  67     (unless (setq img-cobj (concord-decode-object '=location url
  68                                                   'image-resource))
  69       (setq img-id (intern (concord-images-encode-url-as-id url base)))
  70       (setq img-cobj (concord-make-object 'image-resource img-id))
  71       (concord-object-put img-cobj '=location@iiif url))
  72     img-cobj))
  73
  74 (defun concord-images-add-segments (base-cobj x y width height)
  75   (let ((base-id (concord-object-get base-cobj '=id))
  76         base-width base-width-f base-height-f
  77         base-iiif-url
  78         seg-id seg-iiif-url seg-cobj
  79         base-iip-url
  80         rel-x rel-y rel-w rel-h)
  81     (setq seg-id (intern (format "%s/xywh=%d,%d,%d,%d"
  82                                  base-id
  83                                  x y width height)))
  84     (unless (setq seg-cobj (concord-decode-object '=id seg-id
  85                                                   'image-resource))
  86       (setq seg-cobj (concord-make-object 'image-resource seg-id))
  87       (setq base-iiif-url (concord-object-get base-cobj '=location@iiif))
  88       (concord-object-put seg-cobj '=location
  89                           (format "%s#xywh=%d,%d,%d,%d"
  90                                   (concord-object-get base-cobj '=location)
  91                                   x y width height))
  92       (concord-object-put seg-cobj 'image-offset-x x)
  93       (concord-object-put seg-cobj 'image-offset-y y)
  94       (concord-object-put seg-cobj 'image-width width)
  95       (concord-object-put seg-cobj 'image-height height)
  96       (setq seg-iiif-url (format "%s/%d,%d,%d,%d/full/0/default.jpg"
  97                                  base-iiif-url x y width height))
  98       (concord-object-put seg-cobj '=location@iiif seg-iiif-url)
  99       (when (setq base-iip-url (concord-object-get base-cobj '=location@iip))
 100         (setq base-width (concord-object-get base-cobj 'image-width)
 101               base-width-f (float base-width)
 102               base-height-f (float
 103                              (concord-object-get base-cobj 'image-height)))
 104         (setq rel-x (/ x base-width-f)
 105               rel-y (/ y base-height-f)
 106               rel-w (/ width base-width-f)
 107               rel-h (/ height base-height-f))
 108         (if (string-match "&CVT=jpeg" base-iip-url)
 109             (setq base-iip-url (substring base-iip-url 0 (match-beginning 0))))
 110         (concord-object-put
 111          seg-cobj '=location@iip
 112          (format "%s&RGN=%f,%f,%f,%f&WID=%d&CVT=jpeg"
 113                  base-iip-url rel-x rel-y rel-w rel-h width)))
 114       (concord-object-adjoin* seg-cobj '<-image-segment base-cobj)
 115       )
 116     seg-cobj))
 117
 118 (provide 'concord-images)