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

Contents of /src/code/rand.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Sat Dec 14 09:01:01 1991 UTC (22 years, 4 months ago) by wlott
Branch: MAIN
Changes since 1.3: +4 -2 lines
Added make-load-form support.
1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common 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 CMU Common Lisp, please contact
7 ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
8 ;;;
9 (ext:file-comment
10 "$Header: /tiger/var/lib/cvsroots/cmucl/src/code/rand.lisp,v 1.4 1991/12/14 09:01:01 wlott Exp $")
11 ;;;
12 ;;; **********************************************************************
13 ;;;
14 ;;; Functions to random number functions for Spice Lisp
15 ;;; Written by David Adam.
16 ;;;
17 ;;; The random number functions are part of the standard Spicelisp environment.
18 ;;;
19 ;;; **********************************************************************
20 ;;;
21 (in-package 'lisp)
22 (export '(random-state random-state-p random *random-state*
23 make-random-state))
24
25 (defconstant random-const-a 8373)
26 (defconstant random-const-c 101010101)
27 (defconstant random-upper-bound (1- most-positive-fixnum))
28 (defconstant random-max 54)
29 (defconstant %fixnum-length (integer-length most-positive-fixnum))
30 (defvar rand-seed 0)
31
32 (defstruct (random-state
33 (:constructor make-random-object)
34 (:make-load-form-fun :just-dump-it-normally))
35 (j 24 :type integer)
36 (k 0 :type integer)
37 (seed (make-array (1+ random-max) :initial-contents
38 (do ((list-rands () (cons (rand1) list-rands))
39 (i 0 (1+ i)))
40 ((> i random-max) list-rands)))
41 :type simple-vector))
42
43
44 ;;; Generates a random number from rand-seed.
45 (defun rand1 ()
46 (setq rand-seed (mod (+ (* rand-seed random-const-a) random-const-c)
47 (1+ random-upper-bound))))
48
49
50 (defvar *random-state* (make-random-object))
51
52
53 ;;; rand3 -- Internal
54 ;;;
55 ;;; This function generates fixnums between 0 and random-upper-bound,
56 ;;; inclusive For the algorithm to work random-upper-bound must be an
57 ;;; even positive fixnum. State is the random state to use.
58 ;;;
59 (defun rand3 (state)
60 (let ((seed (random-state-seed state))
61 (j (random-state-j state))
62 (k (random-state-k state)))
63 (declare (fixnum j k) (simple-vector seed))
64 (setf (svref seed k)
65 (let ((a (- random-upper-bound
66 (svref seed
67 (setf (random-state-j state)
68 (if (= j 0) random-max (1- j))))
69 (svref seed
70 (setf (random-state-k state)
71 (if (= k 0) random-max (1- k)))))))
72 (if (minusp a) (- a) (- random-upper-bound a))))))
73
74
75 (defun copy-state (cur-state)
76 (let ((state (make-random-object
77 :seed (make-array 55)
78 :j (random-state-j cur-state)
79 :k (random-state-k cur-state))))
80 (do ((i 0 (1+ i)))
81 ((= i 55) state)
82 (declare (fixnum i))
83 (setf (aref (random-state-seed state) i)
84 (aref (random-state-seed cur-state) i)))))
85
86 (defun make-random-state (&optional state)
87 "Make a random state object. If State is not supplied, return a copy
88 of the default random state. If State is a random state, then return a
89 copy of it. If state is T then return a random state generated from
90 the universal time."
91 (cond ((not state) (copy-state *random-state*))
92 ((random-state-p state) (copy-state state))
93 ((eq state t) (setq rand-seed (get-universal-time))
94 (make-random-object))
95 (t (error "Bad argument, ~A, for RANDOM-STATE." state))))
96
97 (proclaim '(ftype (function (t) fixnum) rand3))
98 (defun random (arg &optional (state *random-state*))
99 "Generate a uniformly distributed pseudo-random number between zero
100 and Arg. State, if supplied, is the random state to use."
101 (typecase arg
102 (fixnum
103 (unless (plusp (the fixnum arg))
104 (error "Non-positive argument, ~A, to RANDOM." arg))
105 (rem (the fixnum (rand3 state)) (the fixnum arg)))
106 (float
107 (unless (plusp arg)
108 (error "Non-positive argument, ~A, to RANDOM." arg))
109 (let ((arg-length (float-digits arg)))
110 (* arg (/ (float (random (ash 2 arg-length) state))
111 (float (ash 2 arg-length))))))
112 (integer
113 (unless (plusp arg)
114 (error "Non-positive argument, ~A, to RANDOM." arg))
115 (do ((tot (rand3 state) (+ (ash tot %fixnum-length) (rand3 state)))
116 (end (ash arg (- %fixnum-length))
117 (ash end (- %fixnum-length))))
118 ((zerop end) (mod tot arg))))
119 (t (error "Wrong type argument, ~A, to RANDOM." arg))))

  ViewVC Help
Powered by ViewVC 1.1.5