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