1 | ;;;; levenshtein-path-iterator.scm -*- Scheme -*- |
---|
2 | ;;;; Kon Lovett, Mar '20 |
---|
3 | ;;;; Kon Lovett, Apr '12 |
---|
4 | |
---|
5 | ;; Issues |
---|
6 | ;; |
---|
7 | ;; - violates the 'number-means' idea since uses full-tower operations & |
---|
8 | ;; not those from the 'means' actually used to compute the cost. |
---|
9 | |
---|
10 | (module levenshtein-path-iterator |
---|
11 | |
---|
12 | (;export |
---|
13 | levenshtein-path-iterator) |
---|
14 | |
---|
15 | (import scheme) |
---|
16 | (import (chicken base)) |
---|
17 | (import (srfi 1)) |
---|
18 | (import (srfi 63)) |
---|
19 | (import miscmacros) |
---|
20 | (import numeric-macros) |
---|
21 | (import type-checks) |
---|
22 | (import type-errors) |
---|
23 | |
---|
24 | ;;; |
---|
25 | |
---|
26 | (define (remove-false! ls) |
---|
27 | (let ((ls (delete! #f ls eq?))) |
---|
28 | (and (not (null? ls)) ls) ) ) |
---|
29 | |
---|
30 | (define (strict-array? obj) (and (array? obj) (not (string? obj)) (not (vector? obj)))) |
---|
31 | |
---|
32 | ;;; |
---|
33 | |
---|
34 | ;FIXME path-iterator goes +1 too far! |
---|
35 | ;; (levenshtein-path-iterator MATRIX) |
---|
36 | ;; |
---|
37 | ;; Creates an optimal edit distance operation path iterator over the |
---|
38 | ;; edit operation matrix MATRIX. The matrix is usually the result of an |
---|
39 | ;; invocation of '(levenshtein ... operations: #t)'. |
---|
40 | ;; |
---|
41 | ;; Each invocation of the iterator will generate a list of the form: |
---|
42 | ;; ((cost source-index target-index levenshtein-operator) ...). The last |
---|
43 | ;; invocation will return #f. |
---|
44 | ;; |
---|
45 | ;; Note: The iterator will return, w/ #f, to the initial caller. Saving the result of the 1st |
---|
46 | ;; invocation is not obvious. |
---|
47 | ;; |
---|
48 | ;; (define r0 (iter)) |
---|
49 | ;; (define t r0) |
---|
50 | ;; ... (iter) until it quits |
---|
51 | ;; r0 now has #f, since the iterator finishes by returning to the initial caller, which is the |
---|
52 | ;; body of '(define r0 (iter))', thus re-binding r0. However, t has the original returned value. |
---|
53 | |
---|
54 | (define (levenshtein-path-iterator pm) |
---|
55 | ; |
---|
56 | (define (trim-path path) |
---|
57 | (let* ( |
---|
58 | (cost -inf.0) ) |
---|
59 | (remove-false! |
---|
60 | (map-in-order |
---|
61 | (lambda (elm) |
---|
62 | (let ( |
---|
63 | (elm-cost (car elm)) ) |
---|
64 | (and |
---|
65 | (not (or (zero? elm-cost) (= cost elm-cost))) |
---|
66 | (begin |
---|
67 | (set! cost elm-cost) |
---|
68 | elm) ) ) ) |
---|
69 | path)) ) ) |
---|
70 | ; |
---|
71 | (define (cost@ i j) |
---|
72 | (if (or (< i 0) (< j 0)) |
---|
73 | +inf.0 |
---|
74 | (car (array-ref pm i j)) ) ) |
---|
75 | ; |
---|
76 | (if (not (and (strict-array? pm) (= 2 (array-rank pm)))) |
---|
77 | (error-argument-type 'levenshtein-path-iterator pm "rank 2 array" "path-matrix") |
---|
78 | (let ( |
---|
79 | (dims (array-dimensions pm)) ) |
---|
80 | (let ( |
---|
81 | (n (car dims)) |
---|
82 | (m (cadr dims)) ) |
---|
83 | (letrec ( |
---|
84 | (generator |
---|
85 | (lambda (yielder) |
---|
86 | (let ( |
---|
87 | (yield |
---|
88 | (lambda (value) |
---|
89 | (let/cc continue |
---|
90 | (set! generator |
---|
91 | (lambda (k) |
---|
92 | (set! yielder k) |
---|
93 | (continue value))) |
---|
94 | (yielder value) ) ) ) ) |
---|
95 | (let try ((i (-- n)) (j (-- m)) (path '())) |
---|
96 | (and |
---|
97 | (<= 0 i) (<= 0 j) |
---|
98 | (let* ( |
---|
99 | (o (array-ref pm i j)) |
---|
100 | (oc (car o)) |
---|
101 | (oo (cdr o)) |
---|
102 | (np (cons (list oc i j oo) path)) ) |
---|
103 | (if (and (= 0 i) (= 0 j)) |
---|
104 | (yield (trim-path np)) |
---|
105 | (let ((ai (-- i)) |
---|
106 | (lj (-- j)) |
---|
107 | (better #f)) |
---|
108 | (when (< (cost@ i lj) oc) |
---|
109 | (set! better #t) |
---|
110 | (try i lj np)) |
---|
111 | (when (< (cost@ ai j) oc) |
---|
112 | (set! better #t) |
---|
113 | (try ai j np)) |
---|
114 | (when (< (cost@ ai lj) oc) |
---|
115 | (set! better #t) |
---|
116 | (try ai lj np)) |
---|
117 | (unless better |
---|
118 | (when (= (cost@ i lj) oc) |
---|
119 | (try i lj np)) |
---|
120 | (when (= (cost@ ai j) oc) |
---|
121 | (try ai j np)) |
---|
122 | (when (= (cost@ ai lj) oc) |
---|
123 | (try ai lj np))) ) ) ) ) ) ) ) ) ) |
---|
124 | (lambda () |
---|
125 | (let/cc yielder |
---|
126 | (generator yielder) ) ) ) ) ) ) ) |
---|
127 | |
---|
128 | ) ;module levenshtein-path-iterator |
---|