# Contents of /src/code/rand.lisp

Revision 1.1 - (show annotations)
Tue Feb 6 17:26:34 1990 UTC (23 years, 10 months ago) by ram
Branch: MAIN
```Initial revision
```
 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 134217726) 24 (defconstant random-max 54) 25 (defvar rand-seed 0) 26 (defvar *random-state*) 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 ;;; rand3 -- Internal 44 ;;; 45 ;;; This function generates fixnums between 0 and random-upper-bound, 46 ;;; inclusive For the algorithm to work random-upper-bound must be an 47 ;;; even positive fixnum. State is the random state to use. 48 ;;; 49 (defun rand3 (state) 50 (let ((seed (random-state-seed state)) 51 (j (random-state-j state)) 52 (k (random-state-k state))) 53 (declare (fixnum j k) (simple-vector seed)) 54 (setf (svref seed k) 55 (let ((a (- random-upper-bound 56 (svref seed 57 (setf (random-state-j state) 58 (if (= j 0) random-max (1- j)))) 59 (svref seed 60 (setf (random-state-k state) 61 (if (= k 0) random-max (1- k))))))) 62 (if (minusp a) (- a) (- random-upper-bound a)))))) 63 64 65 (defun random-init () 66 (setq *random-state* 67 (make-random-object :seed 68 (make-array (1+ random-max) :initial-contents 69 '(45117816 133464727 86324180 99419799 68851957 87250180 70 52971860 84081967 30854110 121122797 70449044 18801152 71 45149898 15881380 27398356 117706009 49915564 80620628 72 120974070 98193932 43883764 53717012 100954825 82579490 73 17280729 118523949 42282975 127220348 6288263 56575578 74 2474156 47934425 561006 21989698 74046730 105055318 75 113363907 48749716 78183593 109613585 37323232 65101428 76 46453209 76906562 5371267 86544820 33922642 60765033 77 41889257 77176406 38775255 78514879 72553872 66916641 78 100613180))))) 79 80 (defun copy-state (cur-state) 81 (let ((state (make-random-object 82 :seed (make-array 55) 83 :j (random-state-j cur-state) 84 :k (random-state-k cur-state)))) 85 (do ((i 0 (1+ i))) 86 ((= i 55) state) 87 (declare (fixnum i)) 88 (setf (aref (random-state-seed state) i) 89 (aref (random-state-seed cur-state) i))))) 90 91 (defun make-random-state (&optional state) 92 "Make a random state object. If State is not supplied, return a copy 93 of the default random state. If State is a random state, then return a 94 copy of it. If state is T then return a random state generated from 95 the universal time." 96 (cond ((not state) (copy-state *random-state*)) 97 ((random-state-p state) (copy-state state)) 98 ((eq state t) (setq rand-seed (get-universal-time)) 99 (make-random-object)) 100 (t (error "Bad argument, ~A, for RANDOM-STATE." state)))) 101 102 (proclaim '(ftype (function (t) fixnum) rand3)) 103 (defun random (arg &optional (state *random-state*)) 104 "Generate a uniformly distributed pseudo-random number between zero 105 and Arg. State, if supplied, is the random state to use." 106 (typecase arg 107 (fixnum 108 (unless (plusp (the fixnum arg)) 109 (error "Non-positive argument, ~A, to RANDOM." arg)) 110 (rem (the fixnum (rand3 state)) (the fixnum arg))) 111 (float 112 (unless (plusp arg) 113 (error "Non-positive argument, ~A, to RANDOM." arg)) 114 (let ((arg-length (typecase arg 115 (short-float %short-float-mantissa-length) 116 (single-float %single-float-mantissa-length) 117 (double-float %double-float-mantissa-length) 118 (long-float %long-float-mantissa-length)))) 119 (* arg (/ (float (random (ash 2 arg-length) state)) 120 (float (ash 2 arg-length)))))) 121 (integer 122 (unless (plusp arg) 123 (error "Non-positive argument, ~A, to RANDOM." arg)) 124 (do ((tot (rand3 state) (+ (ash tot %fixnum-length) (rand3 state))) 125 (end (ash arg (- %fixnum-length)) 126 (ash end (- %fixnum-length)))) 127 ((zerop end) (mod tot arg)))) 128 (t (error "Wrong type argument, ~A, to RANDOM." arg))))