Changeset 14465 in project


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

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

Location:
release/4
Files:
10 edited
2 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 
  • release/4/treap/trunk/tests/run.scm

    r4308 r14465  
    22; Verifying the treaps package
    33;
    4 ; Modified for Chicken Scheme and the testeez package by Ivan Raikov
    5 ;
    6 ;
    7 ; $Id: vtreap.scm,v 1.2 2002/11/14 04:45:26 oleg Exp oleg $
     4; Modified for Chicken Scheme and the test package by Ivan Raikov
    85
    96
    10 (require-extension srfi-13)
    11 (require-extension testeez)
    12 (require-extension treap)
    13 
    14 (define-macro (++! x) `(set! ,x (fx+ 1 ,x)))
    15 (define-macro (++ x) `(fx+ 1 ,x))
    16 (define-macro (--! x) `(set! ,x (fx- ,x 1)))
    17 (define-macro (-- x) `(fx- ,x 1))
     7(require-library srfi-1 srfi-13 treap test)
     8(import srfi-1 srfi-13 treap test)
    189
    1910
    20 (define (treap-test:sort)
    21   (testeez "--> Sorting of a set of numbers via a treap"
     11(define (++ x) (fx+ 1 x))
     12(define (-- x) (fx- x 1))
     13
     14(define min-key -1)
     15(define max-key 10)
     16
     17(define a-key (quotient (+ min-key max-key) 2))
    2218           
    23            (test-define "" min-key -1)
    24            (test-define "" max-key 10)
     19(define treap (make-treap (lambda (x y) (- x y))))
    2520           
    26            (test-define "" treap (make-treap (lambda (x y) (- x y))))
     21(define ;; a hard-wired association between a key and a value"
     22  compute-assoc (lambda (key) (cons key (++ key))))
    2723           
    28            (test-define "a hard-wired association between a key and a value"
    29                         compute-assoc (lambda (key) (cons key (++ key))))
     24
     25(test-group "--> Sorting of a set of numbers via a treap"
    3026           
    31            (test/equal "" (treap 'empty?) #t)
    32            (test/equal "" (zero? (treap 'size))  #t)
    33            (test/equal "" (zero? (treap 'depth)) #t)
     27    (test-assert (treap 'empty?) )
     28    (test-assert (zero? (treap 'size)))
     29    (test-assert (zero? (treap 'depth)))
    3430           
    35            (test-eval (string-concatenate (list "loading a sequence ["
    36                                                 (number->string min-key) ", "
    37                                                 (number->string max-key) "] in ascending order"))
    38                       (do ((i min-key (++ i))) ((> i max-key))
    39                         (testeez (test/equal "" ((treap 'put!) i (cdr (compute-assoc i))) #f))))
     31    (do ((i min-key (++ i))) ((> i max-key))
     32      (test-assert (not ((treap 'put!) i (cdr (compute-assoc i))) )))
    4033           
    41            (test-eval "treap nodes: " (treap 'debugprint))
    42            (test-eval "treap depth: " (treap 'depth))
     34    (print "treap depth: " (treap 'depth))
     35    (treap 'debugprint)
    4336           
    44            (test/equal "" (treap 'size) (++ (- max-key min-key)))
    45            (test/equal "" (treap 'empty?)  #f)
    46            (test/equal "" (treap 'get-min) (compute-assoc min-key))
    47            (test/equal "" (treap 'get-max) (compute-assoc max-key))
    48            (test/equal "" (treap 'get-min) ((treap 'get) min-key))
    49            (test/equal "" (treap 'get-max) ((treap 'get) max-key))
     37    (test (++ (- max-key min-key)) (treap 'size) )
     38    (test-assert (not (treap 'empty?)))
     39
     40    (test  (compute-assoc min-key) (treap 'get-min) )
     41    (test  (compute-assoc max-key) (treap 'get-max) )
     42    (test  ((treap 'get) min-key)  (treap 'get-min) )
     43    (test  ((treap 'get) max-key)  (treap 'get-max) )
    5044           
    51            (test/equal "" ((treap 'get) (++ min-key))  (compute-assoc (++ min-key)))
    52            (test/equal "" ((treap 'get) (++ min-key) #f)  (compute-assoc (++ min-key)))
     45    (test (compute-assoc (++ min-key)) ((treap 'get) (++ min-key)) )
     46    (test (compute-assoc (++ min-key)) ((treap 'get) (++ min-key) #f) )
    5347           
    54            (test/equal "check looking up of non-existing keys" (not ((treap 'get) (-- min-key) #f)) #t)
    55            (test/equal "" ((treap 'get) (++ max-key) (lambda () 1)) 1)
     48    (test-assert (not ((treap 'get) (-- min-key) #f)))
    5649           
    57            ;;  (must-have-failed ((treap 'get) (-- min-key)))
     50    (treap 'clear!)
    5851           
    59            (test-eval "clear the treap" (treap 'clear!))
     52    (test-assert (treap 'empty?) )
     53    (test-assert (zero? (treap 'size)) )
     54    (test-assert (zero? (treap 'depth)) )
    6055           
    61            (test/equal "" (treap 'empty?) #t)
    62            (test/equal "" (zero? (treap 'size))  #t)
    63            (test/equal "" (zero? (treap 'depth)) #t)
     56    (do ((i max-key (-- i))) ((< i min-key))
     57      (test-assert (not ((treap 'put!) i (cdr (compute-assoc i))))))
     58
     59    (print "treap depth: " (treap 'depth))
     60    (treap 'debugprint)
     61
     62    (test (compute-assoc min-key) (treap 'get-min) )
     63    (test (compute-assoc min-key) (treap 'delete-min!) )
     64    (test-assert (not ((treap 'get) min-key #f)) )
     65    (test  (compute-assoc (++ min-key)) (treap 'get-min) )
     66
     67    (test (compute-assoc max-key) (treap 'get-max) )
     68    (test (compute-assoc max-key) (treap 'delete-max!) )
     69
     70    (test-assert (not ((treap 'get) max-key #f)) )
     71    (test (treap 'get-max) ((treap 'get) (-- max-key)) )
     72    (test (treap 'size)  (+ -2 (++ (- max-key min-key))))
    6473           
    65            ;;  (must-have-failed ((treap 'get) min-key))
    66            ;;  (must-have-failed (treap 'get-min))
    67            ;;  (must-have-failed (treap 'get-max))
     74    (do ((i (++ min-key) (++ i))) ((> i (-- max-key)))
     75      (test  (compute-assoc i) ((treap 'get) i #f))
     76      (test  (compute-assoc i) (treap 'delete-min!) )
     77      (test-assert (not ((treap 'get) i #f) )))
    6878           
    69            (test-eval "reloading the same seq in descending order"
    70                       (do ((i max-key (-- i))) ((< i min-key))
    71                         (testeez (test/equal "" ((treap 'put!) i (cdr (compute-assoc i))) #f))))
     79    (test-assert (treap 'empty?))
     80    (test-assert (zero? (treap 'size)) )
     81    (test-assert (zero? (treap 'depth)) )
     82           
     83   
     84    (do ((i min-key) (j max-key) (direction #t (not direction)))
     85        ((< j i))
     86      (cond
     87       (direction
     88        (test-assert (not ((treap 'put!) i (cdr (compute-assoc i)))))
     89        (set! i (++ i)))
     90       (else
     91        (test-assert (not ((treap 'put!) j (cdr (compute-assoc j)))))
     92        (set! j (-- j)))))
     93           
    7294
    73            (test-eval "treap nodes: " (treap 'debugprint))
    74            (test-eval "treap depth: " (treap 'depth))
     95    (let* ((old-assoc (compute-assoc a-key))
     96           (new-assoc (cons a-key #\a)))
     97       (test old-assoc ((treap 'get) a-key) )
     98       (test old-assoc ((treap 'put!) a-key (cdr new-assoc)) )
     99       (test new-assoc ((treap 'get) a-key) )
     100       (test new-assoc ((treap 'delete!) a-key) )
     101       (test-assert (not ((treap 'delete!) a-key #f) ))
     102       (test-assert (not ((treap 'put!) a-key (cdr old-assoc)) ))
     103       (test old-assoc ((treap 'put!) a-key (cdr old-assoc)) )
     104       (test old-assoc ((treap 'get) a-key) ))
     105                       
     106    (test (treap 'size) (++ (- max-key min-key)))
    75107
    76            (test/equal "" (treap 'get-min) (compute-assoc min-key))
    77            (test/equal "" (treap 'delete-min!) (compute-assoc min-key))
    78            (test/equal "" ((treap 'get) min-key #f) #f)
    79            (test/equal "" (treap 'get-min) (compute-assoc (++ min-key)))
    80            
    81            (test/equal "" (treap 'get-max) ((treap 'get) max-key))
    82            (test/equal "" (treap 'delete-max!) (compute-assoc max-key))
    83            (test/equal "" ((treap 'get) max-key #f) #f)
    84            (test/equal "" (treap 'get-max)  ((treap 'get) (-- max-key)))
    85            (test/equal "" (treap 'size)     (+ -2 (++ (- max-key min-key))))
    86            
    87            (test-eval "remove the remaining treap elements one by one, from min to max"
    88                       (do ((i (++ min-key) (++ i))) ((> i (-- max-key)))
    89                         (testeez (test/equal "" ((treap 'get) i #f) (compute-assoc i))
    90                                  (test/equal "" (treap 'delete-min!) (compute-assoc i))
    91                                  (test/equal "" ((treap 'get) i #f) #f))))
    92            
    93            (test/equal "" (treap 'empty?) #t)
    94            (test/equal "" (zero? (treap 'size))  #t)
    95            (test/equal "" (zero? (treap 'depth)) #t)
    96            
    97            ;;  (must-have-failed ((treap 'for-each-ascending) (lambda (association) #t)))
    98            ;;  (must-have-failed ((treap 'for-each-descending) (lambda (association) #t)))
    99            
    100            (test-eval "loading the treap again in a \"random\" order"
    101                       (do ((i min-key) (j max-key) (direction #t (not direction)))
    102                           ((< j i))
    103                         (cond
    104                          (direction
    105                           (testeez (test/equal "" ((treap 'put!) i (cdr (compute-assoc i))) #f))
    106                           (++! i))
    107                          (else
    108                           (testeez (test/equal "" ((treap 'put!) j (cdr (compute-assoc j))) #f))
    109                           (--! j)))))
    110            
    111            (test-define "" a-key (quotient (+ min-key max-key) 2))
     108    (print "treap depth: " (treap 'depth))
    112109
    113            (test-eval (string-concatenate (list "checking putting and deleting of an assoc with key "
    114                                                 (number->string a-key)))
    115                       (let* ((old-assoc (compute-assoc a-key))
    116                              (new-assoc (cons a-key #\a)))
    117                         (testeez (test/equal "" ((treap 'get) a-key) old-assoc)
    118                                  (test/equal "" ((treap 'put!) a-key (cdr new-assoc)) old-assoc)
    119                                  (test/equal "" ((treap 'get) a-key) new-assoc)
    120                                  (test/equal "" ((treap 'delete!) a-key) new-assoc)
    121                                  (test/equal "" ((treap 'delete!) a-key #f) #f)
    122                                  (test/equal "" ((treap 'put!) a-key (cdr old-assoc)) #f)
    123                                  (test/equal "" ((treap 'put!) a-key (cdr old-assoc)) old-assoc)
    124                                  (test/equal "" ((treap 'get) a-key) old-assoc))))
    125                        
    126            (test/equal "" (treap 'size) (++ (- max-key min-key)))
     110    (test-assert (not (treap 'empty?)))
    127111
    128            (test-eval "treap depth: " (treap 'depth))
     112    (let ((expected-key min-key))
     113      ((treap 'for-each-ascending)
     114       (lambda (association)
     115         (test association (compute-assoc expected-key))
     116         (set! expected-key (++ expected-key))))
     117      (test expected-key (++ max-key) ))
    129118
    130            (test/equal "" (treap 'empty?) #f)
     119    (let ((expected-key max-key))
     120      ((treap 'for-each-descending)
     121       (lambda (association)
     122         (test association (compute-assoc expected-key))
     123         (set! expected-key (-- expected-key))))
     124      (test expected-key (-- min-key)  )))
    131125
    132   (test-eval "checking traversing in the ascending order"
    133              (let ((expected-key min-key))
    134                ((treap 'for-each-ascending)
    135                 (lambda (association)
    136                   (testeez (test/equal "" association (compute-assoc expected-key)))
    137                   (++! expected-key)))
    138                (testeez (test/equal "" expected-key (++ max-key)))))
    139 
    140   (test-eval "checking traversing in the descending order"
    141              (let ((expected-key max-key))
    142                ((treap 'for-each-descending)
    143                 (lambda (association)
    144                   (testeez (test/equal "" association (compute-assoc expected-key)))
    145                   (--! expected-key)))
    146                (testeez (test/equal "" expected-key (-- min-key)))))))
    147 
    148 
    149 (define (treap-test:map)
    150   (testeez "--> Build a treap to map from digit strings to the numbers "
    151 
    152            (test-define "" lo 1)
    153            (test-define "" hi 150)
    154            (test-define "" treap (make-treap (lambda (x y) (if (string<? x y) -1 (if (string>? x y) 1 0)))))
    155 
    156            (test-define "" min-key #f)
    157            (test-define "" max-key #f)
    158 
    159            (test/equal "" (treap 'empty?) #t)
    160            (test/equal "" (zero? (treap 'size))  #t)
    161            (test/equal "" (zero? (treap 'depth)) #t)
    162 
    163            (test-eval (string-concatenate (list "loading a sequence ["
    164                                                 (number->string lo) ","
    165                                                 (number->string hi)
    166                                                 "] in an ascending number order"))
    167                       (do ((i lo (++ i))) ((> i hi))
    168                         (let ((key (number->string i)))
    169                           (testeez (test/equal "" ((treap 'put!) key i) #f))
    170                           (cond
    171                            ((not min-key) (set! min-key key) (set! max-key key))
    172                            ((string<? key min-key) (set! min-key key))
    173                            ((string>? key max-key) (set! max-key key))))))
    174 
    175            (test-eval "treap depth: " (treap 'depth))
    176 
    177            (test/equal "" (treap 'size) (++ (- hi lo)))
    178            (test/equal "" (treap 'empty?) #f)
    179            (test/equal "" (treap 'get-min) (cons min-key (string->number min-key)))
    180            (test/equal "" (treap 'get-max) (cons max-key (string->number max-key)))
    181            (test/equal "" (treap 'get-min) ((treap 'get) min-key))
    182            (test/equal "" (treap 'get-max) ((treap 'get) max-key))
    183 
    184            (test-define "" a-key-val (quotient (+ lo hi) 2))
    185            (test-define "" a-key     (number->string a-key-val))
    186 
    187            (test-eval (string-concatenate (list "checking putting and deleting of an assoc with key " a-key))
    188                       (let* ((old-assoc (cons a-key a-key-val))
    189                              (new-assoc (cons a-key #\a)))
    190                         (testeez (test/equal "" ((treap 'get) a-key) old-assoc)
    191                                  (test/equal "" ((treap 'put!) a-key (cdr new-assoc)) old-assoc)
    192                                  (test/equal "" ((treap 'get) a-key) new-assoc)
    193                                  (test/equal "" ((treap 'delete!) a-key) new-assoc)
    194                                  (test/equal "" ((treap 'delete!) a-key #f) #f)
    195                                  (test/equal "" ((treap 'put!) a-key (cdr old-assoc)) #f)
    196                                  (test/equal "" ((treap 'put!) a-key (cdr old-assoc)) old-assoc)
    197                                  (test/equal "" ((treap 'get) a-key) old-assoc))))
    198  
    199            (test/equal "" (treap 'size) (++ (- hi lo)))
    200 
    201            (test-define "" values-to-print 15)
    202            
    203            (test-eval (string-concatenate (list "printing out first "
    204                                                 (number->string values-to-print)
    205                                                 " associations in the descending\n"
    206                                                 "\torder of their string keys (but not the values themselves!)"))
    207                       (let* ((printed 0))
    208                         ((treap 'for-each-descending)
    209                          (lambda (association)
    210                            (if (zero? printed)
    211                                (testeez (test/equal "" association (cons max-key (string->number max-key)))))
    212                            (if (< printed values-to-print)
    213                                (print "\t\t" association #\newline))
    214                            (++! printed)))
    215                       (testeez (test/equal "" printed (treap 'size)))))))
    216 (if (treap-test:sort)
    217     (treap-test:map))
  • release/4/treap/trunk/treap-eggdoc.scm

    r7357 r14465  
    77     (description "A sorted dictionary data structure based on randomized search trees.")
    88     (author (p "Oleg Kiselyov; packaged for Chicken Scheme by "
    9                 (url "http://chicken.wiki.br/ivan raikov" "Ivan Raikov")))
     9                (url "http://chicken.wiki.br/users/ivan-raikov" "Ivan Raikov")))
    1010
    1111     (history
     12      (version "1.5" "Ported to Chicken 4")
    1213      (version "1.4" "Build script updated for better cross-platform compatibility")
    1314      (version "1.3" "License upgrade to GPL v3")
     
    262263;; "--> Sorting of a set of numbers via a treap"
    263264
    264 (define-macro (++! x) `(set! ,x (fx+ 1 ,x)))
    265 (define-macro (++ x) `(fx+ 1 ,x))
    266 (define-macro (--! x) `(set! ,x (fx- ,x 1)))
    267 (define-macro (-- x) `(fx- ,x 1))
     265(define (++ x) (fx+ 1 x))
     266(define (-- x) (fx- x 1))
    268267
    269268(let
     
    292291      (lambda (association)
    293292        (print (equal? association (compute-assoc expected-key)))
    294         (++! expected-key))))
     293        (set! expected-key (++ expected-key)))))
    295294    ;(assert (= expected-key (++ max-key))))
    296295
     
    313312      (lambda (association)
    314313        (print (equal? association (compute-assoc expected-key)))
    315         (--! expected-key)))))
     314        (set! expected-key (-- expected-key))))))
    316315    ;(assert (= expected-key (-- min-key))))
    317316EOF
  • release/4/treap/trunk/treap.meta

    r9305 r14465  
     1;;;; -*- Hen -*-
     2
    13((egg "treap.egg") ; This should never change
    24
    35 ; List here all the files that should be bundled as part of your egg. 
    46
    5  (files "treap.scm" "treap-eggdoc.scm" "treap.setup" "tests/run.scm")
     7 (files "treap.scm" "treap-eggdoc.scm" "treap.setup" "tests")
    68
    79 ; Your egg's license:
     
    1618 ; A list of eggs treap depends on.
    1719
    18  (needs testeez eggdoc)
     20 (needs test eggdoc)
    1921
    2022 (eggdoc "treap-eggdoc.scm")
    2123
    22  (author "Oleg Kiselyov; packaged for Chicken Scheme by Ivan Raikov")
     24 (author "Oleg Kiselyov")
     25
     26 (maintainer "Ivan Raikov")
    2327
    2428 (synopsis "A sorted dictionary data structure based on randomized search trees."))
  • release/4/treap/trunk/treap.scm

    r4050 r14465  
    243243; $Id: treap.scm,v 1.3 2004/07/08 21:00:24 oleg Exp $
    244244;
    245 ; Packaged for Chicken Scheme by Ivan Raikov <iraikov@ece.gatech.edu>
    246 ;
    247 
    248 (define-extension treap)
    249 
    250 (declare (export  make-treap))
    251 
    252 (define-macro (inc! x) `(set! ,x (fx+ 1 ,x)))
    253 (define-macro (inc x) `(fx+ 1 ,x))
    254 (define-macro (dec! x) `(set! ,x (fx- ,x 1)))
    255 (define-macro (dec x) `(fx- ,x 1))
     245; Packaged for Chicken Scheme by Ivan Raikov.
     246;
     247
     248(module treap
     249
     250  (make-treap)
     251
     252  (import scheme chicken data-structures)
    256253
    257254; Treaps package needs a random number generator to generate values of
     
    276273; whether that pair has just been inserted or it was already there.
    277274
    278 ;(define wt-tree/split< #f)
    279 ;(define wt-tree/split> #f)
    280 ;(define wt-tree/union #f)
    281 ;(define wt-tree/intersection #f)
    282 ;(define wt-tree/difference #f)
    283 ;(define wt-tree/subset? #f)
    284 ;(define wt-tree/set-equal? #f)
    285 ;(define wt-tree/fold #f)
    286275
    287276
     
    295284  ;   slot 4 - prio, a priority of the node (a FIXNUM random number)
    296285
     286(define-syntax inc!
     287  (lambda (exp r c)
     288    (let ((x (cadr exp)) (%set! (r 'set!)) (%fx+ (r 'fx+)))
     289      `(,%set! ,x (,%fx+ 1 ,x)))))
     290
     291(define-syntax inc
     292  (lambda (exp r c)
     293    (let ((x (cadr exp)) (%fx+ (r 'fx+)))
     294      `(,%fx+ 1 ,x))))
     295
     296(define-syntax dec!
     297  (lambda (exp r c)
     298    (let ((x (cadr exp)) (%set! (r 'set!)) (%fx- (r 'fx-)))
     299      `(,%set! ,x (,%fx- ,x 1)))))
     300
     301(define-syntax dec
     302  (lambda (exp r c)
     303    (let ((x (cadr exp) ) (%fx- (r 'fx-)))
     304      `(,%fx- ,x 1))))
     305
     306
     307(define-syntax node:left-kid
     308  (lambda (x r c)
     309    (let ((node (cadr x))
     310          (%vector-ref (r 'vector-ref)))
     311      `(,%vector-ref ,node 2))))
     312
     313(define-syntax node:right-kid
     314  (lambda (x r c)
     315    (let ((node (cadr x)) (%vector-ref (r 'vector-ref)))
     316      `(,%vector-ref ,node 3))))
     317
     318(define-syntax node:priority
     319  (lambda (x r c)
     320    (let ((node (cadr x))
     321          (%vector-ref (r 'vector-ref)))
     322      `(,%vector-ref ,node 4))))
     323
     324(define-syntax node:left-kid-set!
     325  (lambda (x r c)
     326    (let ((node (cadr x))
     327          (new-kid (caddr x))
     328          (%vector-set! (r 'vector-set!)))
     329      `(,%vector-set! ,node 2 ,new-kid))))
     330     
     331
     332(define-syntax node:right-kid-set!
     333  (lambda (x r c)
     334    (let ((node (cadr x))
     335          (new-kid (caddr x))
     336          (%vector-set! (r 'vector-set!)))
     337      `(,%vector-set! ,node 3 ,new-kid))))
     338     
     339
     340(define-syntax node:unsubordination?
     341  (lambda (x r c)
     342    (let ((parent (cadr x))
     343          (kid (caddr x))
     344          (%node:priority (r 'node:priority))
     345          (%> (r '>)))
     346      `(,%> (,%node:priority ,parent) (,%node:priority ,kid)))))
     347
     348(define-syntax node:dispatch-on-key
     349  (lambda (x r c)
     350    (let ((node (second x)) (key (third x))
     351          (on-less (fourth x)) (on-equal (fifth x)) (on-greater (sixth x)))
     352      (let ((%let   (r 'let))
     353            (%cond  (r 'cond))
     354            (%else  (r 'else))
     355            (%zero?  (r 'zero?))
     356            (%positive?  (r 'positive?))
     357            (%vector-ref (r 'vector-ref))
     358            (result (r 'result)))
     359        `(,%let ((,result (key-compare ,key (,%vector-ref ,node 0) )))
     360                (,%cond
     361                 ((,%zero? ,result)     ,on-equal)
     362                 ((,%positive? ,result) ,on-greater)
     363                 (,%else              ,on-less)))))))
     364
     365
     366(define-syntax node:key
     367  (lambda (x r c)
     368    (let ((node (cadr x)) (%vector-ref (r 'vector-ref)))
     369      `(,%vector-ref ,node 0))))
     370
     371(define-syntax node:key-value
     372  (lambda (x r c)
     373    (let ((node (cadr x))
     374          (%cons (r 'cons))
     375          (%vector-ref (r 'vector-ref)))
     376      `(,%cons (,%vector-ref ,node 0) (,%vector-ref ,node 1)))))
     377
     378(define-syntax node:value-set!
     379  (lambda (x r c)
     380    (let ((node (cadr x)) (value (caddr x))
     381          (%vector-set! (r 'vector-set!)))
     382      `(,%vector-set! ,node 1 ,value))))
     383
    297384  (define (new-leaf key value)
    298385    (vector key value #f #f (random)))
    299 
    300   (define-macro (node:key node)   `(vector-ref ,node 0))
    301   (define-macro (node:key-value node)  `(cons (vector-ref ,node 0)
    302                                               (vector-ref ,node 1)))
    303   (define-macro (node:value-set! node value)   `(vector-set! ,node 1 ,value))
    304 
    305   (define-macro (node:left-kid node)   `(vector-ref ,node 2))
    306   (define-macro (node:right-kid node)  `(vector-ref ,node 3))
    307   (define-macro (node:left-kid-set! node new-kid)
    308                                 `(vector-set! ,node 2 ,new-kid))
    309   (define-macro (node:right-kid-set! node new-kid)
    310                                 `(vector-set! ,node 3 ,new-kid))
    311 
    312   (define-macro (node:priority node) `(vector-ref ,node 4))
    313   (define-macro (node:unsubordination? parent kid)
    314     `(> (node:priority ,parent) (node:priority ,kid)))
    315 
    316   (define-macro (node:dispatch-on-key node key on-less on-equal on-greater)
    317     (let ((result (gensym)))
    318       `(let ((,result (key-compare ,key (vector-ref ,node 0))))
    319         (cond
    320           ((zero? ,result) ,on-equal)
    321           ((positive? ,result) ,on-greater)
    322           (else ,on-less)))))
    323386
    324387  (define (node:debugprint node)
     
    345408            (loop (node:right-kid node))))))
    346409
    347     (define-macro (locate-extremum-node branch-selector)
    348       `(if (not root) (error "empty tree")
    349         (let loop ((node root) (parent #f))
    350           (if node (loop (,branch-selector node) node)
    351             (node:key-value parent)))))
    352 
    353                         ; in-order traversal of the treap
    354     (define-macro (for-each-inorder primary-branch-selector
    355                                     secondary-branch-selector)
    356       `(lambda (proc)
    357         (if (not root) (error "empty tree")
    358           (let loop ((node root))
    359           (when node
    360               (loop (,primary-branch-selector node))
    361               (proc (node:key-value node))
    362               (loop (,secondary-branch-selector node)))))))
     410    (define-syntax locate-extremum-node
     411      (lambda (x r c)
     412        (let ((branch-selector (cadr x))
     413              (%if      (r 'if))
     414              (%let     (r 'let))
     415              (%error   (r 'error))
     416              (%not     (r 'not))
     417              (loop     (r 'loop))
     418              (node     (r 'node))
     419              (parent   (r 'parent))
     420              (node:key-value (r 'node:key-value)))
     421          `(,%if (,%not root) (error "empty tree")
     422              (,%let ,loop ((,node root) (,parent #f))
     423                (,%if ,node (,loop (,branch-selector ,node) ,node)
     424                    (,node:key-value ,parent)))))))
     425
     426    ;; in-order traversal of the treap
     427    (define-syntax for-each-inorder
     428      (lambda (x r c)
     429         (let ((primary-branch-selector (cadr x))
     430               (secondary-branch-selector (caddr x))
     431               (%if      (r 'if))
     432               (%let     (r 'let))
     433               (%not     (r 'not))
     434               (%error   (r 'error))
     435               (%when    (r 'when))
     436               (%lambda  (r 'lambda))
     437               (loop     (r 'loop))
     438               (node     (r 'node))
     439               (node:key-value (r 'node:key-value)))
     440           `(,%lambda (proc)
     441              (,%if (,%not root) (,%error "empty tree")
     442                  (,%let ,loop ((,node root))
     443                    (,%when ,node
     444                      (,loop (,primary-branch-selector ,node))
     445                      (proc (,node:key-value ,node))
     446                      (,loop (,secondary-branch-selector ,node)))))))))
    363447
    364448    (define (get-depth)
     
    496580    ; Deleting existing associations from the treap
    497581
    498     (define-macro (delete-extremum-node! branch-selector
    499                                         branch-setter the-other-branch-selector)
    500       `(cond
    501         ((not root) (error "empty tree"))
    502         ((not (,branch-selector root))  ; root is the extreme node
    503           (let ((result (node:key-value root)))
    504             (set! root (,the-other-branch-selector root))
    505             (dec! size)
    506             result))
    507         (else
    508           (let loop ((node (,branch-selector root)) (parent root))
    509             (let ((kid (,branch-selector node)))
    510               (if kid (loop kid node)
    511                 (let ((result (node:key-value node)))
    512                   (,branch-setter parent (,the-other-branch-selector node))
    513                   (dec! size)
    514                   result)))))))
     582    (define-syntax delete-extremum-node!
     583      (lambda (x r c)
     584        (let ((branch-selector  (cadr x))
     585              (branch-setter    (caddr x))
     586              (the-other-branch-selector (cadddr x))
     587              (%if      (r 'if))
     588              (%let     (r 'let))
     589              (%not     (r 'not))
     590              (%error   (r 'error))
     591              (%when    (r 'when))
     592              (%cond    (r 'cond))
     593              (%else    (r 'else))
     594              (%set!    (r 'set!))
     595              (%dec!    (r 'dec!))
     596              (result   (r 'result))
     597              (loop     (r 'loop))
     598              (node     (r 'node))
     599              (parent   (r 'parent))
     600              (kid      (r 'kid))
     601              (node:key-value (r 'node:key-value)))
     602          `(,%cond
     603            ((,%not root) (,%error "empty tree"))
     604            ((,%not (,branch-selector root))    ; root is the extreme node
     605             (,%let ((,result (,node:key-value root)))
     606               (,%set! root (,the-other-branch-selector root))
     607               (,%dec! size)
     608               ,result))
     609            (,%else
     610             (,%let ,loop ((,node (,branch-selector root)) (,parent root))
     611               (,%let ((,kid (,branch-selector ,node)))
     612                 (,%if ,kid (,loop ,kid ,node)
     613                     (,%let ((,result (,node:key-value ,node)))
     614                       (,branch-setter ,parent (,the-other-branch-selector ,node))
     615                       (,%dec! size)
     616                       ,result)))))))))
    515617
    516618        ; Given two treap branches (both of which could be empty)
     
    597699        (else
    598700          (error "Unknown message " selector " sent to a treap"))))))
     701)
     702
  • release/4/treap/trunk/treap.setup

    r6634 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 treap.exports) '())
    9          treap.scm -lchicken -ldl -lm)
     6(compile -O -d2 -s treap.scm -j treap)
     7(compile -O -d2 -s treap.import.scm)
     8
    109
    1110(run (csi -qbs treap-eggdoc.scm > treap.html))
     
    1716
    1817  ; Files to install for your extension:
    19   `(,(dynld-name "treap") "treap.html"
    20     ,@(if has-exports? '("treap.exports") (list)) )
     18  `(,(dynld-name "treap") ,(dynld-name "treap.import") "treap.html")
     19 
     20  ; Assoc list with properties for your extension:
     21  '((version 1.5)
     22    (documentation "treap.html")
     23    ))
    2124
    22 
    23   ; Assoc list with properties for your extension:
    24   '((version 1.4)
    25     (documentation "treap.html")
    26     ,@(if has-exports? `((exports "treap.exports")) (list)) ))
    27 
Note: See TracChangeset for help on using the changeset viewer.