1;;; -*- mode: scheme; coding: utf-8; -*-
2;;;
3;;; Copyright (C) 2010 Free Software Foundation, Inc.
4;;; Copyright (C) 2002 Sebastian Egner
5;;;
6;;; This code is based on the file conftest.scm in the reference
7;;; implementation of SRFI-27, provided under the following license:
8;;;
9;;; Permission is hereby granted, free of charge, to any person obtaining
10;;; a copy of this software and associated documentation files (the
11;;; "Software"), to deal in the Software without restriction, including
12;;; without limitation the rights to use, copy, modify, merge, publish,
13;;; distribute, sublicense, and/or sell copies of the Software, and to
14;;; permit persons to whom the Software is furnished to do so, subject to
15;;; the following conditions:
16;;;
17;;; The above copyright notice and this permission notice shall be
18;;; included in all copies or substantial portions of the Software.
19;;;
20;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
21;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
22;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
23;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
24;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
25;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
26;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
27;;; SOFTWARE.
28
29(define-module (test-srfi-27)
30  #:use-module (test-suite lib)
31  #:use-module (srfi srfi-27))
32
33(with-test-prefix "large integers"
34  (pass-if "in range"
35    (let loop ((k 0) (n 1))
36      (cond ((> k 1024)
37             #t)
38            ((<= 0 (random-integer n) (- n 1))
39             (loop (+ k 1) (* n 2)))
40            (else
41             #f)))))
42
43(with-test-prefix "reals"
44  (pass-if "in range"
45    (let loop ((k 0) (n 1))
46      (if (> k 1000)
47          #t
48          (let ((x (random-real)))
49            (if (< 0 x 1)
50                (loop (+ k 1) (* n 2))
51                #f))))))
52
53(with-test-prefix "get/set state"
54  (let* ((state1 (random-source-state-ref default-random-source))
55         (x1 (random-integer (expt 2 32)))
56         (state2 (random-source-state-ref default-random-source))
57         (x2 (random-integer (expt 2 32))))
58    (random-source-state-set! default-random-source state1)
59    (pass-if "state1"
60      (= x1 (random-integer (expt 2 32))))
61    (random-source-state-set! default-random-source state2)
62    (pass-if "state2"
63      (= x2 (random-integer (expt 2 32))))))
64
65;; These tests throw 'unresolved instead of failing since it /could/
66;; happen that `random-source-randomize!' (or
67;; `random-source-pseudo-randomize!')  puts the RNG into a state where
68;; it generates the same number as before. They should have a very high
69;; chance of passing, though.
70
71(with-test-prefix "randomize!"
72  (let* ((state1 (random-source-state-ref default-random-source))
73         (x1 (random-integer (expt 2 32))))
74    (random-source-state-set! default-random-source state1)
75    (random-source-randomize! default-random-source)
76    (if (= x1 (random-integer (expt 2 32)))
77        (throw 'unresolved))))
78
79(with-test-prefix "pseudo-randomize!"
80  (let* ((state1 (random-source-state-ref default-random-source))
81         (x1 (random-integer (expt 2 32))))
82    (random-source-state-set! default-random-source state1)
83    (random-source-pseudo-randomize! default-random-source 0 1)
84    (let ((y1 (random-integer (expt 2 32))))
85      (if (= x1 y1)
86          (throw 'unresolved)))
87    (random-source-state-set! default-random-source state1)
88    (random-source-pseudo-randomize! default-random-source 1 0)
89    (let ((y1 (random-integer (expt 2 32))))
90      (if (= x1 y1)
91          (throw 'unresolved)))))
92