- (aref ideograph-radical-chars-vector radical))))
- (aset ideograph-radical-chars-vector radical
- (cons char ret))))
- (setq i (1+ i)))
- (setq i 0)
- (while (< i 256)
- (setq j 0)
- (while (< j 256)
- (setq char (make-char 'ideograph-daikanwa i j))
- (if (and (setq radical (char-ideograph-radical char))
- (not
- (memq char
- (setq ret
- (aref ideograph-radical-chars-vector radical)))))
- (aset ideograph-radical-chars-vector radical
- (cons char ret)))
- (setq j (1+ j)))
- (setq i (1+ i)))
- (while charsets
- (setq i 33)
- (while (< i 127)
- (setq j 33)
- (while (< j 127)
- (setq char (make-char (car charsets) i j))
- (if (and (setq radical (char-ideograph-radical char))
- (not (memq char
- (setq ret
- (aref ideograph-radical-chars-vector
- radical)))))
- (aset ideograph-radical-chars-vector radical
- (cons char ret)))
- (setq j (1+ j)))
- (setq i (1+ i)))
- (setq charsets (cdr charsets)))
- ))
-
-(defun ideograph-char< (a b)
- (let (ra rb)
- (cond
- ((setq ra (or (get-char-attribute a 'morohashi-daikanwa)
- (get-char-attribute a 'non-morohashi)))
- (cond
- ((setq rb (or (get-char-attribute b 'morohashi-daikanwa)
- (get-char-attribute b 'non-morohashi)))
- (cond
- ((= (car ra)(car rb))
- (cond ((eq (car (cdr ra))(car (cdr rb)))
- (cond ((< (length ra)(length rb)))
- ((= (length ra)(length rb))
- (cond ((integerp (nth 2 ra))
- (cond ((integerp (nth 2 rb))
- (< (nth 2 ra)(nth 2 rb)))
- (t nil)))
- (t
- (cond ((setq ra (get-char-attribute a 'ucs))
- (cond
- ((setq rb (get-char-attribute b 'ucs))
- (< ra rb))
- (t))))))))
- )
- ((null (car (cdr ra))))
- ((null (car (cdr rb)))
- nil)
- (t (< (car (cdr ra))(car (cdr rb))))))
- (t (< (car ra)(car rb)))))
- ((setq ra (get-char-attribute a 'ucs))
- (cond
- ((setq rb (get-char-attribute b 'ucs))
- (< ra rb))))
- (t
- (cond
- ((setq ra (char-ideograph-strokes a))
- (cond ((setq rb (char-ideograph-strokes b))
- (cond ((= ra rb)
- (not (char-ideograph-strokes b)))
- ((< ra rb))))))
- )))))))
+ (aref ideograph-radical-chars-vector radical)))
+ (char-ideographic-strokes char)
+ (aset ideograph-radical-chars-vector radical
+ (cons char ret))))
+ nil)
+ 'ideographic-radical)
+ (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))))
+
+(defun char-representative-of-daikanwa (char)
+ (if (get-char-attribute char 'ideograph-daikanwa)
+ char
+ (let ((m (get-char-attribute char 'morohashi-daikanwa))
+ m-m m-s pat)
+ (or (when m
+ (setq m-m (pop m))
+ (setq m-s (pop m))
+ (if (= m-s 0)
+ (decode-char 'ideograph-daikanwa m-m)
+ (when m
+ (setq pat (list m-m m-s))
+ (map-char-attribute (lambda (c v)
+ (if (equal pat v)
+ c))
+ 'morohashi-daikanwa))))
+ 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))))))
+
+(defvar ideographic-radical nil)
+
+(defun char-daikanwa-strokes (char &optional radical)
+ (unless radical
+ (setq radical ideographic-radical))
+ (let ((drc (char-representative-of-daikanwa char)))
+ (char-ideographic-strokes
+ (if (= (char-ideographic-radical drc radical)
+ (char-ideographic-radical char radical))
+ drc
+ char)
+ radical)))
+
+;;;###autoload
+(defun char-daikanwa (char)
+ (or (get-char-attribute char 'ideograph-daikanwa)
+ (get-char-attribute char 'morohashi-daikanwa)))
+
+;;;###autoload
+(defun char-ucs (char)
+ (or (get-char-attribute char 'ucs)
+ (get-char-attribute char '=>ucs)
+ (get-char-attribute 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< < <)
+ '(> > > >))))