mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 12:20:20 +02:00
Code Activity

Merge until badcbd0fe9 from stable-2.2

Browse source 
Manually resolve conflicts in random.c.
This commit is contained in:
Andy Wingo 2017-11-29 21:08:42 +01:00
commit a723f41375
2 changed files with 114 additions and 62 deletions
Download patch file Download diff file Expand all files Collapse all files

47
test-suite/tests/random.test
View file

@ -20,7 +20,8 @@
#: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 (srfi srfi-4 gnu)
#:use-module ((ice-9 control) #:select (let/ec)))
; see strings.test, arrays.test.
(define exception:wrong-type-arg
@ -52,4 +53,46 @@
(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)))))))
(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))