X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fest.git;a=blobdiff_plain;f=est-eval.el;h=3635eafb67271e538590193d662e39b377cbbe80;hp=65ce97ffe541f8aaa0980f865b1e873ee4132b7f;hb=e44c16be30c1faf3d8c707acb25efa3273676cf4;hpb=064fb21a731624826bc09b70f426f2cf031e7c12 diff --git a/est-eval.el b/est-eval.el index 65ce97f..3635eaf 100644 --- a/est-eval.el +++ b/est-eval.el @@ -1,6 +1,51 @@ ;; -*- 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)))) + (cond ((eq spec 'YY) (if (eq lang 'cjk) + (format "%d年" year) + (format "%d" year))) + ((eq spec 00) value) + ((eq spec 01) (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 06) (concat value "集")) + ((eq spec 07) (concat value "輯")) + ((eq spec 08) (concat value "部")) + ((eq spec 09) (concat value "部分")) + ((eq spec 10) (concat value "冊")) + ((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 "分")) + ((eq spec 51) (concat "Vol." value)) + ((eq spec 52) (concat "No." value)) + ((eq spec 53) (concat "Part " value)) + ((eq spec 54) (concat "Issue " value)) + ((eq spec 55) (concat "Tome " value)) + ((eq spec 56) (concat "Tomo " value)) + ((eq spec 57) (concat "Tomus " value)) + ((eq spec 58) (concat "Fasc." value)) + ((eq spec 59) (concat "Livre " value)) + ((eq spec 60) (concat "Année " value)) + ((eq spec 61) (concat "Bd." value)) + ((eq spec 62) (concat "Heft " value)) + ((eq spec 63) (concat "Nr." value)) + ((eq spec 64) (concat "Jahrg." value)) + ((eq spec 65) (concat "Jaarg." value)) + ((eq spec 66) (concat "Trimestre" value)) + (t "") + )) + + ;;; @ Feature value presentation ;;; @@ -9,36 +54,296 @@ (defun est-eval-value-default (value) (if (listp value) - (list* 'list - '(:separator " ") - (mapcar - (lambda (unit) - (format "%S" unit)) - value)) + (if (eq (car value) 'omitted) + value + (list* 'list + '(:separator " ") + (mapcar + (lambda (unit) + (format "%S" unit)) + value))) (est-eval-value-as-S-exp value))) +;; (defun est-journal-volume-object-get-volume-format (spec feature) +;; (when (integerp spec) +;; (setq spec (format "%02d" spec))) +;; (cond ((string= spec "YY") `((decimal (:feature +;; ->published/date*year)) "年")) +;; ((string= spec "00") `((decimal (:feature ,feature)))) +;; ((string= spec "01") `((decimal (:feature ,feature)) "期")) +;; ((string= spec "02") `((decimal (:feature ,feature)) "巻")) +;; ((string= spec "03") `((decimal (:feature ,feature)) "号")) +;; ((string= spec "04") `((decimal (:feature ,feature)) "&HD-JA-4A54;")) +;; ((string= spec "05") `((decimal (:feature ,feature)) "&HD-JA-4A53;")) +;; ((string= spec "06") `((decimal (:feature ,feature)) "集")) +;; ((string= spec "07") `((decimal (:feature ,feature)) "輯")) +;; ((string= spec "08") `((decimal (:feature ,feature)) "部")) +;; ((string= spec "09") `((decimal (:feature ,feature)) "部分")) +;; ((string= spec "10") `((decimal (:feature ,feature)) "冊")) +;; ((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)) "分")) +;; ((string= spec "51") `("Vol." ((decimal (:feature ,feature))))) +;; ((string= spec "52") `("No." ((decimal (:feature ,feature))))) +;; ((string= spec "53") `("Part " ((decimal (:feature ,feature))))) +;; ((string= spec "54") `("Issue " ((decimal (:feature ,feature))))) +;; ((string= spec "55") `("Tome " ((decimal (:feature ,feature))))) +;; ((string= spec "56") `("Tomo " ((decimal (:feature ,feature))))) +;; ((string= spec "57") `("Tomus " ((decimal (:feature ,feature))))) +;; ((string= spec "58") `("Fasc." ((decimal (:feature ,feature))))) +;; ((string= spec "59") `("Livre " ((decimal (:feature ,feature))))) +;; ((string= spec "60") `("Année " ((decimal (:feature ,feature))))) +;; ((string= spec "61") `("Bd." ((decimal (:feature ,feature))))) +;; ((string= spec "62") `("Heft " ((decimal (:feature ,feature))))) +;; ((string= spec "63") `("Nr." ((decimal (:feature ,feature))))) +;; ((string= spec "64") `("Jahrg." ((decimal (:feature ,feature))))) +;; ((string= spec "65") `("Jaarg." ((decimal (:feature ,feature))))) +;; ((string= spec "66") `("Trimestre" ((decimal (:feature ,feature))))) +;; (t nil) +;; )) + +(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 + 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) +;; (est-eval-list +;; '((value (:feature ->name)) +;; (string (:feature role*name))) +;; value nil)) + (defun est-eval-value-as-object (value) (if (or (characterp value) (concord-object-p value)) (list 'object (list :object value) (if (characterp value) (char-to-string value) - (let ((genre-o (concord-decode-object - '=id (concord-object-genre value) - 'genre)) + (let ((genre (concord-object-genre value)) + genre-o format) - (or (and genre-o - (setq format - (concord-object-get - genre-o 'object-representative-format)) - (est-eval-list format value nil)) - (www-get-feature-value - value - (or (and genre-o - (www-get-feature-value - genre-o 'object-representative-feature)) - 'name)) - (est-eval-value-default value))))) + (cond + ((eq genre 'journal-volume@ruimoku) + ;; (est-eval-list + ;; (est-journal-volume-get-object-format value) + ;; value nil) + (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 + (setq genre-o (concord-decode-object '=id genre 'genre)) + (or (and genre-o + (setq format + (concord-object-get + genre-o 'object-representative-format)) + (est-eval-list format value nil)) + (www-get-feature-value + value + (or (and genre-o + (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-HEX (value) @@ -64,25 +369,75 @@ (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-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) @@ -124,7 +479,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 @@ -178,7 +533,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 @@ -187,6 +543,61 @@ value))) (est-eval-value-default value))) +(defun est-eval-value-as-creators-names (value &optional subtype) + (if (listp value) + (let (role-name) + (list* 'creator-name + (if subtype + '(:subtype unordered-list) + '(:separator " ")) + (mapcar (lambda (creator) + (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 &optional subtype) + (if (listp value) + (list* 'creator-name + (if subtype + '(:subtype unordered-list) + '(:separator " ")) + (mapcar (lambda (creator) + (est-eval-list + '((value (:feature <-creator))) + creator nil)) + 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))) + ;;; @ format evaluator ;;; @@ -257,13 +668,31 @@ (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 '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) )) @@ -275,6 +704,17 @@ (setq value (www-get-feature-value object feature-name))) (unless format (setq format (www-feature-value-format feature-name))) + (if (and (consp value) + est-eval-list-feature-items-limit + (not (eq feature-name 'sources))) + (let ((ret (condition-case nil + (nthcdr est-eval-list-feature-items-limit value) + (error nil nil)))) + (when ret + (setcdr ret + (list (list 'omitted + (list :object object :feature feature-name) + "...")))))) (cond ((symbolp format) (est-eval-apply-value object feature-name @@ -349,6 +789,7 @@ ) ((eq (car exp) 'name-url) (let ((fn (plist-get (nth 1 exp) :feature)) + (object (plist-get (nth 1 exp) :object)) domain domain-fn) (when fn (setq domain (char-feature-name-domain feature-name)) @@ -358,6 +799,7 @@ (setq feature-name domain-fn))) (list 'name-url (list :feature feature-name) (www-uri-make-feature-name-url + (est-object-genre object) (www-uri-encode-feature-name feature-name) uri-object)) ) @@ -367,6 +809,11 @@ (format "@%s" domain) "")) ) + ((eq (car exp) 'omitted) + (list 'omitted + (list :object object :feature feature-name) + "...") + ) ((eq (car exp) 'prev-char) (list 'prev-char (list :object object :feature feature-name)