0b5286bb0f6029898eb779f74123ebc9b3c124c1
[packages/base.git] / System / Random.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Module : System.Random
4 -- Copyright : (c) The University of Glasgow 2001
5 -- License : BSD-style (see the file libraries/core/LICENSE)
6 --
7 -- Maintainer : libraries@haskell.org
8 -- Stability : provisional
9 -- Portability : portable
10 --
11 -- $Id: Random.hs,v 1.3 2002/04/11 12:03:44 simonpj Exp $
12 --
13 -- Random numbers.
14 --
15 -----------------------------------------------------------------------------
16
17 module System.Random
18 (
19 RandomGen(next, split, genRange)
20 , StdGen
21 , mkStdGen
22 , Random ( random, randomR,
23 randoms, randomRs,
24 randomIO, randomRIO )
25 , getStdRandom
26 , getStdGen
27 , setStdGen
28 , newStdGen
29 ) where
30
31 -- The June 1988 (v31 #6) issue of the Communications of the ACM has an
32 -- article by Pierre L'Ecuyer called, "Efficient and Portable Combined
33 -- Random Number Generators". Here is the Portable Combined Generator of
34 -- L'Ecuyer for 32-bit computers. It has a period of roughly 2.30584e18.
35
36 -- Transliterator: Lennart Augustsson
37
38 -- sof 1/99 - code brought (kicking and screaming) into the new Random
39 -- world..
40
41 import Prelude
42
43 import System.CPUTime ( getCPUTime )
44 import Data.Char ( isSpace, chr, ord )
45 import System.IO.Unsafe ( unsafePerformIO )
46 import Data.IORef
47
48 #ifdef __GLASGOW_HASKELL__
49 import GHC.Show ( showSignedInt, showSpace )
50 import Numeric ( readDec )
51 import GHC.IOBase ( unsafePerformIO, stToIO )
52 import System.Time ( getClockTime, ClockTime(..) )
53 #endif
54
55 class RandomGen g where
56 next :: g -> (Int, g)
57 split :: g -> (g, g)
58 genRange :: g -> (Int,Int)
59
60 -- default mathod
61 genRange g = (minBound,maxBound)
62
63
64 data StdGen
65 = StdGen Int Int
66
67 instance RandomGen StdGen where
68 next = stdNext
69 split = stdSplit
70
71 #ifdef __GLASGOW_HASKELL__
72 instance Show StdGen where
73 showsPrec p (StdGen s1 s2) =
74 showSignedInt p s1 .
75 showSpace .
76 showSignedInt p s2
77 #endif
78
79 #ifdef __HUGS__
80 instance Show StdGen where
81 showsPrec p (StdGen s1 s2) =
82 showsPrec p s1 .
83 showChar ' ' .
84 showsPrec p s2
85 #endif
86
87 instance Read StdGen where
88 readsPrec _p = \ r ->
89 case try_read r of
90 r@[_] -> r
91 _ -> [stdFromString r] -- because it shouldn't ever fail.
92 where
93 try_read r = do
94 (s1, r1) <- readDec (dropWhile isSpace r)
95 (s2, r2) <- readDec (dropWhile isSpace r1)
96 return (StdGen s1 s2, r2)
97
98 {-
99 If we cannot unravel the StdGen from a string, create
100 one based on the string given.
101 -}
102 stdFromString :: String -> (StdGen, String)
103 stdFromString s = (mkStdGen num, rest)
104 where (cs, rest) = splitAt 6 s
105 num = foldl (\a x -> x + 3 * a) 1 (map ord cs)
106
107
108 mkStdGen :: Int -> StdGen -- why not Integer ?
109 mkStdGen s
110 | s < 0 = mkStdGen (-s)
111 | otherwise = StdGen (s1+1) (s2+1)
112 where
113 (q, s1) = s `divMod` 2147483562
114 s2 = q `mod` 2147483398
115
116 createStdGen :: Integer -> StdGen
117 createStdGen s
118 | s < 0 = createStdGen (-s)
119 | otherwise = StdGen (fromInteger (s1+1)) (fromInteger (s2+1))
120 where
121 (q, s1) = s `divMod` 2147483562
122 s2 = q `mod` 2147483398
123
124
125 -- The class definition - see library report for details.
126
127 class Random a where
128 -- Minimal complete definition: random and randomR
129 random :: RandomGen g => g -> (a, g)
130 randomR :: RandomGen g => (a,a) -> g -> (a,g)
131
132 randoms :: RandomGen g => g -> [a]
133 randoms g = x : randoms g' where (x,g') = random g
134
135 randomRs :: RandomGen g => (a,a) -> g -> [a]
136 randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g
137
138 randomIO :: IO a
139 randomIO = getStdRandom random
140
141 randomRIO :: (a,a) -> IO a
142 randomRIO range = getStdRandom (randomR range)
143
144
145 instance Random Int where
146 randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g
147 random g = randomR (minBound,maxBound) g
148
149 instance Random Char where
150 randomR (a,b) g =
151 case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of
152 (x,g) -> (chr x, g)
153 random g = randomR (minBound,maxBound) g
154
155 instance Random Bool where
156 randomR (a,b) g =
157 case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of
158 (x, g) -> (int2Bool x, g)
159 where
160 bool2Int False = 0
161 bool2Int True = 1
162
163 int2Bool 0 = False
164 int2Bool _ = True
165
166 random g = randomR (minBound,maxBound) g
167
168 instance Random Integer where
169 randomR ival g = randomIvalInteger ival g
170 random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g
171
172 instance Random Double where
173 randomR ival g = randomIvalDouble ival id g
174 random g = randomR (0::Double,1) g
175
176 -- hah, so you thought you were saving cycles by using Float?
177 instance Random Float where
178 random g = randomIvalDouble (0::Double,1) realToFrac g
179 randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g
180
181 #ifdef __GLASGOW_HASKELL__
182 mkStdRNG :: Integer -> IO StdGen
183 mkStdRNG o = do
184 ct <- getCPUTime
185 (TOD sec _) <- getClockTime
186 return (createStdGen (sec * 12345 + ct + o))
187 #endif
188
189 #ifdef __HUGS__
190 mkStdRNG :: Integer -> IO StdGen
191 mkStdRNG o = do
192 ct <- getCPUTime
193 return (createStdGen (ct + o))
194 #endif
195
196 randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
197 randomIvalInteger (l,h) rng
198 | l > h = randomIvalInteger (h,l) rng
199 | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
200 where
201 k = h - l + 1
202 b = 2147483561
203 n = iLogBase b k
204
205 f 0 acc g = (acc, g)
206 f n acc g =
207 let
208 (x,g') = next g
209 in
210 f (n-1) (fromIntegral x + acc * b) g'
211
212 randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)
213 randomIvalDouble (l,h) fromDouble rng
214 | l > h = randomIvalDouble (h,l) fromDouble rng
215 | otherwise =
216 case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of
217 (x, rng') ->
218 let
219 scaled_x =
220 fromDouble ((l+h)/2) +
221 fromDouble ((h-l) / realToFrac intRange) *
222 fromIntegral (x::Int)
223 in
224 (scaled_x, rng')
225
226 intRange :: Integer
227 intRange = toInteger (maxBound::Int) - toInteger (minBound::Int)
228
229 iLogBase :: Integer -> Integer -> Integer
230 iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)
231
232 stdNext :: StdGen -> (Int, StdGen)
233 stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')
234 where z' = if z < 1 then z + 2147483562 else z
235 z = s1'' - s2''
236
237 k = s1 `quot` 53668
238 s1' = 40014 * (s1 - k * 53668) - k * 12211
239 s1'' = if s1' < 0 then s1' + 2147483563 else s1'
240
241 k' = s2 `quot` 52774
242 s2' = 40692 * (s2 - k' * 52774) - k' * 3791
243 s2'' = if s2' < 0 then s2' + 2147483399 else s2'
244
245 stdSplit :: StdGen -> (StdGen, StdGen)
246 stdSplit std@(StdGen s1 s2)
247 = (left, right)
248 where
249 -- no statistical foundation for this!
250 left = StdGen new_s1 t2
251 right = StdGen t1 new_s2
252
253 new_s1 | s1 == 2147483562 = 1
254 | otherwise = s1 + 1
255
256 new_s2 | s2 == 1 = 2147483398
257 | otherwise = s2 - 1
258
259 StdGen t1 t2 = snd (next std)
260
261
262 setStdGen :: StdGen -> IO ()
263 setStdGen sgen = writeIORef theStdGen sgen
264
265 getStdGen :: IO StdGen
266 getStdGen = readIORef theStdGen
267
268 theStdGen :: IORef StdGen
269 theStdGen = unsafePerformIO (newIORef (createStdGen 0))
270
271 newStdGen :: IO StdGen
272 newStdGen = do
273 rng <- getStdGen
274 let (a,b) = split rng
275 setStdGen a
276 return b
277
278 getStdRandom :: (StdGen -> (a,StdGen)) -> IO a
279 getStdRandom f = do
280 rng <- getStdGen
281 let (v, new_rng) = f rng
282 setStdGen new_rng
283 return v