ghc/lib/std/Random.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1995-99
   3 %
   4
   5
   6 The June 1988 (v31 #6) issue of the Communications of the ACM has an
   7 article by Pierre L'Ecuyer called, "Efficient and Portable Combined
   8 Random Number Generators".  Here is the Portable Combined Generator of
   9 L'Ecuyer for 32-bit computers.  It has a period of roughly 2.30584e18.
  10
  11 Transliterator: Lennart Augustsson
  12
  13 sof 1/99 - code brought (kicking and screaming) into the new Random
  14 world..
  15
  16 \begin{code}
  17 module Random
  18         (
  19           RandomGen(next, split)
  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 #ifndef __HUGS__
  32 import PrelGHC          ( RealWorld )
  33 import PrelNum          ( fromInt )
  34 import PrelShow         ( showSignedInt, showSpace )
  35 import PrelRead         ( readDec )
  36 import PrelIOBase       ( unsafePerformIO, stToIO )
  37 import PrelArr          ( STRef, newSTRef, readSTRef, writeSTRef )
  38 import PrelReal         ( toInt )
  39 import PrelFloat        ( float2Double, double2Float )
  40 import Time             ( getClockTime, ClockTime(..) )
  41 #else
  42 import privileged Prelude
  43                         ( 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 (toInt (s1+1)) (toInt (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) (fromInt 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}