ghc/lib/std/Random.lhs

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