Coverage report: /home/ellis/comp/core/lib/nlp/string.lisp

KindCoveredAll%
expression0372 0.0
branch046 0.0
Key
Not instrumented
Conditionalized out
Executed
Not executed
 
Both branches taken
One branch taken
Neither branch taken
1
 ;;; string.lisp --- String Metric Algorithms
2
 
3
 ;; mk-string-metrics—library of efficient implementations of various string
4
 ;; metric algorithms.
5
 ;;
6
 ;; Copyright © 2014–2018 Mark Karpov
7
 ;;
8
 ;; Permission is hereby granted, free of charge, to any person obtaining a
9
 ;; copy of this software and associated documentation files (the
10
 ;; "Software"), to deal in the Software without restriction, including
11
 ;; without limitation the rights to use, copy, modify, merge, publish,
12
 ;; distribute, sublicense, and/or sell copies of the Software, and to
13
 ;; permit persons to whom the Software is furnished to do so, subject to
14
 ;; the following conditions:
15
 ;;
16
 ;; The above copyright notice and this permission notice shall be included
17
 ;; in all copies or substantial portions of the Software.
18
 ;;
19
 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
20
 ;; OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
21
 ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
22
 ;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
23
 ;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
24
 ;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
25
 ;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
26
 
27
 ;;; Code:
28
 (in-package :nlp/string)
29
 
30
 (deftype array-index (&optional (length (1- array-dimension-limit)))
31
   (list 'integer 0 length))
32
 
33
 (defun hamming (x y)
34
   "Calculate Hamming distance between two given strings X and Y, they have
35
 to be of the same length."
36
   (declare (type (simple-array character) x y)
37
            (inline length)
38
            (optimize (safety 0) (speed 3) (space 3)))
39
   (let ((result 0))
40
     (declare (type array-index result))
41
     (dotimes (i (length x) result)
42
       (declare (type array-index i))
43
       (unless (char= (char x i)
44
                      (char y i))
45
         (incf result)))))
46
 
47
 (defun levenshtein (x y)
48
   "Calculate Levenshtein distance between two given strings X and Y."
49
   (declare (type (simple-array character) x y)
50
            (inline length)
51
            (optimize (safety 0) (speed 3) (space 3)))
52
   (let* ((x-len (length x))
53
          (y-len (length y))
54
          (v0 (make-array (1+ y-len) :element-type 'array-index))
55
          (v1 (make-array (1+ y-len) :element-type 'array-index)))
56
     (declare (type (simple-array array-index) v0 v1))
57
     (dotimes (i (1+ y-len))
58
       (declare (type array-index i))
59
       (setf (aref v0 i) i))
60
     (dotimes (i x-len (aref v0 y-len))
61
       (declare (type array-index i))
62
       (setf (aref v1 0) (1+ i))
63
       (dotimes (j y-len)
64
         (declare (type array-index j))
65
         (setf (aref v1 (1+ j))
66
               (min (1+ (aref v1 j))
67
                    (1+ (aref v0 (1+ j)))
68
                    (+  (aref v0 j)
69
                        (if (char= (char x i)
70
                                   (char y j))
71
                            0 1)))))
72
       (rotatef v0 v1))))
73
 
74
 (defun damerau-levenshtein (x y)
75
   "Calculate Damerau-Levenshtein distance between two given strings X and
76
 Y."
77
   (declare (type (simple-array character) x y)
78
            (inline length)
79
            (optimize (safety 0) (speed 3) (space 3)))
80
   (let* ((x-len (length x))
81
          (y-len (length y))
82
          (v0 (make-array (1+ y-len) :element-type 'array-index))
83
          (v1 (make-array (1+ y-len) :element-type 'array-index))
84
          (v* (make-array (1+ y-len) :element-type 'array-index)))
85
     (declare (type (simple-array array-index) v0 v1 v*))
86
     (dotimes (i (1+ y-len))
87
       (declare (type array-index i))
88
       (setf (aref v0 i) i))
89
     (dotimes (i x-len (aref v0 y-len))
90
       (declare (type array-index i))
91
       (setf (aref v1 0) (1+ i))
92
       (dotimes (j y-len)
93
         (declare (type array-index j))
94
         (let* ((x-i (char x i))
95
                (y-j (char y j))
96
                (cost (if (char= x-i y-j) 0 1)))
97
           (declare (type array-index cost))
98
           (setf (aref v1 (1+ j))
99
                 (min (1+ (aref v1 j))
100
                      (1+ (aref v0 (1+ j)))
101
                      (+  (aref v0 j) cost)))
102
           (when (and (plusp i)
103
                      (plusp j))
104
             (let ((x-i-1 (char x (1- i)))
105
                   (y-j-1 (char y (1- j)))
106
                   (val (+ (aref v* (1- j)) cost)))
107
               (declare (type array-index val))
108
               (when (and (char= x-i y-j-1)
109
                          (char= x-i-1 y-j)
110
                          (< val (aref v1 (1+ j))))
111
                 (setf (aref v1 (1+ j)) val))))))
112
       (rotatef v* v0 v1))))
113
 
114
 (defun norm-levenshtein (x y)
115
   "Return normalized Levenshtein distance between X and Y. Result is a real
116
 number from 0 to 1, where 0 signifies no similarity between the strings,
117
 while 1 means exact match."
118
   (let ((r (levenshtein x y)))
119
     (if (zerop r)
120
         1
121
         (- 1 (/ r
122
                 (max (length x)
123
                      (length y)))))))
124
 
125
 (defun norm-damerau-levenshtein (x y)
126
   "Return normalized Damerau-Levenshtein distance between X and Y. Result is
127
 a real number from 0 to 1, where 0 signifies no similarity between the
128
 strings, while 1 means exact match."
129
   (let ((r (damerau-levenshtein x y)))
130
     (if (zerop r)
131
         1
132
         (- 1 (/ r
133
                 (max (length x)
134
                      (length y)))))))
135
 
136
 (defun string-to-set (str)
137
   "Convert string STR into a set. This function is supposed to be inlined."
138
   (declare (type (simple-array character) str)
139
            (inline length)
140
            (optimize (safety 0) (speed 3) (space 3)))
141
   (let ((result (make-hash-table)))
142
     (dotimes (i (length str))
143
       (let ((ch (char str i)))
144
         (if (gethash ch result)
145
             (incf (the array-index (gethash ch result)))
146
             (setf (gethash ch result) 1))))
147
     result))
148
 
149
 (defun intersection-length (x y)
150
   "Returns length of intersection of two strings X and Y. This function is
151
 supposed to be inlined."
152
   (let ((result 0))
153
     (declare (type array-index result)
154
              (optimize (safety 0) (speed 3) (space 3)))
155
     (maphash (lambda (key x-val)
156
                (declare (type array-index x-val))
157
                (let ((y-val (gethash key y)))
158
                  (declare (type (or array-index null) y-val))
159
                  (when y-val
160
                    (incf result (min x-val y-val)))))
161
              x)
162
     result))
163
 
164
 (defun union-length (x y)
165
   "Returns length of union of two strings X and Y. This function is supposed
166
 to be inlined."
167
   (let ((temp (make-hash-table))
168
         (result 0))
169
     (declare (type array-index result)
170
              (optimize (safety 0) (speed 3) (space 3)))
171
     (flet ((extract (h)
172
              (maphash (lambda (key val)
173
                         (declare (type array-index val))
174
                         (let ((t-val (gethash key temp)))
175
                           (declare (type (or array-index null) t-val))
176
                           (setf (gethash key temp)
177
                                 (if t-val
178
                                     (max val t-val)
179
                                     val))))
180
                       h)))
181
       (extract x)
182
       (extract y)
183
       (maphash (lambda (key val)
184
                  (declare (ignore key)
185
                           (type array-index val))
186
                  (incf result val))
187
                temp)
188
       result)))
189
 
190
 (defun overlap (x y)
191
   "This function calculates overlap coefficient between two given strings X
192
 and Y. Returned value is in range from 0 (no similarity) to 1 (exact
193
 match)."
194
   (declare (type (simple-array character) x y)
195
            (inline length)
196
            (optimize (safety 0) (speed 3) (space 3)))
197
   (/ (the array-index (intersection-length (string-to-set x)
198
                                            (string-to-set y)))
199
      (min (length x)
200
           (length y))))
201
 
202
 (defun jaccard (x y)
203
   "Calculate Jaccard similarity coefficient for two strings X and
204
 Y. Returned value is in range from 0 (no similarity) to 1 (exact match)."
205
   (declare (type (simple-array character) x y)
206
            (optimize (safety 0) (speed 3) (space 3)))
207
   (let ((x (string-to-set x))
208
         (y (string-to-set y)))
209
     (if (and (zerop (hash-table-count x))
210
              (zerop (hash-table-count y)))
211
         1
212
         (/ (the array-index (intersection-length x y))
213
            (the array-index (union-length x y))))))
214
 
215
 (defun fast-find (char str str-len &optional (start 0))
216
   "Check if CHAR is in STR. This function is supposed to be inlined."
217
   (declare (type character char)
218
            (type (simple-array character) str)
219
            (type array-index str-len start)
220
            (optimize (safety 0) (speed 3) (space 3)))
221
   (do ((i start (1+ i)))
222
       ((>= i str-len))
223
     (declare (type array-index i))
224
     (when (char= char (char str i))
225
       (return-from fast-find i))))
226
 
227
 (defun jaro (x y)
228
   "Calculate Jaro distance between two strings X and Y. Returned value is in
229
 range from 0 (no similarity) to 1 (exact match)."
230
   (declare (type (simple-array character) x y)
231
            (inline length)
232
            (optimize (safety 0) (speed 1) (space 3)))
233
   (let* ((x-len (length x))
234
          (y-len (length y))
235
          (d (if (and (>= x-len 2)
236
                      (>= y-len 2))
237
                 (- (floor (max x-len y-len) 2) 1)
238
                 0))
239
          (m 0)
240
          (p 0)
241
          (pj 0))
242
     (declare (type array-index d m p pj))
243
     (dotimes (i x-len)
244
       (declare (type array-index i))
245
       (let ((ch (char x i)))
246
         (do ((j (fast-find ch y y-len 0)
247
                 (fast-find ch y y-len (1+ j)))
248
              done)
249
             ((or (null j) done))
250
           (declare (type (or array-index null) j))
251
           (when (and j (<= (the array-index (abs (- i j)))
252
                            d))
253
             (when (and (plusp pj)
254
                        (< j pj))
255
               (incf p))
256
             (setf pj   j
257
                   done t)
258
             (incf m)))))
259
     (if (zerop m)
260
         0
261
         (/ (+ (/ m x-len)
262
               (/ m y-len)
263
               (/ (- m p) m))
264
            3))))
265
 
266
 (defun prefix-length (x y)
267
   "Calculate length of common prefix for strings X and Y."
268
   (declare (type (simple-array character) x y)
269
            (inline length)
270
            (optimize (safety 0) (speed 3) (space 3)))
271
   (let ((x-len (length x))
272
         (y-len (length y))
273
         (result 0))
274
     (declare (type array-index result))
275
     (dotimes (i x-len)
276
       (if (and (< i y-len)
277
                (char= (char x i)
278
                       (char y i)))
279
           (incf result)
280
           (return-from prefix-length result)))
281
     result))
282
 
283
 (defun jaro-winkler (x y)
284
   "Calculate Jaro-Winkler distance between two strings X and Y. Returned
285
 value is in range from 0 (no similarity) to 1 (exact match)."
286
   (let ((jd (jaro x y))
287
         (l  (prefix-length x y)))
288
     (+ jd (* l 1/10 (- 1 jd)))))
289
 �����