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

Last change on this file since 38337 was 38337, checked in by Kon Lovett, 7 months ago

add -operators types, levenshtein-distance/vector* -> number (or boolean array) - 2 values only (nobody uses this (?) so not major)

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