;; -*- coding: utf-8-mcs-er -*- (require 'char-db-util) (require 'chiset-common) ;; (require 'concord-images) (setq file-name-coding-system 'utf-8-mcs-er) (concord-assign-genre 'code-point "/usr/local/var/chise-ipld/db") (concord-assign-genre 'coded-character "/usr/local/var/chise-ipld/db") (concord-assign-genre 'glyph "/usr/local/var/chise-ipld/db") (concord-assign-genre 'image-resource "/usr/local/var/photo/db") (concord-assign-genre 'glyph-image "/usr/local/var/photo/db") (concord-assign-genre 'creator@ruimoku "/usr/local/var/ruimoku/db") (concord-assign-genre 'person-name@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") (concord-assign-genre 'journal-name@ruimoku "/usr/local/var/ruimoku/db") (concord-assign-genre 'publisher@ruimoku "/usr/local/var/ruimoku/db") (concord-assign-genre 'publisher-name@ruimoku "/usr/local/var/ruimoku/db") (mount-char-attribute-table '*instance@ruimoku/bibliography/title) ;; (mount-char-attribute-table '*instance@ruimoku/bibliography/content*note) (concord-assign-genre 'entry@zh-classical "/usr/local/var/kanbun/db") ;; (concord-assign-genre 'morpheme-entry@zh-classical "/usr/local/var/kanbun/db") (concord-assign-genre 'word-class@zh-classical "/usr/local/var/kanbun/db") (concord-assign-genre 'morpheme@zh-classical "/usr/local/var/kanbun/db") (concord-assign-genre 'sentence@zh-classical "/usr/local/var/kanbun/db") ;; (concord-assign-genre 'sentence-entry@zh-classical "/usr/local/var/kanbun/db") (mount-char-attribute-table '*instance@morpheme-entry/zh-classical) (concord-assign-genre 'ud@zh-classical "/usr/local/var/kanbun/db") (concord-assign-genre 'hng-card "/usr/local/var/hng-card/db") (mount-char-attribute-table '->HNG) (mount-char-attribute-table '<-HNG) (mount-char-attribute-table '->HNG@CN/manuscript) (mount-char-attribute-table '<-HNG@CN/manuscript) (mount-char-attribute-table '->HNG@CN/printed) (mount-char-attribute-table '<-HNG@CN/printed) (mount-char-attribute-table '->HNG@JP/manuscript) (mount-char-attribute-table '<-HNG@JP/manuscript) (mount-char-attribute-table '->HNG@JP/printed) (mount-char-attribute-table '<-HNG@JP/printed) (mount-char-attribute-table '->HNG@KR) (mount-char-attribute-table '<-HNG@KR) (mount-char-attribute-table '->HNG@MISC) (mount-char-attribute-table '<-HNG@MISC) (mount-char-attribute-table 'abstract-glyph@iwds-1) (mount-char-attribute-table 'abstract-glyph@iwds-1/confluented) (mount-char-attribute-table '=hdic-tsj-glyph-id) (mount-char-attribute-table '=hdic-syp-entry-id) (mount-char-attribute-table '=hdic-ktb-entry-id) (mount-char-attribute-table '=hdic-ktb-seal-glyph-id) (mount-char-attribute-table 'hdic-tsj-word-id) (mount-char-attribute-table 'hdic-tsj-word) (mount-char-attribute-table 'hdic-tsj-word-description) (mount-char-attribute-table 'hdic-tsj-word-remarks) (mount-char-attribute-table 'hdic-syp-description) (mount-char-attribute-table 'hdic-ktb-description) (mount-char-attribute-table 'hdic-ktb-entry-type) (mount-char-attribute-table 'hdic-ktb-diff) (mount-char-attribute-table 'hdic-ktb-syp-id) (mount-char-attribute-table 'hdic-ktb-yy-id) (mount-char-attribute-table 'hdic-ktb-ndl-pid) (mount-char-attribute-table '<-HDIC-SYP@tenrei-bansho-meigi) (mount-char-attribute-table '->HDIC-SYP@tenrei-bansho-meigi) (mount-char-attribute-table '<-Small-Seal@tenrei-bansho-meigi) (mount-char-attribute-table '->Small-Seal@tenrei-bansho-meigi) (mount-char-attribute-table 'sound@fanqie) (defvar est-hide-cgi-mode nil) (defvar est-view-url-prefix "..") (defvar chise-wiki-view-url "view.cgi") (defvar chise-wiki-edit-url "edit.cgi") (defvar chise-wiki-bitmap-glyph-image-url "https://image.chise.org/glyphs") (defvar chise-wiki-legacy-bitmap-glyphs-url "https://www.chise.org/glyphs") (defvar chise-wiki-hng-bitmap-glyphs-url "https://image.hng-data.org/glyphs/HNG") (defvar chise-wiki-daijiten-bitmap-glyphs-url "https://image.hng-data.org/glyphs/daijiten") (defvar chise-wiki-glyphwiki-glyph-image-url "https://glyphwiki.org/glyph") (defvar chise-wiki-glyph-cgi-url "https://www.chise.org/chisewiki/glyph.cgi") (defvar chise-wiki-displayed-features nil) (defvar est-coded-charset-priority-list '(; =ucs =cns11643-1 =cns11643-2 =cns11643-3 =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7 =gb2312 =gb12345 =jis-x0208 =jis-x0208@1990 =jis-x0213-2 =jis-x0212 =adobe-japan1 =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 ==adobe-japan1 ==jis-x0208 ==jis-x0213-1 ==jis-x0213-2 =>>jis-x0208 =>>jis-x0213-1 =>>jis-x0213-2 =>>adobe-japan1 =+>jis-x0208 =+>jis-x0213-1 =+>jis-x0213-2 =+>jis-x0208@1978 =+>adobe-japan1 =>jis-x0208 =>jis-x0213-1 =>>gt =>ucs@iso =>ucs@unicode =>ucs@jis =>ucs@cns =>ucs@ks =+>ucs@iso =+>ucs@unicode =>>ucs@iso =>>ucs@unicode =>>ucs@jis =>>ucs@cns =>>ucs@ks ==ucs@iso ==ucs@unicode ==ucs@jis ==ucs@cns ==ucs@ks ===ucs@iso =ruimoku-v6 =big5 =big5-cdp =>cbeta =mj ==mj ===mj =ucs-itaiji-001 =ucs-itaiji-002 =ucs-itaiji-003 =ucs-itaiji-004 =ucs-itaiji-005 =ucs-itaiji-006 =ucs-itaiji-007 =ucs-itaiji-008 =ucs-itaiji-009 =ucs-itaiji-010 =ucs-itaiji-011 =ucs-itaiji-084 =ucs-var-001 =ucs-var-002 =ucs-var-003 =ucs-var-004 =ucs-var-010 =ucs@unicode ==ucs@unicode ===ucs@unicode ==>daijiten ==>ucs@bucs ===daikanwa/+p ===gt =>ucs@iwds-1 =>ucs@component =>ucs@cognate =>ucs-itaiji-001 =>ucs-itaiji-002 =>ucs-itaiji-003 =>ucs-itaiji-004 =>ucs-itaiji-005 =>ucs-itaiji-006 =>ucs-itaiji-007 =>ucs-itaiji-008 ===adobe-japan1 ===cns11643-1 ===cns11643-2 ===cns11643-3 ===cns11643-4 ===cns11643-5 ===cns11643-6 ===cns11643-7 )) (defvar est-coded-charset-entity-reference-alist (list* '(=gt "GT-" 5 d) '(=mj "MJ" 6 d) '(=hanyo-denshi/ja "HD-JA-" 4 X) '(=hanyo-denshi/jb "HD-JB-" 4 X) '(=hanyo-denshi/jc "HD-JC-" 4 X) '(=hanyo-denshi/jd "HD-JD-" 4 X) '(=hanyo-denshi/ft "HD-FT-" 4 X) '(=hanyo-denshi/ia "HD-IA-" 4 X) '(=hanyo-denshi/ib "HD-IB-" 4 X) '(=hanyo-denshi/hg "HD-HG-" 4 X) '(=hanyo-denshi/ip "HD-IP-" 4 X) '(=hanyo-denshi/jt "HD-JT-" 4 X) '(=hanyo-denshi/ks "HD-KS-" 6 d) '(=>>hanyo-denshi/ja "G-HD-JA-" 4 X) '(=>>hanyo-denshi/jb "G-HD-JB-" 4 X) '(=>>hanyo-denshi/jc "G-HD-JC-" 4 X) '(=>>hanyo-denshi/jd "G-HD-JD-" 4 X) '(=>>hanyo-denshi/ft "G-HD-FT-" 4 X) '(=>>hanyo-denshi/ia "G-HD-IA-" 4 X) '(=>>hanyo-denshi/ib "G-HD-IB-" 4 X) '(=>>hanyo-denshi/hg "G-HD-HG-" 4 X) '(=>>hanyo-denshi/ip "G-HD-IP-" 4 X) '(=>>hanyo-denshi/jt "G-HD-JT-" 4 X) '(=>>hanyo-denshi/ks "G-HD-KS-" 6 d) '(==mj "g2-MJ" 6 d) '(==hanyo-denshi/ja "g2-HD-JA-" 4 X) '(==hanyo-denshi/jb "g2-HD-JB-" 4 X) '(==hanyo-denshi/jc "g2-HD-JC-" 4 X) '(==hanyo-denshi/jd "g2-HD-JD-" 4 X) '(==hanyo-denshi/ft "g2-HD-FT-" 4 X) '(==hanyo-denshi/ia "g2-HD-IA-" 4 X) '(==hanyo-denshi/ib "g2-HD-IB-" 4 X) '(==hanyo-denshi/hg "g2-HD-HG-" 4 X) '(==hanyo-denshi/ip "g2-HD-IP-" 4 X) '(==hanyo-denshi/jt "g2-HD-JT-" 4 X) '(==hanyo-denshi/ks "g2-HD-KS-" 6 d) '(==daijiten "g2-DJT-" 5 d) '(=cns11643-1 "C1-" 4 X) '(=cns11643-2 "C2-" 4 X) '(=cns11643-3 "C3-" 4 X) '(=cns11643-4 "C4-" 4 X) '(=cns11643-5 "C5-" 4 X) '(=cns11643-6 "C6-" 4 X) '(=cns11643-7 "C7-" 4 X) '(=adobe-japan1-6 "AJ1-" 5 d) '(=big5-cdp "CDP-" 4 X) '(=>big5-cdp "A-CDP-" 4 X) '(=gb2312 "G0-" 4 X) '(=gb12345 "G1-" 4 X) '(=jis-x0208@1990 "J90-" 4 X) '(=jis-x0212 "JSP-" 4 X) '(=cbeta "CB" 5 d) '(=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) '(=daijiten "DJT-" 5 d) '(=>ucs-itaiji-001 "A-U-i001+" 4 X) '(=>ucs-itaiji-002 "A-U-i002+" 4 X) '(=>ucs-itaiji-003 "A-U-i003+" 4 X) '(=>ucs-itaiji-004 "A-U-i004+" 4 X) '(=>ucs-itaiji-005 "A-U-i005+" 4 X) '(=>ucs-itaiji-006 "A-U-i006+" 4 X) '(=>ucs-itaiji-007 "A-U-i007+" 4 X) '(=>ucs-itaiji-008 "A-U-i008+" 4 X) '(=>ucs-itaiji-009 "A-U-i009+" 4 X) '(=>ucs-itaiji-010 "A-U-i010+" 4 X) '(=>ucs-itaiji-011 "A-U-i011+" 4 X) '(=>ucs-itaiji-001@iwds-1 "A-IWDSU-i001+" 4 X) '(=>ucs-itaiji-002@iwds-1 "A-IWDSU-i002+" 4 X) '(=>ucs-itaiji-003@iwds-1 "A-IWDSU-i003+" 4 X) '(=>ucs-itaiji-006@iwds-1 "A-IWDSU-i006+" 4 X) '(=jef-china3 "JC3-" 4 X) '(=ucs@unicode "UU+" 4 X) '(=ucs@JP/hanazono "hanaJU+" 4 X) '(==cns11643-1 "R-C1-" 4 X) '(==cns11643-2 "R-C2-" 4 X) '(==cns11643-3 "R-C3-" 4 X) '(==cns11643-4 "R-C4-" 4 X) '(==cns11643-5 "R-C5-" 4 X) '(==cns11643-6 "R-C6-" 4 X) '(==cns11643-7 "R-C7-" 4 X) '(=hanziku-1 "HZK01-" 4 X) '(=hanziku-2 "HZK02-" 4 X) '(=hanziku-3 "HZK03-" 4 X) '(=hanziku-4 "HZK04-" 4 X) '(=hanziku-5 "HZK05-" 4 X) '(=hanziku-6 "HZK06-" 4 X) '(=hanziku-7 "HZK07-" 4 X) '(=hanziku-8 "HZK08-" 4 X) '(=hanziku-9 "HZK09-" 4 X) '(=hanziku-10 "HZK10-" 4 X) '(=hanziku-11 "HZK11-" 4 X) '(=hanziku-12 "HZK12-" 4 X) '(==>daijiten "A2-DJT-" 5 d) '(==cbeta "CB" 5 d) '(=big5 "B-" 4 X) '(=daikanwa "M-" 5 d) '(=>>daikanwa "G-M-" 5 d) '(===ucs@ks "R-KU+" 4 X) coded-charset-entity-reference-alist)) (defun decode-uri-string (string &optional coding-system) (if (> (length string) 0) (let ((i 0) dest) (setq string (mapconcat (lambda (char) (if (eq char ?+) " " (char-to-string char))) string "")) (while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i) (setq dest (concat dest (substring string i (match-beginning 0)) (char-to-string (int-char (string-to-int (match-string 1 string) 16)))) i (match-end 0))) (decode-coding-string (concat dest (substring string i)) coding-system)))) (defun www-feature-type (feature-name) (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) 'structure) )))) (defun www-feature-format (feature-name) (or (char-feature-property feature-name 'presentation-format) (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-presentation-format) (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 (or (char-feature-property parent 'value-presentation-format) (char-feature-property parent 'value-format))))) (setq fn parent)) ret) (let ((type (www-feature-type feature-name))) (cond ((eq type 'relation) 'space-separated) ((eq type 'structure) 'space-separated-ids) ((eq type 'domain-list) 'space-separated-source-list) ((eq type 'stext) 'wiki-text) )) (if (find-charset feature-name) (if (and (= (charset-dimension feature-name) 2) (= (charset-chars feature-name) 94)) '("0x" (HEX) " (" (decimal) ") <" (ku-ten) "> " (prev-char) (next-char)) '("0x" (HEX) " (" (decimal) ") " (prev-char) (next-char)))) 'space-separated)) (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))) (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 est-object-genre (object) (if (characterp object) 'character (concord-object-genre object))) (defun www-get-feature-value (object feature) (let ((latest-feature (char-feature-name-at-domain feature '$rev=latest))) (cond ((characterp object) (mount-char-attribute-table latest-feature) (or (char-feature object latest-feature) (char-feature object feature)) ) (t (or (condition-case nil (concord-object-get object latest-feature) (error nil)) (condition-case nil (concord-object-get object feature) (error nil))) )))) (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 ;;; ;; (defun est-uri-decode-feature-name-body (uri-feature) ;; (let ((len (length uri-feature)) ;; (i 0) ;; ch dest) ;; (while (< i len) ;; (setq dest ;; (concat ;; dest ;; (if (eq (aref uri-feature i) ?\.) ;; (if (and (< (+ i 2) len) ;; (eq (aref uri-feature (+ i 2)) ?\.)) ;; (prog1 ;; (cond ;; ((eq (setq ch (aref uri-feature (1+ i))) ?\.) ;; "/") ;; ((eq ch ?-) ;; "*") ;; ((eq ch ?_) ;; "+") ;; (t ;; (substring uri-feature i (+ i 3)) ;; )) ;; (setq i (+ i 3))) ;; (setq i (1+ i)) ;; ".") ;; (prog1 ;; (char-to-string (aref uri-feature i)) ;; (setq i (1+ i))))))) ;; dest)) ;; (defun est-uri-encode-feature-name-body (feature) ;; (mapconcat (lambda (c) ;; (cond ((eq c ?*) ;; ".-.") ;; ((eq c ?/) ;; "...") ;; ((eq c ?+) ;; "._.") ;; (t (char-to-string c)))) ;; feature "")) ;; (defun www-uri-decode-feature-name (uri-feature) ;; (let (feature) ;; (setq uri-feature (decode-uri-string uri-feature 'utf-8-mcs-er)) ;; (cond ;; ((string-match "^from\\." uri-feature) ;; (intern (format "<-%s" ;; (est-uri-decode-feature-name-body ;; (substring uri-feature (match-end 0))))) ;; ) ;; ((string-match "^to\\." uri-feature) ;; (intern (format "->%s" ;; (est-uri-decode-feature-name-body ;; (substring uri-feature (match-end 0))))) ;; ) ;; ((string-match "^rep\\." uri-feature) ;; (intern (format "=%s" ;; (est-uri-decode-feature-name-body ;; (substring uri-feature (match-end 0))))) ;; ) ;; ((string-match "^rep[2i]\\." uri-feature) ;; (intern (format "===%s" ;; (est-uri-decode-feature-name-body ;; (substring uri-feature (match-end 0))))) ;; ) ;; ((string-match "^g\\." uri-feature) ;; (intern (format "=>>%s" ;; (est-uri-decode-feature-name-body ;; (substring uri-feature (match-end 0))))) ;; ) ;; ((string-match "^g[i2]\\." uri-feature) ;; (intern (format "==%s" ;; (est-uri-decode-feature-name-body ;; (substring uri-feature (match-end 0))))) ;; ) ;; ((string-match "^gi\\([0-9]+\\)\\." uri-feature) ;; (intern (format "=>>%s%s" ;; (make-string (string-to-int ;; (match-string 1 uri-feature)) ;; ?>) ;; (est-uri-decode-feature-name-body ;; (substring uri-feature (match-end 0))))) ;; ) ;; ((string-match "^o\\." uri-feature) ;; (intern (format "=+>%s" ;; (est-uri-decode-feature-name-body ;; (substring uri-feature (match-end 0))))) ;; ) ;; ((string-match "^a\\." uri-feature) ;; (intern (format "=>%s" ;; (est-uri-decode-feature-name-body ;; (substring uri-feature (match-end 0))))) ;; ) ;; ((string-match "^a\\([0-9]+\\)\\." uri-feature) ;; (intern (format "%s>%s" ;; (make-string (string-to-int ;; (match-string 1 uri-feature)) ;; ?=) ;; (est-uri-decode-feature-name-body ;; (substring uri-feature (match-end 0))))) ;; ) ;; ((and (setq uri-feature (est-uri-decode-feature-name-body uri-feature)) ;; (setq feature (intern (format "=>%s" uri-feature))) ;; (find-charset feature)) ;; feature) ;; ((and (setq feature (intern (format "=>>%s" uri-feature))) ;; (find-charset feature)) ;; feature) ;; ((and (setq feature (intern (format "=>>>%s" uri-feature))) ;; (find-charset feature)) ;; feature) ;; ((and (setq feature (intern (format "=%s" uri-feature))) ;; (find-charset feature)) ;; feature) ;; (t (intern uri-feature))))) ;; (defun www-uri-encode-feature-name (feature-name) ;; (setq feature-name (symbol-name feature-name)) ;; (cond ;; ((string-match "^=\\+>\\([^=>]+\\)" feature-name) ;; (concat "o." ;; (est-uri-encode-feature-name-body ;; (substring feature-name (match-beginning 1)))) ;; ) ;; ((string-match "^=\\([^=>]+\\)" feature-name) ;; (concat "rep." ;; (est-uri-encode-feature-name-body ;; (substring feature-name (match-beginning 1)))) ;; ) ;; ((string-match "^==\\([^=>]+\\)" feature-name) ;; (concat "g2." ;; (est-uri-encode-feature-name-body ;; (substring feature-name (match-beginning 1)))) ;; ) ;; ((string-match "^===\\([^=>]+\\)" feature-name) ;; (concat "repi." ;; (est-uri-encode-feature-name-body ;; (substring feature-name (match-beginning 1)))) ;; ) ;; ((string-match "^=>>\\([^=>]+\\)" feature-name) ;; (concat "g." ;; (est-uri-encode-feature-name-body ;; (substring feature-name (match-beginning 1)))) ;; ) ;; ((string-match "^=>>>\\([^=>]+\\)" feature-name) ;; (concat "gi." ;; (est-uri-encode-feature-name-body ;; (substring feature-name (match-beginning 1)))) ;; ) ;; ((string-match "^=>>\\(>+\\)" feature-name) ;; (format "gi%d.%s" ;; (length (match-string 1 feature-name)) ;; (est-uri-encode-feature-name-body ;; (substring feature-name (match-end 1)))) ;; ) ;; ((string-match "^=>\\([^=>]+\\)" feature-name) ;; (concat "a." ;; (est-uri-encode-feature-name-body ;; (substring feature-name (match-beginning 1)))) ;; ) ;; ((string-match "^\\(=+\\)>" feature-name) ;; (format "a%d.%s" ;; (length (match-string 1 feature-name)) ;; (est-uri-encode-feature-name-body ;; (substring feature-name (match-end 0)))) ;; ) ;; ((string-match "^->" feature-name) ;; (concat "to." ;; (est-uri-encode-feature-name-body ;; (substring feature-name (match-end 0)))) ;; ) ;; ((string-match "^<-" feature-name) ;; (concat "from." ;; (est-uri-encode-feature-name-body ;; (substring feature-name (match-end 0)))) ;; ) ;; (t (est-uri-encode-feature-name-body feature-name)))) (defun www-uri-make-feature-name-url (uri-genre uri-feature-name uri-object) (if est-hide-cgi-mode (format "../feature/%s&%s/%s" uri-feature-name uri-genre uri-object) (format "%s?feature=%s&%s=%s" chise-wiki-view-url uri-feature-name uri-genre uri-object))) (defun www-uri-decode-object (genre char-rep) (let (ccs cpos) (cond ((string-match (if est-hide-cgi-mode "\\(%3D\\|=\\|%3A\\|:\\)" "\\(%3A\\|:\\)") char-rep) (setq ccs (substring char-rep 0 (match-beginning 0)) cpos (substring char-rep (match-end 0))) (setq ccs (www-uri-decode-feature-name ccs)) (setq cpos (est-uri-decode-feature-name-body cpos)) (cond ((string-match "^0x" cpos) (setq cpos (string-to-number (substring cpos (match-end 0)) 16)) ) (t (setq cpos (car (read-from-string (decode-uri-string cpos file-name-coding-system)))) )) (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)) (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 est-coded-charset-priority-list) ccs ret) (while (and ccs-list (setq ccs (pop ccs-list)) (not (setq ret (encode-char object ccs 'defined-only))))) (cond (ret (format (if est-hide-cgi-mode "%s=0x%X" "%s:0x%X") (www-uri-encode-feature-name ccs) ret)) ((and (setq ccs (car (split-char object))) (setq ret (encode-char object ccs))) (format (if est-hide-cgi-mode "%s=0x%X" "%s:0x%X") (www-uri-encode-feature-name ccs) ret)) (t (format (if est-hide-cgi-mode "system-char-id=0x%X" "system-char-id:0x%X") (encode-char object 'system-char-id)) )))) (format (if est-hide-cgi-mode "rep.id=%s" "rep.id:%s") (www-uri-encode-feature-name (concord-object-id object))))) (defun est-format-object (object &optional readable) (if (characterp object) (char-to-string object) (let ((ret (or (if readable (or (concord-object-get object 'name) (concord-object-get object '=name) (concord-object-get object 'title) (concord-object-get object '=title))) (concord-object-id object)))) (format "%s" ret)))) (defun www-uri-make-object-url (object &optional uri-object) (if est-hide-cgi-mode (format "%s/%s/%s" est-view-url-prefix (est-object-genre object) (or uri-object (www-uri-encode-object object))) (format "%s?%s=%s" chise-wiki-view-url (est-object-genre object) (or uri-object (www-uri-encode-object object))))) ;;; @ Feature name presentation ;;; (defun www-format-feature-name-default (feature-name) (mapconcat #'capitalize (split-string (symbol-name feature-name) "-") " ")) (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))) (defun www-format-feature-name-as-rel-from (feature-name) (concat "\u2190" (substring (symbol-name feature-name) 2))) (defun www-format-feature-name-as-CCS (feature-name) (let* ((rest (split-string (symbol-name feature-name) "-")) (dest (upcase (pop rest)))) (when (string-match "^=+>*" dest) (setq dest (concat (substring dest 0 (match-end 0)) " " (substring dest (match-end 0))))) (cond (rest (while (cdr rest) (setq dest (concat dest " " (upcase (pop rest))))) (if (string-match "^[0-9]+$" (car rest)) (concat dest "-" (car rest)) (concat dest " " (upcase (car rest)))) ) (t dest)))) (defun www-format-feature-name* (feature-name &optional lang) (let (name fn parent ret) (cond ((or (and lang (char-feature-property feature-name (intern (format "name@%s" lang)))) (char-feature-property feature-name 'name))) ((and (setq name (symbol-name feature-name)) (string-match "\\*" name)) (www-format-feature-name-as-metadata feature-name lang)) (t (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 (www-format-feature-name* feature-name lang))) ;;; @ HTML generator ;;; (defvar www-format-char-img-style "vertical-align:bottom;") (defun www-format-encode-string (string &optional without-tags as-body) (with-temp-buffer (insert string) (let (plane code subcode start end char variants ret rret) (when as-body (goto-char (point-min)) (while (search-forward "&" nil t) (replace-match "&" nil t))) (goto-char (point-min)) (while (search-forward "<" nil t) (replace-match "<" nil t)) (goto-char (point-min)) (while (search-forward ">" nil t) (replace-match ">" nil t)) (if without-tags (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er) (let ((coded-charset-entity-reference-alist est-coded-charset-entity-reference-alist)) (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?CB\\([0-9]+\\);" nil t) (setq code (string-to-int (match-string 2))) (replace-match (format "\"CB%05d\"" code chise-wiki-legacy-bitmap-glyphs-url (/ code 1000) code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t) (setq plane (match-string 2) code (string-to-int (match-string 3) 16)) (replace-match (format "\"J%s-%04X\"" plane code chise-wiki-legacy-bitmap-glyphs-url plane (- (lsh code -8) 32) (- (logand code 255) 32) www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?J0-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t) (setq code (string-to-int (match-string 2) 16)) (replace-match (format "\"J0-%04X\"" code chise-wiki-legacy-bitmap-glyphs-url (- (lsh code -8) 32) (- (logand code 255) 32) www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-\\(JA\\|JB\\|JC\\|JD\\|FT\\|IA\\|IB\\|HG\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t) (setq plane (match-string 2) code (string-to-int (match-string 3) 16)) (replace-match (format "\"HD-%s-%04X\"" plane code chise-wiki-legacy-bitmap-glyphs-url plane (- (lsh code -8) 32) (- (logand code 255) 32) www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-\\(IP\\|JT\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t) (setq plane (match-string 2) code (string-to-int (match-string 3) 16)) (replace-match (format "\"HD-%s-%04X\"" plane code chise-wiki-legacy-bitmap-glyphs-url plane code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-KS-\\([0-9]+\\);" nil t) (setq code (string-to-int (match-string 2))) (replace-match (format "\"HD-KS%06d\"" code chise-wiki-legacy-bitmap-glyphs-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-TK-\\([0-9]+\\);" nil t) (setq code (string-to-int (match-string 2))) (replace-match (format "\"HD-KS%06d\"" code chise-wiki-legacy-bitmap-glyphs-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t) (setq plane (string-to-int (match-string 1)) code (string-to-int (match-string 2) 16)) (replace-match (format "\"GB%d-%04X\"" plane code chise-wiki-legacy-bitmap-glyphs-url plane (- (lsh code -8) 32) (- (logand code 255) 32) www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(R-\\)?C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t) (setq plane (string-to-int (match-string 2)) code (string-to-int (match-string 3) 16)) (replace-match (format "\"CNS%d-%04X\"" plane code chise-wiki-legacy-bitmap-glyphs-url plane code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(R-\\)?JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t) (setq code (string-to-int (match-string 2) 16)) (replace-match (format "\"JC3-%04X\"" code chise-wiki-bitmap-glyph-image-url code) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t) (setq code (string-to-int (match-string 2))) (replace-match (format "\"ZOB-%04d\"" code chise-wiki-legacy-bitmap-glyphs-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A2-\\|g2-\\|R-\\)?DJT-\\([0-9]+\\);" nil t) (setq code (string-to-int (match-string 2))) (replace-match (format "\"DJT-%05d\"" code chise-wiki-daijiten-bitmap-glyphs-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\)?SW-JIGUGE\\([45]?\\)-\\([0-9]+\\);" nil t) (setq subcode (match-string 2) code (string-to-int (match-string 3))) (setq plane (if (string= subcode "") "5" subcode)) (replace-match (format "
\"SW-JIGUGE%s-%05d\"%s
" plane code chise-wiki-legacy-bitmap-glyphs-url plane code (charset-description (if (string= subcode "") '=shuowen-jiguge (intern (format "===shuowen-jiguge%s" subcode))))) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&HNG\\([0-9]+\\)-\\([0-9][0-9][0-9][0-9]\\)\\([0-9]\\);" nil t) (setq plane (match-string 1) code (string-to-int (match-string 2)) subcode (string-to-int (match-string 3))) (setq subcode (if (eq subcode 0) "" (char-to-string (decode-char 'ascii (+ 96 subcode))))) (replace-match (format "
\"HNG%s-%04d%s\"%s
" plane code subcode chise-wiki-hng-bitmap-glyphs-url plane code subcode (charset-description (car (find (format "HNG%s-" plane) coded-charset-entity-reference-alist :test (lambda (key cell) (string= key (nth 1 cell)))))) ) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(R-\\)?CHISE-HDIC-TSJ\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 2) 16)) (setq char (decode-char '===chise-hdic-tsj code)) (when (setq ret (get-char-attribute char '=hdic-tsj-glyph-id)) (replace-match (format "
\"HDIC-TSJ-%s\"%s
" ret ret (charset-description '===chise-hdic-tsj)) t 'literal))) (goto-char (point-min)) (while (re-search-forward "&\\(R-\\)?CHISE-HDIC-SYP\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 2) 16)) (setq char (decode-char '===chise-hdic-syp code)) (when (setq ret (get-char-attribute char '=hdic-syp-entry-id)) (replace-match (format "
\"HDIC-SYP-%s\"%s
" ret ret (charset-description '===chise-hdic-syp)) t 'literal))) (goto-char (point-min)) (while (re-search-forward "&\\(R-\\)?CHISE-HDIC-KTB\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 2) 16)) (setq char (decode-char '===chise-hdic-ktb code)) (when (setq ret (get-char-attribute char '=hdic-ktb-entry-id)) (replace-match (format "
\"HDIC-KTB-%s\"%s
" ret ret (charset-description '===chise-hdic-ktb)) t 'literal))) (goto-char (point-min)) (while (re-search-forward "&\\(R-\\)?CHISE-HDIC-KTBS\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 2) 16)) (setq char (decode-char '===chise-hdic-ktb-seal code)) (when (setq ret (get-char-attribute char '=hdic-ktb-seal-glyph-id)) (replace-match (format "
\"HDIC-KTBS-%s\"%s
" ret ret (charset-description '===chise-hdic-ktb-seal)) t 'literal))) (goto-char (point-min)) (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?AJ1-\\([0-9]+\\);" nil t) (setq code (string-to-int (match-string 2))) (replace-match (format "\"AJ1-%05d\"" code chise-wiki-legacy-bitmap-glyphs-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\|o-\\|G-\\|g2-\\|R-\\)?MJ\\([0-9]+\\);" nil t) (setq code (string-to-int (match-string 2))) (replace-match (format "\"MJ%06d\"" code code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(o-\\|G-\\|g2-\\)?IU[+-]\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 2) 16)) (replace-match (format "\"u%04x\"" code chise-wiki-glyphwiki-glyph-image-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?KU[+-]\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 2) 16)) (replace-match (format "\"u%04x-k\"" code chise-wiki-glyphwiki-glyph-image-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&A-\\(comp\\|cgn\\)U[+-]\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 2) 16)) (replace-match (format "\"u%04x\"" code chise-wiki-glyphwiki-glyph-image-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\|g2-\\)?\\(IWDS\\)?U-i\\([0-9]+\\)\\+\\([0-9A-F]+\\);" nil t) (setq plane (string-to-int (match-string 3)) code (string-to-int (match-string 4) 16)) (replace-match (format "\"u%04x-itaiji-%03d\"" code plane chise-wiki-glyphwiki-glyph-image-url code plane www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&A-IWDSU\\+\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 1) 16)) (replace-match (format "\"A-IWDSU+%04x\"" code chise-wiki-glyphwiki-glyph-image-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\)?CDP-i\\([0-9]+\\)-\\([0-9A-F]+\\);" nil t) (setq plane (string-to-int (match-string 2)) code (string-to-int (match-string 3) 16)) (replace-match (format "\"cdp-%04x-itaiji-%03d\"" code plane chise-wiki-glyphwiki-glyph-image-url code plane www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\)?CDP-v\\([0-9]+\\)-\\([0-9A-F]+\\);" nil t) (setq plane (string-to-int (match-string 2)) code (string-to-int (match-string 3) 16)) (replace-match (format "\"cdp-%04x-var-%03d\"" code plane chise-wiki-glyphwiki-glyph-image-url code plane www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?M-\\([0-9]+\\);" nil t) (setq code (string-to-int (match-string 2))) (replace-match (format "\"dkw-%05d\"" code chise-wiki-glyphwiki-glyph-image-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(g2-\\)?U-v\\([0-9]+\\)\\+\\([0-9A-F]+\\);" nil t) (setq plane (string-to-int (match-string 2)) code (string-to-int (match-string 3) 16)) (replace-match (format "\"u%04x-var-%03d\"" code plane chise-wiki-glyphwiki-glyph-image-url code plane www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\|G-\\|R-\\|g2-\\)?GT-\\([0-9]+\\);" nil t) (setq code (string-to-int (match-string 2))) (replace-match (format "\"GT-%05d\"" code chise-wiki-glyph-cgi-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\|G-\\|g2-\\)?GT-K\\([0-9]+\\);" nil t) (setq code (string-to-int (match-string 2))) (replace-match (format "\"GT-K%05d\"" code chise-wiki-glyph-cgi-url code www-format-char-img-style) 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 "\"B-%04X\"" code chise-wiki-glyph-cgi-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\|A-IWDS\\)?CDP-\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 2) 16)) (replace-match (format "\"CDP-%04X\"" code chise-wiki-glyph-cgi-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(I-\\)?HZK\\(0[1-9]\\|1[0-2]\\)-\\([0-9A-F]+\\);" nil t) (setq plane (match-string 2) code (string-to-int (match-string 3) 16)) (replace-match (format "\"HZK%s-%04X\"" plane code chise-wiki-glyph-cgi-url plane code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?RUI6-\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 2) 16)) (replace-match (format "\"RUI6-%04X\"" code chise-wiki-glyph-cgi-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&hanaJU\\+\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 1) 16)) (replace-match (format "\"hanaJU+%04X\"" code chise-wiki-glyph-cgi-url code www-format-char-img-style) t 'literal)) (goto-char (point-min)) (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t) (setq code (string-to-int (match-string 3) 16)) (replace-match (format "\"UU+%04X\"" code code www-format-char-img-style) 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)) (cond ((and (setq variants (or (www-get-feature-value char '->subsumptive) (www-get-feature-value char '->denotational))) (progn (if (characterp variants) (setq variants (list variants))) (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) ;; (replace-match "&GT-" t 'literal)) (buffer-string)))) (defun www-html-display-text (text) (princ (with-temp-buffer (insert text) (goto-char (point-min)) (while (search-forward "<" nil t) (replace-match "<" nil t)) (goto-char (point-min)) (while (search-forward ">" nil t) (replace-match ">" nil t)) (goto-char (point-min)) (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t) (replace-match (format "%s" (match-string 2) (match-string 1)) nil t)) (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er) (goto-char (point-min)) (while (search-forward ">-" nil t) (replace-match "&GT-" nil t)) (buffer-string)))) (defun www-html-display-paragraph (text) (princ "

") (www-html-display-text text) (princ "

\n")) ;;; @ for GlyphWiki ;;; (defvar coded-charset-GlyphWiki-id-alist '((===adobe-japan1-0 "aj1-" 5 d nil) (===adobe-japan1-1 "aj1-" 5 d nil) (===adobe-japan1-2 "aj1-" 5 d nil) (===adobe-japan1-3 "aj1-" 5 d nil) (===adobe-japan1-4 "aj1-" 5 d nil) (===adobe-japan1-5 "aj1-" 5 d nil) (===adobe-japan1-6 "aj1-" 5 d nil) (===mj "jmj-" 6 d nil) (===ucs@jis "u" 4 x "-j") (===daikanwa "dkw-" 5 d nil) (===ucs@ks "u" 4 x "-k") (===jis-x0208@1978 "j78-" 4 x nil) (==ucs-itaiji-005 "u" 4 x "-itaiji-005") (=ucs-var-001 "u" 4 x "-var-001") (=ucs-var-002 "u" 4 x "-var-002") (=ucs-var-003 "u" 4 x "-var-003") (=ucs-var-004 "u" 4 x "-var-004") (=ucs-var-006 "u" 4 x "-var-006") (=ucs-var-010 "u" 4 x "-var-010") (=ucs-itaiji-001 "u" 4 x "-itaiji-001") (=ucs-itaiji-002 "u" 4 x "-itaiji-002") (=ucs-itaiji-003 "u" 4 x "-itaiji-003") (=ucs-itaiji-004 "u" 4 x "-itaiji-004") (=ucs-itaiji-005 "u" 4 x "-itaiji-005") (=ucs-itaiji-006 "u" 4 x "-itaiji-006") (=ucs-itaiji-007 "u" 4 x "-itaiji-007") (=ucs-itaiji-008 "u" 4 x "-itaiji-008") (=ucs-itaiji-084 "u" 4 x "-itaiji-084") (=>ucs-itaiji-001 "u" 4 x "-itaiji-001") (=>ucs-itaiji-002 "u" 4 x "-itaiji-002") (=>ucs-itaiji-003 "u" 4 x "-itaiji-003") (=>ucs-itaiji-004 "u" 4 x "-itaiji-004") (=>ucs-itaiji-005 "u" 4 x "-itaiji-005") (=>ucs-itaiji-006 "u" 4 x "-itaiji-006") (=>ucs-itaiji-007 "u" 4 x "-itaiji-007") (=>ucs-itaiji-008 "u" 4 x "-itaiji-008") (==adobe-japan1-0 "aj1-" 5 d nil) (==adobe-japan1-1 "aj1-" 5 d nil) (==adobe-japan1-2 "aj1-" 5 d nil) (==adobe-japan1-3 "aj1-" 5 d nil) (==adobe-japan1-4 "aj1-" 5 d nil) (==adobe-japan1-5 "aj1-" 5 d nil) (==adobe-japan1-6 "aj1-" 5 d nil) (==mj "jmj-" 6 d nil) (==ucs@jis "u" 4 x "-j") (==ucs@iso "u" 4 x nil) ;; (==ucs@cns "u" 4 x "-t") (==ucs@unicode "u" 4 x "-us") (==ucs@JP/hanazono "u" 4 x "-jv") (==gt "gt-" 5 d nil) (==gt-k "gt-k" 5 d nil) (==daikanwa "dkw-" 5 d nil) (==ucs@ks "u" 4 x "-k") (==jis-x0208@1978 "j78-" 4 x nil) (==jis-x0208 "j90-" 4 x nil) (==jis-x0208@1990 "j90-" 4 x nil) (==jis-x0208@1983 "j83-" 4 x nil) (==cbeta "cbeta-" 5 d nil) (=>>hanyo-denshi/ks "koseki-" 6 d nil) (=>>jis-x0208@1978 "j78-" 4 x nil) (=>>big5-cdp "cdp-" 4 x nil) (=>>adobe-japan1-0 "aj1-" 5 d nil) (=>>adobe-japan1-1 "aj1-" 5 d nil) (=>>adobe-japan1-2 "aj1-" 5 d nil) (=>>adobe-japan1-3 "aj1-" 5 d nil) (=>>adobe-japan1-4 "aj1-" 5 d nil) (=>>adobe-japan1-5 "aj1-" 5 d nil) (=>>adobe-japan1-6 "aj1-" 5 d nil) (=>>jis-x0208 "j90-" 4 x nil) (=>>jis-x0208@1990 "j90-" 4 x nil) (=>>jis-x0208@1983 "j83-" 4 x nil) (=>>daikanwa "dkw-" 5 d nil) (=adobe-japan1-0 "aj1-" 5 d nil) (=adobe-japan1-1 "aj1-" 5 d nil) (=adobe-japan1-2 "aj1-" 5 d nil) (=adobe-japan1-3 "aj1-" 5 d nil) (=adobe-japan1-4 "aj1-" 5 d nil) (=adobe-japan1-5 "aj1-" 5 d nil) (=adobe-japan1-6 "aj1-" 5 d nil) (=hanyo-denshi/ks "koseki-" 6 d nil) (=mj "jmj-" 6 d nil) (=decomposition@cid) (=decomposition@hanyo-denshi) (=koseki "koseki-" 6 d nil) (=hanyo-denshi/tk "toki-" 8 d nil) (=ucs@jis "u" 4 x "-j") ;; (=ucs@cns "u" 4 x "-t") (=ucs@ks "u" 4 x "-k") (=ucs@JP "u" 4 x "-jv") (=ucs@JP/hanazono "u" 4 x "-jv") (=ucs@gb "u" 4 x "-g") (=big5-cdp "cdp-" 4 x nil) (=>big5-cdp "cdp-" 4 x nil) (=+>big5-cdp "cdp-" 4 x nil) (=>big5-cdp@iwds-1 "cdp-" 4 x nil) (=cbeta "cbeta-" 5 d nil) (=>cbeta "cbeta-" 5 d nil) (=big5-cdp-var-001 "cdp-" 4 x "-var-001") (=big5-cdp-var-003 "cdp-" 4 x "-var-003") (=big5-cdp-var-005 "cdp-" 4 x "-var-005") (=big5-cdp-itaiji-001 "cdp-" 4 x "-itaiji-001") (=big5-cdp-itaiji-002 "cdp-" 4 x "-itaiji-002") (=big5-cdp-itaiji-003 "cdp-" 4 x "-itaiji-003") (=>big5-cdp-itaiji-001 "cdp-" 4 x "-itaiji-001") (=>big5-cdp-itaiji-002 "cdp-" 4 x "-itaiji-002") (=>big5-cdp-itaiji-003 "cdp-" 4 x "-itaiji-003") (=jef-china3 "jc3-" 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) (=gt "gt-" 5 d nil) (=gt-k "gt-k" 5 d nil) (=>gt-k "gt-k" 5 d nil) (=daikanwa "dkw-" 5 d nil) (=ruimoku-v6 "rui6-" 4 x nil) (=>ruimoku-v6 "rui6-" 4 x nil) (=ucs@iso "u" 4 x "-u") (=ucs@unicode "u" 4 x "-us") (=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@1978 "j78-" 4 x nil) (=+>jis-x0208 "j90-" 4 x nil) (=+>jis-x0208@1990 "j90-" 4 x nil) (=+>jis-x0208@1983 "j83-" 4 x nil) (=ucs "u" 4 x nil) (=big5 "b-" 4 x nil) (=ks-x1001 "k0-" 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) (=jis-x0208 "j90-" 4 x nil) (=jis-x0208@1990 "j90-" 4 x nil) (=jis-x0208@1983 "j83-" 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 (get-char-attribute char (car spec)))))) (when ret (or (and (listp ret) (mapconcat #'char-GlyphWiki-id ret "-")) (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) (encode-char char '=jis-x0213-2)) (setq code (encode-char char '=ucs@jis))) (format "u%04x-j" 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