ghc/lib/std/Random.lhs

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