summaryrefslogtreecommitdiff
path: root/test-suite/tests/random.test
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite/tests/random.test')
-rw-r--r--test-suite/tests/random.test98
1 files changed, 98 insertions, 0 deletions
diff --git a/test-suite/tests/random.test b/test-suite/tests/random.test
new file mode 100644
index 000000000..678bd88b7
--- /dev/null
+++ b/test-suite/tests/random.test
@@ -0,0 +1,98 @@
+;;;; random.test --- tests guile's uniform arrays -*- scheme -*-
+;;;;
+;;;; Copyright 2013 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library 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
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (test-suite test-random)
+ #:use-module ((system base compile) #:select (compile))
+ #:use-module (test-suite lib)
+ #:use-module (srfi srfi-4)
+ #:use-module (srfi srfi-4 gnu)
+ #:use-module ((ice-9 control) #:select (let/ec)))
+
+; see strings.test, arrays.test.
+(define exception:wrong-type-arg
+ (cons #t "Wrong type"))
+
+;;;
+;;; random:normal-vector!
+;;;
+
+(with-test-prefix "random:normal-vector!"
+
+ ;; FIXME need proper function test.
+
+ (pass-if "non uniform"
+ (let ((a (make-vector 4 0))
+ (b (make-vector 4 0))
+ (c (make-shared-array (make-vector 8 0)
+ (lambda (i) (list (+ 1 (* 2 i)))) 4)))
+ (begin
+ (random:normal-vector! b (random-state-from-platform))
+ (random:normal-vector! c (random-state-from-platform))
+ (and (not (equal? a b)) (not (equal? a c))))))
+
+ (pass-if "uniform (f64)"
+ (let ((a (make-f64vector 4 0))
+ (b (make-f64vector 4 0))
+ (c (make-shared-array (make-f64vector 8 0)
+ (lambda (i) (list (+ 1 (* 2 i)))) 4)))
+ (begin
+ (random:normal-vector! b (random-state-from-platform))
+ (random:normal-vector! c (random-state-from-platform))
+ (and (not (equal? a b)) (not (equal? a c))))))
+
+ (pass-if "empty argument"
+ (random:normal-vector! (vector) (random-state-from-platform))
+ (random:normal-vector! (f64vector) (random-state-from-platform))
+ #t))
+
+;;;
+;;; random:hollow-sphere!
+;;;
+
+(with-test-prefix "random:hollow-sphere!"
+
+ (define (sqr a)
+ (* a a))
+ (define (norm a)
+ (sqrt (+ (sqr (array-ref a 0)) (sqr (array-ref a 1)) (sqr (array-ref a 2)))))
+ (define double-eps 1e-15)
+
+ (pass-if "non uniform"
+ (let ((a (transpose-array (make-array 0. 3 10) 1 0)))
+ (let/ec exit
+ (array-slice-for-each 1
+ (lambda (a)
+ (random:hollow-sphere! a)
+ (if (> (magnitude (- 1 (norm a))) double-eps) (exit #f)))
+ a)
+ #t)))
+
+ (pass-if "uniform (f64)"
+ (let ((a (transpose-array (make-array 0. 3 10) 1 0)))
+ (let/ec exit
+ (array-slice-for-each 1
+ (lambda (a)
+ (random:hollow-sphere! a)
+ (if (> (magnitude (- 1 (norm a))) double-eps) (exit #f)))
+ a)
+ #t)))
+
+ (pass-if "empty argument"
+ (random:hollow-sphere! (vector))
+ (random:hollow-sphere! (f64vector))
+ #t))