source: project/release/3/levenshtein/trunk/levenshtein-path-iterator.scm @ 8913

Last change on this file since 8913 was 8913, checked in by Kon Lovett, 12 years ago

Canon dir struct

File size: 3.3 KB
Line 
1;;;; levenshtein-path-iterator.scm
2;;;; Kon Lovett, Sep 16 2005
3
4(use srfi-1 array-lib miscmacros misc-extn-numeric)
5
6(eval-when (compile)
7        (declare
8                (not usual-integrations
9                        + * = < zero?)
10                (inline)
11                (no-procedure-checks)
12                (no-bound-checks)
13                (export
14                        levenshtein-path-iterator) ) )
15
16;; (levenshtein-path-iterator MATRIX)
17;;
18;; Creates an optimal edit distance operation path iterator over the
19;; edit operation matrix MATRIX. The matrix is usually the result of an
20;; invocation of '(levenshtein ... operations: #t)'.
21;;
22;; Each invocation of the iterator will generate a list of the form:
23;; ((cost source-index target-index levenshtein-operator) ...). The last
24;; invocation will return #f.
25;;
26;; Note: The iterator will return, w/ #f, to the initial caller. Saving the result of the 1st
27;; invocation is not obvious.
28;;
29;; (define r0 (iter))
30;; (define t r0)
31;; ... (iter) until it quits
32;; r0 now has #f, since the iterator finishes by returning to the initial caller, which is the
33;; body of '(define r0 (iter))', thus re-binding r0. However, t has the original returned value.
34
35(define levenshtein-path-iterator
36        (let ([trim-path
37                                        (lambda (path)
38                                                (let ([cost -inf.0])
39                                                        (delete! #f
40                                                                (map-in-order
41                                                                        (lambda (elm)
42                                                                                (let ([elm-cost (car elm)])
43                                                                                        (if (or (zero? elm-cost) (= cost elm-cost))
44                                                                                                #f
45                                                                                                (begin (set! cost elm-cost) elm) ) ) )
46                                                                        path)
47                                                                eq?) ) )])
48                (lambda (pm)
49                        (unless (fx= 2 (array-rank pm))
50                                (error 'levenshtein-path-iterator "not a rank 2 array" pm))
51                        (let ([nXm (array-bounds pm)])
52                                (let ([n (cdar nXm)]
53                                                        [m (cdadr nXm)]
54                                                        [cost@
55                                                                (lambda (i j)
56                                                                        (if (or (fx< i 0) (fx< j 0))
57                                                                                +inf.0
58                                                                                (car (array-ref pm i j)) ) )])
59                                                (letrec ([generator
60                                                                                        (lambda (yielder)
61                                                                                                (let ([yield
62                                                                                                                                (lambda (value)
63                                                                                                                                        (let/cc continue
64                                                                                                                                                (set! generator
65                                                                                                                                                        (lambda (k)
66                                                                                                                                                                (set! yielder k)
67                                                                                                                                                                (continue value)))
68                                                                                                                                                (yielder value)))])
69                                                                                                        (let try ([i n] [j m] [path '()])
70                                                                                                                (and
71                                                                                                                        (and (fx<= 0 i) (fx<= 0 j))
72                                                                                                                        (let* ([o (array-ref pm i j)]
73                                                                                                                                                [oc (car o)]
74                                                                                                                                                [oo (cdr o)]
75                                                                                                                                                [np (cons (list oc i j oo) path)])
76                                                                                                                                (if (and (fx= 0 i) (fx= 0 j))
77                                                                                                                                        (begin
78                                                                                                                                                (yield (trim-path np))
79                                                                                                                                                #f)
80                                                                                                                                        (let ([ai (fx-- i)]
81                                                                                                                                                                [lj (fx-- j)]
82                                                                                                                                                                [better #f])
83                                                                                                                                                (when (< (cost@ i lj) oc)
84                                                                                                                                                        (set! better #t)
85                                                                                                                                                        (try i lj np))
86                                                                                                                                                (when (< (cost@ ai j) oc)
87                                                                                                                                                        (set! better #t)
88                                                                                                                                                        (try ai j np))
89                                                                                                                                                (when (< (cost@ ai lj) oc)
90                                                                                                                                                        (set! better #t)
91                                                                                                                                                        (try ai lj np))
92                                                                                                                                                (unless better
93                                                                                                                                                        (when (= (cost@ i lj) oc)
94                                                                                                                                                                (try i lj np))
95                                                                                                                                                        (when (= (cost@ ai j) oc)
96                                                                                                                                                                (try ai j np))
97                                                                                                                                                        (when (= (cost@ ai lj) oc)
98                                                                                                                                                                (try ai lj np)))
99                                                                                                                                                #f)))))))])
100                                                        (lambda ()
101                                                                (let/cc yielder
102                                                                        (generator yielder) ) ) ) ) ) ) ) )
Note: See TracBrowser for help on using the repository browser.