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