X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fest.git;a=blobdiff_plain;f=est-eval.el;h=8076a4325c244493c840de00b1b8fc9a6f4365ec;hp=54e1d1477d3380bd5707f2d896607d62459437b5;hb=df2fa617d25de8d6ccae25b062f2b973e2d95113;hpb=3563bae1461f8469d212d3ab5cc9d15ab06c8af0 diff --git a/est-eval.el b/est-eval.el index 54e1d14..8076a43 100644 --- a/est-eval.el +++ b/est-eval.el @@ -1,6 +1,8 @@ ;; -*- coding: utf-8-mcs-er -*- (require 'cwiki-common) +(defvar est-eval-list-feature-items-limit 20) + (defun ruimoku-format-volume (spec value year lang) (when (stringp spec) (setq spec (car (read-from-string spec)))) @@ -11,19 +13,19 @@ ((eq spec 01) (concat value "期")) ((eq spec 02) (concat value "巻")) ((eq spec 03) (concat value "号")) - ((eq spec 04) (concat value ">-35694;")) - ((eq spec 05) (concat value ">-33870;")) - ((eq spec 06) (concat value ">-56392;")) + ((eq spec 04) (concat value "編")) + ((eq spec 05) (concat value "&MJ019590;")) + ((eq spec 06) (concat value "集")) ((eq spec 07) (concat value "輯")) - ((eq spec 08) (concat value ">-53119;")) - ((eq spec 09) (concat value ">-53119;&AJ1-03580;")) + ((eq spec 08) (concat value "部")) + ((eq spec 09) (concat value "部分")) ((eq spec 10) (concat value "冊")) - ((eq spec 11) (concat value "&AJ1-03580;冊")) - ((eq spec 12) (concat value "&J90-3C21;")) - ((eq spec 13) (concat value ">-18140;号")) - ((eq spec 14) (concat value "特>-56392;号")) + ((eq spec 11) (concat value "分冊")) + ((eq spec 12) (concat value "次")) + ((eq spec 13) (concat value "月号")) + ((eq spec 14) (concat value "特集号")) ((eq spec 15) (concat value "本")) - ((eq spec 16) (concat value "&AJ1-03580;")) + ((eq spec 16) (concat value "分")) ((eq spec 51) (concat "Vol." value)) ((eq spec 52) (concat "No." value)) ((eq spec 53) (concat "Part " value)) @@ -62,6 +64,33 @@ value))) (est-eval-value-as-S-exp value))) +(defun est-eval-value-as-image-resource (value &optional accept-full-image) + (let ((name (concord-object-get value '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) ;; (setq spec (format "%02d" spec))) @@ -71,19 +100,19 @@ ;; ((string= spec "01") `((decimal (:feature ,feature)) "期")) ;; ((string= spec "02") `((decimal (:feature ,feature)) "巻")) ;; ((string= spec "03") `((decimal (:feature ,feature)) "号")) -;; ((string= spec "04") `((decimal (:feature ,feature)) ">-35694;")) -;; ((string= spec "05") `((decimal (:feature ,feature)) ">-33870;")) -;; ((string= spec "06") `((decimal (:feature ,feature)) ">-56392;")) +;; ((string= spec "04") `((decimal (:feature ,feature)) "&AJ1-03620;")) +;; ((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)) ">-53119;")) -;; ((string= spec "09") `((decimal (:feature ,feature)) ">-53119;&AJ1-03580;")) +;; ((string= spec "08") `((decimal (:feature ,feature)) "部")) +;; ((string= spec "09") `((decimal (:feature ,feature)) "部分")) ;; ((string= spec "10") `((decimal (:feature ,feature)) "冊")) -;; ((string= spec "11") `((decimal (:feature ,feature)) "&AJ1-03580;冊")) -;; ((string= spec "12") `((decimal (:feature ,feature)) "&J90-3C21;")) -;; ((string= spec "13") `((decimal (:feature ,feature)) ">-18140;号")) -;; ((string= spec "14") `((decimal (:feature ,feature)) "特>-56392;号")) +;; ((string= spec "11") `((decimal (:feature ,feature)) "分冊")) +;; ((string= spec "12") `((decimal (:feature ,feature)) "次")) +;; ((string= spec "13") `((decimal (:feature ,feature)) "月号")) +;; ((string= spec "14") `((decimal (:feature ,feature)) "特集号")) ;; ((string= spec "15") `((decimal (:feature ,feature)) "本")) -;; ((string= spec "16") `((decimal (:feature ,feature)) "&AJ1-03580;")) +;; ((string= spec "16") `((decimal (:feature ,feature)) "分")) ;; ((string= spec "51") `("Vol." ((decimal (:feature ,feature))))) ;; ((string= spec "52") `("No." ((decimal (:feature ,feature))))) ;; ((string= spec "53") `("Part " ((decimal (:feature ,feature))))) @@ -103,31 +132,195 @@ ;; (t nil) ;; )) -(defun est-eval-journal-volume (value) - (let ((journal (car (concord-object-get value '<-volume))) +(defun est-eval-value-as-journal-volume (value &optional short) + (let ((journal (car (or (concord-object-get value '<-journal/volume) + (concord-object-get value '<-volume)))) + (vol-name (concord-object-get value '<-journal/volume*name)) volume-type number-type - year) - (setq volume-type (concord-object-get journal 'volume/type/code) - number-type (concord-object-get journal 'number/type/code)) - (setq year (or (concord-object-get value '->published/date*year) - (concord-object-get - (car (concord-object-get value 'published/date)) 'year))) - ;; (append (list (concord-object-get journal 'name)) - ;; (est-journal-volume-object-get-volume-format - ;; volume-type '<-volume*volume) - ;; (est-journal-volume-object-get-volume-format - ;; number-type '<-volume*number) - ;; ) - (concat (concord-object-get journal 'name) - " " - (ruimoku-format-volume - volume-type - (concord-object-get value '<-volume*volume) - year 'cjk) - (ruimoku-format-volume - number-type - (concord-object-get value '<-volume*number) - year 'cjk)) + year + dest ret title subtitle) + (cond + (journal + (if vol-name + (setq dest + (list + (list 'object (list :object value) + vol-name))) + (setq volume-type (concord-object-get journal 'volume/type/code) + number-type (concord-object-get journal 'number/type/code)) + (setq year (or (concord-object-get value '->published/date*year) + (concord-object-get + (car (concord-object-get value 'date)) 'year))) + (setq dest + (list + (list 'object + (list :object value) + (ruimoku-format-volume + volume-type + (or (concord-object-get value '<-journal/volume*volume) + (concord-object-get value '<-volume*volume)) + year 'cjk) + (ruimoku-format-volume + number-type + (or (concord-object-get value '<-journal/volume*number) + (concord-object-get value '<-volume*number)) + year 'cjk)))) + ) + (unless short + (if (setq ret (est-eval-value-as-object journal)) + (setq dest + (list* ret " " dest)))) + (list* 'list '(:subtype sequence :separator "") dest) + ) + ((setq title (concord-object-get value 'title)) + (setq subtitle (concord-object-get value 'title/subtitle)) + (list* 'object + (list :object value) + (if (eq (concord-object-get value 'writing-system) 'cjk) + (list + "「" + (list 'object (list :object value) + (if subtitle + (concat title " — " subtitle) + title)) + "」") + (list + " ‘" + (list 'object (list :object value) + (if subtitle + (concat title " — " subtitle) + title)) + "’"))) + ) + (t + (est-eval-value-default value) + )) + ;; (concat (concord-object-get journal 'name) + ;; " " + ;; (ruimoku-format-volume + ;; volume-type + ;; (or (concord-object-get value '<-journal/volume*volume) + ;; (concord-object-get value '<-volume*volume)) + ;; year 'cjk) + ;; (ruimoku-format-volume + ;; number-type + ;; (or (concord-object-get value '<-journal/volume*number) + ;; (concord-object-get value '<-volume*number)) + ;; year 'cjk)) + )) + +(defun est-eval-value-as-article (value) + (let ((journal-volume (car (concord-object-get value '<-article))) + (page (concord-object-get value 'page)) + date ret dest) + (when journal-volume + (setq date (car (concord-object-get journal-volume 'date))) + (if (and date + (setq ret (est-eval-value-as-object date))) + (setq dest (list ", " ret)))) + (if page + (setq dest (list* ", pp." page dest))) + (when (and journal-volume + (setq ret (est-eval-value-as-journal-volume journal-volume))) + (setq dest (cons ret dest))) + (if (setq ret (est-eval-value-as-book value)) + (setq dest (list* ret " " dest))) + (list* 'list '(:subtype sequence :separator "") dest)) + ;; (let ((creators (concord-object-get value '->creator)) + ;; (title (concord-object-get value 'title)) + ;; creator-name creator-role) + ;; (concat + ;; (mapconcat + ;; (lambda (creator) + ;; (setq creator-name + ;; (concord-object-get + ;; (car (concord-object-get creator '->creator/name)) + ;; '=name)) + ;; (setq creator-role + ;; (or (concord-object-get creator 'role*name) + ;; (format "(%s)" + ;; (concord-object-get creator 'role*type)))) + ;; (concat creator-name " " creator-role)) + ;; creators ", ") + ;; (if (eq (concord-object-get value 'writing-system) 'cjk) + ;; (concat "「" title "」") + ;; (concat " ‘" title "’")))) + ) + +(defun est-eval-value-as-book (value) + (let ((creators (concord-object-get value '->creator)) + (title (concord-object-get value 'title)) + (subtitle (concord-object-get value 'title/subtitle)) + (series (concord-object-get value 'series)) + (publisher (car (concord-object-get value 'publisher))) + (date (car (concord-object-get value 'date))) + ;; creator-name creator-role + dest ret) + (if (and date + (setq ret (est-eval-value-as-object date))) + (setq dest (list ", " ret))) + (if (and publisher + (setq ret (est-eval-value-as-object publisher))) + (setq dest (list* " " ret dest))) + (if series + (setq dest (list* series "," dest))) + (setq dest + (if title + (if (eq (concord-object-get value 'writing-system) 'cjk) + (list* + "「" + (list 'object (list :object value) + (if subtitle + (concat title " — " subtitle) + title)) + "」" dest) + (list* + " ‘" + (list 'object (list :object value) + (if subtitle + (concat title " — " subtitle) + title)) + "’" dest)) + (list* " " + (list 'object (list :object value) + "(review)") + dest))) + (when (and creators + (setq ret (est-eval-value-as-creators-names creators))) + (setq dest (cons ret dest))) + (list* 'list '(:subtype sequence :separator "") dest) + ;; (concat + ;; (mapconcat + ;; (lambda (creator) + ;; (setq creator-name + ;; (concord-object-get + ;; (car (concord-object-get creator '->creator/name)) + ;; '=name)) + ;; (setq creator-role + ;; (or (concord-object-get creator 'role*name) + ;; (format "(%s)" + ;; (concord-object-get creator 'role*type)))) + ;; (concat creator-name " " creator-role)) + ;; creators ", ") + ;; (if (eq (concord-object-get value 'writing-system) 'cjk) + ;; (concat "「" title + ;; (if subtitle + ;; (concat " — " subtitle)) + ;; "」") + ;; (concat " ‘" title + ;; (if subtitle + ;; (concat " — " subtitle)) + ;; "’")) + ;; (if series + ;; (concat " " series)) + ;; (if publisher + ;; (concat ", " + ;; (concord-object-get + ;; (car (concord-object-get + ;; publisher '->publisher/name)) + ;; '=name))) + ;; (if date + ;; (concat ", " (concord-object-get date 'name))))) )) ;; (defun est-eval-creator (value) @@ -150,12 +343,24 @@ ;; (est-eval-list ;; (est-journal-volume-get-object-format value) ;; value nil) - (est-eval-journal-volume value) + (est-eval-value-as-journal-volume value) + ) + ((eq genre 'article@ruimoku) + (est-eval-value-as-article value) + ) + ((eq genre 'book@ruimoku) + (est-eval-value-as-book value) ) ;; ((eq genre 'creator@ruimoku) ;; (est-eval-creator value) ;; ) - (t + ((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 (setq format @@ -168,11 +373,36 @@ (www-get-feature-value genre-o 'object-representative-feature)) 'name)) + (www-get-feature-value value '=name) (est-eval-value-default value)) )) ))) (est-eval-value-default value))) +(defun est-eval-value-as-character (value) + (let (ret) + (if (and (concord-object-p value) + (setq ret (concord-object-get value 'character))) + (list 'object (list :object value) + (mapconcat #'char-to-string ret "")) + (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)) @@ -196,25 +426,131 @@ (format "%c" (ideographic-radical value))) (est-eval-value-as-S-exp value))) -(defun est-eval-value-as-object-list (value &optional separator) - (if (listp value) - (list* 'list - (if separator - (list :separator separator)) - ;; (mapcar - ;; (lambda (unit) - ;; (if (characterp unit) - ;; (list 'char-link nil (format "%c" unit)) - ;; (format "%s" unit))) - ;; value) - (mapcar #'est-eval-value-as-object value) - ) +(defun est-eval-value-as-object-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-object value))) + (error (format "%s" value))) + (format "%s" value))) + +(defun est-eval-value-as-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-character 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))) + (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) + (list 'list nil + "+ " + (list 'object (list :object (car cell)) + (format "U+%04X" (car cell))) + " : " + (est-eval-value-as-object (cdr cell)))) + (sort value + (lambda (a b) + (< (car a)(car b))))))) + (error (format "%s" value))) + (format "%s" value))) + +(defun est-eval-value-as-decomposition-list (value) + (if (and (listp value) + (listp (cdr value))) + (condition-case nil + (let (props) + (list* 'list props + (mapconcat #'char-to-string value "") + (list + " (" + (list* 'list '(:separator " + ") + (mapcar + (lambda (chr) + (list 'object (list :object chr) + (format "U+%04X" chr))) + 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)) +;; (format "%s" value))) (defun est-eval-value-as-ids (value) (if (listp value) - (list 'ids nil (ideographic-structure-to-ids value)) - (format "%s" value))) + (list* 'ids + nil + (mapcar #'est-eval-value-as-object + (ideographic-structure-to-ids value)) + ) + (est-eval-value-default value))) (defun est-eval-value-as-space-separated-ids (value) (if (listp value) @@ -256,7 +592,7 @@ '=id item 'article@ruimoku) (intern unit))))) ) - ((eq source 'zob1968) + ((memq source '(zob1959 zob1968)) (if (and (symbolp item) (setq num (symbol-name item)) (string-match @@ -310,7 +646,8 @@ (list (est-eval-value-as-object (intern unit)))) )) (list* 'res-link - (list :source source :item item) + (list :separator " " + :source source :item item) source-objs) ) (t @@ -319,38 +656,60 @@ value))) (est-eval-value-default value))) -(defun est-eval-value-as-creators-names (value) +(defun est-eval-value-as-creators-names (value &optional subtype) (if (listp value) (let (role-name) (list* 'creator-name - '(:separator " ") + (if subtype + '(:subtype unordered-list) + '(:separator " ")) (mapcar (lambda (creator) - (setq role-name - (concord-object-get creator - 'role*name)) - (est-eval-list - (list - '(value (:feature ->name)) - (list - 'object (list :object creator) - (or role-name - (format "(%s)" - (concord-object-get creator - 'role*type))))) - creator nil) - ) + (cond + ((concord-object-p creator) + (setq role-name + (concord-object-get + creator 'role*name)) + (est-eval-list + (list + '(value (:feature ->creator/name)) + (list + 'object (list :object creator) + (or role-name + (format "(%s)" + (concord-object-get creator + 'role*type))))) + creator nil) + ) + (t creator))) value) )) (est-eval-value-default value))) -(defun est-eval-value-as-created-works (value) +(defun est-eval-value-as-created-works (value &optional subtype) (if (listp value) (list* 'creator-name - '(:separator " ") + (if subtype + '(:subtype unordered-list) + '(:separator " ")) (mapcar (lambda (creator) - (est-eval-list - '((value (:feature ->created))) - 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))) + +(defun est-eval-value-as-journal-volumes (value &optional subtype) + (if (listp value) + (list* 'journal-volumes + (if subtype + '(:subtype unordered-list) + '(:separator " ")) + (mapcar (lambda (volume) + (if (concord-object-p volume) + (est-eval-value-as-journal-volume volume 'short) + volume)) value)) (est-eval-value-default value))) @@ -415,6 +774,10 @@ ((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) ) @@ -424,17 +787,39 @@ (est-eval-value-as-kangxi-radical value)) ((eq format 'ids) (est-eval-value-as-ids value)) + ((eq format 'decomposition) + (est-eval-value-as-decomposition-list value)) + ((eq format 'composition) + (est-eval-value-as-composition-list value)) ((or (eq format 'space-separated) (eq format 'space-separated-char-list)) (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 'space-separated-ids) (est-eval-value-as-space-separated-ids value)) ((eq format 'space-separated-domain-list) (est-eval-value-as-domain-list value)) ((eq format 'space-separated-creator-name-list) (est-eval-value-as-creators-names value)) + ((eq format 'unordered-creator-name-list) + (est-eval-value-as-creators-names value 'unordered-list)) ((eq format 'space-separated-created-work-list) (est-eval-value-as-created-works value)) + ((eq format 'unordered-created-work-list) + (est-eval-value-as-created-works value 'unordered-list)) + ((eq format 'journal-volume-list) + (est-eval-value-as-journal-volumes value)) (t (est-eval-value-default value) )) @@ -446,9 +831,11 @@ (setq value (www-get-feature-value object feature-name))) (unless format (setq format (www-feature-value-format feature-name))) - (if (consp value) + (if (and (consp value) + est-eval-list-feature-items-limit + (not (eq feature-name 'sources))) (let ((ret (condition-case nil - (nthcdr 127 value) + (nthcdr est-eval-list-feature-items-limit value) (error nil nil)))) (when ret (setcdr ret @@ -576,7 +963,7 @@ 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 @@ -584,7 +971,7 @@ (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)))