;; -*- coding: utf-8-mcs-er -*-
(require 'char-db-util)
+(setq file-name-coding-system 'utf-8-mcs-er)
+
+
+(concord-assign-genre 'creator@ruimoku "/usr/local/var/ruimoku/db")
+
+(concord-assign-genre 'journal-volume@ruimoku "/usr/local/var/ruimoku/db")
+(concord-assign-genre 'article@ruimoku "/usr/local/var/ruimoku/db")
+(concord-assign-genre 'book@ruimoku "/usr/local/var/ruimoku/db")
+
+(concord-assign-genre 'classification@ruimoku "/usr/local/var/ruimoku/db")
+(concord-assign-genre 'region@ruimoku "/usr/local/var/ruimoku/db")
+(concord-assign-genre 'era@ruimoku "/usr/local/var/ruimoku/db")
+(concord-assign-genre 'period@ruimoku "/usr/local/var/ruimoku/db")
+(concord-assign-genre 'journal@ruimoku "/usr/local/var/ruimoku/db")
+
+
(defvar chise-wiki-view-url "view.cgi")
-(defvar chise-wiki-edit-url "edit/edit.cgi")
+(defvar chise-wiki-edit-url "edit.cgi")
(defvar chise-wiki-bitmap-glyphs-url
"http://chise.zinbun.kyoto-u.ac.jp/glyphs")
(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)
'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)
+ (setq fn feature-name)
+ (while (and (setq parent (char-feature-name-parent fn))
+ (null (setq ret
+ (char-feature-property
+ parent 'value-format))))
+ (setq fn parent))
+ ret)
(let ((type (www-feature-type feature-name)))
(cond ((eq type 'relation)
'space-separated-char-list)
(if (and (= (charset-dimension feature-name) 2)
(= (charset-chars feature-name) 94))
'("0x" (HEX)
- " (" (decimal) ") <" (ku-ten) ">")
- '("0x" (HEX) " (" (decimal) ")")))))
+ " (" (decimal) ") <" (ku-ten) "> " (prev-char) (next-char))
+ '("0x" (HEX) " (" (decimal) ") " (prev-char) (next-char))))))
(defun char-feature-name-at-domain (feature-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)))
- (cond
- ((string-match "@[^*]+$" name)
- (intern (format "%s/%s" name domain))
- )
- (t
- (intern (format "%s@%s" name domain))
- ))))
+ (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)))
(intern (substring feature-name 0 (match-beginning 0)))
feature)))
-(defun www-char-feature (character feature)
+(defun www-get-feature-value (object 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))))
+ (cond
+ ((characterp object)
+ (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))
+ (dim (charset-dimension ccs))
+ (i 0)
+ mask byte-min byte-max
+ bytes dest)
+ (cond
+ ((= chars 94)
+ (setq mask #x7F
+ byte-min 33
+ byte-max 126)
+ )
+ ((= chars 96)
+ (setq mask #x7F
+ byte-min 32
+ byte-max 127)
+ )
+ ((= chars 128)
+ (setq mask #x7F
+ byte-min 0
+ byte-max #xFF)
+ )
+ (t ; (= chars 256)
+ (setq mask #xFF
+ byte-min 0
+ byte-max #xFF)
+ ))
+ (setq bytes (make-vector dim 0))
+ (while (< i dim)
+ (aset bytes i (logand (lsh code (* i -8)) mask))
+ (setq i (1+ i)))
+ (setq i 0)
+ (while (and (< i dim)
+ (progn
+ (aset bytes i (1- (aref bytes i)))
+ (< (aref bytes i) byte-min)))
+ (aset bytes i byte-max)
+ (setq i (1+ i)))
+ (when (< i dim)
+ (setq dest (aref bytes 0)
+ i 1)
+ (while (< i dim)
+ (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
+ i (1+ i)))
+ dest)))
+
+(defun get-next-code-point (ccs code)
+ (let ((chars (charset-chars ccs))
+ (dim (charset-dimension ccs))
+ (i 0)
+ mask byte-min byte-max
+ bytes dest)
+ (cond
+ ((= chars 94)
+ (setq mask #x7F
+ byte-min 33
+ byte-max 126)
+ )
+ ((= chars 96)
+ (setq mask #x7F
+ byte-min 32
+ byte-max 127)
+ )
+ ((= chars 128)
+ (setq mask #x7F
+ byte-min 0
+ byte-max #xFF)
+ )
+ (t ; (= chars 256)
+ (setq mask #xFF
+ byte-min 0
+ byte-max #xFF)
+ ))
+ (setq bytes (make-vector dim 0))
+ (while (< i dim)
+ (aset bytes i (logand (lsh code (* i -8)) mask))
+ (setq i (1+ i)))
+ (setq i 0)
+ (while (and (< i dim)
+ (progn
+ (aset bytes i (1+ (aref bytes i)))
+ (> (aref bytes i) byte-max)))
+ (aset bytes i byte-min)
+ (setq i (1+ i)))
+ (when (< i dim)
+ (setq dest (aref bytes 0)
+ i 1)
+ (while (< i dim)
+ (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
+ i (1+ i)))
+ dest)))
+
+(defun find-previous-defined-code-point (ccs code)
+ (let ((i (get-previous-code-point ccs code))
+ char)
+ (cond
+ ((eq ccs '=jis-x0208)
+ (setq ccs '=jis-x0208@1990))
+ ((eq ccs '=jis-x0213-1)
+ (setq ccs '=jis-x0213-1@2004)))
+ (while (and i
+ (>= i 0)
+ (null (setq char (decode-char ccs i
+ (unless (eq ccs '=ucs)
+ 'defined-only)))))
+ (setq i (get-previous-code-point ccs i)))
+ char))
+
+(defun find-next-defined-code-point (ccs code)
+ (let ((i (get-next-code-point ccs code))
+ max char)
+ (setq max (+ code 1000))
+ (cond
+ ((eq ccs '=jis-x0208)
+ (setq ccs '=jis-x0208@1990))
+ ((eq ccs '=jis-x0213-1)
+ (setq ccs '=jis-x0213-1@2004)))
+ (while (and i
+ (<= i max)
+ (null (setq char (decode-char ccs i
+ (unless (eq ccs '=ucs)
+ 'defined-only)))))
+ (setq i (get-next-code-point ccs i)))
+ char))
;;; @ URI representation
)
(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))
- ))))
-
-(defun www-uri-encode-char (char)
- (if (encode-char char '=ucs)
- (mapconcat
- (lambda (byte)
- (format "%%%02X" byte))
- (encode-coding-string (char-to-string char) 'utf-8-mcs-er)
- "")
- (let ((ccs-list '(; =ucs
- =cns11643-1 =cns11643-2 =cns11643-3
- =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
- =gb2312 =gb12345
- =jis-x0208 =jis-x0208@1990
- =jis-x0212
- =cbeta =jef-china3
- =jis-x0213-1@2000 =jis-x0213-1@2004
- =jis-x0208@1983 =jis-x0208@1978
- =zinbun-oracle
- =daikanwa
- =gt =gt-k
- =>>jis-x0208 =>>jis-x0213-1
- =>jis-x0208 =>jis-x0213-1
- =>>gt
- =big5
- =big5-cdp))
- ccs ret)
- (while (and ccs-list
- (setq ccs (pop ccs-list))
- (not (setq ret (encode-char char ccs 'defined-only)))))
- (cond (ret
- (format "%s:0x%X"
- (www-uri-encode-feature-name ccs)
- ret))
- ((and (setq ccs (car (split-char char)))
- (setq ret (encode-char char ccs)))
- (format "%s:0x%X"
- (www-uri-encode-feature-name ccs)
- ret))
- (t
- (format "system-char-id:0x%X"
- (encode-char char 'system-char-id))
- )))))
+ (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-object (object)
+ (if (characterp object)
+ (if (encode-char object '=ucs)
+ (mapconcat
+ (lambda (byte)
+ (format "%%%02X" byte))
+ (encode-coding-string (char-to-string object) 'utf-8-mcs-er)
+ "")
+ (let ((ccs-list '(; =ucs
+ =cns11643-1 =cns11643-2 =cns11643-3
+ =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
+ =gb2312 =gb12345
+ =jis-x0208 =jis-x0208@1990
+ =jis-x0212
+ =cbeta =jef-china3
+ =jis-x0213-1@2000 =jis-x0213-1@2004
+ =jis-x0208@1983 =jis-x0208@1978
+ =zinbun-oracle =>zinbun-oracle
+ =daikanwa
+ =gt =gt-k
+ =>>jis-x0208 =>>jis-x0213-1
+ =>jis-x0208 =>jis-x0213-1
+ =>>gt
+ =ruimoku-v6
+ =big5
+ =big5-cdp))
+ ccs ret)
+ (while (and ccs-list
+ (setq ccs (pop ccs-list))
+ (not (setq ret (encode-char object ccs 'defined-only)))))
+ (cond (ret
+ (format "%s:0x%X"
+ (www-uri-encode-feature-name ccs)
+ ret))
+ ((and (setq ccs (car (split-char object)))
+ (setq ret (encode-char object ccs)))
+ (format "%s:0x%X"
+ (www-uri-encode-feature-name ccs)
+ ret))
+ (t
+ (format "system-char-id:0x%X"
+ (encode-char object 'system-char-id))
+ ))))
+ (format "rep.id:%s" (concord-object-id object))))
+
+(defun est-format-object (object)
+ (if (characterp object)
+ (char-to-string object)
+ (format "%s" (concord-object-id object))))
;;; @ Feature name presentation
(t dest))))
(defun www-format-feature-name* (feature-name &optional lang)
- (let (name)
+ (let (name fn parent ret)
(cond
((or (and lang
(char-feature-property
(intern (format "name@%s" lang))))
(char-feature-property
feature-name 'name)))
- ((find-charset feature-name)
- (www-format-feature-name-as-CCS feature-name))
((and (setq name (symbol-name feature-name))
(string-match "\\*" name))
(www-format-feature-name-as-metadata feature-name lang))
- ((string-match "^\\(->\\)" name)
- (www-format-feature-name-as-rel-to feature-name))
- ((string-match "^\\(<-\\)" name)
- (www-format-feature-name-as-rel-from feature-name))
(t
- (www-format-feature-name-default feature-name)))))
+ (setq fn feature-name)
+ (while (and (setq parent (char-feature-name-parent fn))
+ (null (setq ret
+ (or (and lang
+ (char-feature-property
+ parent
+ (intern (format "name@%s" lang))))
+ (char-feature-property
+ parent 'name)))))
+ (setq fn parent))
+ (cond
+ (ret
+ (concat ret (substring (symbol-name feature-name)
+ (length (symbol-name parent)))))
+ ((find-charset feature-name)
+ (www-format-feature-name-as-CCS feature-name))
+ ((string-match "^\\(->\\)" name)
+ (www-format-feature-name-as-rel-to feature-name))
+ ((string-match "^\\(<-\\)" name)
+ (www-format-feature-name-as-rel-from feature-name))
+ (t
+ (www-format-feature-name-default feature-name)
+ ))
+ ))))
(defun www-format-feature-name (feature-name &optional lang)
(www-format-encode-string
"%s")
unit)
'without-tags))
- (lambda (unit)
- (if (characterp unit)
- (format "<a href=\"%s?char=%s\">%s</a>"
+ (let (genre-o name-f ret)
+ (lambda (unit)
+ (if (characterp unit)
+ (format "<a href=\"%s?char=%s\">%s</a>"
+ chise-wiki-view-url
+ (www-uri-encode-object unit)
+ (www-format-encode-string (char-to-string unit)))
+ (format "<a href=\"%s?%s=%s\">%s</a>"
chise-wiki-view-url
- (www-uri-encode-char unit)
- (www-format-encode-string (char-to-string unit)))
- (www-format-encode-string (format "%s" unit)))))
+ (concord-object-genre unit)
+ (concord-object-id unit)
+ (cond
+ ((setq ret
+ (www-get-feature-value
+ unit
+ (setq name-f
+ (if (setq genre-o
+ (concord-decode-object
+ '=id
+ (concord-object-genre unit)
+ 'genre))
+ (www-get-feature-value genre-o 'name)
+ 'name))))
+ (www-format-eval-feature-value
+ unit name-f nil nil nil ret
+ 'without-tags 'without-edit)
+ )
+ (t
+ (www-format-encode-string
+ (format "%S" unit))
+ ))
+ unit)))))
value " ")
(www-format-encode-string (format "%s" value) without-tags)))
+(defun www-format-value-as-domain-list (value &optional without-tags)
+ (let (name source0 source num dest rest unit start end ddest)
+ (if (listp value)
+ (if without-tags
+ (mapconcat
+ (lambda (unit)
+ (format "%s" unit))
+ value " ")
+ (setq rest value)
+ (while rest
+ (setq unit (pop rest))
+ (if (symbolp unit)
+ (setq name (symbol-name unit)))
+ (setq dest
+ (concat
+ dest
+ (cond
+ ((string-match "^zob1968=" name)
+ (setq source (intern (substring name 0 (match-end 0)))
+ num (substring name (match-end 0)))
+ (if (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 (string-to-number num)
+ end start))
+ (setq ddest
+ (if (eq source source0)
+ (format
+ ", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
+ start start)
+ (setq source0 source)
+ (format
+ " <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/\">%s</a>=<a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
+ (www-format-encode-string "\u4EAC大人\u6587ç ”ç”²\u9AA8")
+ start start)))
+ (setq start (1+ start))
+ (while (<= start end)
+ (setq ddest
+ (concat
+ ddest
+ (format
+ ", <a href=\"http://chise.zinbun.kyoto-u.ac.jp/koukotsu/rubbings/%04d\">%04d</a>"
+ start start)))
+ (setq start (1+ start)))
+ ddest)
+ (t
+ (setq source unit)
+ (if (eq source source0)
+ ""
+ (setq source0 source)
+ (concat " " name))
+ )))))
+ dest)
+ (www-format-encode-string (format "%s" value) without-tags))))
+
(defun www-format-value-as-ids (value &optional without-tags)
(if (listp value)
(mapconcat
(if (characterp unit)
(format "<a href=\"%s?char=%s\">%s</a>"
chise-wiki-view-url
- (www-uri-encode-char unit)
+ (www-uri-encode-object unit)
(www-format-encode-string (char-to-string unit)))
(www-format-encode-string (format "%s" unit)))))
(ideographic-structure-to-ids value) " ")
(www-format-value-as-S-exp value)))
(defun www-format-value (object feature-name
- &optional value format without-tags)
+ &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)
+ format nil value nil nil
+ without-tags without-edit)
)
(defun www-format-encode-string (string &optional without-tags)
(with-temp-buffer
(insert string)
- (let (plane code start end char variants ret)
+ (let (plane code start end char variants ret rret)
(goto-char (point-min))
(while (search-forward "<" nil t)
(replace-match "<" nil t))
'(=jis-x0208@1997 "J97-" 4 X)
'(=jis-x0208@1978 "J78-" 4 X)
'(=jis-x0208@1983 "J83-" 4 X)
+ '(=ruimoku-v6 "RUI6-" 4 X)
'(=zinbun-oracle "ZOB-" 4 d)
'(=jef-china3 "JC3-" 4 X)
'(=daikanwa "M-" 5 d)
t 'literal))
(goto-char (point-min))
- (while (re-search-forward "&ZOB-\\([0-9]+\\);" nil t)
- (setq code (string-to-int (match-string 1)))
+ (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
+ (setq code (string-to-int (match-string 2)))
(replace-match
(format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\">"
code
chise-wiki-glyph-cgi-url
code)
t 'literal))
-
+
+ (goto-char (point-min))
+ (while (re-search-forward "&RUI6-\\([0-9A-F]+\\);" nil t)
+ (setq code (string-to-int (match-string 1) 16))
+ (replace-match
+ (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\">"
+ code
+ chise-wiki-glyph-cgi-url
+ code)
+ t 'literal))
+
(goto-char (point-min))
(while (re-search-forward "&\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
(setq code (string-to-int (match-string 2) 16))
(setq start (match-beginning 0)
end (match-end 0))
(setq char (decode-char 'system-char-id code))
- (setq variants (or (www-char-feature char '->subsumptive)
- (www-char-feature char '->denotational)))
- (while (and variants
- (setq ret (www-format-encode-string
- (char-to-string (car variants))))
- (string-match "&MCS-\\([0-9A-F]+\\);" ret))
- (setq variants (cdr variants)))
- (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
- (goto-char start)
- (delete-region start end)
- (insert ret)))
+ (cond
+ ((and (setq variants
+ (or (www-get-feature-value char '->subsumptive)
+ (www-get-feature-value char '->denotational)))
+ (progn
+ (while (and variants
+ (setq ret (www-format-encode-string
+ (char-to-string (car variants))))
+ (string-match "&MCS-\\([0-9A-F]+\\);" ret))
+ (setq variants (cdr variants)))
+ ret))
+ (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
+ (goto-char start)
+ (delete-region start end)
+ (insert ret))
+ )
+ ((setq ret (or (www-get-feature-value char 'ideographic-combination)
+ (www-get-feature-value char 'ideographic-structure)))
+ (setq ret
+ (mapconcat
+ (lambda (ch)
+ (if (listp ch)
+ (if (characterp (setq rret (find-char ch)))
+ (setq ch rret)))
+ (if (characterp ch)
+ (www-format-encode-string
+ (char-to-string ch) without-tags)
+ (www-format-encode-string
+ (format "%S" ch) without-tags)))
+ ret ""))
+ (when ret
+ (goto-char start)
+ (delete-region start end)
+ (insert ret))
+ )))
))
;; (goto-char (point-min))
;; (while (search-forward ">-" nil t)
(setq format (plist-get props :format)))
(concat "%"
(plist-get props :flag)
- (if (plist-get props :zero-padding)
- "0")
+ ;; (if (plist-get props :zero-padding)
+ ;; "0")
(if (plist-get props :len)
- (format "%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")
(defun www-format-apply-value (object feature-name
format props value
- &optional uri-char uri-feature
- without-tags)
+ &optional uri-object uri-feature
+ without-tags without-edit)
(let (ret)
(setq ret
(cond
((eq format 'wiki-text)
(if without-tags
(www-xml-format-list value)
- (www-format-eval-list value object feature-name nil uri-char))
+ (www-format-eval-list value object feature-name nil uri-object
+ without-tags without-edit))
)
((eq format 'S-exp)
(www-format-encode-string
(www-format-value-as-char-list value without-tags))
((eq format 'space-separated-ids)
(www-format-value-as-ids value without-tags))
+ ((eq format 'space-separated-domain-list)
+ (www-format-value-as-domain-list value without-tags))
((eq format 'string)
(www-format-encode-string (format "%s" value) without-tags)
)
(www-format-value-default value without-tags)
))
)
- (if (or without-tags (eq (plist-get props :mode) 'peek))
+ (if (or without-tags
+ without-edit
+ (eq (plist-get props :mode) 'peek))
ret
(format "%s <a href=\"%s?char=%s&feature=%s&format=%s\"
><input type=\"submit\" value=\"edit\" /></a>"
ret
chise-wiki-edit-url
- uri-char uri-feature format))))
+ uri-object uri-feature format))))
-(defun www-format-eval-feature-value (char
+(defun www-format-eval-feature-value (object
feature-name
- &optional format lang uri-char value)
+ &optional format lang uri-object value
+ without-tags without-edit)
(unless value
- (setq value (www-char-feature char feature-name)))
+ (setq value (www-get-feature-value object feature-name)))
(unless format
(setq format (www-feature-value-format feature-name)))
(cond
((symbolp format)
(www-format-apply-value
- char feature-name
+ object feature-name
format nil value
- uri-char (www-uri-encode-feature-name feature-name))
+ uri-object (www-uri-encode-feature-name feature-name)
+ without-tags without-edit)
)
((consp format)
(cond ((null (cdr format))
(setq format (car format))
(www-format-apply-value
- char feature-name
+ object feature-name
(car format) (nth 1 format) value
- uri-char (www-uri-encode-feature-name feature-name))
+ uri-object (www-uri-encode-feature-name feature-name)
+ without-tags without-edit)
)
(t
- (www-format-eval-list format char feature-name lang uri-char)
+ (www-format-eval-list format object feature-name lang uri-object
+ without-tags without-edit)
)))))
-(defun www-format-eval-unit (exp char feature-name
- &optional lang uri-char value)
+(defun www-format-eval-unit (exp object feature-name
+ &optional lang uri-object value
+ without-tags without-edit)
(unless value
- (setq value (www-char-feature char feature-name)))
- (unless uri-char
- (setq uri-char (www-uri-encode-char char)))
+ (setq value (www-get-feature-value object feature-name)))
+ (unless uri-object
+ (setq uri-object (www-uri-encode-object object)))
(cond
((stringp exp) (www-format-encode-string exp))
((null exp) "")
((consp exp)
(cond
((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
- S-exp default))
+ 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)
- (www-format-eval-feature-value char feature-name
+ (www-format-eval-feature-value object feature-name
(plist-get (nth 1 exp) :format)
- lang uri-char value)
+ lang uri-object value
+ without-tags without-edit)
(www-format-apply-value
- char feature-name
+ object feature-name
(car exp) (nth 1 exp) value
- uri-char (www-uri-encode-feature-name feature-name)))
+ uri-object (www-uri-encode-feature-name feature-name)
+ without-tags without-edit))
)
((eq (car exp) 'name)
- (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))
+ (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\">%s</a>"
+ (www-uri-make-feature-name-url
+ (www-uri-encode-feature-name feature-name)
+ uri-object)
+ (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-object)
+ )
+ ((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
+ ""
+ (let ((prev-char (find-previous-defined-code-point
+ feature-name value)))
+ (if prev-char
+ (format "\n<a href=\"%s?char=%s\">%s</a>"
+ chise-wiki-view-url
+ (www-uri-encode-object prev-char)
+ "<input type=\"submit\" value=\"-\" />"
+ ;; (www-format-encode-string
+ ;; (char-to-string prev-char))
+ )
+ "")))
+ )
+ ((eq (car exp) 'next-char)
+ (if without-tags
+ ""
+ (let ((next-char (find-next-defined-code-point
+ feature-name value)))
+ (if next-char
+ (format "<a href=\"%s?char=%s\">%s</a>"
+ chise-wiki-view-url
+ (www-uri-encode-object next-char)
+ "<input type=\"submit\" value=\"+\" />"
+ ;; (www-format-encode-string
+ ;; (char-to-string next-char))
+ )
+ "")))
)
((eq (car exp) 'link)
- (format "<a
+ (if without-tags
+ (www-format-eval-list (nthcdr 2 exp)
+ object feature-name lang uri-object
+ without-tags without-edit)
+ (format "<a
href=\"%s\"
>%s</a
>"
- (www-format-eval-list (plist-get (nth 1 exp) :ref)
- char feature-name lang uri-char)
- (www-format-eval-list (nthcdr 2 exp)
- char feature-name lang uri-char)))
+ (www-format-eval-list (plist-get (nth 1 exp) :ref)
+ object feature-name lang uri-object
+ 'without-tags 'without-edit)
+ (www-format-eval-list (nthcdr 2 exp)
+ object feature-name lang uri-object
+ without-tags without-edit)))
+ )
(t
(format "<%s
>%s</%s
>"
(car exp)
- (www-format-eval-list (nthcdr 2 exp) char feature-name
- lang uri-char)
+ (www-format-eval-list (nthcdr 2 exp) object feature-name
+ lang uri-object
+ without-tags without-edit)
(car exp)))))))
-(defun www-format-eval-list (format-list char feature-name
- &optional lang uri-char)
+(defun www-format-eval-list (format-list object feature-name
+ &optional lang uri-object
+ without-tags without-edit)
(if (consp format-list)
(mapconcat
(lambda (exp)
- (www-format-eval-unit exp char feature-name lang uri-char))
+ (www-format-eval-unit exp object feature-name lang uri-object
+ nil without-tags without-edit))
format-list "")
- (www-format-eval-unit format-list char feature-name lang uri-char)))
+ (www-format-eval-unit format-list object feature-name lang uri-object
+ nil without-tags without-edit)))
;;; @ XML generator
(=ucs@unicode "u" 4 x "-us")
(=adobe-japan1-6 "aj1-" 5 d nil)
(=gt "gt-" 5 d nil)
- (=gt-k "gt-k" 5 d nil)
(=big5-cdp "cdp-" 4 x nil)
(=cbeta "cb" 5 d nil)
(=jis-x0208@1978/1pr "j78-" 4 x nil)
(=cns11643-6 "c6-" 4 x nil)
(=cns11643-7 "c7-" 4 x nil)
(=daikanwa "dkw-" 5 d nil)
+ (=gt-k "gt-k" 5 d nil)
(=jef-china3 "jc3-" 4 x nil)
(=big5 "b-" 4 x nil)
(=ks-x1001 "k0-" 4 x nil)
(defun char-GlyphWiki-id (char)
(let ((rest coded-charset-GlyphWiki-id-alist)
- spec
- ret)
+ spec ret code)
(while (and rest
(setq spec (pop rest))
(null (setq ret (char-feature char (car spec))))))
(when ret
- (format (format "%s%%0%d%s%s"
- (nth 1 spec)
- (nth 2 spec)
- (nth 3 spec)
- (or (nth 4 spec) ""))
- ret))))
+ (or
+ (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
+ (cond
+ ((and (or (encode-char char '=jis-x0208@1990)
+ (encode-char char '=jis-x0212)
+ (encode-char char '=jis-x0213-1))
+ (setq code (encode-char char '=ucs@jis)))
+ (format "u%04x" code)
+ )
+ ((and (or (encode-char char '=gb2312)
+ (encode-char char '=gb12345))
+ (setq code (encode-char char '=ucs@gb)))
+ (format "u%04x-g" code)
+ )
+ ((and (or (encode-char char '=cns11643-1)
+ (encode-char char '=cns11643-2)
+ (encode-char char '=cns11643-3)
+ (encode-char char '=cns11643-4)
+ (encode-char char '=cns11643-5)
+ (encode-char char '=cns11643-6)
+ (encode-char char '=cns11643-7))
+ (setq code (encode-char char '=ucs@cns)))
+ (format "u%04x-t" code)
+ )
+ ((and (encode-char char '=ks-x1001)
+ (setq code (encode-char char '=ucs@ks)))
+ (format "u%04x-k" code)
+ )))
+ (format (format "%s%%0%d%s%s"
+ (nth 1 spec)
+ (nth 2 spec)
+ (nth 3 spec)
+ (or (nth 4 spec) ""))
+ ret)))))
;;; @ End.
projects / chise / est.git / blobdiff