ghc/lib/std/Random.lhs

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