System/Random.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  System.Random
   4 -- Copyright   :  (c) The University of Glasgow 2001
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  provisional
   9 -- Portability :  portable
  10 --
  11 -- Random numbers.
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 module System.Random
  16         (
  17           RandomGen(next, split, genRange)
  18         , StdGen
  19         , mkStdGen
  20         , Random ( random,   randomR,
  21                    randoms,  randomRs,
  22                    randomIO, randomRIO )
  23         , getStdRandom
  24         , getStdGen
  25         , setStdGen
  26         , newStdGen
  27         ) where
  28
  29 -- The June 1988 (v31 #6) issue of the Communications of the ACM has an
  30 -- article by Pierre L'Ecuyer called, "Efficient and Portable Combined
  31 -- Random Number Generators".  Here is the Portable Combined Generator of
  32 -- L'Ecuyer for 32-bit computers.  It has a period of roughly 2.30584e18.
  33
  34 -- Transliterator: Lennart Augustsson
  35
  36 -- sof 1/99 - code brought (kicking and screaming) into the new Random
  37 -- world..
  38
  39 import Prelude
  40
  41 import System.CPUTime   ( getCPUTime )
  42 import Data.Char        ( isSpace, chr, ord )
  43 import System.IO.Unsafe ( unsafePerformIO )
  44 import Data.IORef
  45
  46 #ifdef __GLASGOW_HASKELL__
  47 import GHC.Show         ( showSignedInt, showSpace )
  48 import Numeric          ( readDec )
  49 import GHC.IOBase       ( unsafePerformIO, stToIO )
  50 import System.Time      ( getClockTime, ClockTime(..) )
  51 #endif
  52
  53 class RandomGen g where
  54    next     :: g -> (Int, g)
  55    split    :: g -> (g, g)
  56    genRange :: g -> (Int,Int)
  57
  58    -- default mathod
  59    genRange g = (minBound,maxBound)
  60
  61
  62 data StdGen
  63  = StdGen Int Int
  64
  65 instance RandomGen StdGen where
  66   next  = stdNext
  67   split = stdSplit
  68
  69 #ifdef __GLASGOW_HASKELL__
  70 instance Show StdGen where
  71   showsPrec p (StdGen s1 s2) =
  72      showSignedInt p s1 .
  73      showSpace          .
  74      showSignedInt p s2
  75 #endif
  76
  77 #ifdef __HUGS__
  78 instance Show StdGen where
  79   showsPrec p (StdGen s1 s2) =
  80      showsPrec p s1 .
  81      showChar ' ' .
  82      showsPrec 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
 105
 106 mkStdGen :: Int -> StdGen -- why not Integer ?
 107 mkStdGen s
 108  | s < 0     = mkStdGen (-s)
 109  | otherwise = StdGen (s1+1) (s2+1)
 110       where
 111         (q, s1) = s `divMod` 2147483562
 112         s2      = q `mod` 2147483398
 113
 114 createStdGen :: Integer -> StdGen
 115 createStdGen s
 116  | s < 0     = createStdGen (-s)
 117  | otherwise = StdGen (fromInteger (s1+1)) (fromInteger (s2+1))
 118       where
 119         (q, s1) = s `divMod` 2147483562
 120         s2      = q `mod` 2147483398
 121
 122
 123 -- The class definition - see library report for details.
 124
 125 class Random a where
 126   -- Minimal complete definition: random and randomR
 127   random  :: RandomGen g => g -> (a, g)
 128   randomR :: RandomGen g => (a,a) -> g -> (a,g)
 129
 130   randoms  :: RandomGen g => g -> [a]
 131   randoms  g      = x : randoms g' where (x,g') = random g
 132
 133   randomRs :: RandomGen g => (a,a) -> g -> [a]
 134   randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g
 135
 136   randomIO  :: IO a
 137   randomIO         = getStdRandom random
 138
 139   randomRIO :: (a,a) -> IO a
 140   randomRIO range  = getStdRandom (randomR range)
 141
 142
 143 instance Random Int where
 144   randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g
 145   random g        = randomR (minBound,maxBound) g
 146
 147 instance Random Char where
 148   randomR (a,b) g =
 149       case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of
 150         (x,g) -> (chr x, g)
 151   random g        = randomR (minBound,maxBound) g
 152
 153 instance Random Bool where
 154   randomR (a,b) g =
 155       case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of
 156         (x, g) -> (int2Bool x, g)
 157        where
 158          bool2Int False = 0
 159          bool2Int True  = 1
 160
 161          int2Bool 0     = False
 162          int2Bool _     = True
 163
 164   random g        = randomR (minBound,maxBound) g
 165
 166 instance Random Integer where
 167   randomR ival g = randomIvalInteger ival g
 168   random g       = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g
 169
 170 instance Random Double where
 171   randomR ival g = randomIvalDouble ival id g
 172   random g       = randomR (0::Double,1) g
 173
 174 -- hah, so you thought you were saving cycles by using Float?
 175 instance Random Float where
 176   random g        = randomIvalDouble (0::Double,1) realToFrac g
 177   randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g
 178
 179 #ifdef __GLASGOW_HASKELL__
 180 mkStdRNG :: Integer -> IO StdGen
 181 mkStdRNG o = do
 182     ct          <- getCPUTime
 183     (TOD sec _) <- getClockTime
 184     return (createStdGen (sec * 12345 + ct + o))
 185 #endif
 186
 187 #ifdef __HUGS__
 188 mkStdRNG :: Integer -> IO StdGen
 189 mkStdRNG o = do
 190     ct          <- getCPUTime
 191     return (createStdGen (ct + o))
 192 #endif
 193
 194 randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
 195 randomIvalInteger (l,h) rng
 196  | l > h     = randomIvalInteger (h,l) rng
 197  | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
 198      where
 199        k = h - l + 1
 200        b = 2147483561
 201        n = iLogBase b k
 202
 203        f 0 acc g = (acc, g)
 204        f n acc g =
 205           let
 206            (x,g')   = next g
 207           in
 208           f (n-1) (fromIntegral x + acc * b) g'
 209
 210 randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)
 211 randomIvalDouble (l,h) fromDouble rng
 212   | l > h     = randomIvalDouble (h,l) fromDouble rng
 213   | otherwise =
 214        case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of
 215          (x, rng') ->
 216             let
 217              scaled_x =
 218                 fromDouble ((l+h)/2) +
 219                 fromDouble ((h-l) / realToFrac intRange) *
 220                 fromIntegral (x::Int)
 221             in
 222             (scaled_x, rng')
 223
 224 intRange :: Integer
 225 intRange  = toInteger (maxBound::Int) - toInteger (minBound::Int)
 226
 227 iLogBase :: Integer -> Integer -> Integer
 228 iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)
 229
 230 stdNext :: StdGen -> (Int, StdGen)
 231 stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')
 232         where   z'   = if z < 1 then z + 2147483562 else z
 233                 z    = s1'' - s2''
 234
 235                 k    = s1 `quot` 53668
 236                 s1'  = 40014 * (s1 - k * 53668) - k * 12211
 237                 s1'' = if s1' < 0 then s1' + 2147483563 else s1'
 238
 239                 k'   = s2 `quot` 52774
 240                 s2'  = 40692 * (s2 - k' * 52774) - k' * 3791
 241                 s2'' = if s2' < 0 then s2' + 2147483399 else s2'
 242
 243 stdSplit            :: StdGen -> (StdGen, StdGen)
 244 stdSplit std@(StdGen s1 s2)
 245                      = (left, right)
 246                        where
 247                         -- no statistical foundation for this!
 248                         left    = StdGen new_s1 t2
 249                         right   = StdGen t1 new_s2
 250
 251                         new_s1 | s1 == 2147483562 = 1
 252                                | otherwise        = s1 + 1
 253
 254                         new_s2 | s2 == 1          = 2147483398
 255                                | otherwise        = s2 - 1
 256
 257                         StdGen t1 t2 = snd (next std)
 258
 259
 260 setStdGen :: StdGen -> IO ()
 261 setStdGen sgen = writeIORef theStdGen sgen
 262
 263 getStdGen :: IO StdGen
 264 getStdGen  = readIORef theStdGen
 265
 266 theStdGen :: IORef StdGen
 267 theStdGen  = unsafePerformIO (newIORef (createStdGen 0))
 268
 269 newStdGen :: IO StdGen
 270 newStdGen = do
 271   rng <- getStdGen
 272   let (a,b) = split rng
 273   setStdGen a
 274   return b
 275
 276 getStdRandom :: (StdGen -> (a,StdGen)) -> IO a
 277 getStdRandom f = do
 278    rng          <- getStdGen
 279    let (v, new_rng) = f rng
 280    setStdGen new_rng
 281    return v