1 ;; -*- coding: utf-8-mcs-er -*-
2 (require 'cwiki-common)
4 ;;; @ Feature value presentation
7 (defun est-eval-value-as-S-exp (value)
8 (list 'S-exp nil (format "%S" value)))
10 (defun est-eval-value-default (value)
18 (est-eval-value-as-S-exp value)))
20 (defun est-eval-value-as-object (value)
21 (if (or (characterp value)
22 (concord-object-p value))
23 (list 'object (list :object value)
24 (if (characterp value)
25 (char-to-string value)
26 (let ((genre-o (concord-decode-object
27 '=id (concord-object-genre value)
33 genre-o 'object-representative-format))
34 (est-eval-list format value nil))
35 (www-get-feature-value
38 (www-get-feature-value
39 genre-o 'object-representative-feature))
41 (est-eval-value-default value)))))
42 (est-eval-value-default value)))
44 (defun est-eval-value-as-HEX (value)
46 (list 'HEX nil (format "%X" value))
47 (est-eval-value-as-S-exp value)))
49 (defun est-eval-value-as-kuten (value)
55 (- (logand value 255) 32)))
56 (est-eval-value-as-S-exp value)))
58 (defun est-eval-value-as-kangxi-radical (value)
59 (if (and (integerp value)
64 (format "%c" (ideographic-radical value)))
65 (est-eval-value-as-S-exp value)))
67 (defun est-eval-value-as-object-list (value &optional separator)
71 (list :separator separator))
74 ;; (if (characterp unit)
75 ;; (list 'char-link nil (format "%c" unit))
76 ;; (format "%s" unit)))
78 (mapcar #'est-eval-value-as-object value)
82 (defun est-eval-value-as-ids (value)
84 (list 'ids nil (ideographic-structure-to-ids value))
87 (defun est-eval-value-as-space-separated-ids (value)
91 ;; (mapconcat #'char-to-string
92 ;; (ideographic-structure-to-ids value)
94 (mapcar #'est-eval-value-as-object
95 (ideographic-structure-to-ids value))
97 (est-eval-value-default value)))
99 (defun est-eval-value-as-domain-list (value)
101 (let (source item source-objs source0 start end num)
111 ((string-match "=" unit)
113 (substring unit 0 (match-beginning 0)))
114 item (car (read-from-string
115 (substring unit (match-end 0)))))
120 (est-eval-value-as-object
121 (or (concord-decode-object
122 '=id item 'book@ruimoku)
123 (concord-decode-object
124 '=id item 'article@ruimoku)
127 ((eq source 'zob1968)
128 (if (and (symbolp item)
129 (setq num (symbol-name item))
131 "^\\([0-9]+\\)-\\([0-9]+\\)$" num))
132 (setq start (string-to-number
133 (match-string 1 num))
134 end (string-to-number
135 (match-string 2 num)))
138 (if (not (numberp start))
141 (est-eval-value-as-object (intern unit))))
142 (if (eq source source0)
147 (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
150 (setq source0 source)
155 (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
160 (:ref "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/")
161 "\u4EAC大人\u6587研甲\u9AA8")))
163 (setq num (1+ start))
169 (format "http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d"
174 (setq source-objs (nreverse source-objs)))
178 (list (est-eval-value-as-object (intern unit))))
181 (list :source source :item item)
185 (list 'res-link nil unit)
188 (est-eval-value-default value)))
191 ;;; @ format evaluator
194 ;; (defun est-make-env (object feature-name)
195 ;; (list (cons 'object object)
196 ;; (cons 'feature-name feature-name)))
198 ;; (defun est-env-push-item (env item value)
199 ;; (cons (cons item value)
202 ;; (defun est-env-get-item (env item)
203 ;; (cdr (assq item env)))
205 ;; (defun est-env-current-value (env)
206 ;; (let ((obj (est-env-get-item env 'object))
207 ;; (feature (est-env-get-item env 'feature-name)))
208 ;; (if (characterp obj)
209 ;; (char-feature obj feature)
210 ;; (concord-object-get obj feature))))
213 (defun est-eval-props-to-string (props &optional format)
215 (setq format (plist-get props :format)))
217 (plist-get props :flag)
218 (if (plist-get props :len)
220 (let ((ret (plist-get props :len)))
225 ((eq format 'decimal) "d")
226 ((eq format 'hex) "x")
227 ((eq format 'HEX) "X")
228 ((eq format 'S-exp) "S")
231 (defun est-eval-apply-value (object feature-name format props value
232 &optional uri-object)
235 :feature feature-name)
237 ((memq format '(decimal hex HEX))
241 (format (est-eval-props-to-string props format)
246 (list 'string nil (format "%s" value))
248 ((eq format 'wiki-text)
249 (est-eval-list value object feature-name nil uri-object)
252 (est-eval-value-as-S-exp value)
255 (est-eval-value-as-kuten value))
256 ((eq format 'kangxi-radical)
257 (est-eval-value-as-kangxi-radical value))
259 (est-eval-value-as-ids value))
260 ((or (eq format 'space-separated)
261 (eq format 'space-separated-char-list))
262 (est-eval-value-as-object-list value " "))
263 ((eq format 'space-separated-ids)
264 (est-eval-value-as-space-separated-ids value))
265 ((eq format 'space-separated-domain-list)
266 (est-eval-value-as-domain-list value))
268 (est-eval-value-default value)
272 (defun est-eval-feature-value (object feature-name
273 &optional format lang uri-object value)
275 (setq value (www-get-feature-value object feature-name)))
277 (setq format (www-feature-value-format feature-name)))
280 (est-eval-apply-value object feature-name
287 (setq format (car format))
288 (est-eval-apply-value object feature-name
289 (car format) (nth 1 format) value
293 (est-eval-list format object feature-name lang uri-object)
296 (defun est-eval-unit (exp object feature-name
297 &optional lang uri-object value)
299 (setq value (www-get-feature-value object feature-name)))
301 (setq uri-object (www-uri-encode-object object)))
304 ((or (characterp exp)
305 (concord-object-p exp))
306 (est-eval-value-as-object exp)
311 ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
312 S-exp string default))
313 (let ((fn (plist-get (nth 1 exp) :feature))
314 domain domain-fn ret)
317 (setq fn (intern fn)))
318 (setq domain (char-feature-name-domain feature-name))
319 (setq domain-fn (char-feature-name-at-domain fn domain))
320 (if (setq ret (www-get-feature-value object domain-fn))
321 (setq feature-name domain-fn
323 (setq feature-name fn
324 value (www-get-feature-value object fn)))
325 (push feature-name chise-wiki-displayed-features)
327 (if (eq (car exp) 'value)
328 (est-eval-feature-value object feature-name
329 (plist-get (nth 1 exp) :format)
330 lang uri-object value)
331 (est-eval-apply-value
333 (car exp) (nth 1 exp) value
336 ((eq (car exp) 'name)
337 (let ((fn (plist-get (nth 1 exp) :feature))
340 (setq domain (char-feature-name-domain feature-name))
342 (setq fn (intern fn)))
343 (setq domain-fn (char-feature-name-at-domain fn domain))
344 (setq feature-name domain-fn)))
347 :feature feature-name)
348 (www-format-feature-name* feature-name lang))
350 ((eq (car exp) 'name-url)
351 (let ((fn (plist-get (nth 1 exp) :feature))
352 (object (plist-get (nth 1 exp) :object))
355 (setq domain (char-feature-name-domain feature-name))
357 (setq fn (intern fn)))
358 (setq domain-fn (char-feature-name-at-domain fn domain))
359 (setq feature-name domain-fn)))
360 (list 'name-url (list :feature feature-name)
361 (www-uri-make-feature-name-url
362 (est-object-genre object)
363 (www-uri-encode-feature-name feature-name)
366 ((eq (car exp) 'domain-name)
367 (let ((domain (char-feature-name-domain feature-name)))
369 (format "@%s" domain)
372 ((eq (car exp) 'prev-char)
374 (list :object object :feature feature-name)
375 '(input (:type "submit" :value "-")))
377 ((eq (car exp) 'next-char)
379 (list :object object :feature feature-name)
380 '(input (:type "submit" :value "+")))
382 ((eq (car exp) 'link)
385 (est-eval-list (plist-get (nth 1 exp) :ref)
386 object feature-name lang uri-object))
387 (est-eval-list (nthcdr 2 exp)
388 object feature-name lang uri-object))
393 (defun est-eval-list (format-list object feature-name
394 &optional lang uri-object)
395 (if (consp format-list)
399 (est-eval-unit exp object feature-name lang uri-object nil))
402 (list* 'list nil ret)
404 (est-eval-unit format-list object feature-name lang uri-object nil)))
412 ;;; est-eval.el ends here