Revision: 7253
Author: deton.kih
Date: Wed Aug 3 17:40:14 2011
Log: * Add Yamanobe algorithm of Kanchoku Win to bushu conversion
algorithms.
* scm/tutcode-custom.scm
- (tutcode-bushu-conversion-algorithm): Add 'kw-yamanobe choice.
* scm/tutcode.scm
- (tutcode-bushu-convert): Add check of 'kw-yamanobe.
- (tutcode-bushu-convert-kwyamanobe): New.
http://code.google.com/p/uim/source/detail?r=7253
Modified:
/trunk/scm/tutcode-custom.scm
/trunk/scm/tutcode.scm
=======================================
--- /trunk/scm/tutcode-custom.scm Tue Aug 2 23:51:30 2011
+++ /trunk/scm/tutcode-custom.scm Wed Aug 3 17:40:14 2011
@@ -145,6 +145,8 @@
(list 'choice
(list 'tc-2.1+ml1925
(N_ "tc-2.1+[tcode-ml:1925]") (N_ "tc-2.1+[tcode-ml:1925]"))
+ (list 'kw-yamanobe
+ (N_ "Kanchoku Win YAMANOBE") (N_ "Kanchoku Win YAMANOBE"))
(list 'tc-2.3.1-22.6 (N_ "tc-2.3.1-22.6") (N_ "tc-2.3.1-22.6")))
(N_ "Bushu conversion algorithm")
(N_ "long description will be here."))
=======================================
--- /trunk/scm/tutcode.scm Tue Aug 2 23:51:30 2011
+++ /trunk/scm/tutcode.scm Wed Aug 3 17:40:14 2011
@@ -3827,6 +3827,8 @@
(case tutcode-bushu-conversion-algorithm
((tc-2.3.1-22.6)
(tutcode-bushu-convert-tc23 c1 c2))
+ ((kw-yamanobe)
+ (tutcode-bushu-convert-kwyamanobe c1 c2))
(else ; 'tc-2.1+ml1925
(tutcode-bushu-convert-tc21 c1 c2))))
@@ -3907,6 +3909,161 @@
(equal? tc12 tc22)
(newchar tc11)))))))
+;;; Éô¼ó¹çÀ®ÊÑ´¹¤ò¹Ô¤¦¡£
+;;; ´ÁľWin+YAMANOBEÉô¼ó¹çÀ®¥¢¥ë¥´¥ê¥º¥à¤ò»ÈÍÑ¡£
+;;; @param ca 1ÈÖÌܤÎÉô¼ó
+;;; @param cb 2ÈÖÌܤÎÉô¼ó
+;;; @return ¹çÀ®¸å¤Îʸ»ú¡£¹çÀ®¤Ç¤¤Ê¤«¤Ã¤¿¤È¤¤Ï#f
+(define (tutcode-bushu-convert-kwyamanobe ca cb)
+ (if (null? tutcode-bushu-help)
+ (set! tutcode-bushu-help (tutcode-bushu-help-load)))
+ (and ca cb
+ (or
+ (and tutcode-bushu-help (tutcode-bushu-compose ca cb
tutcode-bushu-help))
+ (let
+ ;; ¹çÀ®¸å¤Îʸ»ú¤¬¡¢¹çÀ®Á°¤Î2¤Ä¤ÎÉô¼ó¤È¤Ï°Û¤Ê¤ë
+ ;; ¿·¤·¤¤Ê¸»ú¤Ç¤¢¤ë¤³¤È¤ò³Îǧ¤¹¤ë¡£
+ ;; (string=?¤À¤È#f¤¬¤¢¤Ã¤¿¤È¤¤Ë¥¨¥é¡¼¤Ë¤Ê¤ë¤Î¤Çequal?¤ò»ÈÍÑ)
+ ((newchar
+ (lambda (new)
+ (and new
+ (not (equal? new ca))
+ (not (equal? new cb))
+ new)))
+ (bushu-compose-sub
+ (lambda (x y)
+ (and x y
+ (tutcode-bushu-compose x y tutcode-bushudic))))) ; no swap
+ (or
+ (newchar (bushu-compose-sub ca cb))
+ (let
+ ((a (tutcode-bushu-alternative ca))
+ (b (tutcode-bushu-alternative cb))
+ (compose-alt
+ (lambda (cx cy x y)
+ (and
+ (or
+ (not (string=? x cx))
+ (not (string=? y cy)))
+ (newchar (bushu-compose-sub x y))))))
+ (or
+ (compose-alt ca cb a b)
+ (let*
+ ((ad (tutcode-bushu-decompose a))
+ (bd (tutcode-bushu-decompose b))
+ (a1 (and ad (car ad)))
+ (a2 (and ad (cadr ad)))
+ (b1 (and bd (car bd)))
+ (b2 (and bd (cadr bd)))
+ (compose-newchar
+ (lambda (i1 i2)
+ (newchar (bushu-compose-sub i1 i2))))
+ (compose-l2r
+ (lambda (x y z)
+ (newchar (bushu-compose-sub (bushu-compose-sub x y)
z))))
+ (compose-r2l
+ (lambda (x y z)
+ (newchar (bushu-compose-sub x (bushu-compose-sub y
z)))))
+ (compose-lr
+ (lambda (a a1 a2 b b1 b2)
+ (or
+ (and a1 a2
+ (or
+ (compose-l2r a1 b a2)
+ (compose-r2l a1 a2 b)))
+ (and b1 b2
+ (or
+ (compose-l2r a b1 b2)
+ (compose-r2l b1 a b2))))))
+ (subtract
+ (lambda (a1 a2 b)
+ (or
+ (and (equal? a2 b) (newchar a1))
+ (and (equal? a1 b) (newchar a2))))))
+ (or
+ (compose-lr a a1 a2 b b1 b2)
+ ;; °ú¤»»
+ (subtract a1 a2 b)
+ (let*
+ ((ad1 (and a1 (tutcode-bushu-decompose a1)))
+ (ad2 (and a2 (tutcode-bushu-decompose a2)))
+ (a11 (and ad1 (car ad1)))
+ (a12 (and ad1 (cadr ad1)))
+ (a21 (and ad2 (car ad2)))
+ (a22 (and ad2 (cadr ad2)))
+ (bushu-convert-sub
+ (lambda (a a1 a11 a12 a2 a21 a22 b b1 b2)
+ (or
+ (and a2 a11 a12
+ (or
+ (and (equal? a12 b) (compose-newchar a11 a2))
+ (and (equal? a11 b) (compose-newchar a12
a2))))
+ (and a1 a21 a22
+ (or
+ (and (equal? a22 b) (compose-newchar a1 a21))
+ (and (equal? a21 b) (compose-newchar a1
a22))))
+ ;; °ìÊý¤¬ÉôÉʤˤè¤ë¤·»»
+ (compose-newchar a b1)
+ (compose-newchar a b2)
+ (compose-newchar a1 b)
+ (compose-newchar a2 b)
+ (and a1 a2 b1
+ (or
+ (compose-l2r a1 b1 a2)
+ (compose-r2l a1 a2 b1)))
+ (and a1 a2 b2
+ (or
+ (compose-l2r a1 b2 a2)
+ (compose-r2l a1 a2 b2)))
+ (and a1 b1 b2
+ (or
+ (compose-l2r a1 b1 b2)
+ (compose-r2l b1 a1 b2)))
+ (and a2 b1 b2
+ (or
+ (compose-l2r a2 b1 b2)
+ (compose-r2l b1 a2 b2)))
+ ;; ξÊý¤¬ÉôÉʤˤè¤ë¤·»»
+ (compose-newchar a1 b1)
+ (compose-newchar a1 b2)
+ (compose-newchar a2 b1)
+ (compose-newchar a2 b2)
+ ;; ÉôÉʤˤè¤ë°ú¤»»
+ (and a2 b1 (equal? a2 b1) (newchar a1))
+ (and a2 b2 (equal? a2 b2) (newchar a1))
+ (and a1 b1 (equal? a1 b1) (newchar a2))
+ (and a1 b2 (equal? a1 b2) (newchar a2))
+ (and a2 a11 a12
+ (or
+ (and (or (equal? a12 b1) (equal? a12 b2))
+ (compose-newchar a11 a2))
+ (and (or (equal? a11 b1) (equal? a11 b2))
+ (compose-newchar a12 a2))))
+ (and a1 a21 a22
+ (or
+ (and (or (equal? a22 b1) (equal? a22 b2))
+ (compose-newchar a1 a21))
+ (and (or (equal? a21 b1) (equal? a21 b2))
+ (compose-newchar a1 a22))))))))
+ (or
+ (bushu-convert-sub a a1 a11 a12 a2 a21 a22 b b1 b2)
+ ;; ʸ»ú¤Î½ç½ø¤òµÕ¤Ë¤·¤Æ¤ß¤ë
+ (and (not (equal? ca cb))
+ (or
+ (newchar (bushu-compose-sub cb ca))
+ (compose-alt cb ca b a)
+ (compose-lr b b1 b2 a a1 a2)
+ (subtract b1 b2 a)
+ (let*
+ ((bd1 (and b1 (tutcode-bushu-decompose b1)))
+ (bd2 (and b2 (tutcode-bushu-decompose b2)))
+ (b11 (and bd1 (car bd1)))
+ (b12 (and bd1 (cadr bd1)))
+ (b21 (and bd2 (car bd2)))
+ (b22 (and bd2 (cadr bd2))))
+ (bushu-convert-sub b b1 b11 b12 b2 b21 b22 a
a1 a2)
+ ))))))))))))))
+
;;; Éô¼ó¹çÀ®ÊÑ´¹:c1¤Èc2¤ò¹çÀ®¤·¤Æ¤Ç¤¤ëʸ»ú¤òõ¤·¤ÆÊÖ¤¹¡£
;;; »ØÄꤵ¤ì¤¿½çÈ֤Ǹ«¤Ä¤«¤é¤Ê¤«¤Ã¤¿¾ì¹ç¤Ï¡¢½çÈÖ¤òÆþ¤ì¤«¤¨¤Æõ¤¹¡£
;;; @param c1 1ÈÖÌܤÎÉô¼ó
