source: project/release/5/skiplists/trunk/tests/run.scm @ 37472

Last change on this file since 37472 was 37472, checked in by juergen, 21 months ago

skiplists ported from chicken-4

File size: 6.8 KB
Line 
1;;; tests/run.scm
2
3(import scheme
4        (chicken base)
5        (chicken fixnum)
6        (chicken random)
7        ;%skiplists
8        skiplists
9        simple-tests)
10
11(define sls2 (skiplist 4 20 fixnum? - dups))
12(define sls1 (skiplist 15 fixnum? -))
13(define sls (skiplist integer? -))
14(define lst
15  (let loop ((k 0) (lst '()))
16    (if (= k 100)
17      lst
18      (loop (+ k 1) (cons (pseudo-random-integer 100) lst)))))
19(define item-type (lambda (x)
20                   (and ((list-of? integer?) x) (> (length x) 2))))
21(define primary-order (lambda (x y) (- (car x) (car y))))
22(define secondary-order (lambda (x y) (- (cadr x) (cadr y))))
23(define sls3 (skiplist 3
24                       10
25                       item-type
26                       primary-order
27                       secondary-order
28                       dups))
29(define lst1
30  (let loop ((k 0) (lst '()))
31    (if (= k 100)
32      lst
33      (loop (+ k 1) (cons (pseudo-random-integer 10) lst)))))
34(define lst2
35  (let loop ((k 0) (lst '()))
36    (if (= k 100)
37      lst
38      (loop (+ k 1) (cons (pseudo-random-integer 10) lst)))))
39(define lst3
40  (let loop ((k 0) (lst '()))
41    (if (= k 100)
42      lst
43      (loop (+ k 1) (cons (pseudo-random-integer 100) lst)))))
44
45(define-test (skiplist-test)
46  "SOME CONSTRUCTORS"
47  '(define sls2 (skiplist 4 20 fixnum? - dups))
48  (fx= (sl-width sls2) 4)
49  (fx= (sl-max-height sls2) 20)
50  (sl-dups? sls2)
51  '(define sls1 (skiplist 15 fixnum? -))
52  (fx= (sl-width sls1) 2)
53  (fx= (sl-max-height sls1) 15)
54  (not (sl-dups? sls1))
55  "A NUMERICAL SKIPLIST WITHOUT DUPS"
56  '(define sls (skiplist integer? -))
57  (skiplist? sls)
58  (not (skiplist? '(1 2 3)))
59  (sl-null? sls)
60  (not (sl-dups? sls))
61  (eq? (sl-item? sls) integer?)
62  (fx= (sl-max-height sls) 10)
63  (fx= (sl-width sls) 2)
64  "INSERT RANDOM VALUES ..."
65  '(define lst
66     (let loop ((k 0) (lst '()))
67       (if (= k 100)
68         lst
69         (loop (+ k 1) (cons (pseudo-random-integer 100) lst)))))
70  (apply sl-insert! sls lst)
71
72  (apply < (skiplist->list sls))
73  (<= (sl-count sls) 100)
74  "FILTER ..."
75  ((list-of? even?) (skiplist->list (sl-filter even? sls)))
76  "MAP ..."
77  (let ((fn (lambda (x) (* 2 x))))
78    (equal?
79      (map fn (skiplist->list sls))
80      (skiplist->list (sl-map fn sls))))
81  "INSERT AT BOTH ENDS ..."
82  (sl-insert! sls -1 100)
83  (equal? (sl-min sls) '(-1))
84  (equal? (sl-max sls) '(100))
85  (sl-search! sls -1)
86  (equal? (sl-found sls) '(-1))
87  (sl-search! sls 100)
88  (equal? (sl-found sls) '(100))
89  "REMOVE AT LEFT END ..."
90  (sl-remove! sls -1)
91  (null? (sl-found sls))
92  (sl-search! sls -1)
93  (null? (sl-found sls))
94  "INSERT ONE IN THE MIDDLE AND REMOVE IT AGAIN ..."
95  (sl-insert! sls 25)
96  (sl-search! sls 25)
97  (= 25 (car (sl-found sls)))
98  (memv 25 (sl-found sls))
99  (sl-remove! sls 25)
100  "RESTRUCTURE ..."
101  (equal? (skiplist->list sls)
102          (skiplist->list (sl-restructure sls 4 15)))
103  "REORDER DECREASING WITHOUT DUPS ..."
104  (let ((slsr (sl-reorder sls (lambda (x y) (- y x)))))
105    (apply > (skiplist->list slsr))
106    (equal? (sl-min sls) (sl-max slsr))
107    (equal? (sl-max sls) (sl-min slsr))
108    )
109  "AND WITH DUPS ..."
110  (equal? (reverse
111            (skiplist->list
112              (sl-reorder sls - dups)))
113          (skiplist->list
114            (sl-reorder sls (lambda (x y) (- y x)) dups)))
115  "CLEAR ..."
116  (sl-clear! sls)
117  (null? (sl-min sls))
118  (null? (sl-max sls))
119  (sl-null? sls)
120  "A SKIPLIST OF INTEGER LISTS WITH PRIMARY AND SECONDARY ORDERS"
121  '(define item-type (lambda (x)
122                       (and ((list-of? integer?) x) (> (length x) 2))))
123  '(define primary-order (lambda (x y) (- (car x) (car y))))
124  '(define secondary-order (lambda (x y) (- (cadr x) (cadr y))))
125  '(define sls3 (skiplist 3
126                          10
127                          item-type
128                          primary-order
129                          secondary-order
130                          dups))
131  '(define lst1
132     (let loop ((k 0) (lst '()))
133       (if (= k 100)
134         lst
135         (loop (+ k 1) (cons (pseudo-random-integer 10) lst)))))
136  '(define lst2
137     (let loop ((k 0) (lst '()))
138       (if (= k 100)
139         lst
140         (loop (+ k 1) (cons (pseudo-random-integer 10) lst)))))
141  '(define lst3
142     (let loop ((k 0) (lst '()))
143       (if (= k 100)
144         lst
145         (loop (+ k 1) (cons (pseudo-random-integer 100) lst)))))
146  (apply sl-insert! sls3
147         (map (lambda (x y z) (list x y z))
148              lst1 lst2 lst3)) 
149  (sl-dups? sls3)
150  (= (sl-count sls3) 100)
151  (= (sl-width sls3) 3)
152  "INSERTING ITEM AND REMOVING ALL WITH SAME KEY ..."
153  ((sl-item? sls3) '(1 2 3))
154  (sl-search! sls3 '(1 2 3))
155  (if (sl-found? sls3 '(1 2 3))
156    (apply sl-remove! sls3 (sl-found sls3)))
157  (sl-insert! sls3 '(1 2 3))
158  (sl-search! sls3 '(1 2 3))
159  (member '(1 2 3) (sl-found sls3))
160  (apply sl-remove! sls3 (sl-found sls3))
161  (sl-search! sls3 '(1 2 3))
162  (null? (sl-found sls3))
163  "PRODUCE DUPLICATES AT THE ENDS ..."
164  (sl-insert! sls3 '(-1 2 3) '(-1 2 3 4)) 
165  (equal? (sl-min sls3) '((-1 2 3 4) (-1 2 3)))
166  (sl-insert! sls3 '(10 1 2) '(10 1 2 3) '(10 1 3))
167  (equal? (sl-found sls3) '((10 1 3) (10 1 2 3) (10 1 2)))
168  (equal? (sl-max sls3) '((10 1 3) (10 1 2 3) (10 1 2)))
169  "AND REMOVE THEM AGAIN ..." 
170  (sl-search! sls3 '(-1 2 3 4))
171  (apply sl-remove! sls3 (sl-found sls3))
172  (sl-search! sls3 '(-1 2 3 4))
173  (null? (sl-found sls3))
174  (sl-search! sls3 '(10 1 3))
175  (apply sl-remove! sls3 (sl-found sls3))
176  (null? (sl-found sls3))
177  "UNDUP IN THE MIDDLE ..."
178  (sl-search! sls3 '(2 3 4))
179  (if (not (null? (sl-found sls3)))
180    (apply sl-remove! sls3 (sl-found sls3)))
181  (apply sl-insert! sls3 '((2 3 4) (2 3 5) (2 3 6 7)))
182  (sl-search! sls3 '(2 3 4))
183  (equal? (sl-found sls3) '((2 3 6 7) (2 3 5) (2 3 4)))
184  (sl-search! sls3 '(2 3 4))
185  (apply sl-remove! sls3 (cdr (sl-found sls3)))
186  (sl-search! sls3 '(2 3 4))
187  (equal? (sl-found sls3) '((2 3 6 7)))
188  "UNDUP AT LEFT END ..."
189  (sl-insert! sls3 '(-1 2 3) '(-1 2 3 4)) 
190  (sl-search! sls3 '(-1 2 3))
191  (apply sl-remove! sls3 (cdr (sl-found sls3)))
192  (sl-search! sls3 '(-1 2 3))
193  (equal? (sl-found sls3) '((-1 2 3 4)))
194  "UNDUP AT RIGHT END ..."
195  (sl-insert! sls3 '(10 1 2) '(10 1 2 3) '(10 1 3))
196  (sl-search! sls3 '(10 1 2 3))
197  (apply sl-remove! sls3 (cdr (sl-found sls3)))
198  (sl-search! sls3 '(10 1 2 3))
199  (equal? (sl-found sls3) '((10 1 3)))
200  "REORDER REMOVING ALL DUPS ..."
201  (apply <= (map car
202                 (skiplist->list
203                   (sl-reorder sls3 primary-order secondary-order))))
204  (<= (sl-count (sl-reorder sls3 primary-order secondary-order))
205      (sl-count sls3))
206  "REORDER USING ONLY SECONDARY ORDER ..."
207  (apply < (map cadr
208                (skiplist->list
209                  (sl-reorder sls3 secondary-order))))
210  (>= 10 (sl-count
211           (sl-reorder sls3 secondary-order)))
212  "FILTER VALUE ..."
213  ((list-of? odd?) (map caddr
214                        (skiplist->list
215                          (sl-filter (lambda (x) (odd? (caddr x))) sls3))))
216)
217(compound-test (SKIPLISTS)
218  (skiplist-test)
219  )
Note: See TracBrowser for help on using the repository browser.