;;; ideograph-util.el --- Ideographic Character Database utility

;; Copyright (C) 1999,2000,2001,2002,2003,2004,2005,2007 MORIOKA Tomohiko.

;; Author: MORIOKA Tomohiko <tomo@kanji.zinbun.kyoto-u.ac.jp>
;; Keywords: CHISE, Chaon model, ISO/IEC 10646, Unicode, UCS-4, MULE.

;; This file is part of XEmacs CHISE.

;; XEmacs CHISE is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 2, or (at
;; your option) any later version.

;; XEmacs CHISE is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs CHISE; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.

;;; Code:

(require 'char-db-util)

;;;###autoload
(defun expand-char-feature-name (feature domain)
  (if domain
      (intern (format "%s@%s" feature domain))
    feature))

;;;###autoload
(defun map-char-family (function char &optional ignore-sisters)
  (let ((rest (list char))
	ret checked)
    (catch 'tag
      (while rest
	(unless (memq (car rest) checked)
	  (if (setq ret (funcall function (car rest)))
	      (throw 'tag ret))
	  (setq checked (cons (car rest) checked)
		rest (append rest
			     (get-char-attribute (car rest) '->subsumptive)
			     (get-char-attribute (car rest) '->denotational)
			     (get-char-attribute (car rest) '->identical)))
	  (unless ignore-sisters
	    (setq rest (append rest
			       (get-char-attribute (car rest) '<-subsumptive)
			       (get-char-attribute (car rest) '<-denotational)))))
	(setq rest (cdr rest))))))

(defun get-char-feature-from-domains (char feature domains
					   &optional tester arg
					   ignore-sisters)
  (map-char-family
   (lambda (ch)
     (let (ret)
       (catch 'tag
	 (dolist (domain domains)
	   (if (and (or (null tester)
			(equal (or (char-feature
				    ch (expand-char-feature-name
					tester domain))
				   (char-feature ch tester))
			       arg))
		    (setq ret (or (char-feature
				   ch (expand-char-feature-name
				       feature domain))
				  (char-feature ch feature))))
	       (throw 'tag ret))))))
   char ignore-sisters))


(defvar ideograph-radical-chars-vector
  (make-vector 215 nil))

(defun char-ideographic-radical (char &optional radical ignore-sisters)
  (let (ret)
    (or (if radical
	    (get-char-feature-from-domains
	     char 'ideographic-radical (cons nil char-db-feature-domains)
	     'ideographic-radical radical ignore-sisters)
	  (get-char-feature-from-domains
	   char 'ideographic-radical (cons nil char-db-feature-domains)
	   ignore-sisters))
        ;; (catch 'tag
        ;;   (dolist (domain char-db-feature-domains)
        ;;     (if (and (setq ret (char-feature
        ;;                         char
        ;;                         (intern
        ;;                          (format "%s@%s"
        ;;                                  'ideographic-radical domain))))
        ;;              (or (eq ret radical)
        ;;                  (null radical)))
        ;;         (throw 'tag ret))))
	(catch 'tag
	  (dolist (cell (get-char-attribute char 'ideographic-))
	    (if (and (setq ret (plist-get cell :radical))
		     (or (eq ret radical)
			 (null radical)))
		(throw 'tag ret))))
	(get-char-feature-from-domains
	 char 'ideographic-radical (cons nil char-db-feature-domains))
        ;; (char-feature char 'ideographic-radical)
	(progn
	  (setq ret
		(or (get-char-attribute char 'daikanwa-radical)
		    (get-char-attribute char 'kangxi-radical)
		    (get-char-attribute char 'japanese-radical)
		    (get-char-attribute char 'korean-radical)))
	  (when ret
	    (put-char-attribute char 'ideographic-radical ret)
	    ret)))))

(defvar ideograph-radical-strokes-vector
  ;;0  1  2  3  4  5  6  7  8  9
  [nil 1  1  1  1  1  1  2  2  2
    2  2  2  2  2  2  2  2  2  2
    2  2  2  2  2  2  2  2  2  2
    3  3  3  3  3  3  3  3  3  3
    3  3  3  3  3  3  3  3  3  3
    3  3  3  3  3  3  3  3  3  3
    3  4  4  4  3  4  4  4  4  4
    4  4  4  4  4  4  4  4  4  4
    4  4  4  4  4  3  4  4  4  4
    4  4  4  4  3  5  4  5  5  5
    ;; 100
    5  5  5  5  5  5  5  5  5  5
    5  5  5  5  5  5  5  5  6  6
    6  6  6  6  6  6  6  6  6  6
    4  6  6  6  6  6  6  6  6  6
    4  6  6  6  6  6  6  7  7  7
    7  7  7  7  7  7  7  7  7  7
    7  7  4  3  7  7  7  8  7  8
    3  8  8  8  8  8  9  9  9  9
    9  9  9  9  8  9  9 10 10 10
   10 10 10 10 10 11 11 11 11 11
   ;; 200
   11 12 12 12 12 13 13 13 13 14
   14 15 16 16 17])

;;;###autoload
(defun char-ideographic-strokes-from-domains (char domains &optional radical)
  (if radical
      (get-char-feature-from-domains char 'ideographic-strokes domains
				     'ideographic-radical radical)
    (get-char-feature-from-domains char 'ideographic-strokes domains)))

;;;###autoload
(defun char-ideographic-strokes (char &optional radical preferred-domains)
  (let (ret)
    (or (catch 'tag
	  (dolist (cell (get-char-attribute char 'ideographic-))
	    (if (and (setq ret (plist-get cell :radical))
		     (or (eq ret radical)
			 (null radical)))
		(throw 'tag (plist-get cell :strokes)))))
	(char-ideographic-strokes-from-domains
	 char (append preferred-domains
		      (cons nil
			    char-db-feature-domains))
	 radical)
	(get-char-attribute char 'daikanwa-strokes)
	(let ((strokes
	       (or (get-char-attribute char 'kangxi-strokes)
		   (get-char-attribute char 'japanese-strokes)
		   (get-char-attribute char 'korean-strokes)
		   (let ((r (char-ideographic-radical char))
			 (ts (get-char-attribute char 'total-strokes)))
		     (if (and r ts)
			 (- ts (aref ideograph-radical-strokes-vector r))))
		   )))
	  (when strokes
	    (put-char-attribute char 'ideographic-strokes strokes)
	    strokes)))))

;;;###autoload
(defun char-total-strokes-from-domains (char domains)
  (let (ret)
    (catch 'tag
      (dolist (domain domains)
	(if (setq ret (char-feature
		       char
		       (intern
			(format "%s@%s"
				'total-strokes domain))))
	    (throw 'tag ret))))))

;;;###autoload
(defun char-total-strokes (char &optional preferred-domains)
  (or (char-total-strokes-from-domains char preferred-domains)
      (char-feature char 'total-strokes)
      (char-total-strokes-from-domains char char-db-feature-domains)))

;;;###autoload
(defun update-ideograph-radical-table ()
  (interactive)
  (let (ret rret radical script dest)
    (dolist (feature
	     (cons 'ideographic-radical
		   (progn
		     (dolist (feature (char-attribute-list))
		       (if (string-match "^ideographic-radical@[^@*]+$"
					 (symbol-name feature))
			   (setq dest (cons feature dest))))
		     dest)))
      (map-char-attribute
       (lambda (chr radical)
	 (dolist (char (append
			(if (setq ret
				  (get-char-attribute chr '<-subsumptive))
			    (progn
			      (setq dest nil)
			      (dolist (pc ret)
				(unless (eq (get-char-attribute
					     pc 'ideographic-radical)
					    radical)
				  (if (setq rret
					    (get-char-attribute
					     pc '<-subsumptive))
				      (setq ret (append ret rret))
				    (setq dest (cons pc dest)))))
			      dest)
			  (list chr))
			(let ((rest (append
				     (get-char-attribute chr '<-identical)
				     (get-char-attribute chr '->denotational)))
			      pc)
			  (setq dest nil)
			  (while rest
			    (setq pc (car rest))
			    (if (memq pc dest)
				(setq rest (cdr rest))
			      (setq dest (cons pc dest))
			      (setq rest
				    (append (cdr rest)
					    (get-char-attribute
					     pc '<-identical)
					    (get-char-attribute
					     pc '->denotational)))))
			  dest)))
	   (when (and radical
		      (or (eq radical
			      (or (get-char-attribute
				   char 'ideographic-radical)
				  (char-ideographic-radical char radical)))
			  (null (char-ideographic-radical char)))
		      (or (null (setq script
				      (get-char-attribute char 'script)))
			  (memq 'Ideograph script)))
	     (unless (memq char
			   (setq ret
				 (aref ideograph-radical-chars-vector
				       radical)))
	       (char-ideographic-strokes char)
	       (aset ideograph-radical-chars-vector radical
		     (cons char ret)))))
	 nil)
       feature))
    (map-char-attribute
     (lambda (char data)
       (dolist (cell data)
	 (setq radical (plist-get cell :radical))
	 (when (and radical
		    (or (null (setq script (get-char-attribute char 'script)))
			(memq 'Ideograph script)))
	   (unless (memq char
			 (setq ret
			       (aref ideograph-radical-chars-vector radical)))
	     (char-ideographic-strokes char)
	     (aset ideograph-radical-chars-vector radical
		   (cons char ret))))))
     'ideographic-)))

(defun int-list< (a b)
  (if (numberp (car a))
      (if (numberp (car b))
	  (if (= (car a) (car b))
	      (int-list< (cdr a)(cdr b))
	    (< (car a) (car b)))
	nil)
    (numberp (car b))))

(defun morohashi-daikanwa< (a b)
  (if (integerp a)
      (setq a (list a)))
  (if (integerp b)
      (setq b (list b)))
  (cond ((eq (car a) 'ho)
	 (if (eq (car b) 'ho)
	     (int-list< (cdr a)(cdr b))
	   nil))
	((numberp (car a))
	 (if (eq (car b) 'ho)
	     t
	   (int-list< a b)))
	(t
	 (if (eq (car b) 'ho)
	     t
	   (int-list< a b)))))

;; (defun nil=-int< (a b)
;;   (cond ((null a) nil)
;;         ((null b) nil)
;;         (t (< a b))))

;; (defun nil>-int< (a b)
;;   (cond ((null a) nil)
;;         ((null b) t)
;;         (t (< a b))))

(defvar ideographic-radical nil)

;;;###autoload
(defun char-representative-of-daikanwa (char &optional radical
					     ignore-default checked)
  (unless radical
    (setq radical ideographic-radical))
  (if (or (null radical)
          (eq (or (get-char-attribute char 'ideographic-radical)
                  (char-ideographic-radical char radical t))
              radical))
      (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
                     (encode-char char '=daikanwa-rev2 'defined-only))))
	(or (and ret char)
	    (if (setq ret (get-char-attribute char 'morohashi-daikanwa))
		(let ((m-m (car ret))
		      (m-s (nth 1 ret))
		      pat)
		  (if (= m-s 0)
		      (or (decode-char '=daikanwa-rev2 m-m 'defined-only)
			  (decode-char 'ideograph-daikanwa m-m))
		    (setq pat (list m-m m-s))
		    (map-char-attribute (lambda (c v)
					  (if (equal pat v)
					      c))
					'morohashi-daikanwa))))
            (and (setq ret (get-char-attribute char '=>daikanwa))
		 (if (numberp ret)
		     (or (decode-char '=daikanwa-rev2 ret 'defined-only)
			 (decode-char 'ideograph-daikanwa ret))
		   (map-char-attribute (lambda (c v)
					 (if (equal ret v)
					     char))
				       'morohashi-daikanwa)))
	    (unless (memq char checked)
	      (catch 'tag
		(let ((rest
		       (append (get-char-attribute char '->subsumptive)
			       (get-char-attribute char '->denotational)))
		      (i 0)
		      sc)
		  (setq checked (cons char checked))
		  (while rest
		    (setq sc (car rest))
		    (if (setq ret (char-representative-of-daikanwa
				   sc radical t checked))
			(throw 'tag ret))
		    (setq checked (cons sc checked)
			  rest (cdr rest)
			  i (1+ i)))
		  (setq rest (get-char-attribute char '->identical))
		  (while rest
		    (setq sc (car rest))
		    (when (setq ret (char-representative-of-daikanwa
				     sc radical t checked))
		      (throw 'tag ret))
		    (setq checked (cons sc checked)
			  rest (cdr rest)))
		  (setq rest
			(append (get-char-attribute char '<-subsumptive)
				(get-char-attribute char '<-denotational)))
		  (while rest
		    (setq sc (car rest))
		    (when (setq ret (char-representative-of-daikanwa
				     sc radical t checked))
		      (throw 'tag ret))
		    (setq checked (cons sc checked)
			  rest (cdr rest))))))
	    (unless ignore-default
	      char)))))

(defun char-attributes-poly< (c1 c2 accessors testers defaulters)
  (catch 'tag
    (let (a1 a2 accessor tester dm)
      (while (and accessors testers)
	(setq accessor (car accessors)
	      tester (car testers)
	      dm (car defaulters))
	(when (and accessor tester)
	  (setq a1 (funcall accessor c1)
		a2 (funcall accessor c2))
	  (cond ((null a1)
		 (if a2
		     (cond ((eq dm '<)
			    (throw 'tag t))
			   ((eq dm '>)
			    (throw 'tag nil)))))
		((null a2)
		 (cond ((eq dm '<)
			(throw 'tag nil))
		       ((eq dm '>)
			(throw 'tag t))))
		(t
		 (cond ((funcall tester a1 a2)
			(throw 'tag t))
		       ((funcall tester a2 a1)
			(throw 'tag nil))))))
	(setq accessors (cdr accessors)
	      testers (cdr testers)
	      defaulters (cdr defaulters))))))

(defun char-daikanwa-strokes (char &optional radical)
  (unless radical
    (setq radical ideographic-radical))
  (let ((drc (char-representative-of-daikanwa char radical))
	(r (char-ideographic-radical char radical)))
    (if (or (null r)
	    (= (char-ideographic-radical drc radical) r))
	(setq char drc)))
  (char-ideographic-strokes char radical '(daikanwa)))

;;;###autoload
(defun char-daikanwa (char &optional radical checked)
  (unless radical
    (setq radical ideographic-radical))
  (if (or (null radical)
          (eq (or (get-char-attribute char 'ideographic-radical)
                  (char-ideographic-radical char radical t))
              radical))
      (let ((ret (or (encode-char char 'ideograph-daikanwa 'defined-only)
                     (encode-char char '=daikanwa-rev2 'defined-only)
                     (get-char-attribute char 'morohashi-daikanwa))))
        (or ret
	    (and (setq ret (get-char-attribute char '=>daikanwa))
		 (if (numberp ret)
		     (list ret 0 8)
		   (append ret '(8))))
	    (unless (memq char checked)
	      (catch 'tag
		(let ((rest
		       (append (get-char-attribute char '->subsumptive)
			       (get-char-attribute char '->denotational)))
		      (i 0)
		      sc)
		  (setq checked (cons char checked))
		  (while rest
		    (setq sc (car rest))
		    (if (setq ret (char-daikanwa sc radical checked))
			(throw 'tag ret))
		    (setq checked (cons sc checked)
			  rest (cdr rest)
			  i (1+ i)))
		  (setq rest (get-char-attribute char '->identical))
		  (while rest
		    (setq sc (car rest))
		    (when (setq ret (char-daikanwa sc radical checked))
		      (throw 'tag
			     (if (numberp ret)
				 (list ret 0)
			       (append ret (list i)))))
		    (setq checked (cons sc checked)
			  rest (cdr rest)))
		  (setq rest
			(append (get-char-attribute char '<-subsumptive)
				(get-char-attribute char '<-denotational)))
		  (while rest
		    (setq sc (car rest))
		    (when (setq ret (char-daikanwa sc radical checked))
		      (throw 'tag
			     (if (numberp ret)
				 (list ret 0 i)
			       (append ret (list i)))))
		    (setq checked (cons sc checked)
			  rest (cdr rest))))))))))

;;;###autoload
(defun char-ucs (char)
  (or (encode-char char '=ucs 'defined-only)
      (char-feature char '=>ucs)))

(defun char-id (char)
  (logand (char-int char) #x3FFFFFFF))

(defun ideograph-char< (a b &optional radical)
  (let ((ideographic-radical (or radical
				 ideographic-radical)))
    (char-attributes-poly<
     a b
     '(char-daikanwa-strokes char-daikanwa char-ucs char-id)
     '(< morohashi-daikanwa< < <)
     '(> > > >))))

(defun insert-ideograph-radical-char-data (radical)
  (let ((chars
	 (sort (copy-list (aref ideograph-radical-chars-vector radical))
	       (lambda (a b)
		 (ideograph-char< a b radical))))
	attributes ; ccss
	)
    (dolist (name (char-attribute-list))
      (unless (memq name char-db-ignored-attributes)
        ;; (if (find-charset name)
        ;;     (push name ccss)
	(push name attributes)
	;; )
	))
    (setq attributes (sort attributes #'char-attribute-name<)
	  ;; ccss (sort ccss #'char-attribute-name<)
	  )
    (aset ideograph-radical-chars-vector radical chars)
    (dolist (char chars)
      (when ;;(or
	  (not (some (lambda (atr)
		       (get-char-attribute char atr))
		     char-db-ignored-attributes))
	;; (some (lambda (ccs)
	;;         (encode-char char ccs 'defined-only))
	;;       ccss)
	;;)
	(insert-char-data char nil attributes ;ccss
			  )))))

(defun write-ideograph-radical-char-data (radical file)
  (if (file-directory-p file)
      (let ((name (char-feature (decode-char 'ucs (+ #x2EFF radical))
				'name)))
	(if (string-match "KANGXI RADICAL " name)
	    (setq name (capitalize (substring name (match-end 0)))))
	(setq name (mapconcat (lambda (char)
				(if (eq char ? )
				    "-"
				  (char-to-string char))) name ""))
	(setq file
	      (expand-file-name
	       (format "Ideograph-R%03d-%s.el" radical name)
	       file))))
  (with-temp-buffer
    (insert (format ";; -*- coding: %s -*-\n"
		    char-db-file-coding-system))
    (insert-ideograph-radical-char-data radical)
    (let ((coding-system-for-write char-db-file-coding-system))
      (write-region (point-min)(point-max) file))))

(defun ideographic-structure= (char1 char2)
  (if (char-ref-p char1)
      (setq char1 (plist-get char1 :char)))
  (if (char-ref-p char2)
      (setq char2 (plist-get char2 :char)))
  (let ((s1 (if (characterp char1)
		(get-char-attribute char1 'ideographic-structure)
	      (cdr (assq 'ideographic-structure char1))))
	(s2 (if (characterp char2)
		(get-char-attribute char2 'ideographic-structure)
	      (cdr (assq 'ideographic-structure char2))))
	e1 e2)
    (if (or (null s1)(null s2))
	(char-spec= char1 char2)
      (catch 'tag
	(while (and s1 s2)
	  (setq e1 (car s1)
		e2 (car s2))
	  (unless (ideographic-structure= e1 e2)
	    (throw 'tag nil))
	  (setq s1 (cdr s1)
		s2 (cdr s2)))
	(and (null s1)(null s2))))))

;;;###autoload
(defun ideographic-structure-find-char (structure)
  (let (rest)
    (map-char-attribute (lambda (char value)
			  (setq rest structure)
			  (catch 'tag
			    (while (and rest value)
			      (unless (ideographic-structure=
				       (car rest)(car value))
				(throw 'tag nil))
			      (setq rest (cdr rest)
				    value (cdr value)))
			    (unless (or rest value)
			      char)))
			'ideographic-structure)))

;;;###autoload
(defun chise-string< (string1 string2 accessors)
  (let ((len1 (length string1))
	(len2 (length string2))
	len
	(i 0)
	c1 c2
	rest func
	v1 v2)
    (setq len (min len1 len2))
    (catch 'tag
      (while (< i len)
	(setq c1 (aref string1 i)
	      c2 (aref string2 i))
	(setq rest accessors)
	(while (and rest
		    (setq func (car rest))
		    (setq v1 (funcall func c1)
			  v2 (funcall func c2))
		    (eq v1 v2))
	  (setq rest (cdr rest)))
	(if v1
	    (if v2
		(cond ((< v1 v2)
		       (throw 'tag t))
		      ((> v1 v2)
		       (throw 'tag nil)))
	      (throw 'tag nil))
	  (if v2
	      (throw 'tag t)))
	(setq i (1+ i)))
      (< len1 len2))))


(provide 'ideograph-util)

;;; ideograph-util.el ends here