[PATCH] Support for SRFI 27

[Andreas Rottmann]

Hi!

Attached is my take on adding SRFI 27 "Sources of Random Bits".

From: Andreas Rottmann <address@hidden>
Subject: Add implementation of SRFI 27

* module/srfi/srfi-27.scm: New file; implementation of SRFI 27 in terms of the
  existing random number generator.
* module/Makefile.am (SRFI_SOURCES): Add srfi/srfi-27.scm.

---
 NEWS                          |    4 ++
 module/Makefile.am            |    1 +
 module/srfi/srfi-27.scm       |   86 +++++++++++++++++++++++++++++++++++++++++
 test-suite/Makefile.am        |    1 +
 test-suite/tests/srfi-27.test |   81 ++++++++++++++++++++++++++++++++++++++
 5 files changed, 173 insertions(+), 0 deletions(-)

diff --git a/NEWS b/NEWS
index c6caed3..e4d1117 100644
--- a/NEWS
+++ b/NEWS
@@ -10,6 +10,10 @@ latest prerelease, and a full NEWS corresponding to 1.8 -> 
2.0.
 
 Changes in 1.9.12 (since the 1.9.11 prerelease):
 
+** Support for SRFI-27
+
+SRFI-27 "Sources of Random Bits" is now available.
+
 ** Many R6RS bugfixes
 
 `(rnrs bytevectors)' and `(rnrs io ports)' now have version information,
diff --git a/module/Makefile.am b/module/Makefile.am
index a2fb0f3..588f560 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -252,6 +252,7 @@ SRFI_SOURCES = \
   srfi/srfi-18.scm \
   srfi/srfi-19.scm \
   srfi/srfi-26.scm \
+  srfi/srfi-27.scm \
   srfi/srfi-31.scm \
   srfi/srfi-34.scm \
   srfi/srfi-35.scm \
diff --git a/module/srfi/srfi-27.scm b/module/srfi/srfi-27.scm
new file mode 100644
index 0000000..cb8aaf7
--- /dev/null
+++ b/module/srfi/srfi-27.scm
@@ -0,0 +1,86 @@
+;;; srfi-27.scm --- Sources of Random Bits
+
+;; Copyright (C) 2010 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, see
+;; <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This module is not yet documented at all in the Guile manual.
+
+;;; Code:
+
+(define-module (srfi srfi-27)
+  #:export (random-integer
+            random-real
+            default-random-source
+            make-random-source
+            random-source?
+            random-source-state-ref
+            random-source-state-set!
+            random-source-randomize!
+            random-source-pseudo-randomize!
+            random-source-make-integers
+            random-source-make-reals)
+  #:use-module (srfi srfi-9))
+
+(define-record-type :random-source
+  (%make-random-source state)
+  random-source?
+  (state random-source-state set-random-source-state!))
+
+(define (make-random-source)
+  (%make-random-source (seed->random-state 0)))
+
+(define (random-source-state-ref s)
+  (random-state->datum (random-source-state s)))
+
+(define (random-source-state-set! s state)
+  (set-random-source-state! s (datum->random-state state)))
+
+(define (random-source-randomize! s)
+  (let ((time (gettimeofday)))
+    (set-random-source-state! s (seed->random-state
+                                 (+ (* (car time) 1e6) (cdr time))))))
+
+(define (random-source-pseudo-randomize! s i j)
+  (set-random-source-state! s (seed->random-state (i+j->seed i j))))
+
+(define (i+j->seed i j)
+  (logior (ash (spread i 2) 1)
+          (spread j 2)))
+
+(define (spread n amount)
+  (let loop ((result 0) (n n) (shift 0))
+    (if (zero? n)
+        result
+        (loop (logior result
+                      (ash (logand n 1) shift))
+              (ash n -1)
+              (+ shift amount)))))
+
+(define (random-source-make-integers s)
+  (lambda (n)
+    (random n (random-source-state s))))
+
+;; We ignore `unit', which should still be compliant behavior according to
+;; SRFI-27.
+(define* (random-source-make-reals s #:optional unit)
+  (lambda ()
+    (random:uniform (random-source-state s))))
+
+(define default-random-source (make-random-source))
+(define random-integer (random-source-make-integers default-random-source))
+(define random-real (random-source-make-reals default-random-source))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index eab1cd5..d9f3951 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -110,6 +110,7 @@ SCM_TESTS = tests/00-initial-env.test               \
            tests/srfi-14.test                  \
            tests/srfi-19.test                  \
            tests/srfi-26.test                  \
+           tests/srfi-27.test                  \
            tests/srfi-31.test                  \
            tests/srfi-34.test                  \
            tests/srfi-35.test                  \
diff --git a/test-suite/tests/srfi-27.test b/test-suite/tests/srfi-27.test
new file mode 100644
index 0000000..bd1ebcc
--- /dev/null
+++ b/test-suite/tests/srfi-27.test
@@ -0,0 +1,81 @@
+;;; -*- mode: scheme; coding: utf-8; -*-
+;;;
+;;; Copyright (C) 2010 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 program.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-srfi-27)
+  #:use-module (test-suite lib)
+  #:use-module (srfi srfi-27))
+
+(with-test-prefix "large integers"
+  (pass-if "in range"
+    (let loop ((k 0) (n 1))
+      (cond ((> k 1024)
+             #t)
+            ((<= 0 (random-integer n) (- n 1))
+             (loop (+ k 1) (* n 2)))
+            (else
+             #f)))))
+
+(with-test-prefix "reals"
+  (pass-if "in range"
+    (let loop ((k 0) (n 1))
+      (if (> k 1000)
+          #t
+          (let ((x (random-real)))
+            (if (< 0 x 1)
+                (loop (+ k 1) (* n 2))
+                #f))))))
+
+(with-test-prefix "get/set state"
+  (let* ((state1 (random-source-state-ref default-random-source))
+         (x1 (random-integer (expt 2 32)))
+         (state2 (random-source-state-ref default-random-source))
+         (x2 (random-integer (expt 2 32))))
+    (random-source-state-set! default-random-source state1)
+    (pass-if "state1"
+      (= x1 (random-integer (expt 2 32))))
+    (random-source-state-set! default-random-source state2)
+    (pass-if "state2"
+      (= x2 (random-integer (expt 2 32))))))
+
+;; These tests are commented out since it /could/ happen that
+;; `random-source-randomize!' (or `random-source-pseudo-randomize!') puts the
+;; RNG into a state where it generates the same number as before. If you run
+;; them manually, they should have a very high chance of passing, though.
+
+#;
+(with-test-prefix "randomize!"
+  (let* ((state1 (random-source-state-ref default-random-source))
+         (x1 (random-integer (expt 2 32))))
+    (random-source-state-set! default-random-source state1)
+    (random-source-randomize! default-random-source)
+    (pass-if "other number"
+      (not (= x1 (random-integer (expt 2 32)))))))
+
+#;
+(with-test-prefix "pseudo-randomize!"
+  (let* ((state1 (random-source-state-ref default-random-source))
+         (x1 (random-integer (expt 2 32))))
+    (random-source-state-set! default-random-source state1)
+    (random-source-pseudo-randomize! default-random-source 0 1)
+    (let ((y1 (random-integer (expt 2 32))))
+      (pass-if "other number (0 1)"
+        (not (= x1 y1))))
+    (random-source-state-set! default-random-source state1)
+    (random-source-pseudo-randomize! default-random-source 1 0)
+    (let ((y1 (random-integer (expt 2 32))))
+      (pass-if "other number (1 0)"
+        (not (= x1 y1))))))
-- 
tg: (fe3f01f..) t/srfi-27-new (depends on: t/random-external t/fix-random-64bit)

Regards, Rotty
-- 
Andreas Rottmann -- <http://rotty.yi.org/>