update.
[chise/est.git] / est-eval.el
index 3cd848a..0d4be34 100644 (file)
@@ -14,7 +14,7 @@
        ((eq spec 02) (concat value "巻"))
        ((eq spec 03) (concat value "号"))
        ((eq spec 04) (concat value "編"))
        ((eq spec 02) (concat value "巻"))
        ((eq spec 03) (concat value "号"))
        ((eq spec 04) (concat value "編"))
-       ((eq spec 05) (concat value "&HD-JA-4A53;"))
+       ((eq spec 05) (concat value "&MJ019590;"))
        ((eq spec 06) (concat value "集"))
        ((eq spec 07) (concat value "輯"))
        ((eq spec 08) (concat value "部"))
        ((eq spec 06) (concat value "集"))
        ((eq spec 07) (concat value "輯"))
        ((eq spec 08) (concat value "部"))
                value)))
     (est-eval-value-as-S-exp value)))
 
                value)))
     (est-eval-value-as-S-exp value)))
 
-(defun est-eval-value-as-image-resource (value)
+(defun est-eval-value-as-image-resource (value &optional accept-full-image)
   (let ((name (concord-object-get value 'name)))
   (let ((name (concord-object-get value 'name)))
-    (if (concord-object-get value 'image-offset-x)
-       (list 'img (list* :src (or (concord-object-get value '=location@iiif)
-                                  (concord-object-get value '=location))
-                         (if name
-                             (list :alt name))))
-      name)))
+    (cond
+     ((concord-object-get value 'image-offset-x)
+      (list 'img (list* :src (or (concord-object-get value '=location@iiif)
+                                (concord-object-get value '=location))
+                       (if name
+                           (list :alt name))))
+      )
+     (accept-full-image
+      (list 'img (list* :src (concord-object-get value '=location)
+                       (if name
+                           (list :alt name))))
+      )
+     (t
+      name))))
+
+(defun est-eval-value-as-glyph-image (value)
+  (let ((image-resource (car (concord-object-get value '->image-resource))))
+    (est-eval-value-as-image-resource image-resource)))
+
+(defun est-eval-value-as-image-object (value)
+  (let ((image-resource (car (concord-object-get value '->image-resource))))
+    (list 'object (list :object value)
+         (est-eval-value-as-image-resource
+          image-resource 'accept-full-image))))
 
 ;; (defun est-journal-volume-object-get-volume-format (spec feature)
 ;;   (when (integerp spec)
 
 ;; (defun est-journal-volume-object-get-volume-format (spec feature)
 ;;   (when (integerp spec)
 ;;         ((string= spec "02") `((decimal (:feature ,feature)) "巻"))
 ;;         ((string= spec "03") `((decimal (:feature ,feature)) "号"))
 ;;         ((string= spec "04") `((decimal (:feature ,feature)) "&AJ1-03620;"))
 ;;         ((string= spec "02") `((decimal (:feature ,feature)) "巻"))
 ;;         ((string= spec "03") `((decimal (:feature ,feature)) "号"))
 ;;         ((string= spec "04") `((decimal (:feature ,feature)) "&AJ1-03620;"))
-;;         ((string= spec "05") `((decimal (:feature ,feature)) "&HD-JA-4A53;"))
+;;         ((string= spec "05") `((decimal (:feature ,feature)) "&MJ019590;"))
 ;;         ((string= spec "06") `((decimal (:feature ,feature)) "集"))
 ;;         ((string= spec "07") `((decimal (:feature ,feature)) "輯"))
 ;;         ((string= spec "08") `((decimal (:feature ,feature)) "部"))
 ;;         ((string= spec "06") `((decimal (:feature ,feature)) "集"))
 ;;         ((string= spec "07") `((decimal (:feature ,feature)) "輯"))
 ;;         ((string= spec "08") `((decimal (:feature ,feature)) "部"))
                 ((eq genre 'image-resource)
                  (est-eval-value-as-image-resource value)
                  )
                 ((eq genre 'image-resource)
                  (est-eval-value-as-image-resource value)
                  )
+                 ((eq genre 'glyph-image)
+                 (est-eval-value-as-glyph-image value)
+                 )
                  (t
                  (setq genre-o (concord-decode-object '=id genre 'genre))
                  (or (and genre-o
                  (t
                  (setq genre-o (concord-decode-object '=id genre 'genre))
                  (or (and genre-o
                                 genre-o 'object-representative-feature))
                           'name))
                      (www-get-feature-value value '=name)
                                 genre-o 'object-representative-feature))
                           'name))
                      (www-get-feature-value value '=name)
+                     (www-get-feature-value value '=title)
                      (est-eval-value-default value))
                  ))
                )))
                      (est-eval-value-default value))
                  ))
                )))
            (mapconcat #'char-to-string ret ""))
     (est-eval-value-as-object value))))
 
            (mapconcat #'char-to-string ret ""))
     (est-eval-value-as-object value))))
 
+(defun est-eval-value-as-object-with-description (value
+                                                 object feature-name
+                                                 &optional lang uri-object list-props)
+  (let (ret)
+    (cond
+     ((characterp value)
+      (setq ret (or (get-char-attribute value 'description)
+                   (get-char-attribute value 'hdic-syp-description)
+                   (get-char-attribute value 'hdic-ktb-description)))
+      )
+     ((concord-object-p value)
+      (setq ret (concord-object-get value 'description))
+      ))
+    (if ret
+       (list 'list nil
+             (est-eval-value-as-object value)
+             (est-eval-list ret
+                            object feature-name
+                            lang uri-object list-props))
+      (est-eval-value-as-object value))))
+
+(defun est-eval-value-as-hdic-tsj-character-with-description (value
+                                                             object feature-name
+                                                             &optional
+                                                             lang uri-object list-props)
+  (let (word desc ret)
+    (cond
+     ((characterp value)
+      (when (setq word (get-char-attribute value 'hdic-tsj-word))
+       (if (and (= (length word) 1)
+                (setq ret (get-char-attribute value '<-HDIC-TSJ))
+                (memq (aref word 0) ret))
+           (setq desc (or (get-char-attribute value 'hdic-tsj-word-description)
+                          (get-char-attribute value 'description)))
+         (setq desc (list "(" word ")"))))
+      )
+     ((concord-object-p value)
+      (setq desc (concord-object-get value 'description))
+      ))
+    (if desc
+       (list 'list nil
+             (est-eval-value-as-object value)
+             (est-eval-list (append desc '("  "))
+                            object feature-name
+                            lang uri-object list-props))
+      (est-eval-value-as-object value))))
+
+(defun est-eval-value-as-location (value)
+  (let (ret)
+  (if (and (concord-object-p value)
+          (setq ret (concord-object-get value '=location)))
+      (list 'object (list :object value)
+           ret)
+    (est-eval-value-as-object value))))
+
+(defun est-eval-value-as-name (value)
+  (let (ret)
+  (if (and (concord-object-p value)
+          (setq ret (concord-object-get value 'name)))
+      (list 'object (list :object value)
+           ret)
+    (est-eval-value-as-object value))))
+
 (defun est-eval-value-as-HEX (value)
   (if (integerp value)
       (list 'HEX nil (format "%X" value))
 (defun est-eval-value-as-HEX (value)
   (if (integerp value)
       (list 'HEX nil (format "%X" value))
            (format "%c" (ideographic-radical value)))
     (est-eval-value-as-S-exp value)))
 
            (format "%c" (ideographic-radical value)))
     (est-eval-value-as-S-exp value)))
 
+(defun est-eval-value-as-shuowen-radical (value)
+  (if (and (integerp value)
+          (<= 0 value)
+          (<= value 540))
+      (list 'shuowen-radical
+           nil
+           (format "%c" (shuowen-radical value)))
+    (est-eval-value-as-S-exp value)))
+
+(defun daijiten-page-number-to-ndl-950498 (page)
+  (+ (/ page 2)
+     (cond ((< page 229)
+           23)
+          ((< page 261)
+           24)
+          ((< page 263)
+           25)
+          ((< page 516) ; 284=285
+           26)
+          (t
+           27))))
+
+(defun est-eval-value-as-daijiten-page (value)
+  (if (integerp value)
+      (list 'link
+           (list :ref
+                 (format "http://image.chise.org/tify/?manifest=https://www.dl.ndl.go.jp/api/iiif/950498/manifest.json&tify={%%22pages%%22:[%d]}"
+                         (daijiten-page-number-to-ndl-950498 value)))
+           value)))
+
+(defun est-eval-value-as-ndl-page-by-tify (value)
+  (if (symbolp value)
+      (setq value (symbol-name value)))
+  (if (stringp value)
+      (if (string-match "/" value)
+         (format "http://image.chise.org/tify/?manifest=https://www.dl.ndl.go.jp/api/iiif/%s/manifest.json&tify={%%22pages%%22:[%s]}"
+                 (substring value 0 (match-beginning 0))
+                 (substring value (match-end 0)))
+       (format "http://image.chise.org/tify/?manifest=https://www.dl.ndl.go.jp/api/iiif/%s/manifest.json"
+               value))
+    value))
+
+(defun est-eval-value-as-Web-yunzi-char (value)
+  (if (char-or-char-int-p value)
+      (list 'link
+           (list :ref
+                 (format "http://suzukish.s252.xrea.com/search/inkyo/yunzi/%c"
+                         value))
+           (format "/%s/" (char-to-string value)))))
+
+(defun est-eval-value-as-HDIC-Yuanben-Yupian-volume-leaf-line-number (value)
+  (if (symbolp value)
+      (setq value (symbol-name value)))
+  (if (and (stringp value)
+          (string-match
+           "^Y\\([0-9][0-9]\\)\\([0-9][0-9][0-9]\\)\\([0-9][0-9][0-9]\\)-\\([0-9]\\)$"
+           value))
+      (format "%d巻 %d紙 %d列 %d字目 (%s)"
+             (string-to-int (match-string 1 value))
+             (string-to-int (match-string 2 value))
+             (string-to-int (match-string 3 value))
+             (string-to-int (match-string 4 value))
+             value)
+    value))
+
 (defun est-eval-value-as-object-list (value &optional separator subtype)
   (if (and (listp value)
           (listp (cdr value)))
 (defun est-eval-value-as-object-list (value &optional separator subtype)
   (if (and (listp value)
           (listp (cdr value)))
        (error (format "%s" value)))
     (format "%s" value)))
 
        (error (format "%s" value)))
     (format "%s" value)))
 
+(defun est-eval-value-as-location-list (value &optional separator subtype)
+  (if (and (listp value)
+          (listp (cdr value)))
+      (condition-case nil
+         (let (props)
+           (if separator
+               (setq props (list :separator separator)))
+           (if subtype
+               (setq props (list* :subtype subtype props)))
+           (list* 'list props
+                  (mapcar #'est-eval-value-as-location value)))
+       (error (format "%s" value)))
+    (format "%s" value)))
+
+(defun est-eval-value-as-name-list (value &optional separator subtype)
+  (if (and (listp value)
+          (listp (cdr value)))
+      (condition-case nil
+         (let (props)
+           (if separator
+               (setq props (list :separator separator)))
+           (if subtype
+               (setq props (list* :subtype subtype props)))
+           (list* 'list props
+                  (mapcar #'est-eval-value-as-name value)))
+       (error (format "%s" value)))
+    (format "%s" value)))
+
+(defun est-eval-value-as-image-list (value &optional separator subtype)
+  (if (and (listp value)
+          (listp (cdr value)))
+      (condition-case nil
+         (let (props)
+           (if separator
+               (setq props (list :separator separator)))
+           (if subtype
+               (setq props (list* :subtype subtype props)))
+           (list* 'image-list props
+                  (mapcar #'est-eval-value-as-image-object value)))
+       (error (format "%s" value)))
+    (format "%s" value)))
+
 (defun est-eval-value-as-composition-list (value &optional separator subtype)
   (if (and (listp value)
           (listp (cdr value)))
 (defun est-eval-value-as-composition-list (value &optional separator subtype)
   (if (and (listp value)
           (listp (cdr value)))
        (error (format "%s" value)))
     (format "%s" value)))
 
        (error (format "%s" value)))
     (format "%s" value)))
 
+(defun est-eval-value-as-entry-character-list (value
+                                              object feature-name
+                                              &optional separator subtype
+                                              lang uri-object list-props)
+  (if (and (listp value)
+          (listp (cdr value)))
+      (condition-case nil
+         (let (props)
+           (if separator
+               (setq props (list :separator separator)))
+           (if subtype
+               (setq props (list* :subtype subtype props)))
+           (list* 'list props
+                  (mapcar (lambda (cell)
+                            (est-eval-value-as-object-with-description
+                             cell
+                             object feature-name
+                             lang uri-object list-props))
+                          value)))
+       (error (format "%s" value)))
+    (format "%s" value)))
+
+(defun est-eval-value-as-hdic-tsj-entry-character-list (value
+                                                       object feature-name
+                                                       &optional separator subtype
+                                                       lang uri-object list-props)
+  (if (and (listp value)
+          (listp (cdr value)))
+      (condition-case nil
+         (let (props)
+           (if separator
+               (setq props (list :separator separator)))
+           (if subtype
+               (setq props (list* :subtype subtype props)))
+           (list* 'list props
+                  (mapcar (lambda (cell)
+                            (est-eval-value-as-hdic-tsj-character-with-description
+                             cell
+                             object feature-name
+                             lang uri-object list-props))
+                          value)))
+       (error (format "%s" value)))
+    (format "%s" value)))
+  
+
 ;; (defun est-eval-value-as-ids (value)
 ;;   (if (listp value)
 ;;       (list 'ids nil (ideographic-structure-to-ids value))
 ;; (defun est-eval-value-as-ids (value)
 ;;   (if (listp value)
 ;;       (list 'ids nil (ideographic-structure-to-ids value))
                value)))
     (est-eval-value-default value)))
 
                value)))
     (est-eval-value-default value)))
 
+(defun est-eval-value-as-sources (value)
+  (if (listp value)
+      (let (unit-str
+           source item source-objs source0 start end num
+           source-cobj title)
+       (list* 'res-list
+              '(:separator " ")
+              (mapcar
+               (lambda (unit)
+                 (setq unit-str
+                       (if (symbolp unit)
+                           (symbol-name unit)
+                         (format "%s" unit)))
+                 (if (string-match "=" unit-str)
+                     (setq source (intern
+                                   (substring unit-str 0 (match-beginning 0)))
+                           item (car (read-from-string
+                                      (substring unit-str (match-end 0)))))
+                   (setq source unit
+                         item nil))
+                 (cond
+                  ((and (setq source-cobj (concord-decode-object
+                                           '=chise-bib-id source 'bibliography))
+                        (setq title (concord-object-get source-cobj '=title)))
+                   (setq source-objs
+                         (if item
+                             (list (est-eval-value-as-object source-cobj)
+                                   "="
+                                   item)
+                           (list (est-eval-value-as-object source-cobj))))
+                   )
+                  ((eq source 'bos)
+                   (setq source-objs
+                         (list
+                          (est-eval-value-as-object
+                           (or (concord-decode-object
+                                '=id item 'book@ruimoku)
+                               (concord-decode-object
+                                '=id item 'article@ruimoku)
+                               unit))))
+                   )
+                  ((memq source '(zob1959 zob1968))
+                   (if (and (symbolp item)
+                            (setq num (symbol-name item))
+                            (string-match
+                             "^\\([0-9]+\\)-\\([0-9]+\\)$" num))
+                       (setq start (string-to-number
+                                    (match-string 1 num))
+                             end (string-to-number
+                                  (match-string 2 num)))
+                     (setq start item
+                           end item))
+                   (if (not (numberp start))
+                       (setq source-objs
+                             (list
+                              (est-eval-value-as-object unit)))
+                     (if (eq source source0)
+                         (setq source-objs
+                               (list
+                                (list 'link
+                                      (list :ref
+                                            (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
+                                                    start))
+                                      start)))
+                       (setq source0 source)
+                       (setq source-objs
+                             (list
+                              (list 'link
+                                      (list :ref
+                                            (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
+                                                    start))
+                                      start)
+                              "="
+                              '(link
+                                (:ref "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/")
+                                "\u4EAC大人\u6587研甲\u9AA8")))
+                       )
+                     (setq num (1+ start))
+                     (while (<= num end)
+                       (setq source-objs
+                             (cons
+                              (list 'link
+                                    (list :ref
+                                          (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
+                                                  num))
+                                    num)
+                              source-objs))
+                       (setq num (1+ num)))
+                     (setq source-objs (nreverse source-objs)))
+                   )
+                  (t
+                   (setq source-objs
+                         (list (est-eval-value-as-object unit)))
+                   ))
+                 (list* 'res-link
+                        (list :separator " "
+                              :source source :item item)
+                        source-objs)
+                 )
+               value)))
+    (est-eval-value-default value)))
+
+(defun est-eval-value-as-daijiten-page-list (value &optional separator subtype)
+  (if (and (listp value)
+          (listp (cdr value)))
+      (condition-case nil
+         (let (props)
+           (if separator
+               (setq props (list :separator separator)))
+           (if subtype
+               (setq props (list* :subtype subtype props)))
+           (list* 'list props
+                  (mapcar #'est-eval-value-as-daijiten-page value)))
+       (error (format "%s" value)))
+    (format "%s" value)))
+
+(defun est-eval-value-as-Web-yunzi-char-list (value &optional separator subtype)
+  (if (and (listp value)
+          (listp (cdr value)))
+      (condition-case nil
+         (let (props)
+           (if separator
+               (setq props (list :separator separator)))
+           (if subtype
+               (setq props (list* :subtype subtype props)))
+           (list* 'list props
+                  (mapcar #'est-eval-value-as-Web-yunzi-char value)))
+       (error (format "%s" value)))
+    (format "%s" value)))
+
 (defun est-eval-value-as-creators-names (value &optional subtype)
   (if (listp value)
       (let (role-name)
 (defun est-eval-value-as-creators-names (value &optional subtype)
   (if (listp value)
       (let (role-name)
                 '(:subtype unordered-list)
               '(:separator " "))
             (mapcar (lambda (creator)
                 '(:subtype unordered-list)
               '(:separator " "))
             (mapcar (lambda (creator)
-                      (est-eval-list
-                       '((value (:feature <-creator)))
-                       creator nil))
+                      (if (concord-object-p creator)
+                          (est-eval-list
+                           '((value (:feature <-creator)))
+                           creator nil)
+                        (est-eval-value-default creator)))
                     value))
     (est-eval-value-default value)))
 
                     value))
     (est-eval-value-default value)))
 
         ((eq format 'wiki-text)
          (est-eval-list value object feature-name nil uri-object)
          )
         ((eq format 'wiki-text)
          (est-eval-list value object feature-name nil uri-object)
          )
+        ((eq format 'unordered-link-list)
+         (est-eval-list value object feature-name nil uri-object
+                        '(:subtype unordered-list :separator " "))
+         )
         ((eq format 'S-exp)
          (est-eval-value-as-S-exp value)
          )
         ((eq format 'S-exp)
          (est-eval-value-as-S-exp value)
          )
          (est-eval-value-as-kuten value))
         ((eq format 'kangxi-radical)
          (est-eval-value-as-kangxi-radical value))
          (est-eval-value-as-kuten value))
         ((eq format 'kangxi-radical)
          (est-eval-value-as-kangxi-radical value))
+        ((eq format 'tify-url-for-ndl)
+         (est-eval-value-as-ndl-page-by-tify value)
+         )
+        ((eq format 'hdic-yy-readable)
+         (est-eval-value-as-HDIC-Yuanben-Yupian-volume-leaf-line-number value)
+         )
+        ((eq format 'shuowen-radical)
+         (est-eval-value-as-shuowen-radical value))
         ((eq format 'ids)
          (est-eval-value-as-ids value))
         ((eq format 'decomposition)
         ((eq format 'ids)
          (est-eval-value-as-ids value))
         ((eq format 'decomposition)
          (est-eval-value-as-object-list value " "))
         ((eq format 'char-list)
          (est-eval-value-as-char-list value nil))
          (est-eval-value-as-object-list value " "))
         ((eq format 'char-list)
          (est-eval-value-as-char-list value nil))
+        ((eq format 'location-list)
+         (est-eval-value-as-location-list value nil))
+        ((eq format 'name-list)
+         (est-eval-value-as-name-list value nil))
+        ((eq format 'image-list)
+         (est-eval-value-as-image-list value nil))
         ((eq format 'unordered-list)
          (est-eval-value-as-object-list value nil 'unordered-list))
         ((eq format 'unordered-composition-list)
          (est-eval-value-as-composition-list value nil 'unordered-list))
         ((eq format 'unordered-list)
          (est-eval-value-as-object-list value nil 'unordered-list))
         ((eq format 'unordered-composition-list)
          (est-eval-value-as-composition-list value nil 'unordered-list))
+        ((eq format 'entry-character-list)
+         (est-eval-value-as-entry-character-list
+          value
+          object feature-name
+          nil nil
+          lang uri-object list-props))
+        ((eq format 'unordered-entry-character-list)
+         (est-eval-value-as-entry-character-list
+          value
+          object feature-name
+          nil 'unordered-list
+          lang uri-object list-props))
+        ((eq format 'hdic-tsj-entry-character-list)
+         (est-eval-value-as-hdic-tsj-entry-character-list
+          value
+          object feature-name
+          nil nil
+          lang uri-object list-props))
         ((eq format 'space-separated-ids)
          (est-eval-value-as-space-separated-ids value))
         ((eq format 'space-separated-domain-list)
         ((eq format 'space-separated-ids)
          (est-eval-value-as-space-separated-ids value))
         ((eq format 'space-separated-domain-list)
-         (est-eval-value-as-domain-list value))
+          ;; (est-eval-value-as-domain-list value)
+         (est-eval-value-as-sources value))
+        ((eq format 'space-separated-source-list)
+         (est-eval-value-as-sources value))
         ((eq format 'space-separated-creator-name-list)
          (est-eval-value-as-creators-names value))
         ((eq format 'unordered-creator-name-list)
         ((eq format 'space-separated-creator-name-list)
          (est-eval-value-as-creators-names value))
         ((eq format 'unordered-creator-name-list)
          (est-eval-value-as-created-works value 'unordered-list))
         ((eq format 'journal-volume-list)
          (est-eval-value-as-journal-volumes value))
          (est-eval-value-as-created-works value 'unordered-list))
         ((eq format 'journal-volume-list)
          (est-eval-value-as-journal-volumes value))
+        ((eq format 'space-separated-daijiten-page-list)
+         (est-eval-value-as-daijiten-page-list value " "))
+        ((eq format 'space-separated-Web-yunzi-char-list)
+         (est-eval-value-as-Web-yunzi-char-list value " "))
         (t
          (est-eval-value-default value)
          ))
         (t
          (est-eval-value-default value)
          ))
    ((null exp) "")
    ((consp exp)
     (cond
    ((null exp) "")
    ((consp exp)
     (cond
-     ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
-                             S-exp string default))
+     ((memq (car exp) '(value decimal hex HEX ku-ten
+                             kangxi-radical shuowen-radical
+                             S-exp string default
+                             tify-url-for-ndl hdic-yy-readable))
       (let ((fn (plist-get (nth 1 exp) :feature))
            domain domain-fn ret)
        (when fn
       (let ((fn (plist-get (nth 1 exp) :feature))
            domain domain-fn ret)
        (when fn
       exp)))))
 
 (defun est-eval-list (format-list object feature-name
       exp)))))
 
 (defun est-eval-list (format-list object feature-name
-                                 &optional lang uri-object)
+                                 &optional lang uri-object list-props)
   (if (consp format-list)
       (let ((ret
             (mapcar
   (if (consp format-list)
       (let ((ret
             (mapcar
                (est-eval-unit exp object feature-name lang uri-object nil))
              format-list)))
        (if (cdr ret)
                (est-eval-unit exp object feature-name lang uri-object nil))
              format-list)))
        (if (cdr ret)
-           (list* 'list nil ret)
+           (list* 'list list-props ret)
          (car ret)))
     (est-eval-unit format-list object feature-name lang uri-object nil)))
 
          (car ret)))
     (est-eval-unit format-list object feature-name lang uri-object nil)))