Changeset 38337 in project


Ignore:
Timestamp:
03/24/20 23:05:25 (2 weeks ago)
Author:
Kon Lovett
Message:

add -operators types, levenshtein-distance/vector* -> number (or boolean array) - 2 values only (nobody uses this (?) so not major)

Location:
release/5/levenshtein/trunk
Files:
5 edited

Legend:

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

    r38328 r38337  
    3333(import scheme)
    3434(import (chicken base))
     35(import (chicken type))
    3536(import (chicken syntax))
    3637(import (chicken format))
     
    4445
    4546;;;
     47
     48;; Types
     49
     50(define-type levenshtein-operator (struct levenshtein-operator))
     51
     52(: make-levenshtein-operator (symbol string number fixnum fixnum -> levenshtein-operator))
     53(: clone-levenshtein-operator ((or symbol levenshtein-operator) #!rest -> levenshtein-operator))
     54(: levenshtein-operator? (* -> boolean : levenshtein-operator))
     55(: levenshtein-operator-key (levenshtein-operator -> symbol))
     56(: levenshtein-operator-name (levenshtein-operator -> string))
     57(: levenshtein-operator-cost (levenshtein-operator -> number))
     58(: levenshtein-operator-above (levenshtein-operator -> fixnum))
     59(: levenshtein-operator-left (levenshtein-operator -> fixnum))
     60(: levenshtein-operator=? (levenshtein-operator levenshtein-operator -> boolean))
     61;(: check-levenshtein-operator ( -> ))
     62;(: error-levenshtein-operator ( -> ))
     63(: levenshtein-operator-ref (symbol -> levenshtein-operator))
     64(: levenshtein-operator-set! (levenshtein-operator -> void))
     65(: levenshtein-operator-delete! ((or symbol levenshtein-operator) -> void))
     66(: levenshtein-base-operator? (levenshtein-operator -> boolean))
     67(: levenshtein-insert-operator? (levenshtein-operator -> boolean))
     68(: levenshtein-delete-operator? (levenshtein-operator -> boolean))
     69(: levenshtein-operator-reset (-> void))
     70(: levenshtein-base-operators-vector (-> vector))
    4671
    4772;std unhygienic prelude ?
     
    76101; Operator type
    77102
    78 (define-record levenshtein-operator)
     103;create tag & ctor arity
     104(define-record levenshtein-operator key name cost above left)
    79105(define-record-type levenshtein-operator
    80106  (*make-levenshtein-operator key name cost above left)
     
    90116; The operator printer
    91117
    92 (define-record-printer (levenshtein-operator eo out)
     118(define-record-printer (levenshtein-operator lo out)
    93119  (fprintf out "#,(levenshtein-operator ~A ~S ~A ~A ~A)"
    94     (levenshtein-operator-key eo)
    95     (levenshtein-operator-name eo)
    96     (levenshtein-operator-cost eo)
    97     (levenshtein-operator-above eo)
    98     (levenshtein-operator-left eo)) )
     120    (levenshtein-operator-key lo)
     121    (levenshtein-operator-name lo)
     122    (levenshtein-operator-cost lo)
     123    (levenshtein-operator-above lo)
     124    (levenshtein-operator-left lo)) )
    99125
    100126; No validation of reader input, only for printer output!
     
    108134(define *lo-set!)
    109135(define *lo-del!)
    110 (let ((*lo-table* #f))
     136(let ((+lo-table+ #f))
    111137  (set! clear-lo-table
    112138    (lambda ()
    113       (set! *lo-table* (make-hash-table eq? hash-by-identity 5)) ) )
     139      (set! +lo-table+ (make-hash-table eq? hash-by-identity 5)) ) )
    114140  (set! *lo-ref
    115141    (lambda (key)
    116       (hash-table-ref/default *lo-table* key #f) ) )
     142      (hash-table-ref/default +lo-table+ key #f) ) )
    117143  (set! *lo-set!
    118     (lambda (eo)
    119       (hash-table-set! *lo-table* (levenshtein-operator-key eo) eo) ) )
     144    (lambda (lo)
     145      (hash-table-set! +lo-table+ (levenshtein-operator-key lo) lo) ) )
    120146  (set! *lo-del!
    121     (lambda (eo)
    122       (hash-table-delete! *lo-table* (levenshtein-operator-key eo)) ) ) )
     147    (lambda (lo)
     148      (hash-table-delete! +lo-table+ (levenshtein-operator-key lo))
     149      ;FIXME 'hash-table-delete!' -> boolean but should be void per SRFI-69 doc
     150      (void) ) ) )
    123151
    124152;; Operator table access
    125153
    126154(define (levenshtein-operator=? a b)
     155  (check-levenshtein-operator 'levenshtein-operator=? a)
     156  (check-levenshtein-operator 'levenshtein-operator=? b)
    127157  (and
    128     (levenshtein-operator? a) (levenshtein-operator? b)
    129158    (eq? (levenshtein-operator-key a) (levenshtein-operator-key b))
    130159    (string=? (levenshtein-operator-name a) (levenshtein-operator-name b))
     
    149178
    150179(define (levenshtein-operator-ref key)
    151   (check-symbol 'levenshtein-operator-ref  key "key")
    152   (get-levenshtein-operator 'levenshtein-operator-ref key) )
     180  (get-levenshtein-operator 'levenshtein-operator-ref
     181    (check-symbol 'levenshtein-operator-ref  key "key")) )
    153182
    154183(define (levenshtein-operator-set! lo)
    155   (check-levenshtein-operator 'levenshtein-operator-set! lo "oper")
    156   (*lo-set! lo) )
     184  (*lo-set! (check-levenshtein-operator 'levenshtein-operator-set! lo "oper")) )
    157185
    158186(define (levenshtein-operator-delete! lo)
     
    160188
    161189(define (make-levenshtein-operator key name cost above left)
    162   (check-natural-fixnum 'make-levenshtein-operator above "above")
    163   (check-natural-fixnum 'make-levenshtein-operator left "left")
    164   (check-number 'make-levenshtein-operator cost "cost")
    165   (check-symbol 'make-levenshtein-operator key "key")
    166   (check-string 'make-levenshtein-operator name "name")
    167   (*make-levenshtein-operator key name cost above left) )
     190  (*make-levenshtein-operator
     191    (check-symbol 'make-levenshtein-operator key "key")
     192    (check-string 'make-levenshtein-operator name "name")
     193    (check-number 'make-levenshtein-operator cost "cost")
     194    (check-natural-fixnum 'make-levenshtein-operator above "above")
     195    (check-natural-fixnum 'make-levenshtein-operator left "left")) )
    168196
    169197;let-syntax & (let ((KEY (or KEY (levenshtein-operator-KEY EO)))... ) ...)
     
    174202      (let* (
    175203        (key-var (cadr exp))
    176         (eo (caddr exp))
     204        (lo (caddr exp))
    177205        (sym (symbol-append 'levenshtein-operator- (strip-syntax key-var))) )
    178       `(unless ,key-var (set! ,key-var (,(inj sym) ,eo)) ) ) ) ) )
     206      `(unless ,key-var (set! ,key-var (,(inj sym) ,lo)) ) ) ) ) )
    179207
    180208(define (clone-levenshtein-operator lo #!key key name cost above left)
     
    189217;; Base levenshtein operators predicates
    190218
    191 (define (levenshtein-base-operator? eo)
    192   (and (<= (levenshtein-operator-above eo) 1)
    193        (<= (levenshtein-operator-left eo) 1)))
     219(define (levenshtein-base-operator? lo)
     220  (and (<= (levenshtein-operator-above lo) 1)
     221       (<= (levenshtein-operator-left lo) 1)))
    194222
    195223(define (levenshtein-insert-operator? lo)
     
    205233(define levenshtein-operator-reset)
    206234(define levenshtein-base-operators-vector)
    207 (let ((*base-opers* #f))
     235(let ((+base-opers+ #f))
    208236  (set! levenshtein-operator-reset
    209237    (lambda ()
    210238      ; insert must be 1st!
    211       (set! *base-opers*
     239      (set! +base-opers+
    212240        (vector
    213241          (*make-levenshtein-operator 'Insert "Insert" 1 0 1)
     
    215243          (*make-levenshtein-operator 'Substitute "Substitute" 1 1 1)))
    216244      (clear-lo-table)
    217       (*lo-set! (vector-ref *base-opers* 0))
    218       (*lo-set! (vector-ref *base-opers* 1))
    219       (*lo-set! (vector-ref *base-opers* 2))
     245      (*lo-set! (vector-ref +base-opers+ 0))
     246      (*lo-set! (vector-ref +base-opers+ 1))
     247      (*lo-set! (vector-ref +base-opers+ 2))
    220248      ; Standard, but not part of the base set
    221249      (*lo-set! (*make-levenshtein-operator 'Transpose "Transpose" 1 2 2)) ) )
    222250  (set! levenshtein-base-operators-vector
    223251    (lambda ()
    224       (vector-copy *base-opers*) ) ) )
     252      (vector-copy +base-opers+) ) ) )
    225253
    226254;;;
  • release/5/levenshtein/trunk/levenshtein-print.scm

    r38333 r38337  
    2828
    2929(define-type array (struct array))
     30
    3031(: print-levenshtein-matrix (array -> void))
    3132(: print-levenshtein-matrix-slice (array fixnum fixnum fixnum fixnum -> void))
    32 (: print-levenshtein-matrix-element ((or string (pair string strin)) -> void))
     33(: print-levenshtein-matrix-element ((or string (pair string string)) -> void))
    3334
    3435;; SRFI-63 (from srfi-63.scm example)
  • release/5/levenshtein/trunk/levenshtein-vector-functor.scm

    r38328 r38337  
    2525
    2626;;;
     27
     28;; Types
     29
     30(define-type array (struct array))
     31
     32(: levenshtein-distance/vector* (vector vector #!rest -> number (or boolean array)))
    2733
    2834;;
     
    240246          (trglen (vector-length trgvec))
    241247          (perf void)             ; Perform operation accumulate
    242           (finf identity)         ; Finish
    243           (zrtf                   ; Zero-length, assume 'finf' binding to 'identity'
    244             (lambda (len)
    245               (cost-multiply len (levenshtein-operator-cost insoper)))))
     248          (finf                   ; Finish, "identity"
     249            (lambda (cost) (values cost #f)))
     250          (zrtf                   ; Zero-length, assume 'finf' binding to "identity"
     251            (lambda (len) (cost-multiply len (levenshtein-operator-cost insoper)))))
    246252
    247253      ; Use shorter as the target
  • release/5/levenshtein/trunk/levenshtein-vector.scm

    r38333 r38337  
    2626;; Types
    2727
    28 ;return 1 or 2 values!
    29 #;(: levenshtein-distance/vector* (vector vector #!rest -> *))
     28(define-type array (struct array))
     29
     30(: levenshtein-distance/vector* (vector vector #!rest -> number (or boolean array)))
    3031
    3132;;
     
    251252          (trglen (vector-length trgvec))
    252253          (perf void)             ; Perform operation accumulate
    253           (finf identity)         ; Finish
    254           (zrtf                   ; Zero-length, assume 'finf' binding to 'identity'
    255             (lambda (len)
    256               (mult len (levenshtein-operator-cost insoper)))))
     254          (finf                   ; Finish, "identity"
     255            (lambda (cost) (values cost #f)))
     256          (zrtf                   ; Zero-length, assume 'finf' binding to "identity"
     257            (lambda (len) (mult len (levenshtein-operator-cost insoper)))))
    257258
    258259      ; Use shorter as the target
  • release/5/levenshtein/trunk/tests/levenshtein-test.scm

    r38329 r38337  
    112112          (LAWYQQKPGKA (list->vector (string->list "LAWYQQKPGKA")) ) )
    113113
    114       (test "distance" 6 (levenshtein-distance/vector* YWCQPGK LAWYQQKPGKA))
     114      (test "distance" 6
     115        (let-values (((cost _) (levenshtein-distance/vector* YWCQPGK LAWYQQKPGKA))) cost))
    115116
    116117      (test-assert "cost-and-oper-matrix-match"
     
    153154          (LAWYQQKPGKA (list->vector (string->list "LAWYQQKPGKA")) ) )
    154155
    155       (test "distance" 6 (fx:levenshtein-distance/vector* YWCQPGK LAWYQQKPGKA))
     156      (test "distance" 6
     157        (let-values (((cost _) (fx:levenshtein-distance/vector* YWCQPGK LAWYQQKPGKA))) cost))
    156158
    157159      (test-assert "cost-and-oper-matrix-match"
Note: See TracChangeset for help on using the changeset viewer.