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

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

rm dep

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