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/core/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  provisional
   9 -- Portability :  portable
  10 --
  11 -- $Id: Random.hs,v 1.4 2002/04/24 16:31:45 simonmar Exp $
  12 --
  13 -- Random numbers.
  14 --
  15 -----------------------------------------------------------------------------
  16
  17 module System.Random
  18         (
  19           RandomGen(next, split, genRange)
  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 -- The June 1988 (v31 #6) issue of the Communications of the ACM has an
  32 -- article by Pierre L'Ecuyer called, "Efficient and Portable Combined
  33 -- Random Number Generators".  Here is the Portable Combined Generator of
  34 -- L'Ecuyer for 32-bit computers.  It has a period of roughly 2.30584e18.
  35
  36 -- Transliterator: Lennart Augustsson
  37
  38 -- sof 1/99 - code brought (kicking and screaming) into the new Random
  39 -- world..
  40
  41 import Prelude
  42
  43 import System.CPUTime   ( getCPUTime )
  44 import Data.Char        ( isSpace, chr, ord )
  45 import System.IO.Unsafe ( unsafePerformIO )
  46 import Data.IORef
  47
  48 #ifdef __GLASGOW_HASKELL__
  49 import GHC.Show         ( showSignedInt, showSpace )
  50 import Numeric          ( readDec )
  51 import GHC.IOBase       ( unsafePerformIO, stToIO )
  52 import System.Time      ( getClockTime, ClockTime(..) )
  53 #endif
  54
  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 __GLASGOW_HASKELL__
  72 instance Show StdGen where
  73   showsPrec p (StdGen s1 s2) =
  74      showSignedInt p s1 .
  75      showSpace          .
  76      showSignedInt p s2
  77 #endif
  78
  79 #ifdef __HUGS__
  80 instance Show StdGen where
  81   showsPrec p (StdGen s1 s2) =
  82      showsPrec p s1 .
  83      showChar ' ' .
  84      showsPrec p s2
  85 #endif
  86
  87 instance Read StdGen where
  88   readsPrec _p = \ r ->
  89      case try_read r of
  90        r@[_] -> r
  91        _   -> [stdFromString r] -- because it shouldn't ever fail.
  92     where
  93       try_read r = do
  94          (s1, r1) <- readDec (dropWhile isSpace r)
  95          (s2, r2) <- readDec (dropWhile isSpace r1)
  96          return (StdGen s1 s2, r2)
  97
  98 {-
  99  If we cannot unravel the StdGen from a string, create
 100  one based on the string given.
 101 -}
 102 stdFromString         :: String -> (StdGen, String)
 103 stdFromString s        = (mkStdGen num, rest)
 104         where (cs, rest) = splitAt 6 s
 105               num        = foldl (\a x -> x + 3 * a) 1 (map ord cs)
 106
 107
 108 mkStdGen :: Int -> StdGen -- why not Integer ?
 109 mkStdGen s
 110  | s < 0     = mkStdGen (-s)
 111  | otherwise = StdGen (s1+1) (s2+1)
 112       where
 113         (q, s1) = s `divMod` 2147483562
 114         s2      = q `mod` 2147483398
 115
 116 createStdGen :: Integer -> StdGen
 117 createStdGen s
 118  | s < 0     = createStdGen (-s)
 119  | otherwise = StdGen (fromInteger (s1+1)) (fromInteger (s2+1))
 120       where
 121         (q, s1) = s `divMod` 2147483562
 122         s2      = q `mod` 2147483398
 123
 124
 125 -- The class definition - see library report for details.
 126
 127 class Random a where
 128   -- Minimal complete definition: random and randomR
 129   random  :: RandomGen g => g -> (a, g)
 130   randomR :: RandomGen g => (a,a) -> g -> (a,g)
 131
 132   randoms  :: RandomGen g => g -> [a]
 133   randoms  g      = x : randoms g' where (x,g') = random g
 134
 135   randomRs :: RandomGen g => (a,a) -> g -> [a]
 136   randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g
 137
 138   randomIO  :: IO a
 139   randomIO         = getStdRandom random
 140
 141   randomRIO :: (a,a) -> IO a
 142   randomRIO range  = getStdRandom (randomR range)
 143
 144
 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
 181 #ifdef __GLASGOW_HASKELL__
 182 mkStdRNG :: Integer -> IO StdGen
 183 mkStdRNG o = do
 184     ct          <- getCPUTime
 185     (TOD sec _) <- getClockTime
 186     return (createStdGen (sec * 12345 + ct + o))
 187 #endif
 188
 189 #ifdef __HUGS__
 190 mkStdRNG :: Integer -> IO StdGen
 191 mkStdRNG o = do
 192     ct          <- getCPUTime
 193     return (createStdGen (ct + o))
 194 #endif
 195
 196 randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
 197 randomIvalInteger (l,h) rng
 198  | l > h     = randomIvalInteger (h,l) rng
 199  | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
 200      where
 201        k = h - l + 1
 202        b = 2147483561
 203        n = iLogBase b k
 204
 205        f 0 acc g = (acc, g)
 206        f n acc g =
 207           let
 208            (x,g')   = next g
 209           in
 210           f (n-1) (fromIntegral x + acc * b) g'
 211
 212 randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)
 213 randomIvalDouble (l,h) fromDouble rng
 214   | l > h     = randomIvalDouble (h,l) fromDouble rng
 215   | otherwise =
 216        case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of
 217          (x, rng') ->
 218             let
 219              scaled_x =
 220                 fromDouble ((l+h)/2) +
 221                 fromDouble ((h-l) / realToFrac intRange) *
 222                 fromIntegral (x::Int)
 223             in
 224             (scaled_x, rng')
 225
 226 intRange :: Integer
 227 intRange  = toInteger (maxBound::Int) - toInteger (minBound::Int)
 228
 229 iLogBase :: Integer -> Integer -> Integer
 230 iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)
 231
 232 stdNext :: StdGen -> (Int, StdGen)
 233 stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')
 234         where   z'   = if z < 1 then z + 2147483562 else z
 235                 z    = s1'' - s2''
 236
 237                 k    = s1 `quot` 53668
 238                 s1'  = 40014 * (s1 - k * 53668) - k * 12211
 239                 s1'' = if s1' < 0 then s1' + 2147483563 else s1'
 240
 241                 k'   = s2 `quot` 52774
 242                 s2'  = 40692 * (s2 - k' * 52774) - k' * 3791
 243                 s2'' = if s2' < 0 then s2' + 2147483399 else s2'
 244
 245 stdSplit            :: StdGen -> (StdGen, StdGen)
 246 stdSplit std@(StdGen s1 s2)
 247                      = (left, right)
 248                        where
 249                         -- no statistical foundation for this!
 250                         left    = StdGen new_s1 t2
 251                         right   = StdGen t1 new_s2
 252
 253                         new_s1 | s1 == 2147483562 = 1
 254                                | otherwise        = s1 + 1
 255
 256                         new_s2 | s2 == 1          = 2147483398
 257                                | otherwise        = s2 - 1
 258
 259                         StdGen t1 t2 = snd (next std)
 260
 261
 262 setStdGen :: StdGen -> IO ()
 263 setStdGen sgen = writeIORef theStdGen sgen
 264
 265 getStdGen :: IO StdGen
 266 getStdGen  = readIORef theStdGen
 267
 268 theStdGen :: IORef StdGen
 269 theStdGen  = unsafePerformIO (newIORef (createStdGen 0))
 270
 271 newStdGen :: IO StdGen
 272 newStdGen = do
 273   rng <- getStdGen
 274   let (a,b) = split rng
 275   setStdGen a
 276   return b
 277
 278 getStdRandom :: (StdGen -> (a,StdGen)) -> IO a
 279 getStdRandom f = do
 280    rng          <- getStdGen
 281    let (v, new_rng) = f rng
 282    setStdGen new_rng
 283    return v