File: test_util.scm

package info (click to toggle)
aiscm 0.20.1-1
  • links: PTS
  • area: main
  • in suites: bullseye, sid
  • size: 7,084 kB
  • sloc: lisp: 7,406; sh: 4,184; ansic: 3,613; makefile: 266
file content (247 lines) | stat: -rw-r--r-- 11,786 bytes parent folder | download
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
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
;; AIscm - Guile extension for numerical arrays and tensors.
;; Copyright (C) 2013, 2014, 2015, 2016, 2017, 2018, 2019 Jan Wedekind <jan@wedesoft.de>
;;
;; This program is free software: you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
;;
(use-modules (srfi srfi-1)
             (srfi srfi-64)
             (oop goops)
             (system foreign)
             (rnrs bytevectors)
             (aiscm util))


(test-begin "aiscm util")

(load-extension "libguile-aiscm-tests" "init_tests")

(test-begin "helper methods")
  (test-assert "Convert first element of Scheme array to integer"
    (scm-to-int-array-one-element '(123)))
  (test-assert "Convert second element of Scheme array to integer"
    (scm-to-int-array-second-element '(123 456)))
  (test-assert "Convert first element of Scheme array to long integer"
    (scm-to-long-array-one-element (list (ash 123 32))))
  (test-assert "Convert second element of Scheme array to long integer"
    (scm-to-long-array-second-element (list (ash 123 32) (ash 456 32))))
  (test-eqv "Call Scheme function without exception occurring"
    42 (call-scheme-function (lambda (arg) (car arg)) '(42)))
  (test-assert "Clean up object when exception occurs"
    (cleanup-when-exception (lambda (arg) (/ 1 0))))
  (test-error "Throw exception after cleaning up object"
    'misc-error (throw-exception-after-cleanup (lambda (arg) (/ 1 0))))
(test-end "helper methods")

(toplevel-define! 'a 0)
(define-class* <test<>> <object> <meta<test<>>> <class>
  (t #:init-keyword #:t #:getter get-t))
(template-class (test 32) <test<>>)
(template-class (test 8) <test<>>
  (lambda (class metaclass)
    (define-method (tplus8 (self class)) (+ 8 (get-t self)))
    (define-method (is8? (self metaclass)) #t)))
(define-class <values> ()
  (a #:init-keyword #:a)
  (b #:init-keyword #:b))
(test-eqv "'toplevel-define! should create a definition for the given symbol"
  0 a)
(test-eq "'super' returns the first direct superclass"
  <number> (super <complex>))
(test-eq "'define-class*' should define class and meta-class"
  <meta<test<>>> (class-of <test<>>))
(test-eq "'define-class*' creates the specified slots"
  42 (get-t (make <test<>> #:t 42)))
(test-eqv "'toplevel-define! should return the value of the definition"
  5 (toplevel-define! 'abc 5))
(test-eq "retrieve template class by it's arguments"
  <test<32>> (template-class (test 32) <test<>>))
(test-eq "meta class of template class"
  <meta<test<32>>> (class-of (template-class (test 32) <test<>>)))
(test-equal "base class of template class"
  <test<>> (super (template-class (test 32) <test<>>)))
(test-equal "base class of meta class of template class"
  <meta<test<>>> (super (class-of (template-class (test 32) <test<>>))))
(test-eq "class-name of template class"
  '<test<32>> (class-name <test<32>>))
(test-eq "class-name of template class with class arguments"
  '<test<pair>> (class-name (template-class (test <pair>) <test<>>)))
(test-eq "class-name of template class with multiple arguments"
  '<test<32,pair>> (class-name (template-class (test 32 <pair>) <test<>>)))
(test-eqv "template class can have methods"
  42 (tplus8 (make <test<8>> #:t 34)))
(test-assert "meta classes can have methods"
  (is8? <test<8>>))
(test-equal "exclusive-or for booleans"
  '(#f #t #t #f) (map xor '(#f #f #t #t) '(#f #t #f #t)))
(test-equal "'attach' should add an element at the end of the list"
  '(1 2 3) (attach '(1 2) 3))
(test-assert "'index' returns #f if value is not element of list"
  (not (index-of 4 '(2 3 5 7))))
(test-eqv "'index' returns index of first matching list element"
  2 (index-of 5 '(2 3 5 7)))
(test-equal "'all-but-last' should return a list with the last element removed"
  '(2 3 5) (all-but-last '(2 3 5 7)))
(test-assert "'drop-up-to' returns empty list if drop count is larger than length of list"
  (null? (drop-up-to '(1 2 3) 4)))
(test-equal "'drop-up-to' behaves like 'drop' otherwise"
  '(5 6) (drop-up-to '(1 2 3 4 5 6) 4))
(test-equal "'take-up-to' returns first elements"
  '(1 2 3) (take-up-to '(1 2 3 4 5) 3))
(test-equal "'take-up-to' returns all elements if list is smaller"
  '(1 2) (take-up-to '(1 2) 3))
(test-equal "'flatten' flattens a list"
  '(1 2 3 4) (flatten '(1 (2 3) ((4)))))
(test-equal "'cycle' should cycle the elements of a list"
  '(2 3 4 1) (cycle '(1 2 3 4)))
(test-equal "'uncycle' should reverse cycle the elements of a list"
  '(4 1 2 3) (uncycle '(1 2 3 4)))
(test-equal "cycling an array 0 times"
  '(1 2 3 4) (cycle-times '(1 2 3 4) 0))
(test-equal "cycling an array 0 times"
  '(1 2 3 4) (cycle-times '(1 2 3 4) 0))
(test-equal "cycling an array 1 times"
  '(2 3 4 1) (cycle-times '(1 2 3 4) 1))
(test-equal "cycling an array 2 times"
  '(3 4 1 2) (cycle-times '(1 2 3 4) 2))
(test-equal "cycling an array -1 times"
  '(4 1 2 3) (cycle-times '(1 2 3 4) -1))
(test-equal "cycling an array -2 times"
  '(3 4 1 2) (cycle-times '(1 2 3 4) -2))
(test-equal "'integral' should compute the accumulative sum of a list"
  '(1 3 6 10) (integral '(1 2 3 4)))
(test-equal "'alist-invert' should invert an association list"
  '((1 . a) (2 . b)) (alist-invert '((a . 1) (b . 2))))
(test-equal "'assq-set' should work with empty association list"
  '((3 . c)) (assq-set '() 3 'c))
(test-equal "'assq-set' should append new associations"
  '((1 . a) (2 . b) (3 . c)) (assq-set '((1 . a) (2 . b)) 3 'c))
(test-equal "'assq-set' should override old associations"
  '((1 . a) (2 . c)) (assq-set '((1 . a) (2 . b)) 2 'c))
(test-equal "'assq-remove' should remove entry with specified key"
  '((a . red) (c . blue)) (assq-remove '((a . red) (b . green) (c . blue)) 'b))
(test-equal "'assq-remove' should support removing multiple keys"
  '((c . blue)) (assq-remove '((a . red) (b . green) (c . blue)) 'b 'a))
(test-equal "'product' should create a product set of two lists"
  '((a . 1) (a . 2) (a . 3) (b . 1) (b . 2) (b . 3)) (product '(a b) '(1 2 3)))

(test-equal "'sort-by' should sort arguments by the values of the supplied function"
  '((a . 1) (b . 2) (c . 3)) (sort-by '((c . 3) (a . 1) (b . 2)) cdr))

(test-equal "'sort-by-pred' sorts by boolean result of predicate"
  '(1 3 5 0 2 4) (sort-by-pred (iota 6) even?))

(test-assert "partial sorting of empty list"
  (null? (partial-sort '() <)))
(test-equal "list of integers already sorted"
  '(2 3) (partial-sort '(2 3) <))
(test-equal "order list of two integers"
  '(3 5) (partial-sort '(5 3) <))
(test-equal "order list of two equal integers"
  '(5 5) (partial-sort '(5 5) <))
(test-equal "return items if order is not defined"
  '(7 3) (partial-sort '(7 3) (const #f)))
(test-equal "perform partial ordering"
  '(3 1 2) (partial-sort '(1 2 3) (lambda (x y) (eqv? x 3))))

(test-equal "Get element with minimum of argument"
  '(a . 1) (argmin cdr '((c . 3) (a . 1) (b . 2))))
(test-equal "Get element with maximum of argument"
  '(c . 3) (argmax cdr '((c . 3) (a . 1) (b . 2))))
(test-equal "'gather' groups elements into groups of specified size"
  '((0 1) (2 3 4) (5 6 7 8 9)) (gather '(2 3 5) (iota 10)))
(test-approximate "Fixed point iteration"
  (sqrt 2) (fixed-point 1 (lambda (x) (* 0.5 (+ (/ 2 x) x))) (lambda (a b) (< (abs (- a b)) 1e-5))) 1e-5)
(test-assert "'union' should merge two sets"
  (lset= eqv? '(1 2 3) (union '(1 2) '(2 3))))
(test-assert "'difference' should return the set difference"
  (lset= eqv? '(1) (difference '(1 2) '(2 3))))
(test-equal "Convert pair to list"
  '(a b) (pair->list '(a . b)))
(test-assert "Determine live intervals"
  (lset= equal?  '((a . (0 . 1)) (b . (1 . 2)) (c . (2 . 2))) (live-intervals '((a) (a b) (b c) ()) '(a b c))))
(test-equal "Determine variables with overlapping intervals for an interval"
  '((a b) (a b c) (b c))
  (map (overlap-interval '((a . (0 . 1)) (b . (1 . 2)) (c . (2 . 2)))) '((0 . 1) (1 . 2) (2 . 2))))
(test-equal "Return index of first element for given predicate"
  2 (first-index (lambda (x) (> x 4)) '(2 3 5 7 0)))
(test-assert "Return false if there is no element for given predicate"
  (not (first-index (lambda (x) (> x 7)) '(2 3 5 7 0))))
(test-equal "Return index of last element for given predicate"
  3 (last-index (lambda (x) (> x 4)) '(2 3 5 7 0)))
(test-assert "Return false if there is no element for given predicate"
  (not (last-index (lambda (x) (> x 7)) '(2 3 5 7 0))))
(test-equal "Remove false elements from arguments"
  '(1 2 3) (compact 1 2 #f 3 #f))
(test-equal "Extract part of byte vector"
  #vu8(3 5) (bytevector-sub #vu8(2 3 5 7 11) 1 2))
(test-equal "concatenate byte vectors"
  #vu8(2 3 5 7 11 13) (bytevector-concat (list #vu8(2 3) #vu8(5 7 11) #vu8(13))))
(test-equal "conditional map"
  '(1 -2 3 -4 5) (map-if even? - + '(1 2 3 4 5)))
(test-equal "conditional map with multiple arguments"
  '(1 5 8) (map-if (compose even? car list) - + '(2 3 5) '(1 2 3)))
(test-equal "selective map with multiple arguments"
  '(1 5 8) (map-select '(#t #f #f) - + '(2 3 5) '(1 2 3)))
(test-equal "generate 5 symbols"
  (make-list 5 #t) (map symbol? (symbol-list 5)))
(test-equal "Add type tags to method header"
  '((a <t1>) (b <t2>) (c <t3>)) (typed-header '(a b c) '(<t1> <t2> <t3>)))
(test-assert "Clock starts with zero"
  (let [(t (clock))] (>= (elapsed t) 0)))
(test-assert "Check clock has advanced after 1 second"
  (let [(t (clock))] (sleep 1) (>= (elapsed t) 1)))
(test-assert "Check clock has advanced after 100 milliseconds"
  (let [(t (clock))] (usleep 100000) (>= (elapsed t) 0.1)))
(test-assert "Check clock has not advanced too much after 100 milliseconds"
  (let [(t (clock))] (usleep 100000) (< (elapsed t) 0.2)))
(test-assert "Wait for one second"
  (let [(t (clock))] (synchronise #t 1 (compose sleep inexact->exact round)) (>= (elapsed t) 1)))
(test-assert "Check time with reset"
  (let [(t (clock))] (sleep 1) (elapsed t #t) (< (elapsed t) 1)))
(test-assert "Check time without reset"
  (let [(t (clock))] (sleep 1) (elapsed t) (>= (elapsed t) 1)))
(test-assert "Do not attempt to wait negative time"
  (synchronise #t -1 (compose sleep inexact->exact round)))
(test-eqv "Return specified result after synchronisation"
  42 (synchronise 42 0 identity))
(test-equal "Retrieve slot values from object"
  '(2 3) (object-slots (make <values> #:a 2 #:b 3)))

(test-begin "address conversions")
  (test-eq "convert Scheme object to address"
    (pointer-address (scm->pointer 123)) (scm->address 123))
  (test-eq "convert address to Scheme object"
    123 (address->scm (scm->address 123)))
(test-end "address conversions")

(test-equal "compute list with a value replaced"
  '(2 3 5 42 11) (list-with '(2 3 5 7 11) 3 42))

(test-begin "define typed methods")
  (define-typed-method typed-method (<integer> <integer>) -)
  (test-eqv "define a typed method for two integers"
    5 (typed-method 8 3))
  (test-error "do not define it for arbitrary types"
    'goops-error (typed-method "test" "other"))
(test-end "define typed methods")

(test-begin "define n-ary typed method")
  (define-nary-typed-method typed-unary-method 1 <integer> -)
  (test-eqv "define a unary typed method"
    -5 (typed-unary-method 5))
  (define-nary-typed-method typed-binary-method 2 <integer> -)
  (test-eqv "define a binary typed method"
    5 (typed-binary-method 8 3))
(test-end "define n-ary typed method")
(test-end "aiscm util")