Changeset 14465 in project for release/4/rb-tree


Ignore:
Timestamp:
04/27/09 02:22:35 (11 years ago)
Author:
Ivan Raikov
Message:

treap and rb-tree copied to release/4 branch and ported to Chicken 4

Location:
release/4/rb-tree
Files:
5 edited
1 copied

Legend:

Unmodified
Added
Removed
  • release/4/rb-tree/trunk/rb-tree-eggdoc.scm

    r12430 r14465  
    66     (name "rb-tree")
    77     (description "A sorted dictionary data structure based on red-black trees.")
    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.6" "Ported to Chicken 4")
    1112      (version "2.5" "Fixes to for-each-ascending/descending")
    1213      (version "2.3" "Build script updated for better cross-platform compatibility")
     
    252253;; "--> Sorting of a set of numbers via a red-black tree"
    253254
    254 (define-macro (++! x) `(set! ,x (fx+ 1 ,x)))
    255 (define-macro (++ x) `(fx+ 1 ,x))
    256 (define-macro (--! x) `(set! ,x (fx- ,x 1)))
    257 (define-macro (-- x) `(fx- ,x 1))
     255(define (++ x) (fx+ 1 x))
     256(define (-- x) (fx- x 1))
    258257
    259258(let
     
    278277      (lambda (association)
    279278        (print (equal? association (compute-assoc expected-key)))
    280         (++! expected-key))))
     279        (set! expected-key (++ expected-key)))))
    281280
    282281  ;; clearing the rb-tree and reloading the same sequence in
     
    293292      (lambda (association)
    294293        (print (equal? association (compute-assoc expected-key)))
    295         (--! expected-key)))))
     294        (set! expected-key (-- expected-key))))))
    296295EOF
    297296))
  • release/4/rb-tree/trunk/rb-tree.meta

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

    r12429 r14465  
    1313;;
    1414;;
    15 ;; Copyright 2007 Ivan Raikov and the Okinawa Institute of Science and Technology
     15;; Copyright 2007-2009 Ivan Raikov and the Okinawa Institute of
     16;; Science and Technology.
    1617;;
    1718;;
     
    3435;;
    3536
    36 (require-extension srfi-1)
    37 (require-extension datatype)
    38 
    39 (define-extension rb-tree)
    40 
    41 (declare (export  make-rb-tree))
     37(module rb-tree
     38       
     39  (make-rb-tree)
     40
     41  (import scheme chicken data-structures)
     42 
     43  (require-extension srfi-1 datatype matchable)
    4244
    4345
     
    191193
    192194
     195(define (tree-tag x)
     196  (cases tree x
     197         (Empty () 'Empty)
     198         (Tree (c l k v r) 'Tree)))
     199
     200(define-record-printer (tree x out)
     201  (cases tree x
     202         (Empty () (display "#(Empty)" out))
     203         (Tree (c l k v r)
     204               (display "#(Tree " out)
     205               (display (conc c " ") out)
     206               (display (tree-tag l) out)
     207               (display (conc " " k ":" v " ") out)
     208               (display (tree-tag r) out)
     209               (display ")" out))))
     210
     211;;
     212;; This macro was borrowed from treap.scm by Oleg Kiselyov
     213;;
     214(define-syntax dispatch-on-key
     215  (lambda (x r c)
     216    (let ((key (second x)) (node-key (third x))
     217          (on-less (fourth x)) (on-equal (fifth x)) (on-greater (sixth x)))
     218      (let ((%let   (r 'let))
     219            (%cond  (r 'cond))
     220            (%else  (r 'else))
     221            (%zero  (r 'zero))
     222            (%positive?  (r 'positive?))
     223            (result (r 'result)))
     224        `(,%let ((,result (key-compare ,key ,node-key )))
     225                (,%cond
     226                 ((,%zero? ,result)     ,on-equal)
     227                 ((,%positive? ,result) ,on-greater)
     228                 (,%else              ,on-less)))))))
     229
     230
    193231(define (make-rb-tree key-compare)
    194   ;;
    195   ;; This macro was borrowed from treap.scm by Oleg Kiselyov
    196   ;;
    197   (define-macro (dispatch-on-key key node-key on-less on-equal on-greater)
    198     (let ((result (gensym)))
    199       `(let ((,result (key-compare ,node-key ,key )))
    200         (cond
    201           ((zero? ,result) ,on-equal)
    202           ((positive? ,result) ,on-greater)
    203           (else ,on-less)))))
    204232
    205233  (let ((root (Empty)) (size 0))
     
    604632  (make-rb-tree-dispatcher root size)))
    605633
     634)
  • release/4/rb-tree/trunk/rb-tree.setup

    r12430 r14465  
    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 rb-tree.exports) '())
    9          rb-tree.scm -lchicken -ldl -lm)
     6(compile -O -d2 -s rb-tree.scm -j rb-tree)
     7(compile -O -d2 -s rb-tree.import.scm)
     8
    109
    1110(run (csi -qbs rb-tree-eggdoc.scm > rb-tree.html))
     
    1716
    1817  ; Files to install for your extension:
    19   `(,(dynld-name "rb-tree") "rb-tree.html"
    20     ,@(if has-exports? '("rb-tree.exports") (list)) )
     18  `(,(dynld-name "rb-tree") ,(dynld-name "rb-tree.import") "rb-tree.html")
     19 
     20  ; Assoc list with properties for your extension:
     21  '((version 2.6)
     22    (documentation "rb-tree.html")
     23    ))
    2124
    22   ; Assoc list with properties for your extension:
    23   '((version 2.5)
    24     (documentation "rb-tree.html")
    25     ,@(if has-exports? `((exports "rb-tree.exports")) (list)) ))
  • release/4/rb-tree/trunk/tests/run.scm

    r5343 r14465  
    44;;
    55
    6 (require-extension srfi-13)
    7 (require-extension testeez)
    8 (require-extension rb-tree)
     6(require-library srfi-1 srfi-13 rb-tree test)
     7(import srfi-1 srfi-13 rb-tree test)
    98
    10 (define-macro (++! x) `(set! ,x (fx+ 1 ,x)))
    11 (define-macro (++ x) `(fx+ 1 ,x))
    12 (define-macro (--! x) `(set! ,x (fx- ,x 1)))
    13 (define-macro (-- x) `(fx- ,x 1))
     9(define (++ x) (fx+ 1 x))
     10(define (-- x) (fx- x 1))
    1411
     12(define min-key 1)
     13(define max-key 100)
     14           
     15(define rb-tree (make-rb-tree (lambda (x y) (- x y))))
     16       
     17;; a hard-wired association between a key and a value"   
     18(define compute-assoc (lambda (key) (cons key (++ key))))
     19           
     20(test-group "rb-tree-test initial"
    1521
    16 (define (rb-tree-test)
    17   (testeez "--> Inserting a set of numbers in a red-black tree"
     22            (test-assert (rb-tree 'empty?))
     23            (test-assert (zero? (rb-tree 'size))))
     24
     25(test-group (string-concatenate (list "loading a sequence ["
     26                                      (number->string min-key) ", "
     27                                      (number->string max-key) "] in ascending order"))
     28
     29    (do ((i min-key (++ i))) ((> i max-key))
     30      (test-assert (not ((rb-tree 'put!) i (cdr (compute-assoc i)))))
     31      (test (compute-assoc i)((rb-tree 'get) i) ))
     32
     33     (test (rb-tree 'size) (++ (- max-key min-key)))
     34     (test-assert (not (rb-tree 'empty?)))
    1835           
    19            (test-define "" min-key 1)
    20            (test-define "" max-key 100)
     36     (test (compute-assoc (++ min-key)) ((rb-tree 'get) (++ min-key)) )
     37     (test (compute-assoc (++ min-key)) ((rb-tree 'get) (++ min-key) #f)  )
    2138           
    22            (test-define "" rb-tree (make-rb-tree (lambda (x y) (- x y))))
     39     (test-assert "check looking up of non-existing keys"
     40                  (not ((rb-tree 'get) (-- min-key) #f)))
    2341           
    24            (test-define "a hard-wired association between a key and a value"
    25                         compute-assoc (lambda (key) (cons key (++ key))))
     42     (rb-tree 'clear!)
     43     )
     44
     45(test-group "reloading the same seq in descending order and then deleting"
    2646           
    27            (test/equal "" (rb-tree 'empty?) #t)
    28            (test/equal "" (zero? (rb-tree 'size))  #t)
     47    (test-assert (rb-tree 'empty?))
     48    (test-assert (zero? (rb-tree 'size)))
    2949           
    30            (test-eval (string-concatenate (list "loading a sequence ["
    31                                                 (number->string min-key) ", "
    32                                                 (number->string max-key) "] in ascending order"))
    33                       (do ((i min-key (++ i))) ((> i max-key))
    34                         (testeez (test/equal "" ((rb-tree 'put!) i (cdr (compute-assoc i))) #f)
    35                                  (test/equal "" ((rb-tree 'get) i) (compute-assoc i)))))
     50    (do ((i max-key (-- i))) ((< i min-key))
     51      (test-assert (not ((rb-tree 'put!) i (cdr (compute-assoc i)))))
     52      (test  (compute-assoc i) ((rb-tree 'get) i))
     53      (test-assert ((rb-tree 'delete!) i))))
    3654
    37            (test/equal "" (rb-tree 'size) (++ (- max-key min-key)))
    38            (test/equal "" (rb-tree 'empty?)  #f)
     55(test-group "loading the rb-tree again in a \"random\" order"
     56
     57     (test-assert (zero? (rb-tree 'size)))
    3958           
    40            (test/equal "" ((rb-tree 'get) (++ min-key))  (compute-assoc (++ min-key)))
    41            (test/equal "" ((rb-tree 'get) (++ min-key) #f)  (compute-assoc (++ min-key)))
    42            
    43            (test/equal "check looking up of non-existing keys" (not ((rb-tree 'get) (-- min-key) #f)) #t)
    44            (test/equal "" ((rb-tree 'get) (++ max-key) (lambda () 1)) 1)
    45            
    46            (test-eval "clear the rb-tree" (rb-tree 'clear!))
    47            
    48            (test/equal "" (rb-tree 'empty?) #t)
    49            (test/equal "" (zero? (rb-tree 'size))  #t)
    50            
    51            (test-eval "reloading the same seq in descending order and then deleting"
    52                       (do ((i max-key (-- i))) ((< i min-key))
    53                         (testeez (test/equal "" ((rb-tree 'put!) i (cdr (compute-assoc i))) #f)
    54                                  (test/equal "" ((rb-tree 'get) i) (compute-assoc i))
    55                                  (test/equal "" (if ((rb-tree 'delete!) i) #t #f) #t))))
    56                                  
     59     (do ((i min-key) (j max-key) (direction #t (not direction)))
     60         ((< j i))
     61       (cond
     62        (direction
     63         (test-assert (not ((rb-tree 'put!) i (cdr (compute-assoc i)))))
     64         (set! i (++ i)))
     65        (else
     66         (test-assert (not ((rb-tree 'put!) j (cdr (compute-assoc j)))))
     67         (set! j (-- j))))))
     68   
     69(test-group "looking up the elements in  the rb-tree"
     70    (do ((i min-key (++ i))) ((> i max-key))
     71            (test (compute-assoc i) ((rb-tree 'get) i) )))
    5772
    58            (test/equal "" (zero? (rb-tree 'size)) #t)
    59            
    60            (test-eval "loading the rb-tree again in a \"random\" order"
    61                       (do ((i min-key) (j max-key) (direction #t (not direction)))
    62                           ((< j i))
    63                         (cond
    64                          (direction
    65                           (testeez (test/equal "" ((rb-tree 'put!) i (cdr (compute-assoc i))) #f))
    66                           (++! i))
    67                          (else
    68                           (testeez (test/equal "" ((rb-tree 'put!) j (cdr (compute-assoc j))) #f))
    69                           (--! j)))))
    70            
    71            (test-eval "looking up the elements in  the rb-tree"
    72                       (do ((i min-key (++ i))) ((> i max-key))
    73                         (testeez (test/equal "" ((rb-tree 'get) i) (compute-assoc i)))))
     73(test "using fold to sum the elements in the rb-tree" 
     74      (* 50 (+ (+ 1 min-key) (+ 1 max-key)))
     75      ((rb-tree 'fold) (lambda (x sum) (+ x sum)) 0))
    7476
    75            (test/equal "using fold to sum the elements in the rb-tree"
    76                        ((rb-tree 'fold) (lambda (x sum) (+ x sum)) 0)
    77                        (* 50 (+ (+ 1 min-key) (+ 1 max-key))))
     77(test-group "using 'map to create a copy of tree with each element x mapped to x*10"
     78    (let ((rb-tree-x10 ((rb-tree 'map) (lambda (x) (* x 10))))
     79          (compute-assoc-x10 (lambda (key) (cons key (* 10 (++ key))))))
     80      (do ((i min-key (++ i))) ((> i max-key))
     81        (test (compute-assoc-x10 i) ((rb-tree-x10 'get) i) ))))
    7882
    79            (test-define "Using 'map to create a copy of tree with each element x mapped to x*10"
    80                         rb-tree-x10 ((rb-tree 'map) (lambda (x) (* x 10))))
    81 
    82            (test-define "a hard-wired association between a key and a value multiplied by 10"
    83                         compute-assoc-x10 (lambda (key) (cons key (* 10 (++ key)))))
    84 
    85            (test-eval "looking up the elements in the x10 rb-tree"
    86                       (do ((i min-key (++ i))) ((> i max-key))
    87                         (testeez (test/equal "" ((rb-tree-x10 'get) i) (compute-assoc-x10 i)))))))
    88 
    89 
    90 
    91 
    92 
    93 (rb-tree-test)
    94 
Note: See TracChangeset for help on using the changeset viewer.