source: project/levenshtein/levenshtein-vector-means.scm @ 5835

Last change on this file since 5835 was 5835, checked in by Kon Lovett, 12 years ago

Chgs due to syntax-case support of define-inline

File size: 4.6 KB
Line 
1;;;; levenshtein-vector-means.scm
2;;;; Kon Lovett, Sep '06
3
4;; Issues
5;;
6;; - Don't have a "real" sequence abstraction, only recognizes vector, list, and string.
7;; What about byte-vector, u8vector, ..., and stream?
8
9(use syntax-case vector-lib procedure-surface misc-extn-record misc-extn-numeric)
10(use levenshtein-sequence-surface)
11
12(eval-when (compile)
13  (declare
14    (usual-integrations)
15    (fixnum) ) )
16
17;;;
18
19(define-inline-unchecked-record-type shared-vector
20  (%make-shared-vector vec start end)
21  %shared-vector?
22  (vec %shared-vector-vector)
23  (start %shared-vector-start)
24  (end %shared-vector-end) )
25
26(define-inline (*vector? obj)
27  (or (vector? obj) (%shared-vector? obj)) )
28
29(define (error/type/vector loc obj)
30  (error loc "invalid vector" obj) )
31
32(define-inline (check-vector loc obj)
33  (unless (*vector? obj)
34    (error/type/vector loc obj)) )
35
36(define-inline (check-procedure loc obj)
37  (unless (procedure? obj)
38    (error loc "invalid procedure" obj)) )
39
40;;;
41
42(module levenshtein-vector-means (
43    levenshtein-vector-means
44    levenshtein-vector-means-string-coerce-set!
45    levenshtein-vector-means-string-coerce-reset!)
46
47  (define (sequence->vector seq)
48    (cond [(vector? seq) seq]
49          [(list? seq) (list->vector seq)]
50          [(string? seq) (list->vector (string->list seq))]
51          [else #f]) )
52
53  (define (*vector-length vec)
54    (cond [(vector? vec) (vector-length vec)]
55          [(%shared-vector? vec) (- (%shared-vector-end vec) (%shared-vector-start vec))]
56          [else
57            (error/type/vector '*vector-length vec)] ) )
58
59  (define (*vector-ref vec idx)
60    (cond [(vector? vec) (vector-ref vec idx)]
61          [(%shared-vector? vec)
62            (let ([ridx (+ (%shared-vector-start vec) idx)])
63              (if (and (<= (%shared-vector-start vec) ridx) (< ridx (%shared-vector-end vec)))
64                  (*vector-ref (%shared-vector-vector vec) ridx)
65                  (error 'vector-ref "out of range" idx)))]
66          [else
67            (error/type/vector '*vector-ref vec)] ) )
68
69  (define *vector-for-each
70    (let (
71        [vec-for-each
72          (lambda (f vec start end)
73            (do ([i start (+ i 1)])
74                ([<= end i])
75              (f i (*vector-ref vec i))))])
76      (lambda (f vec . vectors)
77        (check-procedure 'vector-for-each f)
78        (check-vector 'vector-for-each vec)
79        (if (null? vectors)
80            (vec-for-each f vec 0 (*vector-length vec))
81            (error 'vector-for-each "multiple vector support not implemented") ) ) ) )
82
83  (define (subvector/shared vec start #!optional (end (*vector-length vec)))
84    (check-vector 'subvector/shared vec)
85    (%make-shared-vector vec start end) )
86
87  (define (vector-prefix-length =? v1 v2
88            #!optional (s1 0) (e1 (*vector-length v1)) (s2 0) (e2 (*vector-length v2)))
89    (check-vector 'vector-prefix-length v1)
90    (check-vector 'vector-prefix-length v2)
91    (let loop ([i1 s1] [i2 s2])
92      (cond [(or (>= i1 e1) (>= i2 e2))
93              (if (> i1 e1) 0 (- i1 s1))]
94            [(=? (*vector-ref v1 i1) (*vector-ref v2 i2))
95              (loop (++ i1) (++ i2))]
96            [else
97              (- i1 s1)])) )
98
99  (define (vector-suffix-length =? v1 v2
100            #!optional (s1 0) (e1 (*vector-length v1)) (s2 0) (e2 (*vector-length v2)))
101    (check-vector 'vector-suffix-length v1)
102    (check-vector 'vector-suffix-length v2)
103    (let loop ([i1 (-- e1)] [i2 (-- e2)])
104      (cond [(or (<= i1 s1) (<= i2 s2))
105              (if (< i1 s1) 0 (- e1 (++ i1)))]
106            [(=? (*vector-ref v1 i1) (*vector-ref v2 i2))
107              (loop (-- i1) (-- i2))]
108            [else
109              (- e1 (++ i1))])) )
110
111  ;;;
112
113  (declare-procedure-means levenshtein-vector-means levenshtein-sequence-surface
114    #:immutable #f            ; Modified by levenshtein-distance/generic-sequence
115    sequence->vector          sequence->vector
116    sequence-length           *vector-length
117    sequence-prefix-length    vector-prefix-length
118    sequence-suffix-length    vector-suffix-length
119    sequence-for-each         *vector-for-each
120    subsequence/shared        subvector/shared )
121
122  (define (levenshtein-vector-means-string-coerce-set! str-means)
123    (procedure-means-set! levenshtein-vector-means 'sequence->vector
124      (lambda (seq)
125        (if (string? seq)
126          (call/means str-means sequence->vector seq)
127          (sequence->vector seq) ) )) )
128
129  (define (levenshtein-vector-means-string-coerce-reset!)
130    (procedure-means-set! levenshtein-vector-means 'sequence->vector sequence->vector) )
131
132  (export-toplevel
133    levenshtein-vector-means
134    levenshtein-vector-means-string-coerce-set!
135    levenshtein-vector-means-string-coerce-reset!)
136)
Note: See TracBrowser for help on using the repository browser.