-
Notifications
You must be signed in to change notification settings - Fork 0
/
69.scm
181 lines (166 loc) · 6.84 KB
/
69.scm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
;; Copyright 2010, 2012 Alex Shinn
;; SPDX-License-Identifier: MIT
(test-begin "srfi-69")
(define (car-string<? a b) (string<? (car a) (car b)))
(define (car-symbol<? a b) (symbol<? (car a) (car b)))
(let ((ht (make-hash-table eq?)))
;; 3 initial elements
(test-eqv 0 (hash-table-size ht))
(hash-table-set! ht 'cat 'black)
(hash-table-set! ht 'dog 'white)
(hash-table-set! ht 'elephant 'pink)
(test-eqv 3 (hash-table-size ht))
(test-assert (hash-table-exists? ht 'dog))
(test-assert (hash-table-exists? ht 'cat))
(test-assert (hash-table-exists? ht 'elephant))
(test-eqv #f (hash-table-exists? ht 'goose))
(test-eqv 'white (hash-table-ref ht 'dog))
(test-eqv 'black (hash-table-ref ht 'cat))
(test-eqv 'pink (hash-table-ref ht 'elephant))
(test-error (hash-table-ref ht 'goose))
(test-eqv 'grey (hash-table-ref ht 'goose (lambda () 'grey)))
(test-eqv 'grey (hash-table-ref/default ht 'goose 'grey))
(test-equal '(cat dog elephant)
(list-sort symbol<? (hash-table-keys ht)))
(test-equal '(black pink white)
(list-sort symbol<? (hash-table-values ht)))
(test-equal '((cat . black) (dog . white) (elephant . pink))
(list-sort car-symbol<? (hash-table->alist ht)))
;; remove an element
(hash-table-delete! ht 'dog)
(test-eqv 2 (hash-table-size ht))
(test-eqv #f (hash-table-exists? ht 'dog))
(test-assert (hash-table-exists? ht 'cat))
(test-assert (hash-table-exists? ht 'elephant))
(test-error (hash-table-ref ht 'dog))
(test-eqv 'black (hash-table-ref ht 'cat))
(test-eqv 'pink (hash-table-ref ht 'elephant))
(test-equal '(cat elephant)
(list-sort symbol<? (hash-table-keys ht)))
(test-equal '(black pink)
(list-sort symbol<? (hash-table-values ht)))
(test-equal '((cat . black) (elephant . pink))
(list-sort car-symbol<? (hash-table->alist ht)))
;; remove a non-existing element
(hash-table-delete! ht 'dog)
(test-eqv 2 (hash-table-size ht))
(test-eqv #f (hash-table-exists? ht 'dog))
;; overwrite an existing element
(hash-table-set! ht 'cat 'calico)
(test-eqv 2 (hash-table-size ht))
(test-eqv #f (hash-table-exists? ht 'dog))
(test-assert (hash-table-exists? ht 'cat))
(test-assert (hash-table-exists? ht 'elephant))
(test-error (hash-table-ref ht 'dog))
(test-eqv 'calico (hash-table-ref ht 'cat))
(test-eqv 'pink (hash-table-ref ht 'elephant))
(test-equal '(cat elephant)
(list-sort symbol<? (hash-table-keys ht)))
(test-equal '(calico pink)
(list-sort symbol<? (hash-table-values ht)))
(test-equal '((cat . calico) (elephant . pink))
(list-sort car-symbol<? (hash-table->alist ht)))
;; walk and fold
(test-equal '((cat . calico) (elephant . pink))
(let ((a '()))
(hash-table-walk ht (lambda (k v) (set! a (cons (cons k v) a))))
(list-sort car-symbol<? a)))
(test-equal '((cat . calico) (elephant . pink))
(list-sort
car-symbol<?
(hash-table-fold ht (lambda (k v a) (cons (cons k v) a)) '())))
;; copy
(let ((ht2 (hash-table-copy ht)))
(test-eqv 2 (hash-table-size ht2))
(test-eqv #f (hash-table-exists? ht2 'dog))
(test-assert (hash-table-exists? ht2 'cat))
(test-assert (hash-table-exists? ht2 'elephant))
(test-error (hash-table-ref ht2 'dog))
(test-eqv 'calico (hash-table-ref ht2 'cat))
(test-eqv 'pink (hash-table-ref ht2 'elephant))
(test-equal '(cat elephant)
(list-sort symbol<? (hash-table-keys ht2)))
(test-equal '(calico pink)
(list-sort symbol<? (hash-table-values ht2)))
(test-equal '((cat . calico) (elephant . pink))
(list-sort car-symbol<? (hash-table->alist ht2))))
;; merge
(let ((ht2 (make-hash-table eq?)))
(hash-table-set! ht2 'bear 'brown)
(test-eqv 1 (hash-table-size ht2))
(test-eqv #f (hash-table-exists? ht2 'dog))
(test-assert (hash-table-exists? ht2 'bear))
(hash-table-merge! ht2 ht)
(test-eqv 3 (hash-table-size ht2))
(test-assert (hash-table-exists? ht2 'bear))
(test-assert (hash-table-exists? ht2 'cat))
(test-assert (hash-table-exists? ht2 'elephant))
(test-eqv #f (hash-table-exists? ht2 'goose))
(test-eqv 'brown (hash-table-ref ht2 'bear))
(test-eqv 'calico (hash-table-ref ht2 'cat))
(test-eqv 'pink (hash-table-ref ht2 'elephant))
(test-error (hash-table-ref ht2 'goose))
(test-eqv 'grey (hash-table-ref/default ht2 'goose 'grey))
(test-equal '(bear cat elephant)
(list-sort symbol<? (hash-table-keys ht2)))
(test-equal '(brown calico pink)
(list-sort symbol<? (hash-table-values ht2)))
(test-equal '((bear . brown) (cat . calico) (elephant . pink))
(list-sort car-symbol<? (hash-table->alist ht2))))
;; alist->hash-table
(test-equal (list-sort car-symbol<? (hash-table->alist ht))
(list-sort car-symbol<?
(hash-table->alist
(alist->hash-table
'((cat . calico) (elephant . pink)))))))
;; update
(let ((ht (make-hash-table eq?))
(add1 (lambda (x) (+ x 1))))
(hash-table-set! ht 'sheep 0)
(hash-table-update! ht 'sheep add1)
(hash-table-update! ht 'sheep add1)
(test-eqv 2 (hash-table-ref ht 'sheep))
(hash-table-update!/default ht 'crows add1 0)
(hash-table-update!/default ht 'crows add1 0)
(hash-table-update!/default ht 'crows add1 0)
(test-eqv 3 (hash-table-ref ht 'crows)))
;; string keys
(let ((ht (make-hash-table equal?)))
(hash-table-set! ht "cat" 'black)
(hash-table-set! ht "dog" 'white)
(hash-table-set! ht "elephant" 'pink)
(hash-table-ref/default ht "dog" #f)
(test-eqv 'white (hash-table-ref ht "dog"))
(test-eqv 'black (hash-table-ref ht "cat"))
(test-eqv 'pink (hash-table-ref ht "elephant"))
(test-error (hash-table-ref ht "goose"))
(test-eqv 'grey (hash-table-ref/default ht "goose" 'grey))
(test-equal '("cat" "dog" "elephant")
(list-sort string<? (hash-table-keys ht)))
(test-equal '(black pink white)
(list-sort symbol<? (hash-table-values ht)))
(test-equal '(("cat" . black) ("dog" . white) ("elephant" . pink))
(list-sort car-string<? (hash-table->alist ht))))
;; string-ci keys
(let ((ht (make-hash-table string-ci=? string-ci-hash)))
(hash-table-set! ht "cat" 'black)
(hash-table-set! ht "dog" 'white)
(hash-table-set! ht "elephant" 'pink)
(hash-table-ref/default ht "DOG" #f)
(test-eqv 'white (hash-table-ref ht "DOG"))
(test-eqv 'black (hash-table-ref ht "Cat"))
(test-eqv 'pink (hash-table-ref ht "eLePhAnT"))
(test-error (hash-table-ref ht "goose"))
(test-equal '("cat" "dog" "elephant")
(list-sort string<? (hash-table-keys ht)))
(test-equal '(black pink white)
(list-sort symbol<? (hash-table-values ht)))
(test-equal '(("cat" . black) ("dog" . white) ("elephant" . pink))
(list-sort car-string<? (hash-table->alist ht))))
;; stress test
(test-eqv 625
(let ((ht (make-hash-table)))
(do ((i 0 (+ i 1))) ((= i 1000))
(hash-table-set! ht i (* i i)))
(hash-table-ref/default ht 25 #f)))
(test-end "srfi-69")