source: project/release/5/list-utils/tags/2.2.0/tests/list-utils-test.scm @ 39548

Last change on this file since 39548 was 39548, checked in by Kon Lovett, 5 months ago

rel 2.2.0

File size: 5.6 KB
Line 
1;;;; list-utils-test.scm  -*- Scheme -*-
2;;;; Kon Lovett, Jul '18
3
4(import test)
5
6(test-begin "List Utils")
7
8;;;
9
10(import list-utils)
11
12(test-group  "Unique"
13  (test '((a b c d e) (a d)) (receive (list-unique/duplicates '(a a b c d d e))))
14  (test '(a b c d e) (list-unique '(a a b c d d e)))
15)
16
17(test-group  "Skip+"
18  (test '(() -1) (receive (skip+ '() -1)))
19  (test '(() 0) (receive (skip+ '() 0)))
20  (test '(() 1) (receive (skip+ '() 1)))
21  (test '((1) -1) (receive (skip+ '(1) -1)))
22  (test '((1) 0) (receive (skip+ '(1) 0)))
23  (test '(() 0) (receive (skip+ '(1) 1)))
24  (test '(() 1) (receive (skip+ '(1) 2)))
25  (test '((1 2) -1) (receive (skip+ '(1 2) -1)))
26  (test '((1 2) 0) (receive (skip+ '(1 2) 0)))
27  (test '((2) 0) (receive (skip+ '(1 2) 1)))
28  (test '(() 0) (receive (skip+ '(1 2) 2)))
29)
30
31(test-group  "Split-at+"
32  (test '(() ()) (receive (split-at+ '() -1 #f)))   ;should be same
33  (test '(() ()) (receive (split-at+ '() -1)))
34  (test '(() ()) (receive (split-at+ '() 0)))
35  (test '(() ()) (receive (split-at+ '() 1)))
36  (test '(() ()) (receive (split-at+ '() -1 '())))
37  (test '(() ()) (receive (split-at+ '() 0 '())))
38  (test '(() ()) (receive (split-at+ '() 1 '())))
39  (test '(() ()) (receive (split-at+ '() -1 '(1))))
40  (test '(() ()) (receive (split-at+ '() 0 '(1))))
41  (test '(() ()) (receive (split-at+ '() 1 '(1))))
42  (test '(() (1)) (receive (split-at+ '(1) -1)))
43  (test '(() (1)) (receive (split-at+ '(1) 0)))
44  (test '((1) ()) (receive (split-at+ '(1) 1)))
45  (test '(() ()) (receive (split-at+ '(1) 2)))
46  (test '(() (1)) (receive (split-at+ '(1) -1 '())))
47  (test '(() (1)) (receive (split-at+ '(1) 0 '())))
48  (test '((1) ()) (receive (split-at+ '(1) 1 '())))
49  (test '((1) ()) (receive (split-at+ '(1) 2 '())))
50  (test '(() (1)) (receive (split-at+ '(1) -1 '(2))))
51  (test '(() (1)) (receive (split-at+ '(1) 0 '(2))))
52  (test '((1) ()) (receive (split-at+ '(1) 1 '(2))))
53  (test '((1 2) ()) (receive (split-at+ '(1) 2 '(2))))
54)
55
56(test-group  "Section"
57  ;(section LIST SIZE [STEP [PADS]])
58  ;Needs more tests
59
60  (test-error "size <= 0" (section '(1 2) -1 1 #f))
61  (test-error "size <= 0" (section '(1 2) 0 1 #f))
62  (test-error "step <= 0" (section '(1 2) 1 -1 #f))
63  (test-error "step <= 0" (section '(1 2) 1 0 #f))
64
65  (test "null primary" '() (section '() 1 1 #f))
66  (test "size > length primary & no pad" '() (section '(1) 2 2 #f))
67
68  (test '((1) (2)) (section '(1 2) 1 1 #f))
69  (test '((1 2)) (section '(1 2) 2 2 #f))
70  (test "size > length primary & clip" '((1 2)) (section '(1 2) 3 3 '()))
71  (test "size > length primary & pad" '((1 2 3)) (section '(1 2) 3 3 '(3 4 5)))
72
73  (test "size > step" '((1 2) (2 3)) (section '(1 2 3) 2 1))
74  (test "size < step" '((1) (3)) (section '(1 2 3) 1 2))
75
76  (test '((1 2) (2 3)) (section '(1 2 3) 2 1 '(a b c)))
77  (test '((1 2 a)) (section '(1 2) 3 3 '(a b c)))
78  (test '((1 2) (3 a)) (section '(1 2 3) 2 2 '(a b c)))
79  (test '((1 2) (3)) (section '(1 2 3) 2 2))
80)
81
82(define alst1 '((a 1) (b 2) (b 3) (c 4) (b 5) (a 6) (d 7)))
83(define alst2 '((a . 1) (b . 2) (b . 3) (c . 4) (b . 5) (a . 6) (d . 7)))
84
85(test-group  "Length"
86        (test-assert (length=0? '()))
87        (test-assert (not (length=0? '(1))))
88        (test-assert (length=1? '(1)))
89        (test-assert (not (length=1? '())))
90        (test-assert (not (length=1? '(1 2))))
91        (test-assert (length=2? '(1 2)))
92        (test-assert (not (length=2? '())))
93        (test-assert (not (length=2? '(1))))
94        (test-assert (not (length=2? '(1 2 3))))
95        (test-assert (length>1? '(1 2)))
96        (test-assert (not (length>1? '())))
97        (test-assert (not (length>1? '(1))))
98)
99
100(test-group  "Null Stuff"
101  (test '(1) (ensure-list '(1)))
102  (test '(1) (ensure-list 1))
103
104  (test '(1) (not-null? '(1)))
105  (test-assert (not (not-null? '())))
106)
107
108(import (chicken type))
109
110(test-group  "Shift Set"
111  (let ((lst (the (or list false) '(1 2))))
112    (test 1 (shift!/set lst))
113    (test '(2) (identity lst))
114    (test 2 (shift!/set lst))
115    (test '() (identity lst))
116    (test-assert (not (shift!/set lst)))
117    (test '() (identity lst))
118  )
119)
120
121(test-group  "Alist Zip"
122  (test '((a b) ((1) (2))) (receive (unzip-alist '((a 1) (b 2)))))
123  (test '((a . 1) (b . 2)) (zip-alist '(a b) '(1 2)))
124  (test '((a 1) (b 2)) (zip-alist '(a b) '((1) (2))))
125  (test '((a . 1) (b . 2)) (zip-alist '(a b) '(1 2)))
126)
127
128(test-group  "Plist <-> Alist"
129  (test '(a (1) b (2) b (3) c (4) b (5) a (6) d (7)) (alist->plist alst1))
130  (test '(a 1 b 2 b 3 c 4 b 5 a 6 d 7) (alist->plist alst2))
131  (test alst1 (plist->alist '(a (1) b (2) b (3) c (4) b (5) a (6) d (7))))
132  (test alst2 (plist->alist '(a 1 b 2 b 3 c 4 b 5 a 6 d 7)))
133)
134
135(test-group  "Alist Delete"
136  (test '((a 1) (c 4) (b 5) (a 6) (d 7)) (alist-delete-duplicates 'b alst1 eq? 2))
137  (test '((a 1) (c 4) (a 6) (d 7)) (alist-delete-duplicates 'b alst1 eq?))
138  (test '((a 1) (b 2) (b 3) (c 4) (b 5) (a 6)) (alist-delete-duplicates 'd alst1 eq?))
139  (test '((a 1) (b 2) (b 3) (b 5) (a 6) (d 7)) (alist-delete-duplicates 'c alst1 eq?))
140  (test '((b 2) (b 3) (c 4) (b 5) (a 6) (d 7)) (alist-delete-duplicates 'a alst1 eq? 1))
141
142  (test '((a 1) (c 4) (b 5) (a 6) (d 7)) (alist-delete-duplicates! 'b alst1 eq? 2))
143  (test '((a 1) (c 4) (a 6) (d 7)) (alist-delete-duplicates! 'b alst1 eq?))
144  (test '((a 1) (c 4) (a 6)) (alist-delete-duplicates! 'd alst1 eq?))
145  (test '((a 1) (a 6)) (alist-delete-duplicates! 'c alst1 eq?))
146  (test '((a 6)) (alist-delete-duplicates! 'a alst1 eq? 1))
147)
148
149(test-group  "Extensions"
150  (test '(b c) (pair-ref '(a b c) 1))
151  (test '() (pair-ref '(a b c) 3))
152  (let ((ls (list 1 2 3)))
153    (list-set! ls 1 'foo)
154    (test "list-set!" 'foo (list-ref ls 1)) )
155  (test '(a b c) (list-copy* '(a b c)))
156  (test '(b c) (list-copy* '(a b c) 1))
157  (test '(b c z) (list-copy* '(a b c) 1 4 'z))
158)
159
160;;;
161
162(test-end "List Utils")
163
164(test-exit)
Note: See TracBrowser for help on using the repository browser.