-#| -*-Scheme-*-
+;;;; Pseudo-Random number generator for scheme.
+;;; Copyright (C) 1991 Aubrey Jaffer.
+;;; From slib1c4, modified for MIT Scheme by cph.
+;;; $Id: random.scm,v 14.4 1993/01/13 08:48:34 cph Exp $
+;;;
+;;; (random n) procedure
+;;; (random n state) procedure
+;;;
+;;; Accepts a positive integer or real n and returns a number of the
+;;; same type between zero (inclusive) and n (exclusive). The values
+;;; returned have a uniform distribution.
+;;;
+;;; The optional argument state must be of the type produced by
+;;; (make-random-state). It defaults to the value of the variable
+;;; *random-state*. This object is used to maintain the state of the
+;;; pseudo-random-number generator and is altered as a side effect of the
+;;; RANDOM operation.
+;;;
+;;; *random-state* variable
+;;;
+;;; Holds a data structure that encodes the internal state of the
+;;; random-number generator that RANDOM uses by default. The nature of
+;;; this data structure is implementation-dependent. It may be printed
+;;; out and successfully read back in, but may or may not function
+;;; correctly as a random-number state object in another implementation.
+;;;
+;;; (make-random-state) procedure
+;;; (make-random-state state) procedure
+;;;
+;;; Returns a new object of type suitable for use as the value of the
+;;; variable *random-state* and as second argument to RANDOM. If argument
+;;; state is given, a copy of it is returned. Otherwise a copy of
+;;; *random-state* is returned.
+;;;------------------------------------------------------------------
+\f
+(define random
+ (let ((state-tap-1 24)
+ (state-size 55)
+ (chunk-size 24)
+ (chunk-sup #x1000000))
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/random.scm,v 14.3 1989/10/26 06:46:47 cph Rel $
+ (define (get-bits n state)
+ (let loop ((n n))
+ (let ((p (vector-ref state state-size)))
+ (let ((i (fix:modulo (fix:- p state-tap-1) state-size))
+ (chunk (vector-ref state p)))
+ (vector-set! state p (fix:xor (vector-ref state i) chunk))
+ (vector-set! state state-size (fix:modulo (fix:- p 1) state-size))
+ (cond ((fix:= n chunk-size)
+ chunk)
+ ((fix:< n chunk-size)
+ (fix:and chunk (fix:- (fix:lsh 1 n) 1)))
+ (else
+ (+ chunk (* chunk-sup (loop (fix:- n chunk-size))))))))))
-Copyright (c) 1988, 1989 Massachusetts Institute of Technology
+ (define (fix:modulo n d)
+ ;; Specialized for nonnegative D.
+ (let ((r (fix:remainder n d)))
+ (if (or (fix:= r 0)
+ (not (fix:< n 0)))
+ r
+ (fix:+ r d))))
-This material was developed by the Scheme project at the Massachusetts
-Institute of Technology, Department of Electrical Engineering and
-Computer Science. Permission to copy this software, to redistribute
-it, and to use it for any purpose is granted, subject to the following
-restrictions and understandings.
+ (lambda (modulus #!optional state)
+ (if (not (and (exact-integer? modulus) (> modulus 0)))
+ (error:wrong-type-argument modulus "exact positive integer" 'RANDOM))
+ (let ((state (if (default-object? state) *random-state* state)))
+ (if (not (random-state? state))
+ (error:wrong-type-argument state
+ "random number state"
+ 'MAKE-RANDOM-STATE))
+ (let ((ilen (exact-nonnegative-integer-length modulus))
+ (state (random-state-bits state)))
+ (do ((r (get-bits ilen state)
+ (get-bits ilen state))) ;this could be improved.
+ ((< r modulus) r)))))))
-1. Any copy made of this software must include this copyright notice
-in full.
+(define-structure (random-state (constructor %make-random-state))
+ (bits false read-only true))
-2. Users of this software agree to make their best efforts (a) to
-return to the MIT Scheme project any improvements or extensions that
-they make, so that these may be included in future releases; and (b)
-to inform MIT of noteworthy uses of this software.
+(define (make-random-state #!optional state)
+ (let ((state (if (default-object? state) *random-state* state)))
+ (if (not (random-state? state))
+ (error:wrong-type-argument state
+ "random number state"
+ 'MAKE-RANDOM-STATE))
+ (%make-random-state (vector-copy (random-state-bits state)))))
-3. All materials developed as a consequence of the use of this
-software shall duly acknowledge such use, in accordance with the usual
-standards of acknowledging credit in academic research.
+(define *random-state*
+ (%make-random-state
+ (vector #xd909ef #xfd330a #xe33f78 #x76783f #xf3675f
+ #xb54ef8 #x0be455 #xa67946 #x0bcd56 #xfabcde
+ #x9cbd3e #x3fd3ef #xe064ef #xdddecc #x344442
+ #x854444 #x4c5192 #xc03662 #x547345 #x70abcd
+ #x1bbdac #x616c5a #xa982ef #x105996 #x5f0ccc
+ #x1ea055 #xfe2acd #x1891c1 #xe66902 #x6912bc
+ #x2678e1 #x612222 #x907abc #x4ad682 #x9cdd14
+ #x577988 #x5b8924 #x871c9c #xd1e67b #x8b0a32
+ #x578ef2 #x28274e #x823ef5 #x845678 #xe67890
+ #x5890ab #x851fa9 #x13efa1 #xb12278 #xdaf805
+ #xa0befc #x0068a7 #xe024fd #xa7b690 #x27f357
+ 0)))
-4. MIT has made no warrantee or representation that the operation of
-this software will be error-free, and MIT is under no obligation to
-provide any services, by way of maintenance, update, or otherwise.
-
-5. In conjunction with products arising from the use of this material,
-there shall be no use of the name of the Massachusetts Institute of
-Technology nor of any adaptation thereof in any advertising,
-promotional, or sales literature without prior written consent from
-MIT in each case. |#
-
-;;;; Random Number Generator
-;;; package: (runtime random-number)
-
-(declare (usual-integrations))
-
-(define seed)
-(define a)
-(define m)
-(define c)
-
-(define (initialize-package!)
- (set! seed 1)
- (set! a (+ (* 3141 1000 1000) (* 592 1000) 621))
- (set! m (expt 2 63))
- (set! c 1)
- unspecific)
-
-(define (random k)
- (if (not (and (exact-integer? k) (<= 1 k m)))
- (error "RANDOM is valid only for exact integers from 1 to" m))
- (set! seed (remainder (+ (* a seed) c) m))
- (quotient (* seed k) m))
-
-(define (randomize k)
- (if (not (and (exact-integer? k) (<= 1 k m)))
- (error "RANDOMIZE is valid only for exact integers from 1 to" m))
- (set! seed k)
- unspecific)
\ No newline at end of file
+(define exact-nonnegative-integer-length
+ (let ((powers-of-two
+ (let loop ((n 1))
+ (cons n (delay (loop (* 2 n)))))))
+ (lambda (n)
+ (let loop ((powers-of-two powers-of-two) (e 0))
+ (if (< n (car powers-of-two))
+ e
+ (loop (force (cdr powers-of-two)) (fix:+ e 1)))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff