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