source: project/release/5/vlist/trunk/tests/run.scm @ 37274

Last change on this file since 37274 was 37274, checked in by Ivan Raikov, 2 years ago

port of vlist to C5 (thanks to Yuriy Shirokov)

File size: 12.1 KB
Line 
1;;;;
2;;;; Ludovic CourtÚs <ludo@gnu.org>
3;;;;
4;;;;    Copyright (C) 2009, 2010, 2011 Free Software Foundation, Inc.
5;;;;
6;;;; This library is free software; you can redistribute it and/or
7;;;; modify it under the terms of the GNU Lesser General Public
8;;;; License as published by the Free Software Foundation; either
9;;;; version 3 of the License, or (at your option) any later version.
10;;;;
11;;;; This library is distributed in the hope that it will be useful,
12;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
13;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
14;;;; Lesser General Public License for more details.
15
16(import scheme (chicken base) vlist test srfi-1 srfi-69)
17
18
19(test-group "vlist"
20
21  (test-assert "vlist?"
22    (and (vlist? vlist-null)
23         (vlist? (vlist-cons 'a vlist-null))))
24
25  (test-assert "vlist-null?"
26    (vlist-null? vlist-null))
27
28  (test-assert "vlist-cons"
29    (let* ((v1 (vlist-cons 1 vlist-null))
30           (v2 (vlist-cons 2 v1))
31           (v3 (vlist-cons 3 v2))
32           (v4 (vlist-cons 4 v3)))
33      (every vlist? (list v1 v2 v3 v4))))
34
35  (test-assert "vlist-head"
36    (let* ((v1 (vlist-cons 1 vlist-null))
37           (v2 (vlist-cons 2 v1))
38           (v3 (vlist-cons 3 v2))
39           (v4 (vlist-cons 4 v3)))
40      (equal? (map vlist-head (list v1 v2 v3 v4))
41              '(1 2 3 4))))
42
43  (test-assert "vlist-tail"
44    (let* ((v1 (vlist-cons 1 vlist-null))
45           (v2 (vlist-cons 2 v1))
46           (v3 (vlist-cons 3 v2))
47           (v4 (vlist-cons 4 v3)))
48      (equal? (map vlist-head
49                   (map vlist-tail (list v2 v3 v4)))
50              '(1 2 3))))
51
52  (test-assert "vlist->list"
53    (let* ((v1 (vlist-cons 1 vlist-null))
54           (v2 (vlist-cons 2 v1))
55           (v3 (vlist-cons 3 v2))
56           (v4 (vlist-cons 4 v3)))
57      (equal? '(4 3 2 1)
58              (vlist->list v4))))
59
60  (test-assert "list->vlist"
61    (equal? (vlist->list (list->vlist '(1 2 3 4 5)))
62            '(1 2 3 4 5)))
63
64  (test-assert "vlist-drop"
65    (equal? (vlist->list (vlist-drop (list->vlist (iota 77)) 7))
66            (drop (iota 77) 7)))
67
68  (test-assert "vlist-cons2"
69    ;; Example from Bagwell's paper, Figure 2.
70    (let* ((top  (list->vlist '(8 7 6 5 4 3)))
71           (part (vlist-tail (vlist-tail top)))
72           (test (vlist-cons 9 part)))
73      (equal? (vlist->list test)
74              '(9 6 5 4 3))))
75
76  (test-assert "vlist-cons3"
77    (let ((vlst (vlist-cons 'a
78                            (vlist-cons 'b
79                                        (vlist-drop (list->vlist (iota 5))
80                                                    3)))))
81      (equal? (vlist->list vlst)
82              '(a b 3 4))))
83
84  (test-assert "vlist-map"
85    (equal? (vlist->list (vlist-map (lambda (x) (+ 1 x)) (list->vlist '(1 2 3 4 5))))
86            '(2 3 4 5 6)))
87
88  (test-assert "vlist-length"
89    (= (vlist-length (list->vlist (iota 77)))
90       77))
91
92  (test-assert "vlist-length complex"
93    (= (vlist-length (fold vlist-cons
94                           (vlist-drop (list->vlist (iota 77)) 33)
95                           (iota (- 33 7))))
96       70))
97
98  (test-assert "vlist-ref"
99    (let* ((indices (iota 111))
100           (vlst    (list->vlist indices)))
101      (equal? (map (lambda (i)
102                     (vlist-ref vlst i))
103                   indices)
104              indices)))
105
106  (test-assert "vlist-ref degenerate"
107    ;; Degenerate case where VLST contains only 1-element blocks.
108    (let* ((indices (iota 111))
109           (vlst    (fold (lambda (i vl)
110                            (let ((vl (vlist-cons 'x vl)))
111                              (vlist-cons i (vlist-tail vl))))
112                          vlist-null
113                          indices)))
114      (equal? (map (lambda (i)
115                     (vlist-ref vlst i))
116                   (reverse indices))
117              indices)))
118
119  (test-assert "vlist-filter"
120    (let* ((lst  (iota 33))
121           (vlst (fold-right vlist-cons vlist-null lst)))
122      (equal? (vlist->list (vlist-filter even? vlst))
123              (filter even? lst))))
124
125  (test-assert "vlist-delete"
126    (let* ((lst  '(a b c d e))
127           (vlst (fold-right vlist-cons vlist-null lst)))
128      (equal? (vlist->list (vlist-delete 'c vlst))
129              (delete 'c lst))))
130
131  (test-assert "vlist-take"
132    (let* ((lst  (iota 77))
133           (vlst (fold-right vlist-cons vlist-null lst)))
134      (equal? (vlist->list (vlist-take vlst 44))
135              (take lst 44))))
136
137  (test-assert "vlist-unfold"
138    (let ((results (map (lambda (unfold)
139                          (unfold (lambda (i) (> i 100))
140                                  (lambda (i) i)
141                                  (lambda (i) (+ i 1))
142                                  0))
143                        (list unfold vlist-unfold))))
144      (equal? (car results)
145              (vlist->list (cadr results)))))
146
147  (test-assert "vlist-append"
148    (let* ((lists '((a) (b c) (d e f) (g)))
149           (vlst  (apply vlist-append (map list->vlist lists)))
150           (lst   (apply append lists)))
151      (equal? lst (vlist->list vlst))))
152)
153
154
155(test-group "vhash"
156
157  (test-assert "vhash?"
158    (vhash? (vhash-cons "hello" "world" vlist-null)))
159
160  (test-assert "vhash-assoc vlist-null"
161    (not (vhash-assq 'a vlist-null)))
162
163  (test-assert "vhash-assoc simple"
164    (let ((vh (vhash-cons "hello" "world" vlist-null)))
165      (equal? (cons "hello" "world")
166              (vhash-assoc "hello" vh))))
167
168  (test-assert "vhash-assoc regular"
169    (let* ((keys   '(a b c d e f g h i))
170           (values '(1 2 3 4 5 6 7 8 9))
171           (vh     (fold vhash-cons vlist-null keys values)))
172      (fold (lambda (k v result)
173              (and result
174                   (equal? (cons k v)
175                           (vhash-assoc k vh eq?))))
176            #t
177            keys
178            values)))
179
180  (test-assert "vhash-assoc tail"
181    (let* ((keys   '(a b c d e f g h i))
182           (values '(1 2 3 4 5 6 7 8 9))
183           (vh1    (fold vhash-consq vlist-null keys values))
184           (vh2    (vhash-consq 'x 'x (vlist-tail vh1))))
185      (and (fold (lambda (k v result)
186                   (and result
187                        (equal? (cons k v)
188                                (vhash-assq k vh2))))
189                 #t
190                 (cons 'x (delete 'i keys eq?))
191                 (cons 'x (delete 9 values eqv?)))
192           (not (vhash-assq 'i  vh2)))))
193
194  (test-assert "vhash-assoc degenerate"
195    (let* ((keys   '(a b c d e f g h i))
196           (values '(1 2 3 4 5 6 7 8 9))
197           (vh     (fold (lambda (k v vh)
198                           ;; Degenerate case where VH2 contains only
199                           ;; 1-element blocks.
200                           (let* ((vh1 (vhash-cons 'x 'x vh))
201                                  (vh2 (vlist-tail vh1)))
202                             (vhash-cons k v vh2)))
203                         vlist-null keys values)))
204      (and (fold (lambda (k v result)
205                   (and result
206                        (equal? (cons k v)
207                                (vhash-assoc k vh))))
208                 #t
209                 keys
210                 values)
211           (not (vhash-assoc 'x vh)))))
212
213  (test-assert "vhash as vlist"
214    (let* ((keys   '(a b c d e f g h i))
215           (values '(1 2 3 4 5 6 7 8 9))
216           (vh     (fold vhash-cons vlist-null keys values))
217           (alist  (fold alist-cons '() keys values)))
218      (and (equal? (vlist->list vh) alist)
219           (= (length alist) (vlist-length vh))
220           (fold (lambda (i result)
221                   (and result
222                        (equal? (list-ref alist i)
223                                (vlist-ref vh i))))
224                 #t
225                 (iota (vlist-length vh))))))
226
227  (test-assert "vhash entry shadowed"
228    (let* ((a (vhash-consq 'a 1 vlist-null))
229           (b (vhash-consq 'a 2 a)))
230      (and (= 1 (cdr (vhash-assq 'a a)))
231           (= 2 (cdr (vhash-assq 'a b)))
232           (= 1 (cdr (vhash-assq 'a (vlist-tail b)))))))
233
234  (test-assert "vlist-filter"
235    (let* ((keys   '(a b c d e f g h i))
236           (values '(1 2 3 4 5 6 7 8 9))
237           (vh     (fold vhash-cons vlist-null keys values))
238           (alist  (fold alist-cons '() keys values))
239           (pred   (lambda (k+v)
240                     (case (car k+v)
241                       ((c f) #f)
242                       (else  #t)))))
243      (let ((vh    (vlist-filter pred vh))
244            (alist (filter pred alist)))
245        (and (equal? (vlist->list vh) alist)
246             (= (length alist) (vlist-length vh))
247             (fold (lambda (i result)
248                     (and result
249                          (equal? (list-ref alist i)
250                                  (vlist-ref vh i))))
251                   #t
252                   (iota (vlist-length vh)))))))
253
254  (test-assert "vhash-delete"
255    (let* ((keys   '(a b c d e f g d h i))
256           (values '(1 2 3 4 5 6 7 0 8 9))
257           (vh     (fold vhash-cons vlist-null keys values))
258           (alist  (fold alist-cons '() keys values)))
259      (let ((vh    (vhash-delete 'd vh))
260            (alist (alist-delete 'd alist)))
261        (and (= (length alist) (vlist-length vh))
262             (fold (lambda (k result)
263                     (and result
264                          (equal? (assq k alist)
265                                  (vhash-assoc k vh eq?))))
266                   #t
267                   keys)))))
268
269  (test-assert "vhash-delete honors HASH"
270    ;; In 2.0.0, `vhash-delete' would construct a new vhash without
271    ;; using the supplied hash procedure, which could lead to
272    ;; inconsistencies.
273    (let* ((s  "hello")
274           (vh (fold vhash-consq
275                     (vhash-consq s "world" vlist-null)
276                     (iota 300)
277                     (iota 300))))
278      (and (vhash-assq s vh)
279           (pair? (vhash-assq s (vhash-delete 123 vh eq? eq?-hash))))))
280
281  (test-assert "vhash-fold"
282    (let* ((keys   '(a b c d e f g d h i))
283           (values '(1 2 3 4 5 6 7 0 8 9))
284           (vh     (fold vhash-cons vlist-null keys values))
285           (alist  (fold alist-cons '() keys values)))
286      (equal? alist (reverse (vhash-fold alist-cons '() vh)))))
287
288  (test-assert "vhash-fold-right"
289    (let* ((keys   '(a b c d e f g d h i))
290           (values '(1 2 3 4 5 6 7 0 8 9))
291           (vh     (fold vhash-cons vlist-null keys values))
292           (alist  (fold alist-cons '() keys values)))
293      (equal? alist (vhash-fold-right alist-cons '() vh))))
294
295  (test-assert "alist->vhash"
296    (let* ((keys   '(a b c d e f g d h i))
297           (values '(1 2 3 4 5 6 7 0 8 9))
298           (alist  (fold alist-cons '() keys values))
299           (vh     (alist->vhash alist))
300           (alist2 (vlist-fold cons '() vh)))
301      (and (equal? alist (reverse alist2))
302           (fold (lambda (k result)
303                   (and result
304                        (equal? (assq k alist)
305                                (vhash-assoc k vh eq?))))
306                 #t
307                 keys))))
308
309  (test-assert "vhash-fold*"
310    (let* ((keys   (make-list 10 'a))
311           (values (iota 10))
312           (vh     (fold vhash-cons vlist-null keys values)))
313      (equal? (vhash-fold* cons '() 'a vh)
314              values)))
315
316  (test-assert "vhash-fold* tail"
317    (let* ((keys   (make-list 100 'a))
318           (values (iota 100))
319           (vh     (fold vhash-cons vlist-null keys values)))
320      (equal? (vhash-fold* cons '() 'a (vlist-drop vh 42))
321              (take values (- 100 42)))))
322
323  (test-assert "vhash-fold* interleaved"
324    (let* ((keys   '(a b a b a b a b a b c d e a b))
325           (values '(1 0 2 0 3 0 4 0 5 0 0 0 0 6 0))
326           (vh     (fold vhash-cons vlist-null keys values)))
327      (equal? (vhash-fold* cons '() 'a vh)
328              (filter (cut > <> 0) values))))
329
330  (test-assert "vhash-foldq* degenerate"
331    (let* ((keys   '(a b a b a a a b a b a a a z))
332           (values '(1 0 2 0 3 4 5 0 6 0 7 8 9 0))
333           (vh     (fold (lambda (k v vh)
334                           ;; Degenerate case where VH2 contains only
335                           ;; 1-element blocks.
336                           (let* ((vh1 (vhash-consq 'x 'x vh))
337                                  (vh2 (vlist-tail vh1)))
338                             (vhash-consq k v vh2)))
339                         vlist-null keys values)))
340      (equal? (vhash-foldq* cons '() 'a vh)
341              (filter (cut > <> 0) values))))
342)
343
344(test-exit)
Note: See TracBrowser for help on using the repository browser.