Changeset 25777 in project


Ignore:
Timestamp:
01/07/12 06:41:00 (9 years ago)
Author:
Ivan Raikov
Message:

suffix-tree: abandoned messaging interface in favor of direct routines

Location:
release/4/suffix-tree/trunk
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • release/4/suffix-tree/trunk/suffix-tree.scm

    r25759 r25777  
    1919(module suffix-tree
    2020       
    21         ( make-suffix-tree suffix-tree-equal? )
     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 suffix-tree-branch-eol )
    2227
    2328        (import scheme chicken)
     
    3742(define suffix-tree?  (list-of branch?))
    3843
     44(define-record-type suffix-tree
     45  (make-suffix-tree1 leq key->list branches)
     46  suffix-tree?
     47  (leq suffix-tree-compfn)
     48  (key->list suffix-tree-keyfn)
     49  (branches suffix-tree-branches)
     50  )
     51
     52(define (suffix-tree-branch-label b)
     53  (match b (($ branch 'BRN l bs) l)
     54         (else (error 'suffix-tree-branch-label "invalid branch" b))))
     55
     56(define (suffix-tree-branch-children b)
     57  (match b (($ branch 'BRN l bs) bs)
     58         (else (error 'suffix-tree-branch-children "invalid branch" b))))
     59
     60(define (suffix-tree-branch-eol b)
     61  (match b (($ branch 'BRN l (($ branch 'EOL v))) v)
     62         (else #f)))
     63
    3964
    4065(define (suffix-tree-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))
     66  (let ((aeq (suffix-tree-compfn t1))
     67        (tr1 (suffix-tree-branches t1))
     68        (beq (suffix-tree-compfn t2))
     69        (tr2 (suffix-tree-branches t2)))
     70    (let recur ((tr1 tr1) (tr2 tr2))
    4571        (match (list tr1 tr2)
    4672               ((() ())   #t)
     
    5076                (and (aeq a1 a2) (recur tr11 tr21) (recur tr1 tr2)))
    5177               (else #f))
     78        )))
     79
     80
     81(define (make-suffix-tree leq key->list . rest)
     82  (make-suffix-tree1 leq key->list '()))
     83
     84(define (update-branches branches tree)
     85  (make-suffix-tree1 (suffix-tree-compfn tree)
     86                     (suffix-tree-keyfn tree)
     87                     branches))
     88
     89;; Inserts list into tr and associates bval with the EOL indicator for the list
     90
     91(define (suffix-tree-insert key bval tr)
     92
     93  (let ((lst ((suffix-tree-keyfn tr) key)))
     94
     95    (if (null? lst)
     96        (error 'suffix-tree-insert "empty input list"))
     97
     98    (let ((leq (suffix-tree-compfn tr)))
     99   
     100      (let ((branches
     101
     102             (let recur ((lst lst)
     103                         (bval bval)
     104                         (tr (suffix-tree-branches tr)))
     105             
     106               (match (list lst bval tr)
     107                 
     108                      ((() b ())         
     109                       (list (EOL b)))
     110                     
     111                      (((a . t) b ())     
     112                       (list (BRN a (recur t b '()))))
     113                     
     114                      ((() b (($ branch 'EOL _) . _))
     115                       (error 'insert "element already in tree" ))
     116                     
     117                      (((and a (_ . _)) b (($ branch 'EOL b1) . tr))
     118                       (cons (EOL b1) (recur a b tr)))
     119                     
     120                      ((() b tr)
     121                       (cons (EOL b) tr))
     122                     
     123                      (((and al (a . t)) b (and tr (($ branch 'BRN a1 tr1) . tr2)))
     124                       (if (leq  a a1)
     125                           (if (leq a1 a)
     126                               (cons (BRN a1 (recur t b tr1)) tr2)
     127                               (cons (BRN a  (recur t b '())) tr))
     128                           (cons (BRN a1 tr1) (recur al b tr2))
     129                           ))
     130                      ))
     131             ))
     132
     133        (update-branches branches tr)
     134
    52135        ))
    53136    ))
    54 
    55 
    56 (define (make-suffix-tree leq key->list . rest)
    57137 
    58   (let-optionals rest ((tr '()))
    59 
    60   (assert (suffix-tree? 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            ))
    92138   
    93139
    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))
     140;; Returns the value associated with lst in tr
     141(define (suffix-tree-lookup k t . rest)
     142 
     143  (let-optionals rest ((partial #f))
     144     
     145     (let ((leq (suffix-tree-compfn t)))
     146                   
     147       (let recur ((lst ((suffix-tree-keyfn t) k))
     148                   (tr (suffix-tree-branches t)))
     149
    98150         (match (list lst tr)
    99               ((_ ())  (error 'lookup "not found" k))
     151
     152              ((_ ())  (error 'suffix-tree-lookup "not found" k))
    100153             
    101154              ((() (($ branch 'EOL b) . tr)) 
     
    107160              ((() tr)
    108161               (if (not partial)
    109                    (error 'lookup "not found" k)
    110                    (partial tr)
     162                   (error 'suffix-tree-lookup "not found" k)
     163                   (partial (update-branches tr t))
    111164                   ))
    112165             
     
    115168                   (if (leq a1 a)
    116169                       (recur t tr1)
    117                        (error 'lookup "not found" k))
     170                       (error 'suffix-tree-lookup "not found" k))
    118171                   (recur al tr2)))
    119172              ))
    120        ))
    121 
    122   ;; Removes lst from tr.  Any branches having a null subsuffix-tree
    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))))
     173       )))
     174
     175;; Removes lst from tr.  Any branches having a null subsuffix-tree
     176;; associated with them are deleted.
     177
     178(define (suffix-tree-remove k tr)
     179
     180  (let ((leq (suffix-tree-compfn tr)))
     181   
     182    (let ((branches
     183
     184           (let recur ((k ((suffix-tree-keyfn tr) k))
     185                       (tr (suffix-tree-branches tr)))
     186
     187           (match (list k tr)
     188                 
     189                  ((() (($ branch 'EOL _) . tr1))
     190                   tr1)
     191                 
     192                  (((and al (_ . _)) (($ branch 'EOL b) . tr1))
     193                   (cons (EOL b) (recur al tr1)))
     194                 
     195                  ((() tr1)  tr1)
     196                 
     197                  (((and al (a . t)) (and tr (($ branch 'BRN a1 tr1) . tr2)))
     198                   (if (leq a a1)
     199                       (if (leq a1 a)
     200                           (let ((tr3  (recur t tr1)))
     201                             (if (null? tr3) tr2 (cons (BRN a1 tr3) tr2)))
     202                           tr)
     203                       (cons (BRN a1 tr1) (recur al tr2))))
     204                  ))
    142205           ))
    143 
    144   ;; Merges tr1 and tr2.  If there is a list that appears in both
    145   ;; suffix-trees, an exception is raised.
    146 
    147   (define (merge tr1 tr2)
    148     (match (list tr1 tr2)
     206      (update-branches branches tr)
     207      )))
     208       
     209;; Merges tr1 and tr2.  If there is a list that appears in both
     210;; suffix-trees, an exception is raised.
     211
     212(define (suffix-tree-merge tr1 tr2)
     213
     214  (let ((leq (suffix-tree-compfn tr1)))
     215
     216    (let ((branches
     217
     218           (let recur ((tr1 (suffix-tree-branches tr1))
     219                       (tr2 (suffix-tree-branches tr2)))
     220
     221             (match (list tr1 tr2)
     222                 
     223                  ((()  tr2)  tr2)
     224                  ((tr1 ())   tr1)
     225                 
     226                  (((($ branch 'EOL b1) . _) (($ branch 'EOL _) . _))
     227                   (error 'suffix-tree-merge "already in suffix-tree" tr1 tr2))
     228                 
     229                  (((($ branch 'EOL b1) . tr11) tr2)
     230                   (cons (EOL b1) (recur tr11 tr2)))
     231                 
     232                  ((tr1 (($ branch 'EOL b2) . tr21))
     233                   (cons (EOL b2) (recur tr1 tr21)))
     234                 
     235                  (((and tr1 (($ branch 'BRN a1 tr11) . tr12))
     236                    (and tr2 (($ branch 'BRN a2 tr21) . tr22)))
     237                   (if (leq a1 a2)
     238                       (if (leq a2 a1)
     239                           (cons (BRN a1 (recur tr11 tr21)) (recur  tr12 tr22))
     240                           (cons (BRN a1 tr11) (recur  tr12 tr2)))
     241                       (cons (BRN a2 tr21) (recur tr1 tr22))))
     242                  ))))
     243
     244      (update-branches branches tr1)
     245      )))
     246
     247
     248;; Splits tr into three suffix-trees on the basis of a.  The first suffix-tree
     249;; consists of branches headed by actions less than a (plus any EOL
     250;; symbol), the second contains the branch (if any) associated with a,
     251;; and the third consists of branches headed by actions greater than a.
     252
     253(define (suffix-tree-partition a tr)
     254
     255  (let ((leq (suffix-tree-compfn tr)))
     256
     257    (let recur ((a a) (tr (suffix-tree-branches tr)))
     258
     259      (match (list tr a)
    149260           
    150            ((()  tr2)  tr2)
    151            ((tr1 ())   tr1)
    152 
    153            (((($ branch 'EOL b1) . _) (($ branch 'EOL _) . _))
    154             (error "already in suffix-tree" 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 suffix-trees on the basis of a.  The first suffix-tree
    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)
    179261           ((() a)  (list '() '() '()))
    180262           
    181263           (((($ branch 'EOL b) . tr1) a)
    182             (match-let (((tr1 tr2 tr3)  (partition a tr1)))
     264            (match-let (((tr1 tr2 tr3)  (recur a tr1)))
    183265                       (list (cons (EOL b) tr1) tr2 tr3)))
    184 
     266           
    185267           (((and tr (($ branch 'BRN a1 tr1) . tr2)) a)
    186268            (if (leq a a1)
     
    188270                    (list '() (list (BRN a tr1)) tr2)
    189271                    (list '() '() tr))
    190                 (match-let (((tr1 tr2 tr3)  (partition a tr2)))
    191                            (list (cons (BRN a1 tr1) tr1) tr2 tr3))))
    192            ))
     272                (match-let (((tr1 tr2 tr3)  (recur a tr2)))
     273                         (list (cons (BRN a1 tr1) tr1) tr2 tr3))))
     274           )
     275    )))
    193276
    194277
    195278 
    196   ;; Message dispatcher
    197   (lambda (selector)
    198     (case selector
    199          
    200       ((insert)
    201        (lambda (k bval) (make-suffix-tree 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 (suffix-tree? v)
    210                (make-suffix-tree leq key->list v)
    211                v))))
    212 
    213       ((remove)
    214        (lambda (k) (make-suffix-tree leq key->list (remove (key->list k) tr))))
    215 
    216       ((merge) 
    217        (lambda (x) (make-suffix-tree 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   ))
     279(define (suffix-tree-lookup/partial k tr)
     280  (suffix-tree-lookup k tr identity))
    227281
    228282
  • release/4/suffix-tree/trunk/suffix-tree.setup

    r25761 r25777  
    1616 
    1717  ; Assoc list with properties for your extension:
    18   '((version 1.0)
     18  '((version 2.0)
    1919    ))
    2020
  • release/4/suffix-tree/trunk/tests/run.scm

    r25759 r25777  
    33(define t (make-suffix-tree char=? string->list ))
    44
    5 (define t1 ((t 'insert) "key1" 'test1))
    6 (define t2 ((t1 'insert) "key2" 'test2))
     5(define t1 (suffix-tree-insert "key1" 'test1 t))
     6(define t2 (suffix-tree-insert "key2" 'test2 t1))
    77
    8 (assert (equal? 'test1 ((t1 'lookup)  "key1")))
    9 (assert (equal? 'test2 ((t2 'lookup)  "key2")))
     8(assert (equal? 'test2 (suffix-tree-lookup "key2" t2)))
     9(assert (equal? 'test1 (suffix-tree-lookup "key1" t1)))
    1010
    11 (define t3 ((t2 'lookup/partial)  "key"))
     11(define t3 (suffix-tree-lookup/partial  "key" t2))
    1212
    13 (assert (equal? 'test1 ((t3 'lookup)  "1")))
    14 (assert (equal? 'test2 ((t3 'lookup)  "2")))
     13(assert (equal? 'test1 (suffix-tree-lookup "1" t3)))
     14(assert (equal? 'test2 (suffix-tree-lookup "2" t3)))
     15
Note: See TracChangeset for help on using the changeset viewer.