Revision: 6529
Author: deton.kih
Date: Sun Jul 18 13:35:59 2010
Log: * scm/tutcode-editor.scm
- New file.
* scm/tutcode-dialog.scm
- New file.
http://code.google.com/p/uim/source/detail?r=6529
Added:
/trunk/scm/tutcode-dialog.scm
/trunk/scm/tutcode-editor.scm
=======================================
--- /dev/null
+++ /trunk/scm/tutcode-dialog.scm Sun Jul 18 13:35:59 2010
@@ -0,0 +1,122 @@
+;;;
+;;; Copyright (c) 2005-2010 uim Project http://code.google.com/p/uim/
+;;;
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. Neither the name of authors nor the names of its contributors
+;;; may be used to endorse or promote products derived from this
software
+;;; without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
``AS IS'' AND
+;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
CONTRIBUTORS BE LIABLE
+;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT
+;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
WAY
+;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+;;; SUCH DAMAGE.
+;;;;
+
+;; yes/no dialog for tutcode-purge-candidate
+;; this is just a quick hack derived from skk-editor.scm
+
+(define-record 'tutcode-dialog
+ '((context ())
+ (left-string ())
+ (right-string ())))
+(define tutcode-dialog-new-internal tutcode-dialog-new)
+
+(define tutcode-dialog-new
+ (lambda (sc)
+ (let ((dc (tutcode-dialog-new-internal)))
+ (tutcode-dialog-set-context! dc sc)
+ dc)))
+
+(define tutcode-dialog-flush
+ (lambda (dc)
+ (tutcode-dialog-set-left-string! dc ())
+ (tutcode-dialog-set-right-string! dc ())))
+
+(define tutcode-dialog-make-string
+ (lambda (sl dir)
+ (if (null? sl)
+ (if dir
+ "Really purge? (yes/no) "
+ "")
+ (if dir
+ (string-append (tutcode-dialog-make-string (cdr sl) dir)
+ (car sl))
+ (string-append (car sl)
+ (tutcode-dialog-make-string (cdr sl) dir))))))
+
+(define tutcode-dialog-get-left-string
+ (lambda (dc)
+ (tutcode-dialog-make-string
+ (tutcode-dialog-left-string dc) #t)))
+
+(define tutcode-dialog-get-right-string
+ (lambda (dc)
+ (tutcode-dialog-make-string
+ (tutcode-dialog-right-string dc) #f)))
+
+(define tutcode-dialog-commit-char-list
+ (lambda (dc sl)
+ (if (not (null? sl))
+ (begin
+ (tutcode-dialog-set-left-string!
+ dc
+ (cons (car sl)
+ (tutcode-dialog-left-string dc)))
+ (tutcode-dialog-commit-char-list
+ dc (cdr sl))))))
+
+(define tutcode-dialog-commit
+ (lambda (dc str)
+ (tutcode-dialog-commit-char-list
+ dc (reverse (string-to-list str)))))
+
+(define tutcode-dialog-commit-raw
+ (lambda (dc key key-state)
+ (let ((raw-str (im-get-raw-key-str key key-state))
+ (sc (tutcode-dialog-context dc))
+ (str
+ (string-append
+ (tutcode-dialog-get-left-string dc)
+ (tutcode-dialog-get-right-string dc))))
+ (if raw-str
+ (tutcode-dialog-commit dc raw-str)
+ ;; not a string
+ (cond
+ ((tutcode-backspace-key? key key-state)
+ (let ((cur (tutcode-dialog-left-string dc)))
+ (if (not (null? cur))
+ (tutcode-dialog-set-left-string! dc (cdr cur)))))
+ ((tutcode-return-key? key key-state)
+ (cond
+ ((string=? str "Really purge? (yes/no) yes")
+ (tutcode-purge-candidate sc)
+ (tutcode-dialog-flush dc)
+ (tutcode-context-set-child-context! sc ())
+ (tutcode-context-set-child-type! sc ())
+ (tutcode-update-preedit sc))
+ ((string=? str "Really purge? (yes/no) no")
+ (tutcode-dialog-flush dc)
+ (tutcode-context-set-child-context! sc ())
+ (tutcode-context-set-child-type! sc ())
+ (tutcode-update-preedit sc))))
+ ((tutcode-cancel-key? key key-state)
+ (tutcode-dialog-flush dc)
+ (tutcode-context-set-child-context! sc ())
+ (tutcode-context-set-child-type! sc ())
+ (tutcode-update-preedit sc)))))))
=======================================
--- /dev/null
+++ /trunk/scm/tutcode-editor.scm Sun Jul 18 13:35:59 2010
@@ -0,0 +1,142 @@
+;;;
+;;; Copyright (c) 2003-2010 uim Project http://code.google.com/p/uim/
+;;;
+;;; All rights reserved.
+;;;
+;;; Redistribution and use in source and binary forms, with or without
+;;; modification, are permitted provided that the following conditions
+;;; are met:
+;;; 1. Redistributions of source code must retain the above copyright
+;;; notice, this list of conditions and the following disclaimer.
+;;; 2. Redistributions in binary form must reproduce the above copyright
+;;; notice, this list of conditions and the following disclaimer in the
+;;; documentation and/or other materials provided with the distribution.
+;;; 3. Neither the name of authors nor the names of its contributors
+;;; may be used to endorse or promote products derived from this
software
+;;; without specific prior written permission.
+;;;
+;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
``AS IS'' AND
+;;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+;;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE
+;;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR
CONTRIBUTORS BE LIABLE
+;;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL
+;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+;;; OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+;;; HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
STRICT
+;;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
WAY
+;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+;;; SUCH DAMAGE.
+;;;;
+
+;; SKK¤ÈƱ¤¸ºÆµ¢³Ø½¬¤ò¥¤¥ó¥é¥¤¥ó¤Ç¹Ô¤¦¤¿¤á¤Î´Ê°×¥Æ¥¥¹¥È¥¨¥Ç¥£¥¿¡£
+;; skk-editor.scm¤«¤é¥³¥Ô¡¼¤·¤Ætutcode.scmÍѤËÊѹ¹¡£
+
+(define-record 'tutcode-editor
+ '((context ())
+ (left-string ())
+ (right-string ())))
+(define tutcode-editor-new-internal tutcode-editor-new)
+
+(define tutcode-editor-new
+ (lambda (sc)
+ (let ((ec (tutcode-editor-new-internal)))
+ (tutcode-editor-set-context! ec sc)
+ ec)))
+
+(define tutcode-editor-flush
+ (lambda (ec)
+ (tutcode-editor-set-left-string! ec ())
+ (tutcode-editor-set-right-string! ec ())))
+
+(define tutcode-editor-make-string
+ (lambda (sl dir)
+ (if (null? sl)
+ ""
+ (if dir
+ (string-append (tutcode-editor-make-string (cdr sl) dir)
+ (car sl))
+ (string-append (car sl)
+ (tutcode-editor-make-string (cdr sl) dir))))))
+
+(define tutcode-editor-get-left-string
+ (lambda (ec)
+ (tutcode-editor-make-string
+ (tutcode-editor-left-string ec) #t)))
+
+(define tutcode-editor-get-right-string
+ (lambda (ec)
+ (tutcode-editor-make-string
+ (tutcode-editor-right-string ec) #f)))
+
+(define tutcode-editor-commit-char-list
+ (lambda (ec sl)
+ (if (not (null? sl))
+ (begin
+ (tutcode-editor-set-left-string!
+ ec
+ (cons (car sl)
+ (tutcode-editor-left-string ec)))
+ (tutcode-editor-commit-char-list
+ ec (cdr sl))))))
+
+(define tutcode-editor-commit
+ (lambda (ec str)
+ (tutcode-editor-commit-char-list
+ ec (reverse (string-to-list str)))))
+
+(define tutcode-editor-commit-raw
+ (lambda (ec key key-state)
+ (let ((raw-str (im-get-raw-key-str key key-state))
+ (sc (tutcode-editor-context ec))
+ (str
+ (string-append
+ (tutcode-editor-get-left-string ec)
+ (tutcode-editor-get-right-string ec))))
+ (if raw-str
+ (tutcode-editor-commit ec raw-str)
+ ;; not a string
+ (cond
+ ((tutcode-backspace-key? key key-state)
+ (let ((cur (tutcode-editor-left-string ec)))
+ (if (not (null? cur))
+ (tutcode-editor-set-left-string! ec (cdr cur)))))
+ ((generic-go-left-key? key key-state)
+ (let ((cur (tutcode-editor-left-string ec)))
+ (if (not (null? cur))
+ (begin
+ (tutcode-editor-set-left-string! ec (cdr cur))
+ (tutcode-editor-set-right-string!
+ ec (cons (car cur) (tutcode-editor-right-string
ec)))))))
+ ((generic-go-right-key? key key-state)
+ (let ((cur (tutcode-editor-right-string ec)))
+ (if (not (null? cur))
+ (begin
+ (tutcode-editor-set-right-string! ec (cdr cur))
+ (tutcode-editor-set-left-string!
+ ec (cons (car cur) (tutcode-editor-left-string
ec)))))))
+ ((tutcode-return-key? key key-state)
+ (if (< 0 (string-length str))
+ (begin
+ (skk-lib-learn-word
+ (tutcode-make-string (tutcode-context-head sc))
+ ""
+ ""
+ str
+ #f)
+ (tutcode-save-personal-dictionary #t)
+ (tutcode-commit-editor-context sc str))
+ (begin
+ (tutcode-editor-flush ec)
+ (tutcode-context-set-child-context! sc '())
+ (tutcode-context-set-child-type! sc '())
+ (if (> (tutcode-context-nr-candidates sc) 0)
+ (tutcode-back-to-converting-state sc)
+ (tutcode-back-to-yomi-state sc)))))
+ ((tutcode-cancel-key? key key-state)
+ (tutcode-editor-flush ec)
+ (tutcode-context-set-child-context! sc '())
+ (tutcode-context-set-child-type! sc '())
+ (if (> (tutcode-context-nr-candidates sc) 0)
+ (tutcode-back-to-converting-state sc)
+ (tutcode-back-to-yomi-state sc)))
+ )))))
