source: project/release/4/suffix-tree/trunk/suffix-tree.scm @ 30125

Last change on this file since 30125 was 30125, checked in by Ivan Raikov, 7 years ago

suffix-tree: added more examples

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