New files.

diff --git a/est-eval.el b/est-eval.el
new file mode 100644 (file)
index 0000000..65ce97f
--- /dev/null
+++ b/est-eval.el
@@ -0,0 +1,410 @@
+;; -*- coding: utf-8-mcs-er -*-
+(require 'cwiki-common)
+
+;;; @ Feature value presentation
+;;;
+
+(defun est-eval-value-as-S-exp (value)
+  (list 'S-exp nil (format "%S" value)))
+
+(defun est-eval-value-default (value)
+  (if (listp value)
+      (list* 'list
+            '(:separator " ")
+            (mapcar
+             (lambda (unit)
+               (format "%S" unit))
+             value))
+    (est-eval-value-as-S-exp value)))
+
+(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))
+                   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)))))
+    (est-eval-value-default value)))
+
+(defun est-eval-value-as-HEX (value)
+  (if (integerp value)
+      (list 'HEX nil (format "%X" value))
+    (est-eval-value-as-S-exp value)))
+
+(defun est-eval-value-as-kuten (value)
+  (if (integerp value)
+      (list 'ku-ten
+           nil
+           (format "%02d-%02d"
+                   (- (lsh value -8) 32)
+                   (- (logand value 255) 32)))
+    (est-eval-value-as-S-exp value)))
+
+(defun est-eval-value-as-kangxi-radical (value)
+  (if (and (integerp value)
+          (<= 0 value)
+          (<= value 214))
+      (list 'kangxi-radical
+           nil
+           (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)
+            )
+    (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-space-separated-ids (value)
+  (if (listp value)
+      (list* 'ids
+            '(:separator " ")
+            ;; (mapconcat #'char-to-string
+            ;;            (ideographic-structure-to-ids value)
+            ;;            " ")
+            (mapcar #'est-eval-value-as-object
+                    (ideographic-structure-to-ids value))
+            )
+    (est-eval-value-default value)))
+
+(defun est-eval-value-as-domain-list (value)
+  (if (listp value)
+      (let (source item source-objs source0 start end num)
+       (list* 'res-list
+              '(:separator " ")
+              (mapcar
+               (lambda (unit)
+                 (setq unit
+                       (if (symbolp unit)
+                           (symbol-name unit)
+                         (format "%s" unit)))
+                 (cond
+                  ((string-match "=" unit)
+                   (setq source (intern
+                                 (substring unit 0 (match-beginning 0)))
+                         item (car (read-from-string
+                                    (substring unit (match-end 0)))))
+                   (cond
+                    ((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)
+                                 (intern unit)))))
+                     )
+                    ((eq source '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 (intern 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 (intern unit))))
+                     ))
+                   (list* 'res-link
+                          (list :source source :item item)
+                          source-objs)
+                   )
+                  (t
+                   (list 'res-link nil unit)
+                   )))
+               value)))
+    (est-eval-value-default value)))
+
+
+;;; @ format evaluator
+;;;
+
+;; (defun est-make-env (object feature-name)
+;;   (list (cons 'object object)
+;;         (cons 'feature-name feature-name)))
+
+;; (defun est-env-push-item (env item value)
+;;   (cons (cons item value)
+;;         env))
+
+;; (defun est-env-get-item (env item)
+;;   (cdr (assq item env)))
+
+;; (defun est-env-current-value (env)
+;;   (let ((obj (est-env-get-item env 'object))
+;;         (feature (est-env-get-item env 'feature-name)))
+;;     (if (characterp obj)
+;;         (char-feature obj feature)
+;;       (concord-object-get obj feature))))
+
+
+(defun est-eval-props-to-string (props &optional format)
+  (unless format
+    (setq format (plist-get props :format)))
+  (concat "%"
+         (plist-get props :flag)
+         (if (plist-get props :len)
+             (format "0%d"
+                     (let ((ret (plist-get props :len)))
+                       (if (stringp ret)
+                           (string-to-int ret)
+                         ret))))
+         (cond
+          ((eq format 'decimal) "d")
+          ((eq format 'hex) "x")
+          ((eq format 'HEX) "X")
+          ((eq format 'S-exp) "S")
+          (t "s"))))      
+
+(defun est-eval-apply-value (object feature-name format props value
+                                   &optional uri-object)
+  (list 'value
+       (list :object object
+             :feature feature-name)
+       (cond
+        ((memq format '(decimal hex HEX))
+         (if (integerp value)
+             (list format
+                   nil
+                   (format (est-eval-props-to-string props format)
+                           value))
+           (format "%s" value))
+         )
+        ((eq format 'string)
+         (list 'string nil (format "%s" value))
+         )
+        ((eq format 'wiki-text)
+         (est-eval-list value object feature-name nil uri-object)
+         )
+        ((eq format 'S-exp)
+         (est-eval-value-as-S-exp value)
+         )
+        ((eq format 'ku-ten)
+         (est-eval-value-as-kuten value))
+        ((eq format 'kangxi-radical)
+         (est-eval-value-as-kangxi-radical value))
+        ((eq format 'ids)
+         (est-eval-value-as-ids value))
+        ((or (eq format 'space-separated)
+             (eq format 'space-separated-char-list))
+         (est-eval-value-as-object-list value " "))
+        ((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))
+        (t
+         (est-eval-value-default value)
+         ))
+       ))
+
+(defun est-eval-feature-value (object feature-name
+                                     &optional format lang uri-object value)
+  (unless value
+    (setq value (www-get-feature-value object feature-name)))
+  (unless format
+    (setq format (www-feature-value-format feature-name)))
+  (cond
+   ((symbolp format)
+    (est-eval-apply-value object feature-name
+                         format nil value
+                         uri-object)
+    )
+   ((consp format)
+    (cond
+     ((null (cdr format))
+      (setq format (car format))
+      (est-eval-apply-value object feature-name
+                           (car format) (nth 1 format) value
+                           uri-object)
+      )
+     (t
+      (est-eval-list format object feature-name lang uri-object)
+      )))))
+
+(defun est-eval-unit (exp object feature-name
+                                &optional lang uri-object value)
+  (unless value
+    (setq value (www-get-feature-value object feature-name)))
+  (unless uri-object
+    (setq uri-object (www-uri-encode-object object)))
+  (cond
+   ((stringp exp) exp)
+   ((or (characterp exp)
+       (concord-object-p exp))
+    (est-eval-value-as-object exp)
+    )
+   ((null exp) "")
+   ((consp exp)
+    (cond
+     ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
+                             S-exp string default))
+      (let ((fn (plist-get (nth 1 exp) :feature))
+           domain domain-fn ret)
+       (when fn
+         (when (stringp fn)
+           (setq fn (intern fn)))
+         (setq domain (char-feature-name-domain feature-name))
+         (setq domain-fn (char-feature-name-at-domain fn domain))
+         (if (setq ret (www-get-feature-value object domain-fn))
+             (setq feature-name domain-fn
+                   value ret)
+           (setq feature-name fn
+                 value (www-get-feature-value object fn)))
+         (push feature-name chise-wiki-displayed-features)
+          ))
+      (if (eq (car exp) 'value)
+         (est-eval-feature-value object feature-name
+                                        (plist-get (nth 1 exp) :format)
+                                        lang uri-object value)
+       (est-eval-apply-value
+        object feature-name
+        (car exp) (nth 1 exp) value
+        uri-object))
+      )
+     ((eq (car exp) 'name)
+      (let ((fn (plist-get (nth 1 exp) :feature))
+           domain domain-fn)
+       (when fn
+         (setq domain (char-feature-name-domain feature-name))
+         (when (stringp fn)
+           (setq fn (intern fn)))
+         (setq domain-fn (char-feature-name-at-domain fn domain))
+         (setq feature-name domain-fn)))
+      (list 'feature-name
+           (list :object object
+                 :feature feature-name)
+           (www-format-feature-name* feature-name lang))
+      )
+     ((eq (car exp) 'name-url)
+      (let ((fn (plist-get (nth 1 exp) :feature))
+           domain domain-fn)
+       (when fn
+         (setq domain (char-feature-name-domain feature-name))
+         (when (stringp fn)
+           (setq fn (intern fn)))
+         (setq domain-fn (char-feature-name-at-domain fn domain))
+         (setq feature-name domain-fn)))
+      (list 'name-url (list :feature feature-name)
+           (www-uri-make-feature-name-url
+            (www-uri-encode-feature-name feature-name)
+            uri-object))
+      )
+     ((eq (car exp) 'domain-name)
+      (let ((domain (char-feature-name-domain feature-name)))
+       (if domain
+           (format "@%s" domain)
+         ""))
+      )
+     ((eq (car exp) 'prev-char)
+      (list 'prev-char
+           (list :object object :feature feature-name)
+           '(input (:type "submit" :value "-")))
+      )
+     ((eq (car exp) 'next-char)
+      (list 'next-char
+           (list :object object :feature feature-name)
+           '(input (:type "submit" :value "+")))
+      )
+     ((eq (car exp) 'link)
+      (list 'link
+           (list :ref 
+                 (est-eval-list (plist-get (nth 1 exp) :ref)
+                                       object feature-name lang uri-object))
+           (est-eval-list (nthcdr 2 exp)
+                                 object feature-name lang uri-object))
+      )
+     (t
+      exp)))))
+
+(defun est-eval-list (format-list object feature-name
+                                 &optional lang uri-object)
+  (if (consp format-list)
+      (let ((ret
+            (mapcar
+             (lambda (exp)
+               (est-eval-unit exp object feature-name lang uri-object nil))
+             format-list)))
+       (if (cdr ret)
+           (list* 'list nil ret)
+         (car ret)))
+    (est-eval-unit format-list object feature-name lang uri-object nil)))
+
+
+;;; @ End.
+;;;
+
+(provide 'est-eval)
+
+;;; est-eval.el ends here

diff --git a/est-format.el b/est-format.el
new file mode 100644 (file)
index 0000000..c7a7474
--- /dev/null
+++ b/est-format.el
@@ -0,0 +1,178 @@
+;; -*- coding: utf-8-mcs-er -*-
+(require 'cwiki-common)
+
+
+;;; @ XML generator
+;;;
+
+(defun est-format-props (props)
+  (let ((dest "")
+       key val)
+    (while props
+      (setq key (pop props)
+           val (pop props))
+      (if (symbolp key)
+         (setq key (symbol-name key)))
+      (if (eq (aref key 0) ?:)
+         (setq key (substring key 1)))
+      (setq dest
+           (format "%s %s=\"%s\""
+                   dest key
+                   (www-format-encode-string
+                    (format "%s"
+                            (est-format-unit val 'without-tags
+                                             'without-edit 'as-property))
+                    'without-tags))))
+    dest))
+
+(defun est-format-unit (format-unit
+                       &optional without-tags without-edit as-property
+                       separator)
+  (let (name props children ret object feature format value)
+    (cond
+     ((stringp format-unit)
+      (www-format-encode-string format-unit without-tags (not as-property))
+      )
+     ((consp format-unit)
+      (setq name (car format-unit)
+           props (nth 1 format-unit)
+           children (nthcdr 2 format-unit))
+      (cond
+       ((eq name 'object)
+       (setq name 'span)
+       (unless without-tags
+         (when (setq object (plist-get props :object))
+           (setq children
+                 (list
+                  (list* 'a
+                         (list :href (www-uri-make-object-url object))
+                         children)))))
+       )
+       ((eq name 'prev-char)
+       (when (and (not without-tags)
+                  (setq object (plist-get props :object))
+                  (setq feature (plist-get props :feature))
+                  (setq value (www-get-feature-value object feature))
+                  (setq ret (find-previous-defined-code-point feature value)))
+         (setq children
+               (list
+                (list* 'a
+                       (list :href (www-uri-make-object-url ret))
+                       children))))
+       )
+       ((eq name 'next-char)
+       (when (and (not without-tags)
+                  (setq object (plist-get props :object))
+                  (setq feature (plist-get props :feature))
+                  (setq value (www-get-feature-value object feature))
+                  (setq ret (find-next-defined-code-point feature value)))
+         (setq children
+               (list
+                (list* 'a
+                       (list :href (www-uri-make-object-url ret))
+                       children))))
+       )
+       ((eq name 'feature-name)
+       (setq name 'span)
+       (unless without-tags
+         (when (and (setq object (plist-get props :object))
+                    (setq feature (plist-get props :feature)))
+           (setq children
+                 (list
+                  (list* 'a
+                         (list :href
+                               (www-uri-make-feature-name-url
+                                (www-uri-encode-feature-name feature)
+                                (www-uri-encode-object object)))
+                         children)))))
+       )
+       ((eq name 'value)
+       (setq format
+             (if (consp (car children))
+                 (caar children)))
+       (unless without-edit
+         (setq children
+               (append children
+                       (list (list 'edit-value
+                                   (if format
+                                       (list* :format format props)
+                                     props)
+                                   '(input
+                                     (:type "submit" :value "edit")))))))
+       (unless without-tags
+         (setq name 'span
+               props (list* :class "value" props)))
+       )
+       ((eq name 'link)
+       (setq ret (plist-get props :ref))
+        ;; (unless (stringp ret)
+        ;;   (setq props (plist-remprop (copy-list props) :ref))
+        ;;   (setq children
+        ;;         (cons (list 'ref nil ret)
+        ;;               children)))
+       (unless without-tags
+         (setq name 'a
+               props (list* :href ret
+                            (plist-remprop (copy-list props) :ref))))
+       )
+       ((and (eq name 'edit-value)
+            (setq object (plist-get props :object))
+            (setq feature (plist-get props :feature)))
+       (setq format (or (plist-get props :format) 'default))
+       (setq name 'a
+             props (list :href (format "%s?%s=%s&feature=%s&format=%s"
+                                       chise-wiki-edit-url
+                                       (est-object-genre object)
+                                       (www-uri-encode-object object)
+                                       (www-uri-encode-feature-name feature)
+                                       format)))
+       )
+       ((memq name '(div
+                    a ul ol p
+                    span
+                    input))
+       )
+       (t
+       (unless without-tags
+         (setq props (list* :class name props)
+               name 'span))
+       ))
+      (unless separator
+       (setq separator (plist-get props :separator)))
+      (if children
+         (if without-tags
+             (est-format-list children without-tags as-property separator)
+           (format "<%s%s>%s</%s>"
+                   name
+                   (if props
+                       (est-format-props props)
+                     "")
+                   (est-format-list
+                    children nil without-edit as-property separator)
+                   name))
+       (if without-tags
+           ""
+         (format "<%s%s/>"
+                 name (est-format-props props))))
+      )
+     (t
+      (format "%s" format-unit)))))
+
+(defun est-format-list (format-list
+                       &optional without-tags without-edit as-property
+                       separator)
+  (if (atom format-list)
+      (est-format-unit
+       format-list without-tags without-edit as-property separator)
+    (mapconcat (lambda (unit)
+                (est-format-unit
+                 unit without-tags without-edit as-property separator))
+              format-list separator)))
+
+
+;;; @ End.
+;;;
+
+(provide 'est-format)
+
+;;; est-format.el ends here