Revision: 7251
Author: deton.kih
Date: Sun Jul 31 16:32:11 2011
Log: * Add sort for interactive bushu conversion.
* scm/tutcode-bushu.scm
- (tutcode-bushu-sequence-sensitive?,
tutcode-bushu-prioritized-chars,
tutcode-bushu-inhibited-output-chars): New variable.
- (tutcode-bushu-lookup-index2-entry-2):
Change string<=? to string<? according to tc-2.3.1-22.6.
- (tutcode-bushu-priority-level,
tutcode-bushu-higher-priority?,
tutcode-bushu-less?,
tutcode-bushu-less-against-sequence?): New function for sort.
- (tutcode-bushu-complete-compose-set,
tutcode-bushu-strong-compose-set,
tutcode-bushu-weak-compose-set,
tutcode-bushu-strong-diff-set,
tutcode-bushu-weak-diff-set): Change to sort result.
- (tutcode-bushu-compose-interactively):
Change not to make bushu-list in each function.
Add filter for tutcode-bushu-inhibited-output-chars.
http://code.google.com/p/uim/source/detail?r=7251
Modified:
/trunk/scm/tutcode-bushu.scm
=======================================
--- /trunk/scm/tutcode-bushu.scm Mon Jul 25 15:14:10 2011
+++ /trunk/scm/tutcode-bushu.scm Sun Jul 31 16:32:11 2011
@@ -30,13 +30,25 @@
;;; tutcode-bushu.scm: ÂÐÏÃŪ¤ÊÉô¼ó¹çÀ®ÊÑ´¹
;;;
-;;; tc-2.3.1¤Îtc-bushu.el¤ò°Ü¿¢(sort¤Ë¤Ï̤Âбþ)¡£
+;;; tc-2.3.1¤Îtc-bushu.el¤ò°Ü¿¢(sort¤Ç¤ÎÂǤÁ¤ä¤¹¤µ¤Î¹Íθ¤Ï̤Âбþ)¡£
;;; (»²¹Í:Éô¼ó¹çÀ®¥¢¥ë¥´¥ê¥º¥à¤Ï[tcode-ml:1942]¤¢¤¿¤ê)
-(require-extension (srfi 1 8))
+(require-extension (srfi 1 8 95))
(require "fileio.scm")
(require-dynlib "look")
+;;; #t¤Î¾ì¹ç¡¢Éô¼ó¤ÎʤÙÊý¤Ë¤è¤Ã¤Æ¹çÀ®¤µ¤ì¤ëʸ»ú¤ÎÍ¥ÀèÅÙ¤¬ÊѤï¤ë
+(define tutcode-bushu-sequence-sensitive? #t)
+
+;;; Í¥ÀèÅÙ¤¬Æ±¤¸¾ì¹ç¤ËÍ¥À褵¤ì¤ëʸ»ú¤Î¥ê¥¹¥È
+(define tutcode-bushu-prioritized-chars ())
+
+;;; Éô¼ó¹çÀ®½ÐÎϤˤÏÆþ¤ì¤Ê¤¤Ê¸»ú¤Î¥ê¥¹¥È (tc-2.3.1-22.6¤è¤ê)
+(define tutcode-bushu-inhibited-output-chars
+ '("¤¨" "¤·" "¤Ø" "¥¢" "¥¤" "¥¦" "¥¨" "¥ª" "¥«" "¥¯" "¥±" "¥µ" "¥·"
+ "¥¿" "¥Á" "¥Æ" "¥È" "¥Ë" "¥Ì" "¥Í" "¥Î" "¥Ï" "¥Ò" "¥Û" "¥à" "¥á"
+ "¥è" "¥ê" "¥ë" "¥ì" "¥í" "¥ï" "¥ó"))
+
;;; bushu.help¥Õ¥¡¥¤¥ë¤òÆɤó¤ÇÀ¸À®¤·¤¿tutcode-bushudic·Á¼°¤Î¥ê¥¹¥È
(define tutcode-bushu-help ())
@@ -76,7 +88,7 @@
;;; CHAR¤ÈCHAR2¤òÉô¼ó¤È¤·¤Æ»ý¤Äʸ»ú¤Î¥ê¥¹¥È¤òÊÖ¤¹¡£
(define (tutcode-bushu-lookup-index2-entry-2 char char2)
(let
- ((str (if (string<=? char char2)
+ ((str (if (string<? char char2)
(string-append char char2)
(string-append char2 char))))
(tutcode-bushu-lookup-index2-entry-internal str)))
@@ -266,15 +278,124 @@
included)))
ret))))
-(define (tutcode-bushu-complete-compose-set char-list)
- (let ((bushu-list (append-map! tutcode-bushu-for-char char-list)))
+;;; CHAR¤¬ÊÑ¿ô`tutcode-bushu-prioritized-chars'¤Î²¿ÈÖÌܤˤ¢¤ë¤«¤òÊÖ¤¹¡£
+;;; ¤Ê¤±¤ì¤Ð #f ¤òÊÖ¤¹¡£
+(define (tutcode-bushu-priority-level char)
+ (and (pair? tutcode-bushu-prioritized-chars)
+ (let ((char-list (member char tutcode-bushu-prioritized-chars)))
+ (and char-list
+ (- (length tutcode-bushu-prioritized-chars) (length char-list)
-1)))))
+
+;;; REF¤ò´ð½à¤È¤·¤Æ¡¢BUSHU1¤ÎÊý¤¬BUSHU2¤è¤ê¤âʤÓÊý¤¬´ð½à¤Ë¶á¤¤¤«¤É¤¦¤«¡£
+;;; ȽÃǤǤ¤Ê¤«¤Ã¤¿¤ê¡¢¤¹¤ëɬÍפ¬¤Ê¤¤¾ì¹ç¤ÏDEFAULT¤òÊÖ¤¹¡£
+(define (tutcode-bushu-higher-priority? bushu1 bushu2 ref default)
+ (if tutcode-bushu-sequence-sensitive?
+ (let loop
+ ((bushu1 bushu1)
+ (bushu2 bushu2)
+ (ref ref))
+ (if (or (null? ref) (null? bushu1) (null? bushu2))
+ default
+ (let*
+ ((b1 (car bushu1))
+ (b2 (car bushu2))
+ (r (car ref))
+ (r=b1? (string=? r b1))
+ (r=b2? (string=? r b2)))
+ (if (and r=b1? r=b2?)
+ (loop (cdr bushu1) (cdr bushu2) (cdr ref))
+ (cond
+ ((and r=b1? (not r=b2?))
+ #t)
+ ((and (not r=b1?) r=b2?)
+ #f)
+ ((and (not r=b1?) (not r=b2?))
+ default))))))
+ default))
+
+;;; CHAR1¤¬CHAR2¤è¤êÍ¥ÀèÅÙ¤¬¹â¤¤¤«?
+;;; BUSHU-LIST¤Ç»ØÄꤵ¤ì¤¿Éô¼ó¥ê¥¹¥È¤ò´ð½à¤È¤¹¤ë¡£
+;;; OPT-MANY?¤¬#f¤Î¾ì¹ç¡¢Æ±¤¸Í¥ÀèÅ٤Ǥϡ¢BUSHU-LIST¤Ë´Þ¤Þ¤ì¤Ê¤¤
+;;; Éô¼ó¤Î¿ô¤¬¾¯¤Ê¤¤Êý¤¬Í¥À褵¤ì¤ë¡£
+;;; #t¤Î¾ì¹ç¤Ï¿¤¤Êý¤¬Í¥À褵¤ì¤ë¡£
+(define (tutcode-bushu-less? char1 char2 bushu-list . opt-many?)
+ (let*
+ ((many? (:optional opt-many? #f))
+ (bushu1 (tutcode-bushu-for-char char1))
+ (bushu2 (tutcode-bushu-for-char char2))
+ (i1 (tutcode-bushu-intersection bushu1 bushu-list))
+ (i2 (tutcode-bushu-intersection bushu2 bushu-list))
+ (il1 (length i1))
+ (il2 (length i2))
+ (l1 (length bushu1))
+ (l2 (length bushu2)))
+ (if (= il1 il2)
+ (if (= l1 l2)
+ (let ((p1 (tutcode-bushu-priority-level char1))
+ (p2 (tutcode-bushu-priority-level char2)))
+ (cond
+ (p1
+ (if p2
+ (< p1 p2)
+ #t))
+ (p2
+ #f)
+ (else
+ (let
+ ((val (tutcode-bushu-higher-priority? i1 i2
+ (tutcode-bushu-intersection bushu-list
+ (append bushu1 bushu2)) 'default)))
+ (if (not (eq? val 'default))
+ val
+ (let*
+ ((s1 (tutcode-reverse-find-seq char1 tutcode-rule))
+ (s2 (tutcode-reverse-find-seq char2 tutcode-rule))
+ (sl1 (if s1 (length s1) 99))
+ (sl2 (if s2 (length s2) 99)))
+ (cond
+ ((and s1 s2)
+ (if (= sl1 sl2)
+ ;;XXX:ÂǤÁ¤ä¤¹¤µ¤Ç¤ÎÈæ³Ó¤Ï¾Êά
+ (string<? char1 char2)
+ (< sl1 sl2)))
+ (s1
+ #t)
+ (s2
+ #f)
+ (else
+ (string<? char1 char2)))))))))
+ (if many?
+ (> l1 l2)
+ (< l1 l2)))
+ (> il1 il2))))
+
+(define (tutcode-bushu-less-against-sequence? char1 char2 bushu-list)
+ (let ((p1 (tutcode-bushu-priority-level char1))
+ (p2 (tutcode-bushu-priority-level char2)))
+ (cond
+ (p1
+ (if p2
+ (< p1 p2)
+ #t))
+ (p2
+ #f)
+ (else
+ (tutcode-bushu-higher-priority?
+ (tutcode-bushu-for-char char1)
+ (tutcode-bushu-for-char char2)
+ bushu-list
+ (string<? char1 char2))))))
+
+(define (tutcode-bushu-complete-compose-set char-list bushu-list)
+ (sort!
(tutcode-bushu-subtract-set
- (tutcode-bushu-char-list-for-bushu bushu-list) char-list)))
-
-(define (tutcode-bushu-strong-compose-set char-list)
+ (tutcode-bushu-char-list-for-bushu bushu-list) char-list)
+ (lambda (a b)
+ (tutcode-bushu-less-against-sequence? a b bushu-list))))
+
+(define (tutcode-bushu-strong-compose-set char-list bushu-list)
(let*
- ((bushu-list (append-map! tutcode-bushu-for-char char-list))
- (r (tutcode-bushu-superset bushu-list))
+ ((r (tutcode-bushu-superset bushu-list))
(r2
(let loop
((lis char-list)
@@ -282,7 +403,7 @@
(if (null? lis)
r
(loop (cdr lis) (delete! (car lis) r))))))
- r2))
+ (sort! r2 (lambda (a b) (tutcode-bushu-less? a b bushu-list)))))
(define (tutcode-bushu-include-all-chars-bushu? char char-list)
(let*
@@ -332,12 +453,15 @@
(tutcode-bushu-include-all-chars-bushu? char char-list))
all-list)))
-(define (tutcode-bushu-weak-compose-set char-list strong-compose-set)
+(define (tutcode-bushu-weak-compose-set char-list bushu-list
strong-compose-set)
(if (null? (cdr char-list)) ; char-list ¤¬°ìʸ»ú¤À¤±¤Î»þ¤Ï²¿¤â¤·¤Ê¤¤
()
- (tutcode-bushu-subtract-set
- (tutcode-bushu-all-compose-set char-list ())
- strong-compose-set)))
+ (sort!
+ (tutcode-bushu-subtract-set
+ (tutcode-bushu-all-compose-set char-list ())
+ strong-compose-set)
+ (lambda (a b)
+ (tutcode-bushu-less? a b bushu-list)))))
(define (tutcode-bushu-subset bushu-list)
;;XXX:Ť¤¥ê¥¹¥È¤ËÂФ¹¤ëdelete-duplicates!¤ÏÃÙ¤¤¤Î¤Ç¡¢filter¸å¤Ë¹Ô¤¦
@@ -372,12 +496,16 @@
(or (and (pair? d1) (pair? d2))
(and (null? d1) (null? d2)))
()
- (delete! char
- (if (pair? rest)
- (tutcode-bushu-strong-diff-set rest d1-or-d2 complete?)
- (if complete?
- (tutcode-bushu-char-list-for-bushu d1-or-d2)
- (tutcode-bushu-subset d1-or-d2))))))))))
+ (if (pair? rest)
+ (delete! char
+ (tutcode-bushu-strong-diff-set rest d1-or-d2 complete?))
+ (sort!
+ (delete! char
+ (if complete?
+ (tutcode-bushu-char-list-for-bushu d1-or-d2)
+ (tutcode-bushu-subset d1-or-d2)))
+ (lambda (a b)
+ (tutcode-bushu-less? a b bushu-list #t))))))))))
(define (tutcode-bushu-complete-diff-set char-list)
(tutcode-bushu-strong-diff-set char-list () #t))
@@ -420,6 +548,7 @@
(tutcode-bushu-subtract-set
(tutcode-bushu-all-diff-set char-list () ())
strong-diff-set))
+ (less-or-many? (lambda (a b) (tutcode-bushu-less? a b bushu-list #t)))
(res
(receive
(true-diff-set rest-diff-set)
@@ -429,7 +558,8 @@
(tutcode-bushu-subtract-set
(tutcode-bushu-for-char char) bushu-list)))
diff-set)
- (append! true-diff-set rest-diff-set))))
+ (append! (sort! true-diff-set less-or-many?)
+ (sort! rest-diff-set less-or-many?)))))
(delete-duplicates! res)))
;;; bushu.help¥Õ¥¡¥¤¥ë¤òÆɤó¤Çtutcode-bushudic·Á¼°¤Î¥ê¥¹¥È¤òÀ¸À®¤¹¤ë
@@ -506,20 +636,26 @@
;;; @return ¹çÀ®²Äǽ¤Ê´Á»ú¤Î¥ê¥¹¥È
(define (tutcode-bushu-compose-interactively char-list)
(let*
- ((explicit (tutcode-bushu-compose-explicitly char-list))
- (complete-compose-set (tutcode-bushu-complete-compose-set char-list))
+ ((bushu-list (append-map! tutcode-bushu-for-char char-list))
+ (explicit (tutcode-bushu-compose-explicitly char-list))
+ (complete-compose-set
+ (tutcode-bushu-complete-compose-set char-list bushu-list))
(complete-diff-set (tutcode-bushu-complete-diff-set char-list))
- (strong-compose-set (tutcode-bushu-strong-compose-set char-list))
+ (strong-compose-set
+ (tutcode-bushu-strong-compose-set char-list bushu-list))
(strong-diff-set (tutcode-bushu-strong-diff-set char-list))
(weak-diff-set (tutcode-bushu-weak-diff-set char-list
strong-diff-set))
- (weak-compose-set (tutcode-bushu-weak-compose-set char-list
+ (weak-compose-set (tutcode-bushu-weak-compose-set char-list bushu-list
strong-compose-set)))
(delete-duplicates!
- (append!
- explicit
- complete-compose-set
- complete-diff-set
- strong-compose-set
- strong-diff-set
- weak-diff-set
- weak-compose-set))))
+ (filter!
+ (lambda (elem)
+ (not (member elem tutcode-bushu-inhibited-output-chars)))
+ (append!
+ explicit
+ complete-compose-set
+ complete-diff-set
+ strong-compose-set
+ strong-diff-set
+ weak-diff-set
+ weak-compose-set)))))
