/[cmucl]/src/code/rand.lisp
ViewVC logotype

Contents of /src/code/rand.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Fri Aug 24 18:12:35 1990 UTC (23 years, 8 months ago) by wlott
Branch: MAIN
Changes since 1.1: +7 -22 lines
Moved MIPS branch onto trunk; no merge necessary.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the Spice Lisp project at
5 ;;; Carnegie-Mellon University, and has been placed in the public domain.
6 ;;; If you want to use this code or any part of Spice Lisp, please contact
7 ;;; Scott Fahlman (FAHLMAN@CMUC).
8 ;;; **********************************************************************
9 ;;;
10 ;;; Functions to random number functions for Spice Lisp
11 ;;; Written by David Adam.
12 ;;;
13 ;;; The random number functions are part of the standard Spicelisp environment.
14 ;;;
15 ;;; **********************************************************************
16 ;;;
17 (in-package 'lisp)
18 (export '(random-state random-state-p random *random-state*
19 make-random-state))
20
21 (defconstant random-const-a 8373)
22 (defconstant random-const-c 101010101)
23 (defconstant random-upper-bound (1- most-positive-fixnum))
24 (defconstant random-max 54)
25 (defconstant %fixnum-length (integer-length most-positive-fixnum))
26 (defvar rand-seed 0)
27
28 (defstruct (random-state (:constructor make-random-object))
29 (j 24 :type integer)
30 (k 0 :type integer)
31 (seed (make-array (1+ random-max) :initial-contents
32 (do ((list-rands () (cons (rand1) list-rands))
33 (i 0 (1+ i)))
34 ((> i random-max) list-rands)))
35 :type simple-vector))
36
37
38 ;;; Generates a random number from rand-seed.
39 (defun rand1 ()
40 (setq rand-seed (mod (+ (* rand-seed random-const-a) random-const-c)
41 (1+ random-upper-bound))))
42
43
44 (defvar *random-state* (make-random-object))
45
46
47 ;;; rand3 -- Internal
48 ;;;
49 ;;; This function generates fixnums between 0 and random-upper-bound,
50 ;;; inclusive For the algorithm to work random-upper-bound must be an
51 ;;; even positive fixnum. State is the random state to use.
52 ;;;
53 (defun rand3 (state)
54 (let ((seed (random-state-seed state))
55 (j (random-state-j state))
56 (k (random-state-k state)))
57 (declare (fixnum j k) (simple-vector seed))
58 (setf (svref seed k)
59 (let ((a (- random-upper-bound
60 (svref seed
61 (setf (random-state-j state)
62 (if (= j 0) random-max (1- j))))
63 (svref seed
64 (setf (random-state-k state)
65 (if (= k 0) random-max (1- k)))))))
66 (if (minusp a) (- a) (- random-upper-bound a))))))
67
68
69 (defun copy-state (cur-state)
70 (let ((state (make-random-object
71 :seed (make-array 55)
72 :j (random-state-j cur-state)
73 :k (random-state-k cur-state))))
74 (do ((i 0 (1+ i)))
75 ((= i 55) state)
76 (declare (fixnum i))
77 (setf (aref (random-state-seed state) i)
78 (aref (random-state-seed cur-state) i)))))
79
80 (defun make-random-state (&optional state)
81 "Make a random state object. If State is not supplied, return a copy
82 of the default random state. If State is a random state, then return a
83 copy of it. If state is T then return a random state generated from
84 the universal time."
85 (cond ((not state) (copy-state *random-state*))
86 ((random-state-p state) (copy-state state))
87 ((eq state t) (setq rand-seed (get-universal-time))
88 (make-random-object))
89 (t (error "Bad argument, ~A, for RANDOM-STATE." state))))
90
91 (proclaim '(ftype (function (t) fixnum) rand3))
92 (defun random (arg &optional (state *random-state*))
93 "Generate a uniformly distributed pseudo-random number between zero
94 and Arg. State, if supplied, is the random state to use."
95 (typecase arg
96 (fixnum
97 (unless (plusp (the fixnum arg))
98 (error "Non-positive argument, ~A, to RANDOM." arg))
99 (rem (the fixnum (rand3 state)) (the fixnum arg)))
100 (float
101 (unless (plusp arg)
102 (error "Non-positive argument, ~A, to RANDOM." arg))
103 (let ((arg-length (float-digits arg)))
104 (* arg (/ (float (random (ash 2 arg-length) state))
105 (float (ash 2 arg-length))))))
106 (integer
107 (unless (plusp arg)
108 (error "Non-positive argument, ~A, to RANDOM." arg))
109 (do ((tot (rand3 state) (+ (ash tot %fixnum-length) (rand3 state)))
110 (end (ash arg (- %fixnum-length))
111 (ash end (- %fixnum-length))))
112 ((zerop end) (mod tot arg))))
113 (t (error "Wrong type argument, ~A, to RANDOM." arg))))

  ViewVC Help
Powered by ViewVC 1.1.5