source: project/release/5/levenshtein/trunk/levenshtein-sequence-functor.scm @ 38477

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

updae comment, appropriate optimization with rt type-checks, add check-sequence

File size: 6.9 KB
Line 
1;;;; levenshtein-sequence-functor.scm -*- Scheme -*-
2;;;; Kon Lovett, Mar '20
3;;;; Kon Lovett, Apr '12
4;;;; Kon Lovett, May '06
5
6;; Issues
7;;
8;; - When insert-cost <> delete-cost is the initialization of the work-vector correct?
9;; What about when we swap the source & target?
10;;
11;; - Don't have a "real" sequence abstraction, only recognizes vector, list, and string.
12;; What about byte-vector, u8vector, ..., and stream?
13
14(include "levenshtein-cost-interface")
15(include "levenshtein-sequence-interface")
16
17(functor (levenshtein-sequence-functor (CO COST-OPER) (SO SEQUENCE-OPER))
18
19(;export
20  levenshtein-distance/sequence)
21
22(import scheme)
23(import (chicken base))
24(import (chicken type))
25(import (srfi 1))
26(import (srfi 63))
27(import vector-lib)
28(import miscmacros)
29(import moremacros)
30(import numeric-macros)
31(import type-checks)
32(import type-errors)
33(import levenshtein-operators)
34(import CO)
35(import SO)
36;;;
37
38(define (levenshtein-distance/sequence source target
39          #!key
40          (insert-cost 1) (delete-cost 1) (substitute-cost 1)
41          (get-work-vector make-vector)
42          (elm-eql eqv?)
43          (limit-cost #f))
44
45  ; Validate
46  (check-sequence 'levenshtein-distance/generic-sequence source)
47  (check-sequence 'levenshtein-distance/generic-sequence target)
48  (check-procedure 'levenshtein-distance/generic-sequence elm-eql "elm-eql")
49  (check-procedure 'levenshtein-distance/generic-sequence get-work-vector "get-work-vector")
50
51  ;
52  (let ((source-length (sequence-length source))
53        (target-length (sequence-length target)))
54
55    (cond
56
57      ; Quit when source or target empty
58      ((zero? source-length)
59        (cost-multiply target-length insert-cost))
60      ((zero? target-length)
61        (cost-multiply source-length insert-cost))
62
63      ; Otherwise need to calculate distance
64      (else
65
66        ; "Strip" common prefix & suffix
67        (let ((prefix-length (sequence-prefix-length elm-eql source target))
68              (suffix-length (sequence-suffix-length elm-eql source target)))
69
70          (let ((stripped-source-start prefix-length)
71                (stripped-source-end (- source-length suffix-length))
72                (stripped-target-start prefix-length)
73                (stripped-target-end (- target-length suffix-length)))
74
75            (let ((stripped-source-length (- stripped-source-end stripped-source-start))
76                  (stripped-target-length (- stripped-target-end stripped-target-start)))
77
78              ; Prefix overlaps suffix?
79              (unless (and (<= 0 stripped-source-length) (<= 0 stripped-target-length))
80
81                ; Use the longest match & revert to the full string otherwise
82                (if (< prefix-length suffix-length)
83                  (begin
84                    (set! stripped-source-start 0)
85                    (set! stripped-target-start 0))
86                  (begin
87                    (set! stripped-source-end source-length)
88                    (set! stripped-target-end target-length)))
89
90                ; Re-calc stripped lengths
91                (set! stripped-source-length (- stripped-source-end stripped-source-start))
92                (set! stripped-target-length (- stripped-target-end stripped-target-start)))
93
94              (cond
95
96                ; Stripped source or target empty?
97                ((zero? stripped-source-length)
98                  (cost-multiply stripped-target-length insert-cost))
99                ((zero? stripped-target-length)
100                  (cost-multiply stripped-source-length insert-cost))
101
102                ; Otherwise need to calculate distance
103                (else
104
105                  ; Perform distance calculation on "stripped" source & target
106                  (let ((source
107                          (subsequence/shared source stripped-source-start stripped-source-end))
108                        (target
109                          (subsequence/shared target stripped-target-start stripped-target-end))
110                        (source-length stripped-source-length)
111                        (target-length stripped-target-length))
112
113                    ; Swap so target is the shorter of source & target
114                    (when (< source-length target-length)
115                      (swap! source-length target-length)
116                      (swap! source target))
117
118                    ; Allocate matrix row/column work vector
119                    (let ((work (get-work-vector (++ target-length))))
120
121                      ; Initialize work vector
122                      (do ((k 0 (++ k))
123                           (cost 0 (cost-add cost insert-cost)))
124                          ((> k target-length))
125                        (vector-set! work k cost))
126
127                      ; "Early" return is needed
128                      (let/cc return
129
130                        ; Calculate edit "cost"
131                        (let ((total-cost #f)
132                              (cost-at-source delete-cost))
133
134                          ; For each source element
135                          (sequence-for-each
136                            (lambda (source-index source-elm)
137
138                              ; Every element costs
139                              (let ((current-cost cost-at-source))
140
141                                ; For each target element
142                                (sequence-for-each
143                                  (lambda (target-index target-elm)
144
145                                    ; Calculate cost to this position
146                                    (set! total-cost
147                                      (cost-minimum
148                                        (cost-add insert-cost (vector-ref work (++ target-index)))
149                                        (cost-add delete-cost current-cost)
150                                        (let ((cost-at-target (vector-ref work target-index)))
151                                          (if (elm-eql source-elm target-elm) cost-at-target
152                                            (cost-add substitute-cost cost-at-target)))))
153
154                                    ; Quit when past limit
155                                    (when (and limit-cost (cost-less-than limit-cost total-cost))
156                                      (return limit-cost))
157
158                                    ; Save the cost to this point
159                                    (vector-set! work target-index current-cost)
160                                    (set! current-cost total-cost) )
161                                  target)
162
163                                ; Save total-cost at target
164                                (vector-set! work target-length total-cost) )
165
166                                ; Bump to next source cost
167                                ; Assumes indexing from 0 to end
168                                (set! cost-at-source (cost-add cost-at-source delete-cost)) )
169                              source)
170
171                          ; Result is the total cost of edit
172                          total-cost ) ) ) ) ) ) ) ) ) ) ) ) )
173
174) ;functor levenshtein-sequence-functor
Note: See TracBrowser for help on using the repository browser.