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