source: project/release/5/list-utils/trunk/tests/list-utils-test.scm @ 38846

Last change on this file since 38846 was 38846, checked in by Kon Lovett, 10 months ago

fix *split-at+ type, strict-types, drop fx in favor of compiler, test optional arguments (a little) better, drop redundant local

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