source: project/release/4/trie/trunk/trie.scm @ 25594

Last change on this file since 25594 was 25594, checked in by Ivan Raikov, 9 years ago

initial import of a trie implementation

File size: 5.7 KB
Line 
1;;
2;;
3;; An implementation of tries, a data type for representing sets of
4;; lists efficiently, provided there is an ordering relation on the
5;; elements of lists.
6;;
7;; Copyright 2011 Ivan Raikov and the Okinawa Institute of Science and
8;; Technology.
9;;
10;;
11;; A trie is a tree with arcs labeled by elements from the element
12;; type of the lists and with branches ordered on the basis of their
13;; arc labels; moreover, only one branch per distinct label value is
14;; allowed per node.  Ends of lists are designated by an "EOL" marker;
15;; a value may be associated with the EOL symbol.
16;;
17;;
18
19(module trie
20       
21        ( make-trie trie-equal? )
22
23        (import scheme chicken)
24        (require-library srfi-1 data-structures)
25        (import (only srfi-1 every)
26                (only data-structures identity))
27        (require-extension datatype matchable)
28
29
30(define (list-of pred) (lambda (x) (every pred x)))
31       
32(define-datatype branch branch?
33  (EOL (v identity))
34  (BRN (label identity) 
35       (branches (list-of branch?))))
36
37(define trie?  (list-of branch?))
38
39
40(define (trie-equal? t1 t2)
41  (let ((t1 (t1 'repr)) (t2 (t2 'repr)))
42    (let ((aeq (car t1)) (tr1 (caddr t1))
43          (beq (car t2)) (tr2 (caddr t2)))
44      (let recur ((tr1 tr1) (tr2 tr2))
45        (match (list tr1 tr2)
46               ((() ())   #t)
47               (((($ branch 'EOL b1) . tr1) (($ branch 'EOL b2) . tr2))
48                (and (beq b1 b2) (recur tr1 tr2)))
49               (((($ branch 'BRN a1 tr11) . tr1) (($ branch 'BRN a2 tr21) . tr2))
50                (and (aeq a1 a2) (recur tr11 tr21) (recur tr1 tr2)))
51               (else #f))
52        ))
53    ))
54
55
56(define (make-trie leq key->list . rest)
57 
58  (let-optionals rest ((tr '()))
59
60  (assert (trie? tr))
61
62  (define empty '())
63
64  ;; Inserts list into tr and associates bval with the EOL indicator for the list
65
66  (define (insert lst bval tr)
67    (match (list lst bval tr)
68           
69           ((() b ())         
70            (list (EOL b)))
71           
72           (((a . t) b ())     
73            (list (BRN a (insert t b '()))))
74           
75           ((() b (($ branch 'EOL _) . _)) 
76            (error 'insert "element already in tree" ))
77           
78           (((and a (_ . _)) b (($ branch 'EOL b1) . tr)) 
79            (cons (EOL b1) (insert a b tr)))
80           
81           ((() b tr) 
82            (cons (EOL b) tr))
83           
84           (((and al (a . t)) b (and tr (($ branch 'BRN a1 tr1) . tr2)))
85            (if (leq  a a1)
86                (if (leq a1 a) 
87                    (cons (BRN a1 (insert t b tr1)) tr2)
88                    (cons (BRN a  (insert t b '())) tr))
89                (cons (BRN a1 tr1) (insert al b tr2))
90                ))
91           ))
92   
93
94  ;; Returns the value associated with lst in tr
95  (define (lookup k tr . rest)
96    (let-optionals rest ((partial #f))
97       (let recur ((lst k) (tr tr))
98         (match (list lst tr)
99              ((_ ())  (error 'lookup "not found" k))
100             
101              ((() (($ branch 'EOL b) . tr)) 
102               b)
103             
104              (((and al (_ . _)) (($ branch 'EOL _) . tr)) 
105               (recur al tr))
106             
107              ((() tr) 
108               (if (not partial)
109                   (error 'lookup "not found" k)
110                   (partial tr)
111                   ))
112             
113              (((and al (a . t)) (($ branch 'BRN a1 tr1) . tr2))
114               (if (leq a a1)
115                   (if (leq a1 a) 
116                       (recur t tr1)
117                       (error 'lookup "not found" k))
118                   (recur al tr2)))
119              ))
120       ))
121
122  ;; Removes lst from tr.  Any branches having a null subtrie
123  ;; associated with them are deleted.
124
125  (define (remove lst tr)
126    (match (list lst tr)
127           ((() ((EOL _) . tr1)) 
128            tr1)
129
130           (((and al (_ . _)) (($ branch 'EOL b) . tr1))
131            (cons (EOL b) (remove al tr1)))
132
133           ((() tr1)  tr1)
134
135           (((and al (a . t)) (and tr (($ branch 'BRN a1 tr1) . tr2)))
136            (if (leq a a1)
137                (if (leq a1 a)
138                    (let ((tr3  (remove t tr1)))
139                      (if (null? tr3) tr2 (cons (BRN a1 tr3) tr2)))
140                    tr)
141                (cons (BRN a1 tr1) (remove al tr2))))
142           ))
143
144  ;; Merges tr1 and tr2.  If there is a list that appears in both
145  ;; tries, an exception is raised.
146
147  (define (merge tr1 tr2)
148    (match (list tr1 tr2)
149           
150           ((()  tr2)  tr2)
151           ((tr1 ())   tr1)
152
153           (((($ branch 'EOL b1) . _) (($ branch 'EOL _) . _))
154            (error "already in trie" tr1 tr2))
155
156           (((($ branch 'EOL b1) . tr11) tr2)
157            (cons (EOL b1) (merge tr11 tr2)))
158
159           ((tr1 (($ branch 'EOL b2) . tr21))
160            (cons (EOL b2) (merge tr1 tr21)))
161
162           (((and tr1 (($ branch 'BRN a1 tr11) . tr12))
163             (and tr2 (($ branch 'BRN a2 tr21) . tr22))) 
164            (if (leq a1 a2)
165                (if (leq a2 a1)
166                    (cons (BRN a1 (merge tr11 tr21)) (merge  tr12 tr22))
167                    (cons (BRN a1 tr11) (merge  tr12 tr2)))
168                (cons (BRN a2 tr21) (merge tr1 tr22))))
169           ))
170
171
172  ;; Splits tr into three tries on the basis of a.  The first trie
173  ;; consists of branches headed by actions less than a (plus any EOL
174  ;; symbol), the second contains the branch (if any) associated with a,
175  ;; and the third consists of branches headed by actions greater than a.
176
177  (define (partition a tr)
178    (match (list tr a)
179           ((() a)  (list '() '() '()))
180           
181           (((($ branch 'EOL b) . tr1) a)
182            (match-let (((tr1 tr2 tr3)  (partition a tr1)))
183                       (list (cons (EOL b) tr1) tr2 tr3)))
184
185           (((and tr (($ branch 'BRN a1 tr1) . tr2)) a)
186            (if (leq a a1)
187                (if (leq a1 a)
188                    (list '() (list (BRN a tr1)) tr2)
189                    (list '() '() tr))
190                (match-let (((tr1 tr2 tr3)  (partition a tr2)))
191                           (list (cons (BRN a1 tr1) tr1) tr2 tr3))))
192           ))
193
194
195 
196  ;; Message dispatcher
197  (lambda (selector)
198    (case selector
199         
200      ((insert) 
201       (lambda (k bval) (make-trie leq key->list (insert (key->list k) bval tr))))
202
203      ((lookup) 
204       (lambda (k) (lookup (key->list k) tr)))
205
206      ((lookup/partial) 
207       (lambda (k)
208         (let ((v (lookup (key->list k) tr identity)))
209           (if (trie? v) 
210               (make-trie leq key->list v)
211               v))))
212
213      ((remove) 
214       (lambda (k) (make-trie leq key->list (remove (key->list k) tr))))
215
216      ((merge) 
217       (lambda (x) (make-trie leq key->list (merge tr x))))
218
219      ((partition) 
220       (lambda (a) (partition a tr)))
221
222      ((repr) 
223       (lambda () (list leq key->list tr)))
224
225      ))
226  ))
227
228
229)
Note: See TracBrowser for help on using the repository browser.