Changeset 14491 in project


Ignore:
Timestamp:
04/28/09 10:57:45 (10 years ago)
Author:
Ivan Raikov
Message:

sfht ported to Chicken 4

Location:
release/4
Files:
6 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/random-swb/trunk/random-swb.scm

    r14477 r14491  
    7272<#
    7373
    74 (define cminus (foreign-lambda int "cminus" int int int))
     74(define cminus (foreign-lambda unsigned-int "cminus" unsigned-int unsigned-int unsigned-int))
    7575
    7676
  • release/4/sfht/trunk/sfht-eggdoc.scm

    r7358 r14491  
    66     (name "sfht")
    77     (description "A dictionary data structure based on counting Bloom filters.")
    8      (author (url "http://chicken.wiki.br/ivan raikov" "Ivan Raikov"))
     8     (author (url "http://chicken.wiki.br/users/ivan-raikov" "Ivan Raikov"))
    99
    1010     (history
     11      (version "2.3" "Ported to Chicken 4")
    1112      (version "2.1" "Build script updated for better cross-platform compatibility")
    1213      (version "2.0" "Introduced an API that is independent of the RNG used")
     
    134135
    135136     (license
    136       "Copyright 2007 Ivan Raikov and the Okinawa Institute of Science and Technology
     137      "Copyright 2007-2009 Ivan Raikov.
    137138
    138139This program is free software: you can redistribute it and/or modify
  • release/4/sfht/trunk/sfht.meta

    r9305 r14491  
     1;;;; -*- Hen -*-
     2
    13((egg "sfht.egg") ; This should never change
    24
    35 ; List here all the files that should be bundled as part of your egg. 
    46
    5  (files "sfht.scm" "sfht-eggdoc.scm" "sfht.setup" "tests/run.scm")
     7 (files "sfht.scm" "sfht-eggdoc.scm" "sfht.setup" "tests")
    68
    79 ; Your egg's license:
     
    1618 ; A list of eggs sfht depends on.
    1719
    18  (needs testeez eggdoc sparse-vectors)
     20 (needs eggdoc test matchable sparse-vectors)
    1921
    2022 (eggdoc "sfht-eggdoc.scm")
  • release/4/sfht/trunk/sfht.scm

    r6192 r14491  
    88;;
    99;;
    10 ;; Copyright 2007 Ivan Raikov
     10;; Copyright 2007-2009 Ivan Raikov.
    1111;;
    1212;;
     
    2525;;
    2626
    27 (require-extension srfi-1)
    28 (require-extension sparse-vectors)
    29 
    30 (define-extension sfht)
     27(module sfht
     28
     29  (make-sfht)
     30
     31  (import scheme chicken data-structures)
     32
     33  (require-extension srfi-1 matchable sparse-vectors)
    3134
    3235(define ln06185 (log 0.6185))
     
    5861   
    5962    ;; Hash functions based on uniform pseudo-random numbers
    60     (define rng-states (list-tabulate k (lambda (i) (make-random-state i))))
     63    (define rng-states (list-tabulate k (lambda (i)
     64                                          (make-random-state i))))
    6165
    6266    ;; Pre-calculate hash function coefficients for vectors of size up
     
    6569
    6670    (define random-coeffs
    67       (map (lambda (st) (list-tabulate H (lambda (x) (random! st))))
     71      (map (lambda (st)
     72             (list-tabulate H (lambda (x) (random! st))))
    6873           rng-states))
    6974
     
    108113                            (if (fx= 0 sz)
    109114                                (sparse-vector-set! ba index (list 1 (list (cons key x))))
    110                                 (begin
     115                                (beginxb
    111116                                  (let tail ((k sz) (lst lst) (prev #f))
    112117                                    (if (null? lst)
     
    213218         (sfht:error "Unknown message " selector " sent to an SFHT"))))))
    214219   
    215 
    216 
     220)
  • release/4/sfht/trunk/sfht.setup

    r6630 r14491  
    1 
    2 (define has-exports? (string>=? (chicken-version) "2.310"))
     1;;;; -*- Hen -*-
    32
    43(define (dynld-name fn)         
    54  (make-pathname #f fn ##sys#load-dynamic-extension))   
    65
    7 (compile -O2 -d0 -s
    8          ,@(if has-exports? '(-check-imports -emit-exports sfht.exports) '())
    9          sfht.scm -lchicken -ldl -lm)
     6(compile -O2 -d0 -s sfht.scm -j sfht)
     7(compile -O2 -d0 -s sfht.import.scm)
    108
    119(run (csi -qbs sfht-eggdoc.scm > sfht.html))
     
    1715
    1816  ; Files to install for your extension:
    19   `(,(dynld-name "sfht") "sfht.html"
    20     ,@(if has-exports? '("sfht.exports") (list)) )
     17  `(,(dynld-name "sfht") ,(dynld-name "sfht.import") "sfht.html" )
    2118
    2219
    2320  ; Assoc list with properties for your extension:
    24   '((version 2.1)
     21  '((version 2.3)
    2522    (documentation "sfht.html")
    26     ,@(if has-exports? `((exports "sfht.exports")) (list)) ))
     23    ))
    2724
  • release/4/sfht/trunk/tests/run.scm

    r6192 r14491  
    44
    55
    6 (require-extension srfi-13)
    7 (require-extension testeez)
    8 (require-extension iset)
    9 (require-extension random-swb)
    10 (require-extension sfht)
    11 
    12 (define-macro (++! x) `(set! ,x (fx+ 1 ,x)))
    13 (define-macro (++ x) `(fx+ 1 ,x))
    14 (define-macro (--! x) `(set! ,x (fx- ,x 1)))
    15 (define-macro (-- x) `(fx- ,x 1))
     6(require-extension test random-swb iset sfht)
     7(import test random-swb iset sfht)
    168
    179
    18 (define (sfht-test)
    19   (testeez "--> Inserting a set of numbers in an SFHT"
     10(define (++ x) (fx+ 1 x))
     11(define (-- x) (fx- x 1))
     12
     13(define min-key 1)
     14(define max-key 100)
    2015           
    21            (test-define "" min-key 1)
    22            (test-define "" max-key 10)
     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))
     22
     23(define compute-assoc (lambda (key) (cons key (++ key))))
     24
     25(test-group  "sfht test"
    2326           
    24            (test-define "" sfht (make-sfht 100000 0.0001
    25                                            (lambda (i) (make-swb-random-state i (fx+ i 17)))
    26                                            swb:random!
    27                                            integer->bit-vector
    28                                            (compose (lambda (x) (if x 1 0))
    29                                                     bit-vector-ref)
    30                                            bit-vector-length))
     27  (test-assert (sfht 'empty?))
     28  (test-assert (zero? (sfht 'size)))
    3129           
    32            (test-define "a hard-wired association between a key and a value"
    33                         compute-assoc (lambda (key) (cons key (++ key))))
     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?)))
     36 
     37  (test   (compute-assoc (++ min-key)) ((sfht 'get) (++ min-key)))
     38  (test   (compute-assoc (++ min-key)) ((sfht 'get) (++ min-key) #f))
    3439           
    35            (test/equal "" (sfht 'empty?) #t)
    36            (test/equal "" (zero? (sfht 'size))  #t)
     40  (test-assert (not ((sfht 'get) (-- min-key) #f)))
     41
     42  (sfht 'clear!)
    3743           
    38            (test-eval (string-concatenate (list "loading a sequence ["
    39                                                 (number->string min-key) ", "
    40                                                 (number->string max-key) "] in ascending order"))
    41                       (do ((i min-key (++ i))) ((> i max-key))
    42                         (testeez (test/equal "" ((sfht 'put!) i (cdr (compute-assoc i))) #f)
    43                                  (test/equal "" ((sfht 'get) i) (compute-assoc i)))))
     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)))))
    4465
    45            (test/equal "" (sfht 'size) (++ (- max-key min-key)))
    46            (test/equal "" (sfht 'empty?)  #f)
    47            
    48            (test/equal "" ((sfht 'get) (++ min-key))  (compute-assoc (++ min-key)))
    49            (test/equal "" ((sfht 'get) (++ min-key) #f)  (compute-assoc (++ min-key)))
    50            
    51            (test/equal "check looking up of non-existing keys" (not ((sfht 'get) (-- min-key) #f)) #t)
    52            (test/equal "" ((sfht 'get) (++ max-key) (lambda () 1)) 1)
    53            
    54            (test-eval "clear the sfht" (sfht 'clear!))
    55            
    56            (test/equal "" (sfht 'empty?) #t)
    57            (test/equal "" (zero? (sfht 'size))  #t)
    58            
    59            (test-eval "reloading the same seq in descending order and then deleting"
    60                       (do ((i max-key (-- i))) ((< i min-key))
    61                         (testeez (test/equal "" ((sfht 'put!) i (cdr (compute-assoc i))) #f)
    62                                  (test/equal "" ((sfht 'get) i) (compute-assoc i))
    63                                  (test/equal "" ((sfht 'delete!) i) #t))))
    64                                  
     66  (do ((i min-key (++ i))) ((> i max-key))
     67    (test (compute-assoc i) ((sfht 'get) i) ))
    6568
    66            (test/equal "" (zero? (sfht 'size)) #t)
    67            
    68            (test-eval "loading the sfht again in a \"random\" order"
    69                       (do ((i min-key) (j max-key) (direction #t (not direction)))
    70                           ((< j i))
    71                         (cond
    72                          (direction
    73                           (testeez (test/equal "" ((sfht 'put!) i (cdr (compute-assoc i))) #f))
    74                           (++! i))
    75                          (else
    76                           (testeez (test/equal "" ((sfht 'put!) j (cdr (compute-assoc j))) #f))
    77                           (--! j)))))
    78            
    79            (test-eval "looking up the elements in  the sfht"
    80                       (do ((i min-key (++ i))) ((> i max-key))
    81                         (testeez (test/equal "" ((sfht 'get) i) (compute-assoc i)))))))
     69)
    8270
    83 (sfht-test)
    84 
Note: See TracChangeset for help on using the changeset viewer.