(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")
+
(defun decode-uri-string (string &optional coding-system)
(if (> (length string) 0)
(let ((i 0)
(or (char-feature-property feature-name 'type)
(let ((str (symbol-name feature-name)))
(cond
+ ((string-match "\\*note\\(@[^*]+\\)?$" str)
+ 'stext)
+ ((string-match "\\*sources\\(@[^*]+\\)?$" str)
+ 'domain-list)
+ ((string-match "\\*" str)
+ nil)
((string-match "^\\(->\\|<-\\)" str)
'relation)
((string-match "^ideographic-structure\\(@\\|$\\)" str)
(cond ((eq type 'relation)
'space-separated-char-list)
((eq type 'structure)
- 'space-separated-ids)))
+ 'space-separated-ids)
+ ((eq type 'stext)
+ 'wiki-text)
+ ))
(if (find-charset feature-name)
(if (and (= (charset-dimension feature-name) 2)
(= (charset-chars feature-name) 94))
" (" (decimal) ") <" (ku-ten) ">")
'("0x" (HEX) " (" (decimal) ")")))))
+(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))
+ ))))
+
+(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))))
+
;;; @ URI representation
;;;
=gt =gt-k
=>>jis-x0208 =>>jis-x0213-1
=>jis-x0208 =>jis-x0213-1
+ =>>gt
=big5
=big5-cdp))
ccs ret)
"-")
" "))
+(defun www-format-feature-name-as-metadata (feature-name &optional lang)
+ (let ((str (symbol-name feature-name))
+ base meta)
+ (cond
+ ((string-match "\\*[^*]+$" str)
+ (setq base (substring str 0 (match-beginning 0))
+ meta (substring str (match-beginning 0)))
+ (concat (www-format-feature-name* (intern base) lang)
+ meta))
+ (t
+ (www-format-feature-name-default feature-name)
+ ))))
+
(defun www-format-feature-name-as-rel-to (feature-name)
(concat "\u2192" (substring (symbol-name feature-name) 2)))
((find-charset feature-name)
(www-format-feature-name-as-CCS feature-name))
((and (setq name (symbol-name feature-name))
- (string-match "^\\(->\\)" 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))
(- (lsh value -8) 32)
(- (logand value 255) 32)))
+(defun www-format-value-default (value &optional without-tags)
+ (if (listp value)
+ (mapconcat
+ (lambda (unit)
+ (www-format-encode-string
+ (format "%S" unit)
+ without-tags))
+ value " ")
+ (www-format-encode-string (format "%S" value) without-tags)))
+
(defun www-format-value-as-char-list (value &optional without-tags)
(if (listp value)
(mapconcat
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
value)
(www-format-value-as-S-exp value)))
-(defun www-format-value (value &optional feature-name format without-tags)
- ;; (cond
- ;; ((find-charset feature-name)
- ;; (cond
- ;; ((and (= (charset-chars feature-name) 94)
- ;; (= (charset-dimension feature-name) 2))
- ;; (www-format-value-as-CCS-94x94 value))
- ;; (t
- ;; (www-format-value-as-CCS-default value)))
- ;; )
- ;; (t
- ;; (www-format-value-as-S-exp value)))
- (www-format-apply-value format nil value nil nil without-tags)
+(defun www-format-value-as-kangxi-radical (value)
+ (if (and (integerp value)
+ (<= 0 value)
+ (<= value 214))
+ (www-format-encode-string
+ (format "%c" (ideographic-radical value)))
+ (www-format-value-as-S-exp value)))
+
+(defun www-format-value (object feature-name
+ &optional value format without-tags)
+ (unless value
+ (setq value (www-char-feature object feature-name)))
+ (www-format-apply-value object feature-name
+ format nil value nil nil without-tags)
)
(defun www-format-encode-string (string &optional without-tags)
(with-temp-buffer
(insert string)
- (let (plane code)
+ (let (plane code start end char variants ret)
(goto-char (point-min))
(while (search-forward "<" nil t)
(replace-match "<" nil t))
(encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
(let ((coded-charset-entity-reference-alist
(list*
+ '(=gt "GT-" 5 d)
'(=cns11643-1 "C1-" 4 X)
'(=cns11643-2 "C2-" 4 X)
'(=cns11643-3 "C3-" 4 X)
'(=jis-x0208@1990 "J90-" 4 X)
'(=jis-x0212 "JSP-" 4 X)
'(=cbeta "CB" 5 d)
- '(=jef-china3 "JC3-" 4 X)
'(=jis-x0208@1997 "J97-" 4 X)
'(=jis-x0208@1978 "J78-" 4 X)
'(=jis-x0208@1983 "J83-" 4 X)
'(=zinbun-oracle "ZOB-" 4 d)
+ '(=jef-china3 "JC3-" 4 X)
'(=daikanwa "M-" 5 d)
coded-charset-entity-reference-alist)))
(encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
chise-wiki-bitmap-glyphs-url
code)
t 'literal))
- ))
- (goto-char (point-min))
- (while (search-forward ">-" nil t)
- (replace-match "&GT-" t 'literal))
+ (goto-char (point-min))
+ (while (re-search-forward "&\\(G-\\)?GT-\\([0-9]+\\);" nil t)
+ (setq code (string-to-int (match-string 2)))
+ (replace-match
+ (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\">"
+ code
+ chise-wiki-glyph-cgi-url
+ code)
+ t 'literal))
+
+ (goto-char (point-min))
+ (while (re-search-forward "&\\(G-\\)?GT-K\\([0-9]+\\);" nil t)
+ (setq code (string-to-int (match-string 2)))
+ (replace-match
+ (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\">"
+ code
+ chise-wiki-glyph-cgi-url
+ code)
+ t 'literal))
+
+ (goto-char (point-min))
+ (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
+ (setq code (string-to-int (match-string 1) 16))
+ (replace-match
+ (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\">"
+ code
+ chise-wiki-glyph-cgi-url
+ code)
+ t 'literal))
+
+ (goto-char (point-min))
+ (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t)
+ (setq code (string-to-int (match-string 1) 16))
+ (replace-match
+ (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%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))
+ (replace-match
+ (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\">"
+ code
+ code)
+ t 'literal))
+
+ (goto-char (point-min))
+ (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
+ (setq code (string-to-int (match-string 1) 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)))
+ ))
+ ;; (goto-char (point-min))
+ ;; (while (search-forward ">-" nil t)
+ ;; (replace-match "&GT-" t 'literal))
(buffer-string))))
(defun www-format-props-to-string (props &optional format)
((eq format 'S-exp) "S")
(t "s"))))
-(defun www-format-apply-value (format props value
+(defun www-format-apply-value (object feature-name
+ format props value
&optional uri-char uri-feature
without-tags)
(let (ret)
(format "%s" value)
without-tags))
)
+ ((eq format 'wiki-text)
+ (if without-tags
+ (www-xml-format-list value)
+ (www-format-eval-list value object feature-name nil uri-char))
+ )
((eq format 'S-exp)
(www-format-encode-string
(format (www-format-props-to-string props format)
without-tags))
((eq format 'ku-ten)
(www-format-value-as-kuten value))
+ ((eq format 'kangxi-radical)
+ (www-format-value-as-kangxi-radical value))
((eq format 'space-separated-char-list)
(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)
+ )
(t
- (setq format 'default)
- (www-format-encode-string
- (format (www-format-props-to-string props 'default)
- value)
- without-tags))))
+ (www-format-value-default value without-tags)
+ ))
+ )
(if (or without-tags (eq (plist-get props :mode) 'peek))
ret
(format "%s <a href=\"%s?char=%s&feature=%s&format=%s\"
feature-name
&optional format lang uri-char value)
(unless value
- (setq value (char-feature char feature-name)))
+ (setq value (www-char-feature char feature-name)))
(unless format
(setq format (www-feature-value-format feature-name)))
(cond
((symbolp format)
(www-format-apply-value
+ char feature-name
format nil value
uri-char (www-uri-encode-feature-name feature-name))
)
(cond ((null (cdr format))
(setq format (car format))
(www-format-apply-value
+ char feature-name
(car format) (nth 1 format) value
uri-char (www-uri-encode-feature-name feature-name))
)
(defun www-format-eval-unit (exp char feature-name
&optional lang uri-char value)
(unless value
- (setq value (char-feature char feature-name)))
+ (setq value (www-char-feature char feature-name)))
(unless uri-char
(setq uri-char (www-uri-encode-char char)))
(cond
((null exp) "")
((consp exp)
(cond
- ((memq (car exp) '(value decimal hex HEX ku-ten S-exp default))
+ ((memq (car exp) '(value decimal hex HEX ku-ten kangxi-radical
+ S-exp default))
(if (eq (car exp) 'value)
(www-format-eval-feature-value char feature-name
(plist-get (nth 1 exp) :format)
lang uri-char value)
(www-format-apply-value
+ char feature-name
(car exp) (nth 1 exp) value
uri-char (www-uri-encode-feature-name feature-name)))
)
(www-format-eval-unit format-list char feature-name lang uri-char)))
+;;; @ XML generator
+;;;
+
+(defun www-xml-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" val) 'without-tags))))
+ dest))
+
+(defun www-xml-format-unit (format-unit)
+ (let (name props children ret)
+ (cond
+ ((stringp format-unit)
+ (mapconcat (lambda (c)
+ (cond
+ ((eq c ?&) "&")
+ ;; ((eq c ?<) "&lt;")
+ ;; ((eq c ?>) "&gt;")
+ (t
+ (char-to-string c))))
+ (www-format-encode-string format-unit 'without-tags)
+ "")
+ )
+ ((consp format-unit)
+ (setq name (car format-unit)
+ props (nth 1 format-unit)
+ children (nthcdr 2 format-unit))
+ (when (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))))
+ (if children
+ (format "<%s%s>%s</%s>"
+ name
+ (if props
+ (www-xml-format-props props)
+ "")
+ (www-xml-format-list children)
+ name)
+ (format "<%s%s/>"
+ name (www-xml-format-props props)))
+ )
+ (t
+ (format "%s" format-unit)))))
+
+(defun www-xml-format-list (format-list)
+ (if (atom format-list)
+ (www-xml-format-unit format-list)
+ (mapconcat #'www-xml-format-unit
+ format-list "")))
+
+
;;; @ HTML generator
;;;
(www-html-display-text text)
(princ "</p>\n"))
+
+;;; @ for GlyphWiki
+;;;
+
+(defvar coded-charset-GlyphWiki-id-alist
+ '((=ucs "u" 4 x nil)
+ (=ucs@JP "u" 4 x nil)
+ (=ucs@jis "u" 4 x nil)
+ (=ucs@gb "u" 4 x "-g")
+ (=ucs@cns "u" 4 x "-t")
+ (=ucs@ks "u" 4 x "-k")
+ (=ucs@iso "u" 4 x "-u")
+ (=ucs@unicode "u" 4 x "-us")
+ (=adobe-japan1-6 "aj1-" 5 d nil)
+ (=gt "gt-" 5 d nil)
+ (=big5-cdp "cdp-" 4 x nil)
+ (=cbeta "cb" 5 d nil)
+ (=jis-x0208@1978/1pr "j78-" 4 x nil)
+ (=jis-x0208@1978/-4pr "j78-" 4 x nil)
+ (=jis-x0208@1978 "j78-" 4 x nil)
+ (=jis-x0208@1983 "j83-" 4 x nil)
+ (=jis-x0208@1990 "j90-" 4 x nil)
+ (=jis-x0212 "jsp-" 4 x nil)
+ (=jis-x0213-1@2000 "jx1-2000-" 4 x nil)
+ (=jis-x0213-1@2004 "jx1-2004-" 4 x nil)
+ (=jis-x0213-2 "jx2-" 4 x nil)
+ (=cns11643-1 "c1-" 4 x nil)
+ (=cns11643-2 "c2-" 4 x nil)
+ (=cns11643-3 "c3-" 4 x nil)
+ (=cns11643-4 "c4-" 4 x nil)
+ (=cns11643-5 "c5-" 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 code)
+ (while (and rest
+ (setq spec (pop rest))
+ (null (setq ret (char-feature char (car spec))))))
+ (when 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.
+;;;
+
(provide 'cwiki-common)
+
+;;; cwiki-common.el ends here
projects / chise / est.git / blobdiff