ghc/lib/std/Random.lhs

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