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

Contents of /src/code/rand.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1.1.1 - (hide annotations) (vendor branch)
Tue Jul 10 13:19:21 1990 UTC (23 years, 9 months ago) by ram
Changes since 1.1: +7 -22 lines
Fixed stuff to work with the new float, fixnum formats.
1 ram 1.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 ram 1.1.1.1 (defconstant random-upper-bound (1- most-positive-fixnum))
24 ram 1.1 (defconstant random-max 54)
25 ram 1.1.1.1 (defconstant %fixnum-length (integer-length most-positive-fixnum))
26 ram 1.1 (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 ram 1.1.1.1
43    
44     (defvar *random-state* (make-random-object))
45    
46 ram 1.1
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 ram 1.1.1.1 (let ((arg-length (float-digits arg)))
104 ram 1.1 (* 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