source: project/release/5/levenshtein/trunk/levenshtein-vector.scm @ 38890

Last change on this file since 38890 was 38890, checked in by Kon Lovett, 2 months ago

rm dep

File size: 10.5 KB
Line 
1;;;; levenshtein-vector.scm -*- Scheme -*-
2;;;; Kon Lovett, Mar '20
3;;;; Kon Lovett, Apr '12
4;;;; Kon Lovett, Sep '05
5
6(module levenshtein-vector
7
8(;export
9  levenshtein-distance/vector*)
10
11(import scheme)
12(import (chicken base))
13(import (chicken type))
14(import (chicken fixnum))
15(import (srfi 1))
16(import (srfi 63))
17(import vector-lib)
18(import type-checks)
19(import type-errors)
20(import levenshtein-operators)
21
22;;;
23
24;moremacros
25(define-syntax swap!
26  (syntax-rules ()
27    ((swap! ?a ?b)
28      (let (
29        (_tmp ?a) )
30        (set! ?a ?b)
31        (set! ?b _tmp)) ) ) )
32
33;; Types
34
35(define-type array (struct array))
36
37(: levenshtein-distance/vector* (vector vector #!rest -> number (or boolean array)))
38
39;;
40
41(define (vector-relop op vec)
42  (let ((len (vector-length vec)))
43    (if (zero? len)
44      (values #f #f)
45      (let ((idx 0)
46            (val (vector-ref vec 0)) )
47        (do ((i 1 (add1 i)))
48            ((= i len) (values val idx))
49          (let ((nval (vector-ref vec i)))
50            (unless (op val nval)
51              (set! idx i)
52              (set! val nval) ) ) ) ) ) ) )
53
54;;
55
56(define (levenshtein/vector sv tv n m cv av lv eqlp perf finf plus mult ltp)
57
58  (let ((wrkvec (make-vector (add1 m)))
59        (inscst (vector-ref cv 0))
60        (delcst (vector-ref cv 1)) )
61
62    (do ((k 0 (add1 k))
63         (cst 0 (plus cst inscst)))
64        ((> k m))
65      (vector-set! wrkvec k cst) )
66
67    (let ((next #f))
68
69      (do ((i 0 (add1 i)))
70          ((= i n) (finf next))
71
72        (let ((s-i (vector-ref sv i)))
73
74          (do ((j 0 (add1 j))
75               (cur (mult delcst (add1 i)) next))
76              ((= j m) (vector-set! wrkvec m next))
77
78            (let ((apply-oper
79                    (lambda (eo-i cost)
80                      (let ((a (vector-ref av eo-i))
81                            (l (vector-ref lv eo-i)))
82                        (if (zero? a)                                       ; A L
83                            (if (zero? l)                                   ; - -
84                                (plus cost (vector-ref wrkvec j))           ; 0 0
85                                (plus cost (vector-ref wrkvec (add1 j))))   ; 0 1
86                            (if (zero? l)                                   ;
87                                (plus cost cur)                             ; 1 0
88                                (let ((cost@ (vector-ref wrkvec j)))        ;
89                                  (if (eqlp s-i (vector-ref tv j))          ; 1 1
90                                      cost@
91                                      (plus cost cost@)))))))))
92
93              (let-values (((cost index)
94                            (vector-relop ltp (vector-map apply-oper cv))))
95                (perf i j index cost)
96                (set! next cost)
97                (vector-set! wrkvec j cur) ) ) ) ) ) ) ) )
98
99;;
100
101(define (levenshtein/matrix sv tv n m cv av lv eqlp perf finf plus mult ltp)
102
103  (let ((mat (make-array '#() (add1 n) (add1 m)))
104        (inscst (vector-ref cv 0))
105        (delcst (vector-ref cv 1)))
106
107    (do ((j 0 (add1 j))
108         (cst 0 (plus cst inscst)))
109        ((> j m))
110      (array-set! mat cst 0 j) )
111
112    (do ((i 1 (add1 i)))
113        ((> i n) (finf (array-ref mat n m)))
114
115      (array-set! mat (mult i delcst) i 0)
116
117      (let* ((i-1 (sub1 i))
118             (s-i (vector-ref sv i-1)) )
119
120        (do ((j 1 (add1 j)))
121            ((> j m))
122
123          (let* ((j-1 (sub1 j))
124                 (t-j (vector-ref tv j-1)) )
125
126            (let ((apply-oper
127                    (lambda (eo-i opercost)
128
129                      (let ((a (vector-ref av eo-i))
130                            (l (vector-ref lv eo-i)) )
131
132                        ; Must be within bounds of matrix
133                        (if (and (>= i a) (>= j l))
134
135                          (let ((currcost (array-ref mat (- i a) (- j l))))
136                            (cond
137
138                              ; Allow a no-op cost <> 0
139                              ((and (zero? a) (zero? l))
140                                (plus currcost opercost))
141
142                              ; Special case w/ test, simplified
143                              ((and (= a 1) (= l 1))
144                                (if (eqlp s-i t-j) currcost
145                                  (plus currcost opercost)))
146
147                              ; General case w/ test
148                              ((or (> a 1) (> l 1))
149                                (let ((x (plus currcost opercost)))
150                                  (unless (eqlp (vector-ref sv (- i a)) t-j)
151                                    (set! x (plus x opercost)))
152                                  (unless (eqlp s-i (vector-ref tv (- j l)))
153                                    (set! x (plus x opercost)))
154                                  x))
155
156                              ; Otherwise a = 0|1 & l = 1|0
157                              (else
158                                (plus currcost opercost) ) ) )
159
160                          ; Does this make sense when operation would violate mat bounds?
161                          ; Also out of fixnum range.
162                          +inf.0)))))
163
164              (let-values (((cost index)
165                            (vector-relop ltp (vector-map apply-oper cv))))
166
167                ; Performed operation matrix is 0-based
168                (perf i-1 j-1 index cost)
169                (array-set! mat cost i j) ) ) ) ) ) ) ) )
170
171;;;
172
173#|
174Discussion -
175
176  Inputs -
177
178    UTF8 character encoding
179
180    String, Vector, List
181
182    Edit Operation Specification
183
184    Linear Gap Cost Specification
185
186      - Run of insertions (or deletions) of length x, has a cost
187      of ax+b, for constants a and b. If b>0, this penalises
188      numerous short runs of insertions and deletions.
189
190    Cost limiting
191
192    Common prefix/suffix stripping
193
194  Outputs -
195
196    Total Cost
197
198    Cost of Each Performed Operation
199
200    Each Performed Operation
201
202    Linear Gap Cost
203|#
204
205(define (levenshtein-distance/vector* srcvec trgvec
206          #!rest operlist
207          #!key
208          operations
209          (eqlp char=?)
210          (mult fx*)
211          (plus fx+)
212          (ltp fx<))
213
214  (check-vector 'levenshtein-distance/vector* srcvec "source")
215  (check-vector 'levenshtein-distance/vector* trgvec "target")
216  (check-procedure 'levenshtein-distance/vector* eqlp "eqlp")
217  (check-procedure 'levenshtein-distance/vector* mult "mult")
218  (check-procedure 'levenshtein-distance/vector* plus "plus")
219  (check-procedure 'levenshtein-distance/vector* ltp "ltp")
220
221  ; Note that the edit-distance procedures
222  ; return via the (finf) procedure.
223  (let* ((operlist (filter levenshtein-operator? operlist)) ;only opers
224         (opervec (levenshtein-base-operators-vector))
225         (insoper (vector-ref opervec 0)) )
226
227    ; List of edit operations?
228    (unless (null? operlist)
229      ; Verify valid operators
230      (for-each
231        (cut check-levenshtein-operator 'levenshtein-distance/vector* <>)
232        operlist)
233      (set! opervec (list->vector operlist))
234      ; Insert operator must be 1st in vector
235      (let ((idx (vector-index levenshtein-insert-operator? opervec)))
236        (cond
237          ((not idx)
238            (set! idx (vector-length opervec))
239            (set! opervec (vector-append opervec (vector insoper)))
240            (vector-swap! opervec 0 idx))
241          ((positive? idx)
242            (vector-swap! opervec 0 idx))))
243      (set! insoper (vector-ref opervec 0))
244      ; Delete operator must be 2nd in vector
245      (let ((idx (vector-index levenshtein-delete-operator? opervec)))
246        (cond
247          ((not idx)
248            (set! idx (vector-length opervec))
249            (set! opervec
250              (vector-append
251                opervec
252                (vector (vector-ref (levenshtein-base-operators-vector) 1))))
253            (vector-swap! opervec 1 idx))
254          ((> idx 1) ;can't be zero, see above
255            (vector-swap! opervec 1 idx)))))
256
257      ; Setup for no operation introspection
258    (let ((srclen (vector-length srcvec))
259          (trglen (vector-length trgvec))
260          (perf void)             ; Perform operation accumulate
261          (finf                   ; Finish, "identity"
262            (lambda (cost) (values cost #f)))
263          (zrtf                   ; Zero-length, assume 'finf' binding to "identity"
264            (lambda (len) (mult len (levenshtein-operator-cost insoper)))))
265
266      ; Use shorter as the target
267      (when (< srclen trglen)
268        (swap! srclen trglen)
269        (swap! srcvec trgvec))
270
271      ; Setup callback & return procedures for performed operations matrix
272      ; should caller want operation introspection
273      (when operations
274        (if (and (zero? srclen) (zero? trglen))
275            ;then degenerate case
276            (set! zrtf
277              (lambda (x)
278                (values 0 (make-array '#() 0 0))))
279            ;else source or target non-empty
280            (let ((pm #f)
281                  (pm-rows (max 1 srclen))
282                  (pm-cols (max 1 trglen)))
283              (set! pm
284                (make-array '#() pm-rows pm-cols))
285              (set! perf
286                (lambda (i j ovi cost)
287                  (array-set! pm (cons cost (vector-ref opervec ovi)) i j)))
288              (set! finf
289                (lambda (cost)
290                  (values cost pm)))
291              (set! zrtf
292                (lambda (len)
293                  (let ((io-c (levenshtein-operator-cost insoper)))
294                    (do ((i 0 (add1 i))
295                          (i-cost io-c (plus i-cost io-c)))
296                        ((= i pm-rows))
297                      (do ((j 0 (add1 j))
298                            (j-cost i-cost (plus j-cost io-c)))
299                          ((= j pm-cols))
300                        (perf i j 0 j-cost)))
301                    (finf (mult io-c len))))))))
302
303      ; Unpack edit operation offsets
304      (let ((cstvec (vector-map (lambda (i eo) (levenshtein-operator-cost eo)) opervec))
305            (abvvec (vector-map (lambda (i eo) (levenshtein-operator-above eo)) opervec))
306            (lftvec (vector-map (lambda (i eo) (levenshtein-operator-left eo)) opervec)))
307
308        ; Handle empty source/target special case, then choose algorithm based
309        ; on complexity of edit operations
310        (cond
311          ((zero? srclen)
312            (zrtf trglen))
313          ((zero? trglen)
314            (zrtf srclen))
315          ((or (null? operlist)
316               (every levenshtein-base-operator? operlist))
317            (levenshtein/vector
318              srcvec trgvec srclen trglen
319              cstvec abvvec lftvec eqlp perf finf plus mult ltp))
320          (else
321            (levenshtein/matrix
322              srcvec trgvec srclen trglen
323              cstvec abvvec lftvec eqlp perf finf plus mult ltp))) ) ) ) )
324
325) ;module levenshtein-vector
Note: See TracBrowser for help on using the repository browser.