Changeset 30122 in project


Ignore:
Timestamp:
11/27/13 08:12:23 (6 years ago)
Author:
Ivan Raikov
Message:

sfht: converted to typeclass interface

Location:
release/4/sfht/trunk
Files:
4 edited

Legend:

Unmodified
Added
Removed
  • release/4/sfht/trunk/sfht.meta

    r23288 r30122  
    1818 ; A list of eggs sfht depends on.
    1919
    20  (needs matchable sparse-vectors)
     20 (needs typeclass matchable sparse-vectors)
    2121 (test-depends test iset random-swb)
    2222
  • release/4/sfht/trunk/sfht.scm

    r25306 r30122  
    88;;
    99;;
    10 ;; Copyright 2007-2011 Ivan Raikov.
     10;; Copyright 2007-2013 Ivan Raikov.
    1111;;
    1212;;
     
    2727(module sfht
    2828
    29   (make-sfht)
     29  (sfht-map
     30   <SFHT>)
    3031
    3132  (import scheme chicken data-structures)
    3233
    33   (require-extension srfi-1 matchable sparse-vectors)
     34  (require-extension typeclass srfi-1 matchable sparse-vectors)
    3435
    3536(define ln06185 (log 0.6185))
     
    4748                 (loop (cdr objs)))))))
    4849
    49 (define (make-sfht n p make-random-state random! key->vector key-vector-ref key-vector-length . rest)
     50
     51(define-class <SFHT> empty get delete! put! empty? size clear!)
     52
     53(define-record sfht ba size)
     54
     55
     56(define (sfht-map n p make-random-state random! key->vector key-vector-ref key-vector-length . rest)
    5057
    5158  (let-optionals rest ((key-equal? equal?))
     
    5663    (define default (list 0 (list)))
    5764   
    58     (define ba (make-sparse-vector default))
    59    
    60     (define size 0)
    61    
    6265    ;; Hash functions based on uniform pseudo-random numbers
    63     (define rng-states (list-tabulate k (lambda (i)
    64                                           (make-random-state i))))
     66    (define rng-states (list-tabulate k (lambda (i) (make-random-state i))))
    6567
    6668    ;; Pre-calculate hash function coefficients for vectors of size up
     
    101103                        (cons (and-coeffs (car hh) kv) ax)))))))
    102104
    103     (define (insert! key x)
     105    (define (empty) (make-sfht (make-sparse-vector default) 0))
     106
     107
     108    (define (insert! sfht key x)
    104109      (let ((h  (hash key k n))
    105110            (b  (cons (cons key x) (list))))
     
    107112          (if (not (null? i))
    108113              (let* ((index  (car i))
    109                      (bkt    (sparse-vector-ref ba index)))
    110                 (let-values (((sz lst) (match bkt
    111                                               ((sz lst)  (values sz lst))
    112                                               (else (sfht:error 'insert! ": invalid bucket " bkt " at index " index)))))
     114                     (bkt    (sparse-vector-ref (sfht-ba sfht) index)))
     115                (match-let (((sz lst) bkt))
    113116                            (if (fx= 0 sz)
    114                                 (sparse-vector-set! ba index (list 1 (list (cons key x))))
     117                                (sparse-vector-set! (sfht-ba sfht) index (list 1 (list (cons key x))))
    115118                                (begin
    116119                                  (let tail ((k sz) (lst lst) (prev #f))
     
    123126                                  (set-car! bkt (fx+ 1 (car bkt)))))
    124127                            (loop (cdr i))))))
    125         (set! size (fx+ 1 size))
     128        (sfht-size-set! sfht (fx+ 1 (sfht-size sfht)))
    126129        #f))
     130
    127131     
    128     (define (delete! key)
     132    (define (delete! sfht key)
    129133      (define found? #f)
    130134      (let ((h  (hash key k n)))
     
    132136          (if (not (null? i))
    133137              (let* ((index  (car i))
    134                      (bkt    (sparse-vector-ref ba index)))
    135                 (let-values (((sz lst) (match bkt
    136                                               ((sz lst)  (values sz lst))
    137                                               (else (sfht:error 'remove! ": invalid bucket " bkt " at index " i)))))
     138                     (bkt    (sparse-vector-ref (sfht-ba sfht) index)))
     139                (match-let (((sz lst) bkt))
    138140                  (let bktloop ((k sz) (lst lst) (prev #f))
    139141                    (if (not (null? lst))
     
    149151                                   (else (sfht:error 'remove! ": invalid bucket list " lst)))))))
    150152                (loop (cdr i)))))
    151         (if found? (set! size (fx- size 1)))
     153        (if found? (sfht-size-set! sfht (fx- (sfht-size sfht) 1)))
    152154        found?))
     155
    153156
    154157    (define (min-bucket bkts . rest)
     
    159162                               (min-bucket (cdr bkts) bkt)
    160163                               (min-bucket (cdr bkts) minb))))))
    161    
    162     (define (find key)
     164
     165   
     166    (define (find sfht key)
    163167      (let* ((h     (hash key k n))
    164              (bkts  (map (lambda (i) (sparse-vector-ref ba i)) h))
     168             (bkts  (map (lambda (i) (sparse-vector-ref (sfht-ba sfht) i)) h))
    165169             (minb  (min-bucket bkts)))
    166170        (let loop ((k (car minb)) (lst (cadr minb)))
     
    171175                          (loop (fx- k 1) rest)))
    172176                     (else (sfht:error 'find ": invalid bucket list " lst)))))))
    173    
    174      (define (debugprint)
    175        (let ((bkts (sparse-vector->list ba)))
     177
     178   
     179     (define (debugprint sfht)
     180       (let ((bkts (sparse-vector->list (sfht-ba sfht))))
    176181         (for-each
    177182          (lambda (bkt)
     
    192197       (else (car default-clause))))
    193198   
    194    
    195     ;; Dispatcher
    196     (lambda (selector)
    197       (case selector
    198         ((get)
    199          (lambda (key . default-clause)
    200            (or (find key) (apply-default-clause 'get key default-clause))))
    201        
    202         ((delete!)
    203          (lambda (key . default-clause)
    204            (or (delete! key) (apply-default-clause 'delete! key default-clause))))
    205        
    206         ((put!) insert!)
    207        
    208         ((empty?) (fx= size 0))
    209        
    210         ((size)   size)
    211        
    212         ((clear!)  (begin
    213                      (set! ba (make-sparse-vector default))
    214                      (set! size 0)))
    215        
    216         ((debugprint) (debugprint))
    217         (else
    218          (sfht:error "Unknown message " selector " sent to an SFHT"))))))
     199
     200    (make-<SFHT>
     201
     202     ;; empty
     203     empty
     204   
     205     ;; get
     206     (lambda (sfht key . default-clause)
     207       (or (find sfht key) (apply-default-clause 'get key default-clause)))
     208       
     209     ;; delete!
     210     (lambda (sfht key . default-clause)
     211       (or (delete! sfht key) (apply-default-clause 'delete! key default-clause)))
     212
     213     ;; put!
     214     insert!
     215
     216     ;; empty?
     217     (lambda (sfht) (fx= (sfht-size sfht) 0))
     218       
     219     ;; size
     220     sfht-size
     221       
     222     ;; clear!) 
     223     (lambda (sfht)
     224       (sfht-ba-set! sfht (make-sparse-vector default))
     225       (sfht-size-set! sfht 0))
     226       
     227
     228     )))
    219229   
    220230)
  • release/4/sfht/trunk/sfht.setup

    r25306 r30122  
    44  (make-pathname #f fn ##sys#load-dynamic-extension))   
    55
    6 (compile -O2 -d0 -s sfht.scm -j sfht)
     6(compile -O -d2 -s sfht.scm -j sfht)
    77(compile -O2 -d0 -s sfht.import.scm)
    88
     
    1717
    1818  ; Assoc list with properties for your extension:
    19   '((version 2.6)
     19  '((version 3.0)
    2020    ))
    2121
  • release/4/sfht/trunk/tests/run.scm

    r25306 r30122  
    44
    55
    6 (require-extension test random-swb iset sfht)
    7 (import test random-swb iset sfht)
     6(require-extension test random-swb iset typeclass sfht)
     7(import typeclass test random-swb iset sfht)
    88
    99
     
    1313(define min-key 1)
    1414(define max-key 100)
     15
     16(define (compute-assoc key) (cons key (++ key)))
     17
     18
     19(let ((m (sfht-map  100000 0.0001
     20                    (lambda (i) (make-swb-random-state i (fx+ i 17)))
     21                    swb:random!
     22                    integer->bit-vector
     23                    (compose (lambda (x) (if x 1 0)) bit-vector-ref)
     24                    bit-vector-length)))
     25     (with-instance ((<SFHT> m))
     26
     27
     28       (let ((t (empty)))
     29
     30       (test-group  "sfht test"
    1531           
    16 (define sfht (make-sfht 100000 0.0001
    17                         (lambda (i) (make-swb-random-state i (fx+ i 17)))
    18                         swb:random!
    19                         integer->bit-vector
    20                         (compose (lambda (x) (if x 1 0)) bit-vector-ref)
    21                         bit-vector-length))
     32          (test-assert (empty? t))
     33          (test-assert (zero? (size t)))
     34           
     35          (print "(compute-assoc 0) = " (compute-assoc 0))
     36          (do ((i min-key (++ i))) ((> i max-key))
     37            (test-assert (not (put! t i (cdr (compute-assoc i)))))
     38            (test (compute-assoc i) (get t i)))
    2239
    23 (define compute-assoc (lambda (key) (cons key (++ key))))
     40          (test  (++ (- max-key min-key)) (size t))
     41          (test-assert (not (empty? t)))
     42 
     43          (test   (compute-assoc (++ min-key)) (get t (++ min-key)))
     44          (test   (compute-assoc (++ min-key)) (get t (++ min-key) #f))
     45           
     46          (test-assert (not (get t (-- min-key) #f)))
    2447
    25 (test-group  "sfht test"
     48          (clear! t)
    2649           
    27   (test-assert (sfht 'empty?))
    28   (test-assert (zero? (sfht 'size)))
     50          (test-assert (empty? t))
     51          (test-assert (zero? (size t)))
    2952           
    30   (do ((i min-key (++ i))) ((> i max-key))
    31     (test-assert (not ((sfht 'put!) i (cdr (compute-assoc i)))))
    32     (test  (compute-assoc i) ((sfht 'get) i)))
    33 
    34   (test  (++ (- max-key min-key)) (sfht 'size))
    35   (test-assert (not (sfht 'empty?)))
     53          (do ((i max-key (-- i))) ((< i min-key))
     54            (test-assert (not (put! t i (cdr (compute-assoc i)))))
     55            (test (compute-assoc i) (get t i) )
     56            (test-assert (delete! t i)))
     57                                 
     58          (test-assert (zero? (size t)))
    3659 
    37   (test   (compute-assoc (++ min-key)) ((sfht 'get) (++ min-key)))
    38   (test   (compute-assoc (++ min-key)) ((sfht 'get) (++ min-key) #f))
    39            
    40   (test-assert (not ((sfht 'get) (-- min-key) #f)))
    41 
    42   (sfht 'clear!)
    43            
    44   (test-assert (sfht 'empty?))
    45   (test-assert (zero? (sfht 'size)))
    46            
    47    (do ((i max-key (-- i))) ((< i min-key))
    48      (test-assert (not ((sfht 'put!) i (cdr (compute-assoc i)))))
    49      (test (compute-assoc i) ((sfht 'get) i) )
    50      (test-assert ((sfht 'delete!) i)))
    51                                  
    52  
    53   (test-assert (zero? (sfht 'size)))
    54            
    55  
    56   (do ((i min-key) (j max-key) (direction #t (not direction)))
    57       ((< j i))
    58     (cond
    59      (direction
    60       (test-assert (not ((sfht 'put!) i (cdr (compute-assoc i)))))
    61       (set! i (++ i)))
    62      (else
    63       (test-assert (not ((sfht 'put!) j (cdr (compute-assoc j)))))
    64       (set! j (-- j)))))
    65 
    66   (do ((i min-key (++ i))) ((> i max-key))
    67     (test (compute-assoc i) ((sfht 'get) i) ))
    68 
    69 )
    70 
     60          (do ((i min-key) (j max-key) (direction #t (not direction)))
     61              ((< j i))
     62            (cond
     63             (direction
     64              (test-assert (not (put! t i (cdr (compute-assoc i)))))
     65              (set! i (++ i)))
     66             (else
     67              (test-assert (not (put! t j (cdr (compute-assoc j)))))
     68              (set! j (-- j)))))
     69         
     70          (do ((i min-key (++ i))) ((> i max-key))
     71            (test (compute-assoc i) (get t i) ))
     72         
     73          ))
     74       ))
     75       
    7176(test-exit)
Note: See TracChangeset for help on using the changeset viewer.