;; -*- coding: utf-8-mcs-er -*-
(require 'char-db-util)
+(setq file-name-coding-system 'utf-8-mcs-er)
+
+(concord-assign-genre 'creator "/usr/local/var/ruimoku/db")
+(concord-assign-genre 'bibliography "/usr/local/var/ruimoku/db")
+(concord-assign-genre 'era "/usr/local/var/ruimoku/db")
+(concord-assign-genre 'period "/usr/local/var/ruimoku/db")
+(concord-assign-genre 'journal "/usr/local/var/ruimoku/db")
+
(defvar chise-wiki-view-url "view.cgi")
(defvar chise-wiki-edit-url "edit.cgi")
(defvar chise-wiki-glyph-cgi-url
"http://chise.zinbun.kyoto-u.ac.jp/chisewiki/glyph.cgi")
+(defvar chise-wiki-displayed-features nil)
+
(defun decode-uri-string (string &optional coding-system)
(if (> (length string) 0)
(let ((i 0)
(concat dest (substring string i))
coding-system))))
+(defun www-get-genre (object)
+ (if (characterp object)
+ 'character
+ 'default))
+
(defun www-feature-type (feature-name)
(or (char-feature-property feature-name 'type)
(let ((str (symbol-name feature-name)))
'structure)
))))
+(defun www-feature-format (feature-name)
+ (or (char-feature-property feature-name 'format)
+ (let (fn parent ret)
+ (setq fn feature-name)
+ (while (and (setq parent (char-feature-name-parent fn))
+ (null (setq ret
+ (char-feature-property
+ parent 'format))))
+ (setq fn parent))
+ ret)
+ '((name) " : " (value))))
+
(defun www-feature-value-format (feature-name)
(or (char-feature-property feature-name 'value-format)
(let (fn parent ret)
'("0x" (HEX) " (" (decimal) ") " (prev-char) (next-char))))))
(defun char-feature-name-at-domain (feature-name domain)
- (let ((name (symbol-name feature-name)))
- (cond
- ((string-match "@[^*]+$" name)
- (intern (format "%s/%s" name domain))
- )
- (t
- (intern (format "%s@%s" name domain))
- ))))
+ (if domain
+ (let ((name (symbol-name feature-name)))
+ (cond
+ ((string-match "@[^*]+$" name)
+ (intern (format "%s/%s" name domain))
+ )
+ (t
+ (intern (format "%s@%s" name domain))
+ )))
+ feature-name))
(defun char-feature-name-parent (feature-name)
(let ((name (symbol-name feature-name)))
(if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
(intern (substring name 0 (car (last (match-data) 2)))))))
+(defun char-feature-name-domain (feature-name)
+ (let ((name (symbol-name feature-name)))
+ (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
+ (intern (substring name (1+ (match-beginning 0)))))))
+
(defun char-feature-name-sans-versions (feature)
(let ((feature-name (symbol-name feature)))
(if (string-match "[@/]\\$rev=latest$" feature-name)
(intern (substring feature-name 0 (match-beginning 0)))
feature)))
-(defun www-char-feature (character feature)
- (let ((latest-feature (char-feature-name-at-domain feature '$rev=latest)))
- (mount-char-attribute-table latest-feature)
- (or (char-feature character latest-feature)
- (char-feature character feature))))
+(defun www-get-feature-value (object feature)
+ (let ((genre (www-get-genre object))
+ (latest-feature (char-feature-name-at-domain feature '$rev=latest)))
+ (cond
+ ((eq genre 'character)
+ (mount-char-attribute-table latest-feature)
+ (or (char-feature object latest-feature)
+ (char-feature object feature))
+ )
+ (t
+ (or (concord-object-get object latest-feature)
+ (concord-object-get object feature))
+ ))))
(defun get-previous-code-point (ccs code)
(let ((chars (charset-chars ccs))
)
(t feature-name)))
-(defun www-uri-decode-char (char-rep)
+(defun www-uri-make-feature-name-url (uri-feature-name uri-char)
+ (format "%s?feature=%s&char=%s"
+ chise-wiki-view-url uri-feature-name uri-char))
+
+(defun www-uri-decode-object (genre char-rep)
(let (ccs cpos)
(cond
((string-match "\\(%3A\\|:\\)" char-rep)
(string-to-number (substring cpos (match-end 0)) 16))
)
(t
- (setq cpos (string-to-number cpos))
+ (setq cpos (car (read-from-string cpos)))
))
- (if (numberp cpos)
- (decode-char ccs cpos))
+ (if (and (eq genre 'character)
+ (numberp cpos))
+ (decode-char ccs cpos)
+ (concord-decode-object ccs cpos genre))
)
(t
(setq char-rep (decode-uri-string char-rep 'utf-8-mcs-er))
- (when (= (length char-rep) 1)
- (aref char-rep 0))
- ))))
+ (cond
+ ((eq genre 'character)
+ (when (= (length char-rep) 1)
+ (aref char-rep 0))
+ )
+ ((eq genre 'feature)
+ (concord-decode-object
+ '=id (www-uri-decode-feature-name char-rep) 'feature)
+ )
+ (t
+ (concord-decode-object
+ '=id (car (read-from-string char-rep)) genre)
+ ))))))
(defun www-uri-encode-char (char)
(if (encode-char char '=ucs)
&optional value format
without-tags without-edit)
(unless value
- (setq value (www-char-feature object feature-name)))
+ (setq value (www-get-feature-value object feature-name)))
(www-format-apply-value object feature-name
format nil value nil nil
without-tags without-edit)
(setq char (decode-char 'system-char-id code))
(cond
((and (setq variants
- (or (www-char-feature char '->subsumptive)
- (www-char-feature char '->denotational)))
+ (or (www-get-feature-value char '->subsumptive)
+ (www-get-feature-value char '->denotational)))
(progn
(while (and variants
(setq ret (www-format-encode-string
(delete-region start end)
(insert ret))
)
- ((setq ret (or (www-char-feature char 'ideographic-combination)
- (www-char-feature char 'ideographic-structure)))
+ ((setq ret (or (www-get-feature-value char 'ideographic-combination)
+ (www-get-feature-value char 'ideographic-structure)))
(setq ret
(mapconcat
(lambda (ch)
;; (if (plist-get props :zero-padding)
;; "0")
(if (plist-get props :len)
- (format "0%d" (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")
&optional format lang uri-char value
without-tags without-edit)
(unless value
- (setq value (www-char-feature char feature-name)))
+ (setq value (www-get-feature-value char feature-name)))
(unless format
(setq format (www-feature-value-format feature-name)))
(cond
&optional lang uri-char value
without-tags without-edit)
(unless value
- (setq value (www-char-feature char feature-name)))
+ (setq value (www-get-feature-value char feature-name)))
(unless uri-char
(setq uri-char (www-uri-encode-char char)))
(cond
(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 char domain-fn))
+ (setq feature-name domain-fn
+ value ret)
+ (setq feature-name fn
+ value (www-get-feature-value char fn)))
+ (push feature-name chise-wiki-displayed-features)
+ ))
(if (eq (car exp) 'value)
(www-format-eval-feature-value char feature-name
(plist-get (nth 1 exp) :format)
without-tags without-edit))
)
((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)))
(if without-tags
(www-format-feature-name feature-name lang)
- (format "<a href=\"%s?feature=%s&char=%s\">%s</a>"
- chise-wiki-view-url
- (www-uri-encode-feature-name feature-name)
- uri-char
- (www-format-feature-name feature-name lang)))
+ (format "<a href=\"%s\">%s</a>"
+ (www-uri-make-feature-name-url
+ (www-uri-encode-feature-name feature-name)
+ uri-char)
+ (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)))
+ (www-uri-make-feature-name-url
+ (www-uri-encode-feature-name feature-name)
+ uri-char)
)
+ ((eq (car exp) 'domain-name)
+ (let ((domain (char-feature-name-domain feature-name)))
+ (if domain
+ (format "@%s" domain))))
((eq (car exp) 'prev-char)
(if without-tags
""
projects / chise / est.git / blobdiff