[uim-commit] r1870 - branches/composer/scm
yamaken at freedesktop.org
yamaken at freedesktop.org
Sat Oct 22 18:13:08 PDT 2005
Author: yamaken
Date: 2005-10-22 18:13:04 -0700 (Sat, 22 Oct 2005)
New Revision: 1870
Added:
branches/composer/scm/trec.scm
Modified:
branches/composer/scm/Makefile.am
Log:
* This commit adds the tree-based generic recursive
sequence-to-sequence mapper to replace evmap
* scm/Makefile.am
- (SCM_FILES): Add trec.scm
* scm/trec.scm
- New file
- (trec-enable-reroutable-search, TREC-NULL-KEY, TREC-NULL-VALUE,
TREC-MATCHER-FIN, TREC-MATCHER-RETRY, trec-node-rec-spec,
trec-context-rec-spec): New variable
- (record trec-context, record trec-node): New record
- (last-pair?, find-map, remove-once, trec-rule-path,
trec-rule-value, trec-rule-new, trec-vnode-directive?,
trec-parse-ruleset, trec-node-key, trec-node-val,
trec-node-branches, trec-node-set-branches!, trec-vnode?,
trec-node-root?, trec-node-leaf?, trec-node-insert-branch!,
trec-node-descend!, trec-node-merge-rule!,
trec-node-merge-ruleset!, trec-route-new, trec-route-point-node,
trec-route-last-node, trec-route-initial?, trec-route-initial,
trec-route-root?, trec-route-last-root, trec-route-goal?,
trec-route-next-descendants, trec-route-last-key,
trec-route-nth-key, trec-route-keys, trec-route-filter-keys,
trec-route-value, trec-route-values, trec-route-advance,
trec-route-route, trec-route-backtrack, filter-map-trec-route,
trec-context-initial?, trec-context-goal?, trec-context-keys,
trec-context-values, trec-context-reset!, trec-context-advance!,
trec-context-backtrack!, trec-router-vanilla-advance-new,
trec-router-advance-with-fallback-new, trec-make-node,
trec-router-std-advance-new, trec-matcher-terminal-state,
trec-vkey?, trec-matcher-std-new, trec-vkey-keyset-new,
trec-vkey-keyseq-new, trec-vnode-peek-new,
trec-make-vnode-recur-new, trec-vnode-join-new,
trec-vnode-join-retry-new, trec-vnode-recur-new,
trec-vnode-recur-retry-new, peek, join, join-retry, recur,
recur-retry): New procedure
Modified: branches/composer/scm/Makefile.am
===================================================================
--- branches/composer/scm/Makefile.am 2005-10-23 01:01:55 UTC (rev 1869)
+++ branches/composer/scm/Makefile.am 2005-10-23 01:13:04 UTC (rev 1870)
@@ -8,7 +8,7 @@
default.scm \
util.scm key.scm ustr.scm utext.scm i18n.scm \
ng-action.scm action.scm load-action.scm \
- ng-key.scm physical-key.scm event.scm evmap.scm evmap-csv.scm \
+ ng-key.scm physical-key.scm event.scm trec.scm evmap.scm evmap-csv.scm \
event-translator.scm \
key-custom.scm \
segmental-converter.scm \
Added: branches/composer/scm/trec.scm
===================================================================
--- branches/composer/scm/trec.scm 2005-10-23 01:01:55 UTC (rev 1869)
+++ branches/composer/scm/trec.scm 2005-10-23 01:13:04 UTC (rev 1870)
@@ -0,0 +1,516 @@
+;;; trec.scm: A tree-based generic recursive sequence-to-sequence mapper
+;;;
+;;; Copyright (c) 2005 uim Project http://uim.freedesktop.org/
+;;;
+;;; 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.
+;;;;
+
+;; trec (pronounced as 'trek') is a tree (in exactly, de la Briandais trie)
+;; -based generic sequence-to-sequence mapper. It maps an arbitrary abstract
+;; object sequence to another arbitrary object sequence, based on an
+;; user-defined ruleset.
+;;
+;; This file only provides the generic data structure and algorithms. To use
+;; trec as a concrete character composition engine, some supplemental parts
+;; such as event handlings and preedit string extractor are
+;; required. trec-composer.scm will provide them.
+;;
+;; The name 'trec' comes from:
+;; - 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 "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))
+
+
+;;
+;; generic utilities
+;;
+
+(define last-pair?
+ (lambda (lst)
+ (null? (cdr lst))))
+
+(define find-map
+ (lambda (f lst)
+ (and (not (null? lst))
+ (or (f (car lst))
+ (find-map f (cdr lst))))))
+
+(define remove-once
+ (lambda (pred lst)
+ (receive (head tail) (break pred lst)
+ (if (null? tail)
+ lst
+ (append head (cdr tail))))))
+
+
+;;
+;; trec-rule
+;;
+
+;; (path . value)
+(define trec-rule-path car)
+(define trec-rule-value cdr)
+(define trec-rule-new cons)
+
+(define trec-vnode-directive? procedure?)
+
+;; .parameter ruleset A list of trec-rule
+;; .parameter backward-match Bool value indicates that the ruletree shall be
+;; built for backward-match
+;; .returns A trec-node as a compiled ruletree
+(define trec-parse-ruleset
+ (lambda (key=? backward-match ruleset)
+ (let ((root (trec-node-new)))
+ (trec-node-merge-ruleset! root key=? backward-match ruleset)
+ (if (trec-node-val root)
+ (error "root node cannot hold value")
+ root)))
+
+
+;;
+;; trec-node
+;;
+
+(define TREC-NULL-KEY #f)
+(define TREC-NULL-VALUE #f)
+
+(define trec-node-rec-spec
+ '((key #f)
+ (val #f)
+ ;; . (branches ())
+ ))
+(define-record 'trec-node trec-node-rec-spec)
+(define trec-node-key car) ;; optimization
+(define trec-node-val cadr) ;; optimization
+(define trec-node-branches cddr)
+(define trec-node-set-branches!
+ (lambda (node new-branches)
+ (set-cdr! (cdr node) new-branches)))
+
+(define trec-vnode? procedure?)
+
+(define trec-node-root?
+ (lambda (node)
+ (and (not (trec-node-key node))
+ (not (trec-node-val node)))))
+
+(define trec-node-leaf?
+ (compose null? trec-node-branches))
+
+(define trec-node-insert-branch!
+ (lambda (node branch)
+ (trec-node-set-branches! node (cons branch (trec-node-branches node)))
+ new-branches))
+
+(define trec-node-descend!
+ (lambda (node key=? key)
+ (or (find (lambda (branch)
+ (key=? (trec-node-key branch) key))
+ (trec-node-branches node))
+ (car (trec-node-insert-branch! node (trec-node-new key))))))
+
+(define trec-node-merge-rule!
+ (lambda (node key=? backward-match rule)
+ (let* ((path (if backward-match
+ (reverse (trec-rule-path rule))
+ (trec-rule-path rule)))
+ (val (trec-rule-value rule))
+ (descend! (lambda (keys cur-node)
+ (if (trec-vnode-directive? (cdr keys))
+ (let* ((make-vnode (cdr keys))
+ (vnode (make-vnode (car keys) val)))
+ (trec-node-insert-branch! cur-node vnode)
+ #f)
+ (trec-node-descend! cur-node key=? (car keys)))))
+ (leaf (pair-fold descend! node path)))
+ (if leaf
+ (trec-node-set-val! leaf val))
+ node)))
+
+(define trec-node-merge-ruleset!
+ (lambda (node key=? backward-match ruleset)
+ (let ((merge! (lambda (rule node)
+ (trec-node-merge-rule! node key=? backward-match rule))))
+ (fold merge! node ruleset))))
+
+
+;;
+;; trec-route
+;;
+
+(define trec-route-new
+ (lambda (initial-node)
+ (list (list initial-node))))
+
+;; 'route point' is each route element backtrackable to
+(define trec-route-point-node
+ (if trec-enable-reroutable-search?
+ car
+ values))
+
+(define trec-route-last-node
+ ;;(compose trec-route-point-node car))
+ ;; optimzation
+ (if trec-enable-reroutable-search?
+ caar
+ car))
+
+(define trec-route-initial? last-pair?)
+
+(define trec-route-initial last-pair)
+
+;; root node may be appeared more than once in a route, as a result of
+;; recursive joining
+(define trec-route-root?
+ (compose trec-node-root? trec-route-last-node))
+
+(define trec-route-last-root
+ (lambda (route)
+ (find-tail trec-route-root? route)))
+
+(define trec-route-goal?
+ (compose trec-node-leaf? trec-route-last-node))
+
+(define trec-route-next-descendants
+ (compose trec-node-branches trec-route-last-node))
+
+(define trec-route-last-key
+ (compose trec-node-key trec-route-last-node))
+
+(define trec-route-nth-key
+ (lambda (route idx interesting-key?)
+ (let* ((keys (trec-route-filter-keys route interesting-key?))
+ (len (length keys)))
+ (list-ref keys (compensate-index idx len)))))
+
+(define trec-route-keys
+ (let ((collect? (compose not trec-route-root?)))
+ (lambda (route)
+ (trec-route-filter-keys route collect?))))
+
+(define trec-route-filter-keys
+ (lambda (route pred)
+ (let ((f (lambda (rest)
+ (let ((key (trec-route-last-key rest)))
+ (and (pred key)
+ key)))))
+ (filter-map-trec-route f route))))
+
+(define trec-route-value
+ (compose trec-node-val trec-route-last-node))
+
+(define trec-route-values
+ (lambda (route)
+ (let ((f (lambda (rest)
+ (or (and (trec-route-root? rest)
+ (not (last-pair? rest))
+ (trec-route-value (cdr rest)))
+ (and (eq? rest route)
+ (trec-route-value rest))))))
+ (filter-map-trec-route f route))))
+
+;; .returns (new-route . rejected-keys)
+(define trec-route-advance
+ (lambda (route router key)
+ (router route (trec-route-next-descendants route) key)))
+
+;; .returns (new-route . rejected-keys)
+(define trec-route-route
+ (lambda (route router keys)
+ (or (and-let* (((not (null? keys)))
+ (rt.rej (trec-route-advance route router (car keys)))
+ ((null? (cdr rt.rej)))) ;; successfully consumed the key
+ (trec-route-route (car rt.rej) router (cdr keys)))
+ (cons route keys))))
+
+(define trec-route-backtrack
+ (lambda (route)
+ (if (trec-route-initial? route)
+ (cons route #f)
+ (cons (cdr route)
+ (trec-route-last-key route)))))
+
+(define filter-map-trec-route
+ (lambda (f route)
+ (pair-fold (lambda (rest filtered)
+ (let ((mapped (f rest)))
+ (or (and mapped
+ (cons mapped filtered))
+ filtered)))
+ ()
+ route)))
+
+
+;;
+;; trec-context
+;;
+
+(define trec-context-rec-spec
+ '((route ())))
+(define-record 'trec-context trec-context-rec-spec)
+
+(define trec-context-initial? (compose trec-route-initial? trec-context-route))
+(define trec-context-goal? (compose trec-route-goal? trec-context-route))
+(define trec-context-keys (compose trec-route-keys trec-context-route))
+(define trec-context-values (compose trec-route-values trec-context-route))
+
+(define trec-context-reset!
+ (lambda (tc)
+ (trec-context-set-route! tc (trec-route-initial (trec-context-route tc)))))
+
+;; .returns rejected keys (null if no rejected keys), or #f if matching failed
+(define trec-context-advance!
+ (lambda (tc router key)
+ (and-let* ((rt.rej (trec-route-advance (trec-context-route tc) router key)))
+ (trec-context-set-route! tc (car rt.rej))
+ (cdr rt.rej))))
+
+;; .returns Retrieved key (not keys). #f if initial context
+(define trec-context-backtrack!
+ (lambda (tc)
+ (let ((rt.rej (trec-route-backtrack (trec-context-route tc))))
+ (trec-context-set-route! tc (car rt.rej))
+ (cdr rt.rej))))
+
+
+;;
+;; route transition drivers (router)
+;;
+
+;; a router returns (route . rejected-keys)
+
+;; 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)
+ ())))))))
+
+(define trec-router-advance-with-fallback-new
+ (lambda (base-router fallback-router)
+ (lambda (route cands key)
+ (or (base-router route cands key)
+ (fallback-router route cands key)))))
+
+;; FIXME: rename appropriately
+(define trec-make-node
+ (lambda (node matched key)
+ (cond
+ ((eq? matched TREC-MATCHER-FIN)
+ (cons key (cdr node)))
+ ((eq? matched TREC-MATCHER-RETRY)
+ (cons TREC-NULL-KEY (cdr node)))
+ (else
+ (let ((next-node (cons matched (cdr node))))
+ (list key TREC-NULL-VALUE next-node))))))
+
+;; TODO: simplify
+(define trec-router-std-advance-new
+ (lambda (matcher)
+ (define advance
+ (lambda (route cands key)
+ (and (not (null? cands))
+ (let ((node (car cands))
+ (rest (cdr cands)))
+ (or (if (trec-vnode? node)
+ (node advance route matcher key)
+ (and-let* ((matched (matcher (trec-node-key node) key))
+ (new-node (trec-make-node node matched key))
+ (advanced (cons (cons new-node rest)
+ route)))
+ (if (eq? matched TREC-MATCHER-RETRY)
+ (advance advanced
+ (trec-node-branches new-node) key)
+ (cons advanced ()))))
+ (advance route rest key))))))
+ advance))
+
+
+;;
+;; key matchers
+;;
+
+;; A matcher returns:
+;;
+;; TREC-MATCHER-FIN matched and the state transition has been finished
+;; TREC-MATCHER-RETRY matched and finished, and instructs that
+;; re-injecting of the last key for next key-matching
+;; <others> matched and transited to an intermediate state
+;; #f unmatched
+
+;; Dummy pairs are used to allocate unique ID without polluting namespace
+;; of symbols, or value space of numbers.
+(define TREC-MATCHER-FIN (cons #f #f))
+(define TREC-MATCHER-RETRY (cons #f #f))
+
+(define trec-matcher-terminal-state
+ (lambda (state)
+ (safe-car (memq state (list TREC-MATCHER-FIN
+ TREC-MATCHER-RETRY)))))
+
+(define trec-vkey? procedure?)
+
+(define trec-matcher-std-new
+ (lambda (match?)
+ (lambda (key-exp key)
+ (if (trec-vkey? key-exp)
+ (key-exp key-exp key)
+ (and (match? key-exp key)
+ TREC-MATCHER-FIN)))))
+
+
+;;
+;; virtual keys
+;;
+
+;; TODO: simplify
+;; .pre-condition matcher must be a trec-matcher-std
+(define trec-vkey-keyset-new
+ (lambda (matcher keyset)
+ (lambda (dummy-key-exp key)
+ (let retry ((rest-keys keyset))
+ (and-let* ((transit (lambda (key-exp)
+ (matcher key-exp key)))
+ (matched (find-map transit rest-keys))
+ (rest-keys (remove-once matcher rest-keys)))
+ (or (and (trec-matcher-terminal-state matched)
+ (or (and (null? rest-keys)
+ matched)
+ (and (eq? matched TREC-MATCHER-FIN)
+ (trec-vkey-keyset-new matcher rest-keys))
+ (and (eq? matched TREC-MATCHER-RETRY)
+ (retry rest-keys))))
+ (let ((rest-vkey (trec-vkey-keyset-new matcher rest-keys)))
+ (trec-vkey-keyseq-new matcher (list matched rest-vkey)))))))))
+
+;; TODO: simplify
+;; .pre-condition matcher must be a trec-matcher-std
+(define trec-vkey-keyseq-new
+ (lambda (matcher keyseq)
+ (lambda (dummy-key-exp key)
+ (let retry ((rest-seq keyseq))
+ (and-let* ((key-exp (safe-car rest-seq))
+ (matched (matcher key-exp key))
+ (rest-seq (cdr rest-seq)))
+ (or (and (trec-matcher-terminal-state matched)
+ (or (and (null? rest-seq)
+ matched)
+ (and (eq? matched TREC-MATCHER-FIN)
+ (trec-vkey-keyseq-new matcher rest-seq))
+ (and (eq? matched TREC-MATCHER-RETRY)
+ (retry rest-seq))))
+ (trec-vkey-keyseq-new matcher (cons matched rest-seq))))))))
+
+
+;;
+;; virtual nodes
+;;
+
+;; TODO: simplify
+(define trec-vnode-peek-new
+ (lambda (pregiven-keys)
+ (if (not (null? pregiven-keys))
+ (error "'peek' does not take arguments"))
+ (define make-vnode
+ (lambda (rule-key rule-val)
+ (lambda (router route matcher key)
+ (and-let* ((matched (matcher rule-key key)))
+ (cond
+ ((eq? matched TREC-MATCHER-FIN)
+ (cons (cons (list TREC-NULL-KEY rule-val)
+ route)
+ (list key)))
+ ((eq? matched TREC-MATCHER-RETRY)
+ (router (cons (list TREC-NULL-KEY rule-val)
+ route)
+ ()
+ key))
+ (else
+ (let ((next-node (make-vnode matched rule-val)))
+ (cons (cons (list TREC-NULL-KEY TREC-NULL-VALUE next-node)
+ route)
+ (list key)))))))))
+ make-vnode))
+
+;; TODO: simplify
+(define trec-make-vnode-recur-new
+ (lambda (join retry)
+ (lambda (pregiven-keys)
+ (define make-vnode
+ (lambda (rule-key rule-val)
+ (lambda (router route matcher key)
+ (and-let* ((matched (matcher rule-key key)))
+ (if (not (trec-matcher-terminal-state matched))
+ (let ((next-node (make-vnode matched rule-val)))
+ (cons (list key TREC-NULL-VALUE next-node)
+ route))
+ (let ((root (trec-route-last-root route))
+ (keys (if retry
+ (append pregiven-keys (list key))
+ pregiven-keys))
+ (node (cond
+ ((eq? matched TREC-MATCHER-FIN)
+ (list key rule-val))
+ ((eq? matched TREC-MATCHER-RETRY)
+ (list TREC-NULL-KEY rule-val)))))
+ (trec-route-route router
+ (if join
+ (cons* root node route)
+ root)
+ keys)))))))
+ make-vnode)))
+
+(define trec-vnode-join-new (trec-make-vnode-recur-new #f #f))
+(define trec-vnode-join-retry-new (trec-make-vnode-recur-new #f #t))
+(define trec-vnode-recur-new (trec-make-vnode-recur-new #t #f))
+(define trec-vnode-recur-retry-new (trec-make-vnode-recur-new #t #t))
+
+;; FIXME: resolve namespace pollution
+;; shortcut for rule path definition
+(define peek trec-vnode-peek-new)
+(define join trec-vnode-join-new)
+(define join-retry trec-vnode-join-retry-new)
+(define recur trec-vnode-recur-new)
+(define recur-retry trec-vnode-recur-retry-new)
+
+
+(if trec-enable-reroutable-search
+ (require "trec-reroutable.scm"))
More information about the uim-commit
mailing list