Changeset 9817 in project


Ignore:
Timestamp:
03/16/08 17:06:25 (12 years ago)
Author:
Kon Lovett
Message:

Removed syntax-case dependency.

Location:
release/3/levenshtein/trunk
Files:
17 edited

Legend:

Unmodified
Added
Removed
  • release/3/levenshtein/trunk/levenshtein-eggdoc.scm

    r8913 r9817  
    5353    (description (p "Levenshtein edit distance"))
    5454    (author (url "mailto:klovett@pacbell.net" "Kon Lovett"))
    55     (history
    56      (version "1.602" "Changes for syntax-case support of define-inline")
    57      (version "1.6.1" "Missing means source files for syntax-case module")
    58      (version "1.6" "Refactoring")
    59      (version "1.5" "Needs misc-extn > 2.0")
    60      (version "1.4" "Shared code")
    61      (version "1.3" "Major changes")
    62      (version "1.2" "Switched to array-lib")
    63      (version "1.1" "Requirement for srfi-43 was wrong [Thanks to Benedikt Rosenau]")
    64      (version "1.0" "Initial release"))
    6555
    6656    (requires
     
    7060      (url "miscmacros.html" "miscmacros")
    7161      (url "misc-extn.html" "misc-extn")
    72       (url "syntax-case.html" "syntax-case")
    7362      (url "vector-lib.html" "vector-lib")
    7463      (url "array-lib.html" "array-lib"))
     
    437426      )
    438427
     428    (history
     429      (version "1.7.0" "Support for toplevel-only utf8 egg. Removed syntax-case dependency.")
     430      (version "1.602" "Changes for syntax-case support of define-inline")
     431      (version "1.6.1" "Missing means source files for syntax-case module")
     432      (version "1.6" "Refactoring")
     433      (version "1.5" "Needs misc-extn > 2.0")
     434      (version "1.4" "Shared code")
     435      (version "1.3" "Major changes")
     436      (version "1.2" "Switched to array-lib")
     437      (version "1.1" "Requirement for srfi-43 was wrong [Thanks to Benedikt Rosenau]")
     438      (version "1.0" "Initial release"))
     439
    439440    (section "License" (pre ,license))
    440441  )
  • release/3/levenshtein/trunk/levenshtein-fixnum-means.scm

    r8913 r9817  
    22;;;; Kon Lovett, May '06
    33
    4 (use syntax-case procedure-surface)
    5 (use levenshtein-numeric-surface)
     4(use syntax-case procedure-surface levenshtein-numeric-surface)
    65
    76(eval-when (compile)
    87  (declare
    98    (usual-integrations)
    10     (fixnum) ) )
     9    (fixnum)
     10    (inline)
     11    (no-procedure-checks)
     12    (no-bound-checks)
     13    (export
     14      levenshtein-fixnum-means ) ) )
    1115
    12 (module levenshtein-fixnum-means (levenshtein-fixnum-means)
    13 
    14   (define (*fxmin num . nums)
    15     (let loop ([nums nums] [min num])
    16       (if (null? nums)
    17         min
    18         (loop (cdr nums) (fxmin min (car nums))) ) ) )
    19 
    20   (declare-procedure-means levenshtein-fixnum-means levenshtein-numeric-surface
    21     #:immutable #t
    22     number?     fixnum?
    23     *           fx*
    24     +           fx+
    25     min         *fxmin
    26     <           fx< )
    27 
    28   (export-toplevel levenshtein-fixnum-means)
    29 )
     16(declare-procedure-means levenshtein-fixnum-means levenshtein-numeric-surface
     17  #:immutable #t
     18  number?     fixnum?
     19  *           fx*
     20  +           fx+
     21  min         (lambda (num . nums)
     22                (let loop ([nums nums] [min num])
     23                  (if (null? nums)
     24                      min
     25                      (loop (cdr nums) (fxmin min (car nums))) ) ) )
     26  <           fx< )
  • release/3/levenshtein/trunk/levenshtein-generic-sequence.scm

    r8913 r9817  
    77;; What about when we swap the source & target?
    88
    9 (use syntax-case procedure-surface miscmacros misc-extn-numeric misc-extn-control)
    10 
    11 (use levenshtein-fixnum-means levenshtein-octet-means levenshtein-vector-means)
    12 (import levenshtein-fixnum-means)
    13 (import levenshtein-octet-means)
    14 (import levenshtein-vector-means)
     9(use procedure-surface miscmacros misc-extn-numeric misc-extn-control
     10     levenshtein-fixnum-means levenshtein-octet-means levenshtein-vector-means)
    1511
    1612(eval-when (compile)
    1713  (declare
    1814    (not usual-integrations
    19       number? * + min <)            ; Not rqrd, just being specific
     15      number? * + min < ) ; Not rqrd, just being specific
    2016    (inline)
    2117    (no-procedure-checks)
    2218    (no-bound-checks)
    2319    (export
    24       levenshtein-distance/generic-sequence) ) )
     20      levenshtein-distance/generic-sequence ) ) )
    2521
    2622;;;
     
    6864      [sequence-means
    6965        (if (and (string? source) (string? target))
    70           string-means
    71           levenshtein-vector-means)])
     66            string-means
     67            levenshtein-vector-means)])
    7268
    7369    ; When mixed source & target must make sure both are vectors
     
    125121                    ; Use the longest match & revert to the full string otherwise
    126122                    (if (fx< prefix-length suffix-length)
    127                       (begin
    128                         (set! stripped-source-start 0)
    129                         (set! stripped-target-start 0))
    130                       (begin
    131                         (set! stripped-source-end source-length)
    132                         (set! stripped-target-end target-length)))
     123                        (begin
     124                          (set! stripped-source-start 0)
     125                          (set! stripped-target-start 0))
     126                        (begin
     127                          (set! stripped-source-end source-length)
     128                          (set! stripped-target-end target-length)))
    133129
    134130                    ; Re-calc stripped lengths
     
    195191                                            (let ([cost-at-target (vector-ref work target-index)])
    196192                                              (if (=? source-char target-char)
    197                                                 cost-at-target
    198                                                 (+ substitute-cost cost-at-target)))))
     193                                                  cost-at-target
     194                                                  (+ substitute-cost cost-at-target)))))
    199195
    200196                                        ; Quit when past limit
  • release/3/levenshtein/trunk/levenshtein-generic-string.scm

    r8913 r9817  
    33;;;; BSD
    44
    5 (use syntax-case)
    65(use levenshtein-generic-sequence levenshtein-fixnum-means levenshtein-octet-means)
    7 (import levenshtein-fixnum-means)
    8 (import levenshtein-octet-means)
    96
    107(eval-when (compile)
     
    1411    (no-bound-checks)
    1512    (export
    16       levenshtein-distance/generic-string) ) )
     13      levenshtein-distance/generic-string ) ) )
    1714
    1815;; Generic String & Number Levenshtein Edit Distance
  • release/3/levenshtein/trunk/levenshtein-gennum-means.scm

    r8913 r9817  
    77        (declare
    88                (usual-integrations)
    9                 (generic) ) )
     9                (generic)
     10    (inline)
     11    (no-procedure-checks)
     12    (no-bound-checks)
     13    (export
     14      levenshtein-gennum-means ) ) )
    1015
    11 (module levenshtein-gennum-means (levenshtein-gennum-means)
    12 
    13         (declare-procedure-means levenshtein-gennum-means levenshtein-numeric-surface
    14                 #:immutable #t
    15                 number?         number?
    16                 *                                       *
    17                 +                                       +
    18                 min                             min
    19                 <                                       < )
    20 
    21         (export-toplevel levenshtein-gennum-means)
    22 )
     16(declare-procedure-means levenshtein-gennum-means levenshtein-numeric-surface
     17  #:immutable #t
     18  number?               number?
     19  *                                     *
     20  +                                     +
     21  min                           min
     22  <                                     < )
  • release/3/levenshtein/trunk/levenshtein-numbers-means.scm

    r8913 r9817  
    22;;;; Kon Lovett, May '06
    33
    4 (use syntax-case procedure-surface levenshtein-numeric-surface numbers)
     4(use procedure-surface levenshtein-numeric-surface numbers)
    55
    66(eval-when (compile)
    77  (declare
    88    (not usual-integrations
    9       * + - min < number?) ) )
     9      * + - min < number? )
     10    (inline)
     11    (no-procedure-checks)
     12    (no-bound-checks)
     13    (export
     14      levenshtein-numbers-means ) ) )
    1015
    11 (module levenshtein-numbers-means (levenshtein-numbers-means)
    12 
    13   (declare-procedure-means levenshtein-numbers-means levenshtein-numeric-surface
    14     #:immutable #t
    15     number?   number?
    16     *         *
    17     +         +
    18     min       min
    19     <         < )
    20 
    21   (export-toplevel levenshtein-numbers-means)
    22 )
     16(declare-procedure-means levenshtein-numbers-means levenshtein-numeric-surface
     17  #:immutable #t
     18  number?   number?
     19  *         *
     20  +         +
     21  min       min
     22  <         < )
  • release/3/levenshtein/trunk/levenshtein-numeric-surface.scm

    r8913 r9817  
    99    (fixnum)
    1010    (inline)
     11    (no-procedure-checks)
     12    (no-bound-checks)
    1113    (export
    12       levenshtein-numeric-surface) ) )
     14      levenshtein-numeric-surface ) ) )
    1315
    1416(define-procedure-surface levenshtein-numeric-surface
  • release/3/levenshtein/trunk/levenshtein-octet-means.scm

    r8913 r9817  
    22;;;; Kon Lovett, May '06
    33
    4 ;; Issues
    5 ;;
    6 ;; - The 'string-for-each' variable isn't bound until runtime. So
    7 
    8 (use syntax-case procedure-surface srfi-13)
    9 (use levenshtein-sequence-surface)
     4(use srfi-13 procedure-surface levenshtein-sequence-surface)
    105
    116(eval-when (compile)
    127  (declare
    13     (not usual-integrations
    14       string->list)
    15     (fixnum) ) )
     8    (fixnum)
     9    (inline)
     10    (no-procedure-checks)
     11    (no-bound-checks)
     12    (export
     13      levenshtein-octet-means ) ) )
    1614
    17 (define octet-string-for-each string-for-each)
     15(define octet-substring/shared      substring/shared)
     16(define octet-string-length         string-length)
     17(define octet-string-prefix-length  string-prefix-length)
     18(define octet-string-suffix-length  string-suffix-length)
     19(define octet-string-for-each       string-for-each)
     20(define octet-string->list          string->list)
    1821
    19 (module levenshtein-octet-means (levenshtein-octet-means)
    20 
    21   ;; Provides 'for-each' procedure with signature of 'vector-for-each'
    22  
    23   (define (*string-for-each f s . rest)
    24     (let ([i 0])
    25       (apply octet-string-for-each
    26         (lambda (c)
    27           (f i c)
    28           (set! i (fx+ i 1)))
    29         s rest) ) )
    30 
    31   (declare-procedure-means levenshtein-octet-means levenshtein-sequence-surface
    32     #:immutable #t
    33     sequence->vector          (compose list->vector string->list)
    34     sequence-length           string-length
    35     sequence-prefix-length    (lambda (f s1 s2 . rest) (apply string-prefix-length s1 s2 rest))
    36     sequence-suffix-length    (lambda (f s1 s2 . rest) (apply string-suffix-length s1 s2 rest))
    37     sequence-for-each         *string-for-each
    38     subsequence/shared        substring/shared )
    39 
    40   (export-toplevel levenshtein-octet-means)
    41 )
     22(declare-procedure-means levenshtein-octet-means levenshtein-sequence-surface
     23  #:immutable #t
     24  sequence->vector          (compose list->vector octet-string->list)
     25  sequence-length           octet-string-length
     26  sequence-prefix-length    (lambda (f s1 s2 . rest) (apply octet-string-prefix-length s1 s2 rest))
     27  sequence-suffix-length    (lambda (f s1 s2 . rest) (apply octet-string-suffix-length s1 s2 rest))
     28  ; Provides 'for-each' procedure with signature of 'vector-for-each'
     29  sequence-for-each         (lambda (f s . rest)
     30                              (let ([i 0])
     31                                (apply octet-string-for-each (lambda (c) (f i c) (set! i (fx+ i 1)))
     32                                                             s rest) ) )
     33  subsequence/shared        octet-substring/shared )
  • release/3/levenshtein/trunk/levenshtein-sequence-surface.scm

    r8913 r9817  
    99    (fixnum)
    1010    (inline)
     11    (no-procedure-checks)
     12    (no-bound-checks)
    1113    (export
    12       levenshtein-sequence-surface) ) )
     14      levenshtein-sequence-surface ) ) )
    1315
    1416(define-procedure-surface levenshtein-sequence-surface
  • release/3/levenshtein/trunk/levenshtein-utf8-means.scm

    r8913 r9817  
    22;;;; Kon Lovett, May '06
    33
    4 (use syntax-case procedure-surface levenshtein-sequence-surface)
    5 (use utf8 utf8-srfi-13)
     4(use syntax-case
     5     procedure-surface levenshtein-sequence-surface
     6     utf8 utf8-srfi-13)
    67
    78(eval-when (compile)
    89  (declare
    9     (not usual-integrations
    10       string->list string-length)
    1110    (fixnum)
    12     (inline) ) )
     11    (inline)
     12    (no-procedure-checks)
     13    (no-bound-checks)
     14    (export
     15      levenshtein-utf8-means ) ) )
    1316
    14 (module levenshtein-utf8-means (levenshtein-utf8-means)
    15 
    16   (import utf8)
    17   (import utf8-srfi-13)
    18 
    19   (define (*string-for-each f s . rest)
    20     (let ([i 0])
    21       (apply string-for-each
    22         (lambda (c)
    23           (f i c)
    24           (set! i (fx+ i 1)))
    25         s rest) ) )
    26 
    27   (declare-procedure-means levenshtein-utf8-means levenshtein-sequence-surface
    28     #:immutable #t
    29     sequence->vector          (o list->vector string->list)
    30     sequence-length           string-length
    31     sequence-prefix-length    (lambda (f s1 s2 . rest) (apply string-prefix-length s1 s2 rest))
    32     sequence-suffix-length    (lambda (f s1 s2 . rest) (apply string-suffix-length s1 s2 rest))
    33     sequence-for-each         *string-for-each
    34     subsequence/shared        substring/shared )
    35 
    36   (export-toplevel levenshtein-utf8-means)
    37 )
     17(declare-procedure-means levenshtein-utf8-means levenshtein-sequence-surface
     18  #:immutable #t
     19  sequence->vector          (o list->vector string->list)
     20  sequence-length           string-length
     21  sequence-prefix-length    (lambda (f s1 s2 . rest) (apply string-prefix-length s1 s2 rest))
     22  sequence-suffix-length    (lambda (f s1 s2 . rest) (apply string-suffix-length s1 s2 rest))
     23  ; Provides 'for-each' procedure with signature of 'vector-for-each'
     24  sequence-for-each         (lambda (f s . rest)
     25                              (let ([i 0])
     26                                (apply string-for-each (lambda (c) (f i c) (set! i (fx+ i 1)))
     27                                                       s rest) ) )
     28  subsequence/shared        substring/shared )
  • release/3/levenshtein/trunk/levenshtein-vector-means.scm

    r8913 r9817  
    77;; What about byte-vector, u8vector, ..., and stream?
    88
    9 (use syntax-case vector-lib procedure-surface misc-extn-record misc-extn-numeric)
    10 (use levenshtein-sequence-surface)
     9(use vector-lib procedure-surface misc-extn-record misc-extn-numeric
     10    levenshtein-sequence-surface)
    1111
    1212(eval-when (compile)
    1313  (declare
    1414    (usual-integrations)
    15     (fixnum) ) )
     15    (fixnum)
     16    (inline)
     17    (no-procedure-checks)
     18    (no-bound-checks)
     19    (export
     20      levenshtein-vector-means
     21      levenshtein-vector-means-string-coerce-set!
     22      levenshtein-vector-means-string-coerce-reset! ) ) )
    1623
    1724;;;
     
    4047;;;
    4148
    42 (module levenshtein-vector-means (
    43     levenshtein-vector-means
    44     levenshtein-vector-means-string-coerce-set!
    45     levenshtein-vector-means-string-coerce-reset!)
     49(define (sequence->vector seq)
     50  (cond [(vector? seq)  seq]
     51        [(list? seq)    (list->vector seq)]
     52        [(string? seq)  (list->vector (string->list seq))]
     53        [else           #f]) )
    4654
    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]) )
     55(define (*vector-length vec)
     56  (cond [(vector? vec)          (vector-length vec)]
     57        [(%shared-vector? vec)  (- (%shared-vector-end vec) (%shared-vector-start vec))]
     58        [else                   (error/type/vector '*vector-length vec)] ) )
    5259
    53   (define (*vector-length vec)
    54     (cond [(vector? vec) (vector-length vec)]
    55           [(%shared-vector? vec) (- (%shared-vector-end vec) (%shared-vector-start vec))]
     60(define (*vector-ref vec idx)
     61  (cond [(vector? vec)
     62          (vector-ref vec idx)]
     63        [(%shared-vector? vec)
     64          (let ([ridx (+ (%shared-vector-start vec) idx)])
     65            (if (and (<= (%shared-vector-start vec) ridx) (< ridx (%shared-vector-end vec)))
     66                (*vector-ref (%shared-vector-vector vec) ridx)
     67                (error 'vector-ref "out of range" idx)))]
     68        [else
     69          (error/type/vector '*vector-ref vec)] ) )
     70
     71(define *vector-for-each
     72  (let (
     73      [vec-for-each
     74        (lambda (f vec start end)
     75          (do ([i start (+ i 1)])
     76              ([<= end i])
     77            (f i (*vector-ref vec i))))])
     78    (lambda (f vec . vectors)
     79      (check-procedure 'vector-for-each f)
     80      (check-vector 'vector-for-each vec)
     81      (if (null? vectors)
     82          (vec-for-each f vec 0 (*vector-length vec))
     83          (error 'vector-for-each "multiple vector support not implemented") ) ) ) )
     84
     85(define (subvector/shared vec start #!optional (end (*vector-length vec)))
     86  (check-vector 'subvector/shared vec)
     87  (%make-shared-vector vec start end) )
     88
     89(define (vector-prefix-length =? v1 v2
     90          #!optional (s1 0) (e1 (*vector-length v1)) (s2 0) (e2 (*vector-length v2)))
     91  (check-vector 'vector-prefix-length v1)
     92  (check-vector 'vector-prefix-length v2)
     93  (let loop ([i1 s1] [i2 s2])
     94    (cond [(or (>= i1 e1) (>= i2 e2))
     95            (if (> i1 e1) 0 (- i1 s1))]
     96          [(=? (*vector-ref v1 i1) (*vector-ref v2 i2))
     97            (loop (++ i1) (++ i2))]
    5698          [else
    57             (error/type/vector '*vector-length vec)] ) )
     99            (- i1 s1)])) )
    58100
    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)))]
     101(define (vector-suffix-length =? v1 v2
     102          #!optional (s1 0) (e1 (*vector-length v1)) (s2 0) (e2 (*vector-length v2)))
     103  (check-vector 'vector-suffix-length v1)
     104  (check-vector 'vector-suffix-length v2)
     105  (let loop ([i1 (-- e1)] [i2 (-- e2)])
     106    (cond [(or (<= i1 s1) (<= i2 s2))
     107            (if (< i1 s1) 0 (- e1 (++ i1)))]
     108          [(=? (*vector-ref v1 i1) (*vector-ref v2 i2))
     109            (loop (-- i1) (-- i2))]
    66110          [else
    67             (error/type/vector '*vector-ref vec)] ) )
     111            (- e1 (++ i1))])) )
    68112
    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") ) ) ) )
     113;;;
    82114
    83   (define (subvector/shared vec start #!optional (end (*vector-length vec)))
    84     (check-vector 'subvector/shared vec)
    85     (%make-shared-vector vec start end) )
     115(declare-procedure-means levenshtein-vector-means levenshtein-sequence-surface
     116  #:immutable #f            ; Modified by levenshtein-distance/generic-sequence
     117  sequence->vector          sequence->vector
     118  sequence-length           *vector-length
     119  sequence-prefix-length    vector-prefix-length
     120  sequence-suffix-length    vector-suffix-length
     121  sequence-for-each         *vector-for-each
     122  subsequence/shared        subvector/shared )
    86123
    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)
     124(define (levenshtein-vector-means-string-coerce-set! str-means)
     125  (procedure-means-set! levenshtein-vector-means 'sequence->vector
     126    (lambda (seq)
     127      (if (string? seq)
    126128          (call/means str-means sequence->vector seq)
    127129          (sequence->vector seq) ) )) )
    128130
    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 )
     131(define (levenshtein-vector-means-string-coerce-reset!)
     132  (procedure-means-set! levenshtein-vector-means 'sequence->vector sequence->vector) )
  • release/3/levenshtein/trunk/levenshtein-vector.scm

    r8913 r9817  
    22;;;; Kon Lovett, Sep 16 2005
    33
    4 (use srfi-1 vector-lib array-lib procedure-surface misc-extn-numeric misc-extn-control)
    5 (use levenshtein-operators levenshtein-numeric-surface)
    6 (use levenshtein-fixnum-means)
    7 (import levenshtein-fixnum-means)
     4(use srfi-1 vector-lib array-lib procedure-surface misc-extn-numeric misc-extn-control
     5     levenshtein-operators levenshtein-numeric-surface levenshtein-fixnum-means)
    86
    97(eval-when (compile)
    108  (declare
    119    (not usual-integrations
    12       + * <)
     10      + * < )
    1311    (inline)
    1412    (generic)
     
    1614    (no-bound-checks)
    1715    (export
    18       levenshtein-distance/vector*) ) )
     16      levenshtein-distance/vector* ) ) )
    1917
    2018;;;
     
    2624        (lambda (i m n)
    2725          (if (< n m)
    28             (begin (set! idx i) n)
    29             m ) )
     26              (begin (set! idx i) n)
     27              m ) )
    3028        +inf.0
    3129        vec)
     
    5957                    (let ([a (vector-ref av eo-i)]
    6058                          [l (vector-ref lv eo-i)])
    61                       (if (fx= a 0)                           ; A L
    62                         (if (fx= l 0)                         ; - -
    63                           (+ cost (vector-ref W j))           ; 0 0
    64                           (+ cost (vector-ref W (fx++ j)))) ; 0 1
    65                         (if (fx= l 0)                         ;
    66                           (+ cost cur)                        ; 1 0
    67                           (let ([cost@ (vector-ref W j)])     ;
    68                             (if (=? s-i (vector-ref tv j))    ; 1 1
    69                               cost@
    70                               (+ cost cost@)))))))])
     59                      (if (fx= a 0)                             ; A L
     60                          (if (fx= l 0)                         ; - -
     61                              (+ cost (vector-ref W j))         ; 0 0
     62                              (+ cost (vector-ref W (fx++ j)))) ; 0 1
     63                          (if (fx= l 0)                         ;
     64                              (+ cost cur)                      ; 1 0
     65                              (let ([cost@ (vector-ref W j)])   ;
     66                                (if (=? s-i (vector-ref tv j))  ; 1 1
     67                                    cost@
     68                                    (+ cost cost@)))))))])
    7169
    7270              (let-values ([(cost index) (vector-min (vector-map apply-oper cv))])
     
    112110                      (if (and (fx>= i a) (fx>= j l))
    113111
    114                         (let ([currcost (array-ref D (fx- i a) (fx- j l))])
    115                           (cond
    116 
    117                             ; Allow a no-op cost <> 0
    118                             [(and (fx= a 0) (fx= l 0))
    119                               (+ currcost opercost)]
    120 
    121                             ; Special case w/ test, simplified
    122                             [(and (fx= a 1) (fx= l 1))
    123                               (if (=? s-i t-j)
    124                                 currcost
    125                                 (+ currcost opercost))]
    126 
    127                             ; General case w/ test
    128                             [(or (fx> a 1) (fx> l 1))
    129                               (let ([x (+ currcost opercost)])
    130                                 (unless (=? (vector-ref sv (fx- i a)) t-j)
    131                                   (set! x (+ x opercost)))
    132                                 (unless (=? s-i (vector-ref tv (fx- j l)))
    133                                   (set! x (+ x opercost)))
    134                                 x)]
    135 
    136                             ; Otherwise a = 0|1 & l = 1|0
    137                             [else
    138                               (+ currcost opercost)])
    139                           )
    140 
    141                         ; Does this make sense when operation would violate D bounds?
    142                         +inf.0)))])
     112                          (let ([currcost (array-ref D (fx- i a) (fx- j l))])
     113                            (cond
     114 
     115                              ; Allow a no-op cost <> 0
     116                              [(and (fx= a 0) (fx= l 0))
     117                                (+ currcost opercost)]
     118 
     119                              ; Special case w/ test, simplified
     120                              [(and (fx= a 1) (fx= l 1))
     121                                (if (=? s-i t-j)
     122                                  currcost
     123                                  (+ currcost opercost))]
     124 
     125                              ; General case w/ test
     126                              [(or (fx> a 1) (fx> l 1))
     127                                (let ([x (+ currcost opercost)])
     128                                  (unless (=? (vector-ref sv (fx- i a)) t-j)
     129                                    (set! x (+ x opercost)))
     130                                  (unless (=? s-i (vector-ref tv (fx- j l)))
     131                                    (set! x (+ x opercost)))
     132                                  x)]
     133 
     134                              ; Otherwise a = 0|1 & l = 1|0
     135                              [else
     136                                (+ currcost opercost)])
     137                            )
     138 
     139                          ; Does this make sense when operation would violate D bounds?
     140                          +inf.0)))])
    143141
    144142              (let-values ([(cost index) (vector-min (vector-map apply-oper cv))])
     
    218216      ; Insert operator must be 1st in vector
    219217      (let ([idx (vector-index levenshtein-insert-operator? opervec)])
    220         (cond
    221           [(not idx)
    222             (set! idx (vector-length opervec))
    223             (set! opervec (vector-append opervec (vector insoper)))
    224             (vector-swap! opervec 0 idx)]
    225           [(positive? idx)
    226             (vector-swap! opervec 0 idx)]))
     218        (cond [(not idx)
     219                (set! idx (vector-length opervec))
     220                (set! opervec (vector-append opervec (vector insoper)))
     221                (vector-swap! opervec 0 idx)]
     222              [(positive? idx)
     223                (vector-swap! opervec 0 idx)]))
    227224      (set! insoper (vector-ref opervec 0))
    228225      ; Delete operator must be 2nd in vector
    229226      (let ([idx (vector-index levenshtein-delete-operator? opervec)])
    230         (cond
    231           [(not idx)
    232             (set! idx (vector-length opervec))
    233             (set! opervec (vector-append opervec (vector (vector-ref (*levenshtein-base-operators-vector) 1))))
    234             (vector-swap! opervec 1 idx)]
    235           [(positive? idx)
    236             (vector-swap! opervec 1 idx)])))
     227        (cond [(not idx)
     228                (set! idx (vector-length opervec))
     229                (set! opervec
     230                      (vector-append
     231                       opervec
     232                       (vector (vector-ref (*levenshtein-base-operators-vector) 1))))
     233                (vector-swap! opervec 1 idx)]
     234              [(positive? idx)
     235                (vector-swap! opervec 1 idx)])))
    237236
    238237    ; "Unpack" work procedures
     
    293292          ; Handle empty source/target special case, then choose algorithm based
    294293          ; on complexity of edit operations
    295           (cond
    296             [(fx= 0 srclen)
    297               (zrtf trglen)]
    298             [(fx= 0 trglen)
    299               (zrtf srclen)]
    300             [(or (eq? opervec (*levenshtein-base-operators-vector))
    301                   (andmap levenshtein-base-operator? operlist))
    302               (levenshtein/vector srcvec trgvec srclen trglen cstvec abvvec lftvec =? perf finf + * <)]
    303             [else
    304               (levenshtein/matrix srcvec trgvec srclen trglen cstvec abvvec lftvec =? perf finf + * <)]) ) ) ) ) )
     294          (cond [(fx= 0 srclen)
     295                  (zrtf trglen)]
     296                [(fx= 0 trglen)
     297                  (zrtf srclen)]
     298                [(or (eq? opervec (*levenshtein-base-operators-vector))
     299                      (andmap levenshtein-base-operator? operlist))
     300                  (levenshtein/vector srcvec trgvec srclen trglen
     301                                      cstvec abvvec lftvec =? perf finf + * <)]
     302                [else
     303                  (levenshtein/matrix srcvec trgvec srclen trglen
     304                                      cstvec abvvec lftvec =? perf finf + * <)]) ) ) ) ) )
  • release/3/levenshtein/trunk/levenshtein.html

    r8913 r9817  
    156156<h3>Author</h3><a href="mailto:klovett@pacbell.net">Kon Lovett</a></div>
    157157<div class="section">
    158 <h3>Version</h3>
    159 <ul>
    160 <li>1.602 Changes for syntax-case support of define-inline</li>
    161 <li>1.6.1 Missing means source files for syntax-case module</li>
    162 <li>1.6 Refactoring</li>
    163 <li>1.5 Needs misc-extn &gt; 2.0</li>
    164 <li>1.4 Shared code</li>
    165 <li>1.3 Major changes</li>
    166 <li>1.2 Switched to array-lib</li>
    167 <li>1.1 Requirement for srfi-43 was wrong [Thanks to Benedikt Rosenau]</li>
    168 <li>1.0 Initial release</li></ul></div>
    169 <div class="section">
    170158<h3>Requires</h3>
    171159<ul>
     
    175163<li><a href="miscmacros.html">miscmacros</a></li>
    176164<li><a href="misc-extn.html">misc-extn</a></li>
    177 <li><a href="syntax-case.html">syntax-case</a></li>
    178165<li><a href="vector-lib.html">vector-lib</a></li>
    179166<li><a href="array-lib.html">array-lib</a></li></ul></div>
     
    447434<p><a href="http://en.wikipedia.org/wiki/Talk:Levenshtein_distance">Talk:Levenshtein distance @ Wikipedia</a></p></div>
    448435<div class="section">
     436<h3>Version</h3>
     437<ul>
     438<li>1.7.0 Support for toplevel-only utf8 egg. Removed syntax-case dependency.</li>
     439<li>1.602 Changes for syntax-case support of define-inline</li>
     440<li>1.6.1 Missing means source files for syntax-case module</li>
     441<li>1.6 Refactoring</li>
     442<li>1.5 Needs misc-extn &gt; 2.0</li>
     443<li>1.4 Shared code</li>
     444<li>1.3 Major changes</li>
     445<li>1.2 Switched to array-lib</li>
     446<li>1.1 Requirement for srfi-43 was wrong [Thanks to Benedikt Rosenau]</li>
     447<li>1.0 Initial release</li></ul></div>
     448<div class="section">
    449449<h3>License</h3>
    450450<pre>Copyright (c) 2005, 2006, Kon Lovett.  All rights reserved.
  • release/3/levenshtein/trunk/levenshtein.meta

    r8913 r9817  
    66 (author "Kon Lovett")
    77 (egg "levenshtein.egg")
    8  (needs vector-lib misc-extn array-lib syntax-case utf8 procedure-surface miscmacros)
     8 (needs vector-lib misc-extn array-lib utf8 procedure-surface miscmacros)
    99 (license "BSD")
    1010 (files
  • release/3/levenshtein/trunk/levenshtein.setup

    r8913 r9817  
    22
    33(required-extension-version
    4   'syntax-case            "6.998"
    54  'vector-lib             "1.1"
    65  'array-lib              "2.0"
  • release/3/levenshtein/trunk/tests/levenshtein-string-numeric-test.scm

    r8913 r9817  
    22
    33(use testbase testbase-output-human)
    4 (use syntax-case)
    54(use levenshtein-generic-string)
    65(use levenshtein-fixnum-means levenshtein-gennum-means levenshtein-numbers-means)
    7 (import levenshtein-fixnum-means)
    8 (import levenshtein-gennum-means)
    9 (import levenshtein-numbers-means)
    106
    117(eval-when (compile)
    128  (declare
    139    (not usual-integrations
    14       * string->number)
    15   )
    16 )
     10      * string->number ) ) )
    1711
    1812(define-expect-binary =)
  • release/3/levenshtein/trunk/tests/levenshtein-string-utf8-test.scm

    r8913 r9817  
    22
    33(use testbase testbase-output-human)
    4 (use syntax-case)
    54(use levenshtein-generic-string)
    65(use levenshtein-utf8-means)
    7 (import levenshtein-utf8-means)
    86
    97(define-test utf8-levenshtein-distance/generic-string-test "Default Numeric & UTF8 String"
Note: See TracChangeset for help on using the changeset viewer.