Changeset 38874 in project


Ignore:
Timestamp:
08/22/20 21:29:38 (5 weeks ago)
Author:
Kon Lovett
Message:

add functor types include, note path-iterator bug

Location:
release/5/levenshtein/trunk
Files:
3 added
12 edited

Legend:

Unmodified
Added
Removed
  • release/5/levenshtein/trunk/levenshtein-cost-fixnum.scm

    r38328 r38874  
    55
    66(include "levenshtein-cost-interface")
    7 
    87(module levenshtein-cost-fixnum COST-OPER
    98
     
    1413
    1514(define-type cost fixnum)
    16 
    17 (: cost-multiply (cost cost -> cost))
    18 (: cost-add (cost cost -> cost))
    19 (: cost-minimum (cost #!rest cost -> cost))
    20 (: cost-less-than (cost cost -> boolean))
    21 (define-type cost-positive-infinity cost)
     15(include "levenshtein-cost-interface.types")
    2216
    2317(define cost-add fx+)
  • release/5/levenshtein/trunk/levenshtein-cost-interface.scm

    r38328 r38874  
    1010  cost-add                      ;cost cost -> cost
    1111  cost-minimum                  ;cost cost -> cost
    12   cost-less-than                ;cost cost -> cost
     12  cost-less-than                ;
    1313  cost-positive-infinity))      ;cost
  • release/5/levenshtein/trunk/levenshtein-cost-number.scm

    r38328 r38874  
    55
    66(include "levenshtein-cost-interface")
    7 
    87(module levenshtein-cost-number COST-OPER
    98
     
    1312
    1413(define-type cost number)
    15 
    16 (: cost-multiply (cost cost -> cost))
    17 (: cost-add (cost cost -> cost))
    18 (: cost-minimum (cost #!rest cost -> cost))
    19 (: cost-less-than (cost cost -> boolean))
    20 (define-type cost-positive-infinity cost)
     14(include "levenshtein-cost-interface.types")
    2115
    2216(define cost-add +)
  • release/5/levenshtein/trunk/levenshtein-operators.scm

    r38337 r38874  
    134134(define *lo-set!)
    135135(define *lo-del!)
    136 (let ((+lo-table+ #f))
     136(let ((+lo-table+ (make-hash-table))) ;throw-away 4 type-system
    137137  (set! clear-lo-table
    138138    (lambda ()
  • release/5/levenshtein/trunk/levenshtein-path-iterator.scm

    r38328 r38874  
    2424;;;
    2525
    26 (define (strict-array? obj)
    27   (and (array? obj) (not (string? obj)) (not (vector? obj))))
     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))))
    2831
    2932;;;
    3033
     34;FIXME path-iterator goes +1 too far!
    3135;; (levenshtein-path-iterator MATRIX)
    3236;;
     
    4953
    5054(define (levenshtein-path-iterator pm)
    51 
     55  ;
    5256  (define (trim-path path)
    53     (let ((cost -inf.0))
    54       (delete! #f
     57    (let* (
     58      (cost -inf.0) )
     59      (remove-false!
    5560        (map-in-order
    5661          (lambda (elm)
    57             (let ((elm-cost (car elm)))
    58               (if (or (zero? elm-cost) (= cost elm-cost))
    59                 #f
    60                 (begin (set! cost elm-cost) elm) ) ) )
    61           path)
    62         eq?) ) )
    63 
     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  ;
    6476  (if (not (and (strict-array? pm) (= 2 (array-rank pm))))
    65       (error-argument-type 'levenshtein-path-iterator pm "rank 2 array" "path-matrix")
    66       (let ((dims (array-dimensions pm)))
    67         (let ((n (car dims))
    68               (m (cadr dims))
    69               (cost@
    70                 (lambda (i j)
    71                   (if (or (< i 0) (< j 0))
    72                     +inf.0
    73                     (car (array-ref pm i j)) ) ) ) )
    74             (letrec ((generator
    75                       (lambda (yielder)
    76                         (let ((yield
    77                                 (lambda (value)
    78                                   (let/cc continue
    79                                     (set! generator
    80                                       (lambda (k)
    81                                         (set! yielder k)
    82                                         (continue value)))
    83                                     (yielder value) ) ) ) )
    84                           (let try ((i (-- n)) (j (-- m)) (path '()))
    85                             (and
    86                               (<= 0 i) (<= 0 j)
    87                               (let* ((o (array-ref pm i j))
    88                                      (oc (car o))
    89                                      (oo (cdr o))
    90                                      (np (cons (list oc i j oo) path) ) )
    91                                 (if (and (= 0 i) (= 0 j))
    92                                     (begin
    93                                       (yield (trim-path np))
    94                                       #f)
    95                                     (let ((ai (-- i))
    96                                           (lj (-- j))
    97                                           (better #f))
    98                                       (when (< (cost@ i lj) oc)
    99                                         (set! better #t)
    100                                         (try i lj np))
    101                                       (when (< (cost@ ai j) oc)
    102                                         (set! better #t)
    103                                         (try ai j np))
    104                                       (when (< (cost@ ai lj) oc)
    105                                         (set! better #t)
    106                                         (try ai lj np))
    107                                       (unless better
    108                                         (when (= (cost@ i lj) oc)
    109                                           (try i lj np))
    110                                         (when (= (cost@ ai j) oc)
    111                                           (try ai j np))
    112                                         (when (= (cost@ ai lj) oc)
    113                                           (try ai lj np)))
    114                                       #f ) ) ) ) ) ) ) ) )
    115               (lambda ()
    116                 (let/cc yielder
    117                   (generator yielder) ) ) ) ) ) ) )
     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) ) ) ) ) ) ) )
    118127
    119128) ;module levenshtein-path-iterator
  • release/5/levenshtein/trunk/levenshtein-print.scm

    r38337 r38874  
    2929(define-type array (struct array))
    3030
     31(define-type levenshtein-operator (struct levenshtein-operator))
     32
    3133(: print-levenshtein-matrix (array -> void))
    3234(: print-levenshtein-matrix-slice (array fixnum fixnum fixnum fixnum -> void))
    33 (: print-levenshtein-matrix-element ((or string (pair string string)) -> void))
     35;(: print-levenshtein-matrix-element ((or string (pair string string)) -> void))
     36(: print-levenshtein-matrix-element ((or string (pair string levenshtein-operator)) -> void))
    3437
    3538;; SRFI-63 (from srfi-63.scm example)
  • release/5/levenshtein/trunk/levenshtein-sequence-interface.scm

    r38477 r38874  
    1414  sequence-for-each           ;procedure sequence #!rest sequence -> number
    1515  subsequence/shared))        ;sequence number #!optional number -> sequence
    16 
    17 (define-type sequence (or vector list string (struct shared-vector)))
  • release/5/levenshtein/trunk/levenshtein-sequence-string.scm

    r38477 r38874  
    1515(import type-errors)
    1616
    17 (: check-sequence (symbol * #!optional (or symbol string) -> sequence))
    18 (: sequence-length (sequence -> number))
    19 (: sequence-prefix-length (procedure sequence sequence #!rest sequence -> number))
    20 (: sequence-suffix-length (procedure sequence sequence #!rest sequence -> number))
    21 (: sequence-for-each (procedure sequence #!rest sequence -> number))
    22 (: subsequence/shared (sequence number #!optional number -> sequence))
     17(define-type sequence string)
     18(include "levenshtein-sequence-interface.types")
    2319
    2420;;;
  • release/5/levenshtein/trunk/levenshtein-sequence-utf8.scm

    r38477 r38874  
    1616(import type-errors)
    1717
    18 (: check-sequence (symbol * #!optional (or symbol string) -> sequence))
    19 (: sequence-length (sequence -> number))
    20 (: sequence-prefix-length (procedure sequence sequence #!rest sequence -> number))
    21 (: sequence-suffix-length (procedure sequence sequence #!rest sequence -> number))
    22 (: sequence-for-each (procedure sequence #!rest sequence -> number))
    23 (: subsequence/shared (sequence number #!optional number -> sequence))
     18(define-type sequence string)
     19(include "levenshtein-sequence-interface.types")
    2420
    2521;;;
  • release/5/levenshtein/trunk/levenshtein-sequence-vector.scm

    r38477 r38874  
    1616(import type-errors)
    1717
    18 (: check-sequence (symbol * #!optional (or symbol string) -> sequence))
    19 (: sequence-length (sequence -> number))
    20 (: sequence-prefix-length (procedure sequence sequence #!rest sequence -> number))
    21 (: sequence-suffix-length (procedure sequence sequence #!rest sequence -> number))
    22 (: sequence-for-each (procedure sequence #!rest sequence -> number))
    23 (: subsequence/shared (sequence number #!optional number -> sequence))
    24 
    25 ;;;
    26 
    27 (define (sequence->vector seq)
    28   (cond
    29     ((vector? seq)          seq)
    30     ((%shared-vector? seq)  seq)
    31     ((list? seq)            (list->vector seq))
    32     ((string? seq)          (list->vector (string->list seq)))
    33     (else                   #f)) )
    34 
    35 ;;;
    36 
    37 (define-record shared-vector)
    38 (define-record-type shared-vector
    39   (%make-shared-vector vec start end)
    40   %shared-vector?
    41   (vec %shared-vector-vector)
    42   (start %shared-vector-start)
    43   (end %shared-vector-end) )
    44 
    45 (define (*vector? obj)
    46   (or (vector? obj) (%shared-vector? obj)) )
    47 
    48 (define (error/type/vector loc obj)
    49   (error-argument-type loc obj "vector") )
    50 
    51 (define (check-*vector loc obj)
    52   (unless (*vector? obj)
    53     (error/type/vector loc obj))
    54   obj )
     18(define-type sequence (or vector list string (struct shared-vector)))
     19(include "levenshtein-sequence-interface.types")
    5520
    5621;;;
     
    11075;;;
    11176
    112 (define check-sequence check-*vector)
    113 (define sequence-length *vector-length)
     77(define check-sequence check-vector)
     78(define sequence-length vector-length)
    11479(define sequence-prefix-length vector-prefix-length)
    11580(define sequence-suffix-length vector-suffix-length)
    116 (define sequence-for-each *vector-for-each)
     81(define sequence-for-each vector-for-each)
    11782(define subsequence/shared subvector/shared)
    11883
  • release/5/levenshtein/trunk/levenshtein.egg

    r38477 r38874  
    33
    44( (synopsis "Levenshtein edit distance")
    5   (version "2.0.3")
     5  (version "2.1.0")
    66  (category data)
    77        (author "[[kon lovett]]")
    88        (license "BSD")
    99        (dependencies
    10                 (srfi-1 "0.5.1")
    11                 (srfi-13 "0.3")
    12                 (srfi-63 "0.5")
    13                 (srfi-69 "0.4.1")
    14                 (vector-lib "2.1.1")
    15                 (utf8 "3.6.2")
    16                 (check-errors "3.1.2")
     10                srfi-1 srfi-13 srfi-63 srfi-69 vector-lib utf8 check-errors
    1711                (miscmacros "1.0")
    1812                (moremacros "2.2.1") )
     
    2115  (components
    2216    (scheme-include levenshtein-cost
    23       (files "levenshtein-cost-interface.scm"
     17      (files "levenshtein-cost-interface.types.scm"
     18              "levenshtein-cost-interface.scm"
    2419              "levenshtein-cost-number.scm"
    2520              "levenshtein-cost-fixnum.scm"))
    2621    (scheme-include levenshtein-sequence
    27       (files "levenshtein-sequence-interface.scm"
     22      (files "levenshtein-sequence-interface.types.scm"
     23              "levenshtein-sequence-interface.scm"
    2824              "levenshtein-sequence-vector.scm"
    2925              "levenshtein-sequence-string.scm"
     
    3127    (extension levenshtein-operators
    3228      (types-file)
    33       (csc-options "-O3" "-d1" "-local" "-no-procedure-checks") )
     29      (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks") )
    3430    (extension levenshtein-vector
    3531      (types-file)
    3632      (component-dependencies levenshtein-operators)
    37       (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
     33      (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
    3834   (extension levenshtein-path-iterator
    3935      (types-file)
    40       (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
     36      (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
    4137   (extension levenshtein-print
    4238      (types-file)
    4339      (component-dependencies levenshtein-operators)
    44       (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
     40      (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
    4541   (extension levenshtein-vector-functor
    4642      (types-file)
    47       (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
     43      (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
    4844   (extension levenshtein-sequence-functor
    4945      (types-file)
    50       (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
     46      (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
    5147   (extension levenshtein-byte
    5248      (types-file)
    53       (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
     49      (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
    5450   (extension levenshtein-transpose-byte
    5551      (types-file)
    56       (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") )
     52      (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") )
    5753   (extension levenshtein-sequence-functor
    5854      (types-file)
    5955      #;(component-dependencies levenshtein-sequence levenshtein-cost)
    60       (csc-options "-O3" "-d1" "-local" "-no-procedure-checks" "-no-bound-checks") ) ) )
     56      (csc-options "-O3" "-d1" "-strict-types" "-no-procedure-checks" "-no-bound-checks") ) ) )
  • release/5/levenshtein/trunk/tests/levenshtein-test.scm

    r38372 r38874  
    238238        (do ((r (iter) (iter))
    239239             (i 0 (add1 i)))
    240             ((not r) vec)
     240            ;FIXME path-iterator goes +1 too far
     241            ((or (not r) (= (vector-length vec) i)) vec)
    241242          (vector-set! vec i r))))
    242243
     
    247248            (do (levenshtein-operator-ref 'Delete)))
    248249        (vector-set! vec 0
    249           (list (list 1 0 0 so) (list 2 1 1 so) (list 3 2 3 so) (list 4 4 5 so) (list 5 4 6 do) (list 6 6 10 do)))
     250          `((1 0 0 ,so) (2 1 1 ,so) (3 2 3 ,so) (4 4 5 ,so) (5 4 6 ,do) (6 6 10 ,do)))
    250251        (vector-set! vec 1
    251           (list (list 1 0 0 so) (list 2 0 1 do) (list 3 2 3 so) (list 4 4 5 so) (list 5 4 6 do) (list 6 6 10 do)))
     252          `((1 0 0 ,so) (2 0 1 ,do) (3 2 3 ,so) (4 4 5 ,so) (5 4 6 ,do) (6 6 10 ,do)))
    252253        (vector-set! vec 2
    253           (list (list 1 0 0 so) (list 2 1 1 so) (list 3 2 3 so) (list 4 3 5 do) (list 5 4 6 do) (list 6 6 10 do)))
     254          `((1 0 0 ,so) (2 1 1 ,so) (3 2 3 ,so) (4 3 5 ,do) (5 4 6 ,do) (6 6 10 ,do)))
    254255        (vector-set! vec 3
    255           (list (list 1 0 0 so) (list 2 0 1 do) (list 3 2 3 so) (list 4 3 5 do) (list 5 4 6 do) (list 6 6 10 do)))
     256          `((1 0 0 ,so) (2 0 1 ,do) (3 2 3 ,so) (4 3 5 ,do) (5 4 6 ,do) (6 6 10 ,do)))
    256257        (vector-set! vec 4
    257           (list (list 1 0 0 so) (list 2 1 1 so) (list 3 2 3 so) (list 4 3 5 do) (list 5 3 6 do) (list 6 6 10 do)))
     258          `((1 0 0 ,so) (2 1 1 ,so) (3 2 3 ,so) (4 3 5 ,do) (5 3 6 ,do) (6 6 10 ,do)))
    258259        (vector-set! vec 5
    259           (list (list 1 0 0 so) (list 2 0 1 do) (list 3 2 3 so) (list 4 3 5 do) (list 5 3 6 do) (list 6 6 10 do)))
     260          `((1 0 0 ,so) (2 0 1 ,do) (3 2 3 ,so) (4 3 5 ,do) (5 3 6 ,do) (6 6 10 ,do)))
    260261        vec))
    261262
Note: See TracChangeset for help on using the changeset viewer.