X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=cwiki-common.el;h=aa35fd61fb377fe8dfe1fdfd20822c40f501710f;hb=a275f38aac7477584abcdf4d706e923c9f4401a7;hp=b0e1628000fe7ddd14d9d8f18ab156ac6ad145b2;hpb=9a97c38f7a05c4f573301a4e8555c0b075b1b5bc;p=chise%2Fest.git diff --git a/cwiki-common.el b/cwiki-common.el index b0e1628..aa35fd6 100644 --- a/cwiki-common.el +++ b/cwiki-common.el @@ -2,7 +2,7 @@ (require 'char-db-util) (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") @@ -10,6 +10,8 @@ (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) @@ -31,6 +33,11 @@ (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))) @@ -47,8 +54,28 @@ '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) @@ -61,18 +88,30 @@ (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))) @@ -80,11 +119,136 @@ (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)))) + (or (char-feature object latest-feature) + (char-feature 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 @@ -172,7 +336,11 @@ ) (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) @@ -185,16 +353,19 @@ (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)) - )))) + (if (eq genre 'character) + (when (= (length char-rep) 1) + (aref char-rep 0)) + (concord-decode-object '=id char-rep genre)))))) (defun www-uri-encode-char (char) (if (encode-char char '=ucs) @@ -212,12 +383,13 @@ =cbeta =jef-china3 =jis-x0213-1@2000 =jis-x0213-1@2004 =jis-x0208@1983 =jis-x0208@1978 - =zinbun-oracle + =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) @@ -290,7 +462,7 @@ (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 @@ -298,17 +470,34 @@ (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 @@ -464,11 +653,13 @@ (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) ) @@ -478,7 +669,7 @@ (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)) @@ -505,6 +696,7 @@ '(=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) @@ -567,8 +759,8 @@ 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 "\"ZOB-%04d\"" code @@ -615,7 +807,17 @@ 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 "\"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)) @@ -631,17 +833,41 @@ (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) @@ -653,10 +879,14 @@ (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") @@ -667,7 +897,7 @@ (defun www-format-apply-value (object feature-name format props value &optional uri-char uri-feature - without-tags) + without-tags without-edit) (let (ret) (setq ret (cond @@ -682,7 +912,8 @@ ((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-char + without-tags without-edit)) ) ((eq format 'S-exp) (www-format-encode-string @@ -706,7 +937,9 @@ (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 " @@ -716,9 +949,10 @@ (defun www-format-eval-feature-value (char feature-name - &optional format lang uri-char value) + &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 @@ -726,7 +960,8 @@ (www-format-apply-value char feature-name format nil value - uri-char (www-uri-encode-feature-name feature-name)) + uri-char (www-uri-encode-feature-name feature-name) + without-tags without-edit) ) ((consp format) (cond ((null (cdr format)) @@ -734,16 +969,19 @@ (www-format-apply-value char feature-name (car format) (nth 1 format) value - uri-char (www-uri-encode-feature-name feature-name)) + uri-char (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 char feature-name lang uri-char + without-tags without-edit) ))))) (defun www-format-eval-unit (exp char feature-name - &optional lang uri-char value) + &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 @@ -752,49 +990,134 @@ ((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 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) - lang uri-char value) + lang uri-char value + without-tags without-edit) (www-format-apply-value char feature-name (car exp) (nth 1 exp) value - uri-char (www-uri-encode-feature-name feature-name))) + uri-char (www-uri-encode-feature-name feature-name) + without-tags without-edit)) ) ((eq (car exp) 'name) - (format "%s" - 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 "%s" + (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 + "" + (let ((prev-char (find-previous-defined-code-point + feature-name value))) + (if prev-char + (format "\n%s" + chise-wiki-view-url + (www-uri-encode-char prev-char) + "" + ;; (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 "%s" + chise-wiki-view-url + (www-uri-encode-char next-char) + "" + ;; (www-format-encode-string + ;; (char-to-string next-char)) + ) + ""))) ) ((eq (car exp) 'link) - (format "%s" - (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) + char feature-name lang uri-char + 'without-tags 'without-edit) + (www-format-eval-list (nthcdr 2 exp) + char feature-name lang uri-char + without-tags without-edit))) + ) (t (format "<%s >%s" (car exp) (www-format-eval-list (nthcdr 2 exp) char feature-name - lang uri-char) + lang uri-char + without-tags without-edit) (car exp))))))) (defun www-format-eval-list (format-list char feature-name - &optional lang uri-char) + &optional lang uri-char + 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 char feature-name lang uri-char + 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 char feature-name lang uri-char + nil without-tags without-edit))) ;;; @ XML generator