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