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

Contents of /src/code/rand.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Fri Feb 8 13:35:04 1991 UTC (23 years, 2 months ago) by ram
Branch: MAIN
Changes since 1.2: +8 -4 lines
New file header with RCS header FILE-COMMENT.
1 ram 1.1 ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
2     ;;;
3     ;;; **********************************************************************
4 ram 1.3 ;;; 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.3 1991/02/08 13:35:04 ram Exp $")
11     ;;;
12 ram 1.1 ;;; **********************************************************************
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 wlott 1.2 (defconstant random-upper-bound (1- most-positive-fixnum))
28 ram 1.1 (defconstant random-max 54)
29 wlott 1.2 (defconstant %fixnum-length (integer-length most-positive-fixnum))
30 ram 1.1 (defvar rand-seed 0)
31    
32     (defstruct (random-state (:constructor make-random-object))
33     (j 24 :type integer)
34     (k 0 :type integer)
35     (seed (make-array (1+ random-max) :initial-contents
36     (do ((list-rands () (cons (rand1) list-rands))
37     (i 0 (1+ i)))
38     ((> i random-max) list-rands)))
39     :type simple-vector))
40    
41    
42     ;;; Generates a random number from rand-seed.
43     (defun rand1 ()
44     (setq rand-seed (mod (+ (* rand-seed random-const-a) random-const-c)
45     (1+ random-upper-bound))))
46 wlott 1.2
47    
48     (defvar *random-state* (make-random-object))
49    
50 ram 1.1
51     ;;; rand3 -- Internal
52     ;;;
53     ;;; This function generates fixnums between 0 and random-upper-bound,
54     ;;; inclusive For the algorithm to work random-upper-bound must be an
55     ;;; even positive fixnum. State is the random state to use.
56     ;;;
57     (defun rand3 (state)
58     (let ((seed (random-state-seed state))
59     (j (random-state-j state))
60     (k (random-state-k state)))
61     (declare (fixnum j k) (simple-vector seed))
62     (setf (svref seed k)
63     (let ((a (- random-upper-bound
64     (svref seed
65     (setf (random-state-j state)
66     (if (= j 0) random-max (1- j))))
67     (svref seed
68     (setf (random-state-k state)
69     (if (= k 0) random-max (1- k)))))))
70     (if (minusp a) (- a) (- random-upper-bound a))))))
71    
72    
73     (defun copy-state (cur-state)
74     (let ((state (make-random-object
75     :seed (make-array 55)
76     :j (random-state-j cur-state)
77     :k (random-state-k cur-state))))
78     (do ((i 0 (1+ i)))
79     ((= i 55) state)
80     (declare (fixnum i))
81     (setf (aref (random-state-seed state) i)
82     (aref (random-state-seed cur-state) i)))))
83    
84     (defun make-random-state (&optional state)
85     "Make a random state object. If State is not supplied, return a copy
86     of the default random state. If State is a random state, then return a
87     copy of it. If state is T then return a random state generated from
88     the universal time."
89     (cond ((not state) (copy-state *random-state*))
90     ((random-state-p state) (copy-state state))
91     ((eq state t) (setq rand-seed (get-universal-time))
92     (make-random-object))
93     (t (error "Bad argument, ~A, for RANDOM-STATE." state))))
94    
95     (proclaim '(ftype (function (t) fixnum) rand3))
96     (defun random (arg &optional (state *random-state*))
97     "Generate a uniformly distributed pseudo-random number between zero
98     and Arg. State, if supplied, is the random state to use."
99     (typecase arg
100     (fixnum
101     (unless (plusp (the fixnum arg))
102     (error "Non-positive argument, ~A, to RANDOM." arg))
103     (rem (the fixnum (rand3 state)) (the fixnum arg)))
104     (float
105     (unless (plusp arg)
106     (error "Non-positive argument, ~A, to RANDOM." arg))
107 wlott 1.2 (let ((arg-length (float-digits arg)))
108 ram 1.1 (* arg (/ (float (random (ash 2 arg-length) state))
109     (float (ash 2 arg-length))))))
110     (integer
111     (unless (plusp arg)
112     (error "Non-positive argument, ~A, to RANDOM." arg))
113     (do ((tot (rand3 state) (+ (ash tot %fixnum-length) (rand3 state)))
114     (end (ash arg (- %fixnum-length))
115     (ash end (- %fixnum-length))))
116     ((zerop end) (mod tot arg))))
117     (t (error "Wrong type argument, ~A, to RANDOM." arg))))

  ViewVC Help
Powered by ViewVC 1.1.5