Author: yamakenz
Date: Fri May 9 23:20:51 2008
New Revision: 5479
Added:
trunk/scm/trec.scm
- copied, changed from r5472, /branches/composer/scm/trec.scm
trunk/test2/test-trec.scm
Modified:
trunk/scm/Makefile.am
trunk/test2/Makefile.am
Log:
* This commit port trec.scm from the composer branch, and make
core part working. Although the data structure and basic
search algorithm is still effective for uim, overall code
organization is over-generalized and complicated to be capable
of non-core features. It seems needing a design overhaul and
code simplification. I'll do it for uim 1.6.0.
* scm/trec.scm
- Port from the composer branch
- Adapt codes written for SIOD to SigScheme
- (trec-route-new): Fix broken trec-enable-reroutable-search? handling
- (trec-parse-ruleset): Fix broken parens
- (trec-node-insert-branch!): Fix lack of return value
- (trec-route-last-root, trec-route-keys): Fix logical typo
- (trec-router-vanilla-advance-new): Fix incomplete implementation
* scm/Makefile.am
- (SCM_FILES): Add trec.scm
* test2/test-trec.scm
- New file
- Add various but incomplete tests for trec.scm core
* test2/Makefile.am
- (uim_tests): Add test-trec.scm
Modified: trunk/scm/Makefile.am
==============================================================================
--- trunk/scm/Makefile.am (original)
+++ trunk/scm/Makefile.am Fri May 9 23:20:51 2008
@@ -8,7 +8,7 @@
im-switcher.scm \
default.scm \
util.scm deprecated-util.scm ichar.scm light-record.scm wlos.scm \
- ustr.scm i18n.scm iso-639-1.scm \
+ ustr.scm trec.scm i18n.scm iso-639-1.scm \
key.scm action.scm load-action.scm \
uim-sh.scm editline.scm custom.scm custom-rt.scm \
direct.scm \
Copied: trunk/scm/trec.scm (from r5472, /branches/composer/scm/trec.scm)
==============================================================================
--- /branches/composer/scm/trec.scm (original)
+++ trunk/scm/trec.scm Fri May 9 23:20:51 2008
@@ -1,6 +1,6 @@
;;; trec.scm: A tree-based generic recursive sequence-to-sequence mapper
;;;
-;;; Copyright (c) 2005 uim Project http://uim.freedesktop.org/
+;;; Copyright (c) 2005-2008 uim Project http://code.google.com/p/uim/
;;;
;;; All rights reserved.
;;;
@@ -43,17 +43,15 @@
;; - TREe-based RECursive Converter
;; - The meaning and pronunciation of the word 'trek'
-(use srfi-1)
-(use srfi-2)
-(use srfi-8)
-(use srfi-23)
+(require-extension (srfi 1 2 8 23))
(require "util.scm")
;; Resource-consumption sensitive environment may enable only deterministic
;; search. This variable only affects on startup-time.
-(or (not (symbol-bound? 'trec-enable-reroutable-search?))
- (define trec-enable-reroutable-search #f))
+(or (symbol-bound? 'trec-enable-reroutable-search?)
+ (eval '(define trec-enable-reroutable-search? #f)
+ (interaction-environment)))
;;
@@ -99,7 +97,7 @@
(trec-node-merge-ruleset! root key=? backward-match ruleset)
(if (trec-node-val root)
(error "root node cannot hold value")
- root)))
+ root))))
;;
@@ -132,11 +130,14 @@
(define trec-node-leaf?
(compose null? trec-node-branches))
+;; TODO: return 'branch' only
(define trec-node-insert-branch!
(lambda (node branch)
- (trec-node-set-branches! node (cons branch (trec-node-branches node)))
- new-branches))
+ (let ((new-branches (cons branch (trec-node-branches node))))
+ (trec-node-set-branches! node new-branches)
+ new-branches)))
+;; TODO: follow the return value change of trec-node-insert-branch!
(define trec-node-descend!
(lambda (node key=? key)
(or (find (lambda (branch)
@@ -162,6 +163,7 @@
(trec-node-set-val! leaf val))
node)))
+;; TODO: Backtrack from the leaf of previous rule to reduce full search
(define trec-node-merge-ruleset!
(lambda (node key=? backward-match ruleset)
(let ((merge! (lambda (rule node)
@@ -175,7 +177,9 @@
(define trec-route-new
(lambda (initial-node)
- (list (list initial-node))))
+ (if trec-enable-reroutable-search?
+ (list (list initial-node))
+ (list initial-node))))
;; 'route point' is each route element backtrackable to
(define trec-route-point-node
@@ -201,7 +205,7 @@
(define trec-route-last-root
(lambda (route)
- (find-tail trec-route-root? route)))
+ (find-tail trec-node-root? route)))
(define trec-route-goal?
(compose trec-node-leaf? trec-route-last-node))
@@ -219,9 +223,9 @@
(list-ref keys (compensate-index idx len)))))
(define trec-route-keys
- (let ((collect? (compose not trec-route-root?)))
+ (let ((not-root-key? values))
(lambda (route)
- (trec-route-filter-keys route collect?))))
+ (trec-route-filter-keys route not-root-key?))))
(define trec-route-filter-keys
(lambda (route pred)
@@ -312,17 +316,21 @@
;; route transition drivers (router)
;;
-;; a router returns (route . rejected-keys)
+;; a router returns (route . rejected-keys) or #f
;; no vkey and vnode
(define trec-router-vanilla-advance-new
(lambda (match?)
(define advance
(lambda (route cands key)
- (let ((node (car cands)))
- (and (match? (trec-node-key node) key)
- (cons (cons (cons key (cdr node)) route)
- ())))))))
+ (and (not (null? cands))
+ (let ((node (car cands))
+ (rest (cdr cands)))
+ (or (and (match? (trec-node-key node) key)
+ (cons (cons (cons key (cdr node)) route)
+ ()))
+ (advance route rest key))))))
+ advance))
(define trec-router-advance-with-fallback-new
(lambda (base-router fallback-router)
@@ -342,6 +350,7 @@
(let ((next-node (cons matched (cdr node))))
(list key TREC-NULL-VALUE next-node))))))
+;; FIXME: node
;; TODO: simplify
(define trec-router-std-advance-new
(lambda (matcher)
@@ -517,5 +526,5 @@
(cons 'recur-retry trec-vnode-recur-retry-new)))
-(if trec-enable-reroutable-search
+(if trec-enable-reroutable-search?
(require "trec-reroutable.scm"))
Modified: trunk/test2/Makefile.am
==============================================================================
--- trunk/test2/Makefile.am (original)
+++ trunk/test2/Makefile.am Fri May 9 23:20:51 2008
@@ -4,6 +4,7 @@
test-fail.scm \
test-light-record.scm \
test-template.scm \
+ test-trec.scm \
test-wlos.scm
uim_optional_tests =
uim_xfail_tests = test-fail.scm
Added: trunk/test2/test-trec.scm
==============================================================================
--- (empty file)
+++ trunk/test2/test-trec.scm Fri May 9 23:20:51 2008
@@ -0,0 +1,208 @@
+;; test-trec.scm: Unit tests for trec.scm
+;;
+;;; Copyright (c) 2008 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.
+
+(require-extension (unittest))
+
+(require "trec.scm")
+
+(define romaji-ruleset '((("a") . ("A"))
+ (("i") . ("I"))
+ (("k") . ("K"))
+ (("k" "a") . ("KA"))
+ (("u") . ("U"))
+ (("k" "k" "y" "a") . ("KKYA"))
+ (("k" "k" "a") . ("KKA"))
+ (("k" "k" "y") . ("KKY"))
+ (("k" "k") . ("KK"))))
+(define romaji-ruletree (trec-parse-ruleset string=? #f romaji-ruleset))
+
+(test-begin "trec-node")
+(test-equal #f (trec-node-key romaji-ruletree))
+(test-equal #f (trec-node-val romaji-ruletree))
+(test-true (pair? (trec-node-branches romaji-ruletree)))
+(test-true (trec-node-root? romaji-ruletree))
+(test-false (trec-node-leaf? romaji-ruletree))
+(test-end)
+
+(test-begin "trec-route")
+(define initial (trec-route-new romaji-ruletree))
+(test-eq romaji-ruletree
+ (car (trec-route-point-node initial)))
+(test-eq romaji-ruletree
+ (trec-route-last-node initial))
+(test-true (trec-route-initial? initial))
+(test-eq romaji-ruletree
+ (car (trec-route-initial initial)))
+(test-true (trec-route-root? initial))
+(test-eq initial
+ (trec-route-last-root initial))
+(test-false (trec-route-goal? initial))
+(test-true (pair? (trec-route-next-descendants initial)))
+(test-eq #f (trec-route-last-key initial))
+
+;; filter
+(test-equal '()
+ (filter-map-trec-route (lambda (rt)
+ (trec-route-last-key rt))
+ initial))
+(test-equal '((#f))
+ (filter-map-trec-route (lambda (rt)
+ (list (trec-route-last-key rt)))
+ initial))
+
+;; keys
+(test-equal '()
+ (trec-route-filter-keys initial values))
+(test-equal '()
+ (trec-route-filter-keys initial (lambda (k) #t)))
+(test-error (trec-route-nth-key initial 0 values))
+(test-error (trec-route-nth-key initial 0 (lambda (k) #t)))
+
+;; values
+(test-eq #f (trec-route-value initial))
+(test-equal '()
+ (trec-route-values initial))
+(test-end)
+
+(test-begin "trec-route advanced once")
+;;(define rtr-string=? (trec-router-std-advance-new string=?))
+(define rtr-string=? (trec-router-vanilla-advance-new string=?))
+(define rt1.rej (trec-route-advance initial rtr-string=? "k"))
+(define rt1 (car rt1.rej))
+(test-eq '()
+ (cdr rt1.rej))
+(test-false (trec-node-root? (trec-route-last-node rt1)))
+(test-false (trec-node-leaf? (trec-route-last-node rt1)))
+(test-false (trec-route-initial? rt1))
+(test-eq romaji-ruletree
+ (car (trec-route-initial rt1)))
+(test-false (trec-route-root? rt1))
+(test-eq initial
+ (trec-route-last-root rt1))
+(test-false (trec-route-goal? rt1))
+(test-true (pair? (trec-route-next-descendants rt1)))
+(test-equal "k"
+ (trec-route-last-key rt1))
+;; keys
+(test-equal '("k")
+ (trec-route-filter-keys rt1 values))
+(test-equal '("k")
+ (trec-route-filter-keys rt1 (lambda (k) #t)))
+(test-equal "k"
+ (trec-route-nth-key rt1 0 values))
+(test-equal "k"
+ (trec-route-nth-key rt1 0 (lambda (k) #t)))
+
+;; values
+(test-equal '("K")
+ (trec-route-value rt1))
+(test-equal '(("K"))
+ (trec-route-values rt1))
+(test-end)
+
+(test-begin "trec-route-route")
+(test-equal '("KKYA")
+ (trec-route-value
+ (car
+ (trec-route-route initial rtr-string=? '("k" "k" "y" "a")))))
+(test-equal '()
+ (cdr
+ (trec-route-route initial rtr-string=? '("k" "k" "y" "a"))))
+(test-equal '("KKYA")
+ (trec-route-value
+ (car
+ (trec-route-route initial rtr-string=? '("k" "k" "y" "a" "f")))))
+(test-equal '("f")
+ (cdr
+ (trec-route-route initial rtr-string=? '("k" "k" "y" "a" "f"))))
+(test-equal '("f" "o" "o")
+ (cdr
+ (trec-route-route initial rtr-string=? '("k" "k" "y" "a" "f" "o"
"o"))))
+(test-end)
+
+(test-begin "trec-route-backtrack")
+(define k (car (trec-route-advance initial rtr-string=? "k")))
+(define kk (car (trec-route-advance k rtr-string=? "k")))
+(define kka (car (trec-route-advance kk rtr-string=? "a")))
+(define kky (car (trec-route-advance kk rtr-string=? "y")))
+(define kkya (car (trec-route-advance kky rtr-string=? "a")))
+(test-eq initial
+ (car (trec-route-backtrack initial)))
+(test-equal #f
+ (cdr (trec-route-backtrack initial)))
+(test-eq initial
+ (car (trec-route-backtrack k)))
+(test-equal "k"
+ (cdr (trec-route-backtrack k)))
+(test-eq k
+ (car (trec-route-backtrack kk)))
+(test-equal "k"
+ (cdr (trec-route-backtrack kk)))
+(test-eq kk
+ (car (trec-route-backtrack kky)))
+(test-equal "y"
+ (cdr (trec-route-backtrack kky)))
+(test-eq kky
+ (car (trec-route-backtrack kkya)))
+(test-equal kka
+ (car (trec-route-advance
+ (car (trec-route-backtrack
+ (car (trec-route-backtrack kkya))))
+ rtr-string=? "a")))
+(test-end)
+
+(test-begin "trec-route-keys")
+(test-equal '()
+ (trec-route-keys initial))
+(test-equal '("k")
+ (trec-route-keys k))
+(test-equal '("k" "k")
+ (trec-route-keys kk))
+(test-equal '("k" "k" "y")
+ (trec-route-keys kky))
+(test-equal '("k" "k" "y" "a")
+ (trec-route-keys kkya))
+(test-end)
+
+(test-begin "trec-route-values")
+(test-equal '()
+ (trec-route-values initial))
+(test-equal '(("K"))
+ (trec-route-values k))
+(test-equal '(("KK"))
+ (trec-route-values kk))
+(test-equal '(("KKY"))
+ (trec-route-values kky))
+(test-equal '(("KKYA"))
+ (trec-route-values kkya))
+(test-end)
+
+(test-report-result)
