From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: Andreas Rottmann Newsgroups: gmane.lisp.guile.devel Subject: [PATCH] Support for SRFI 27 Date: Sat, 14 Aug 2010 17:55:00 +0200 Message-ID: <87eie1w5nv.fsf@delenn.lan> NNTP-Posting-Host: lo.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: dough.gmane.org 1281801329 32567 80.91.229.12 (14 Aug 2010 15:55:29 GMT) X-Complaints-To: usenet@dough.gmane.org NNTP-Posting-Date: Sat, 14 Aug 2010 15:55:29 +0000 (UTC) To: Guile Development Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Sat Aug 14 17:55:27 2010 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([199.232.76.165]) by lo.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1OkJ4x-0000ia-0i for guile-devel@m.gmane.org; Sat, 14 Aug 2010 17:55:27 +0200 Original-Received: from localhost ([127.0.0.1]:60184 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OkJ4w-0005qc-HS for guile-devel@m.gmane.org; Sat, 14 Aug 2010 11:55:26 -0400 Original-Received: from [140.186.70.92] (port=58450 helo=eggs.gnu.org) by lists.gnu.org with esmtp (Exim 4.43) id 1OkJ4n-0005qS-OE for guile-devel@gnu.org; Sat, 14 Aug 2010 11:55:23 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.69) (envelope-from ) id 1OkJ4h-0000Dl-4Y for guile-devel@gnu.org; Sat, 14 Aug 2010 11:55:17 -0400 Original-Received: from mailout-de.gmx.net ([213.165.64.23]:49103 helo=mail.gmx.net) by eggs.gnu.org with smtp (Exim 4.69) (envelope-from ) id 1OkJ4g-0000DP-Ir for guile-devel@gnu.org; Sat, 14 Aug 2010 11:55:11 -0400 Original-Received: (qmail invoked by alias); 14 Aug 2010 15:55:08 -0000 Original-Received: from 83-215-154-5.hage.dyn.salzburg-online.at (EHLO nathot.lan) [83.215.154.5] by mail.gmx.net (mp005) with SMTP; 14 Aug 2010 17:55:08 +0200 X-Authenticated: #3102804 X-Provags-ID: V01U2FsdGVkX1/mGqYE6+TmFq9hkdKE2Gq33sN+25Pw+cehD5Xswt CbaAhg6JxJ43JJ Original-Received: from localhost (localhost.localdomain [127.0.0.1]) by nathot.lan (Postfix) with ESMTP id 7DA7F3A695 for ; Sat, 14 Aug 2010 17:55:07 +0200 (CEST) Original-Received: from nathot.lan ([127.0.0.1]) by localhost (nathot.lan [127.0.0.1]) (amavisd-new, port 10024) with ESMTP id 91GmfzBRtVvN for ; Sat, 14 Aug 2010 17:55:01 +0200 (CEST) Original-Received: from delenn.lan (delenn.lan [192.168.3.11]) by nathot.lan (Postfix) with ESMTP id 3824B3A693 for ; Sat, 14 Aug 2010 17:55:01 +0200 (CEST) Original-Received: by delenn.lan (Postfix, from userid 1000) id E8F584A8441; Sat, 14 Aug 2010 17:55:00 +0200 (CEST) User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/23.2 (gnu/linux) X-Y-GMX-Trusted: 0 X-detected-operating-system: by eggs.gnu.org: Genre and OS details not recognized. X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.5 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:10763 Archived-At: --=-=-= Hi! Attached is my take on adding SRFI 27 "Sources of Random Bits". --=-=-= Content-Type: text/x-diff Content-Disposition: inline; filename=srfi-27-new.diff From: Andreas Rottmann 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 +;; . + +;;; 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 . + +(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 -- --=-=-=--