{-# OPTIONS_NHC98 -cpp #-}
{-
The June 1988 (v31 #6) issue of the Communications of the ACM has an
article by Pierre L'Ecuyer called, "Efficient and Portable Combined
Random Number Generators". Here is the Portable Combined Generator of
L'Ecuyer for 32-bit computers. It has a period of roughly 2.30584e18.
Transliterator: Lennart Augustsson
sof 1/99 - code brought (kicking and screaming) into the new Random
world..
malcolm 2/00 - patched for nhc98
-}
module Random
(
RandomGen(next, split, genRange)
, StdGen
, mkStdGen
, Random ( random, randomR,
randoms, randomRs,
randomIO, randomRIO )
, getStdRandom
, getStdGen
, setStdGen
, newStdGen
) where
import Char ( isSpace, chr, ord )
#ifdef __GLASGOW_HASKELL__
import PrelGHC ( RealWorld )
import PrelNum ( fromInt )
import PrelShow ( showSignedInt, showSpace )
import PrelRead ( readDec )
import PrelIOBase ( unsafePerformIO, stToIO )
import PrelArr ( MutableVar, newVar, readVar, writeVar )
import PrelReal ( toInt )
import CPUTime ( getCPUTime )
import PrelFloat ( float2Double, double2Float )
import Time ( getClockTime, ClockTime(..) )
#endif
#ifdef __NHC__
import NHC.IOExtras ( unsafePerformIO, IORef, newIORef, readIORef,
writeIORef)
import Numeric ( readDec )
fromInt :: Num a => Int -> a
fromInt = fromInteger . toInteger
toInt :: Integral a => a -> Int
toInt = fromIntegral
#endif
class RandomGen g where
next :: g -> (Int, g)
split :: g -> (g, g)
genRange :: g -> (Int,Int)
genRange g = (minBound,maxBound)
data StdGen
= StdGen Int Int
instance RandomGen StdGen where
next = stdNext
split = stdSplit
genRange g = (minBound,maxBound)
-- without this Hat+nhc98 do not work
#if defined(__HUGS__) || defined(__NHC__)
instance Show StdGen where
showsPrec p (StdGen s1 s2) =
showsPrec p s1 .
showChar ' ' .
showsPrec p s2
#else
instance Show StdGen where
showsPrec p (StdGen s1 s2) =
showSignedInt p s1 .
showSpace .
showSignedInt p s2
#endif
instance Read StdGen where
readsPrec _p = \ r ->
case try_read r of
r@[_] -> r
_ -> [stdFromString r] -- because it shouldn't ever fail.
where
try_read r = do
(s1, r1) <- readDec (dropWhile isSpace r)
(s2, r2) <- readDec (dropWhile isSpace r1)
return (StdGen s1 s2, r2)
{-
If we cannot unravel the StdGen from a string, create
one based on the string given.
-}
stdFromString :: String -> (StdGen, String)
stdFromString s = (mkStdGen num, rest)
where (cs, rest) = splitAt 6 s
num = foldl (\a x -> x + 3 * a) 1 (map ord cs)
mkStdGen :: Int -> StdGen -- why not Integer ?
mkStdGen s
| s < 0 = mkStdGen (-s)
| otherwise = StdGen (s1+1) (s2+1)
where
(q, s1) = s `divMod` 2147483562
s2 = q `mod` 2147483398
createStdGen :: Integer -> StdGen
createStdGen s
| s < 0 = createStdGen (-s)
| otherwise = StdGen (toInt (s1+1)) (toInt (s2+1))
where
(q, s1) = s `divMod` 2147483562
s2 = q `mod` 2147483398
class Random a where
-- Minimal complete definition: random and randomR
random :: RandomGen g => g -> (a, g)
randomR :: RandomGen g => (a,a) -> g -> (a,g)
randoms :: RandomGen g => g -> [a]
randoms g = (\(x,g') -> x : randoms g') (random g)
randomRs :: RandomGen g => (a,a) -> g -> [a]
randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g
randomIO :: IO a
randomIO = getStdRandom random
randomRIO :: (a,a) -> IO a
randomRIO range = getStdRandom (randomR range)
instance Random Int where
randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g
random g = randomR (minBound,maxBound) g
instance Random Char where
randomR (a,b) g =
case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of
(x,g) -> (chr x, g)
random g = randomR (minBound,maxBound) g
instance Random Bool where
randomR (a,b) g =
case (randomIvalInteger (toInteger (bool2Int a), toInteger (bool2Int b)) g) of
(x, g) -> (int2Bool x, g)
where
bool2Int False = 0
bool2Int True = 1
int2Bool 0 = False
int2Bool _ = True
random g = randomR (minBound,maxBound) g
instance Random Integer where
randomR ival g = randomIvalInteger ival g
random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g
instance Random Double where
randomR ival g = randomIvalDouble ival id g
random g = randomR (0::Double,1) g
-- hah, so you thought you were saving cycles by using Float?
#if defined(__HUGS__) || defined(__NHC__)
instance Random Float where
random g = randomIvalDouble (0::Double,1) realToFrac g
randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g
#else
instance Random Float where
randomR (a,b) g = randomIvalDouble (float2Double a, float2Double b) double2Float g
random g = randomIvalDouble (0::Double,1) double2Float g
#endif
#if defined(__HUGS__) || defined(__NHC__)
mkStdRNG :: Integer -> IO StdGen
mkStdRNG o = return (createStdGen o)
#else
mkStdRNG :: Integer -> IO StdGen
mkStdRNG o = do
ct <- getCPUTime
(TOD sec _) <- getClockTime
return (createStdGen (sec * 12345 + ct + o))
#endif
randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
randomIvalInteger (l,h) rng
| l > h = randomIvalInteger (h,l) rng
| otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
where
k = h - l + 1
b = 2147483561
n = iLogBase b k
f 0 acc g = (acc, g)
f n acc g =
let
(x,g') = next g
in
f (n-1) (fromInt x + acc * b) g'
randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g)
randomIvalDouble (l,h) fromDouble rng
| l > h = randomIvalDouble (h,l) fromDouble rng
| otherwise =
case (randomIvalInteger (toInteger (minBound::Int), toInteger (maxBound::Int)) rng) of
(x, rng') ->
let
scaled_x =
fromDouble ((l+h)/2) +
fromDouble ((h-l) / realToFrac intRange) *
fromIntegral (x::Int)
in
(scaled_x, rng')
intRange :: Integer
intRange = toInteger (maxBound::Int) - toInteger (minBound::Int)
iLogBase :: Integer -> Integer -> Integer
iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)
stdNext :: StdGen -> (Int, StdGen)
stdNext (StdGen s1 s2) = (z', StdGen s1'' s2'')
where z' = if z < 1 then z + 2147483562 else z
z = s1'' - s2''
k = s1 `quot` 53668
s1' = 40014 * (s1 - k * 53668) - k * 12211
s1'' = if s1' < 0 then s1' + 2147483563 else s1'
k' = s2 `quot` 52774
s2' = 40692 * (s2 - k' * 52774) - k' * 3791
s2'' = if s2' < 0 then s2' + 2147483399 else s2'
#if defined(__HUGS__) || defined(__NHC__)
stdSplit :: StdGen -> (StdGen, StdGen)
stdSplit std@(StdGen s1 s2)
= (left, right)
where
-- no statistical foundation for this!
left = StdGen new_s1 t2
right = StdGen t1 new_s2
new_s1 | s1 == 2147483562 = 1
| otherwise = s1 + 1
new_s2 | s2 == 1 = 2147483398
| otherwise = s2 - 1
StdGen t1 t2 = snd (next std)
#else
stdSplit :: StdGen -> (StdGen, StdGen)
stdSplit std@(StdGen s1 _) = (std, unsafePerformIO (mkStdRNG (fromInt s1)))
#endif
#if defined(__HUGS__) || defined(__NHC__)
setStdGen :: StdGen -> IO ()
setStdGen sgen = writeIORef theStdGen sgen
getStdGen :: IO StdGen
getStdGen = readIORef theStdGen
theStdGen :: IORef StdGen
#ifdef __HUGS__
theStdGen = primRunST (newIORef (createStdGen 0))
#else
theStdGen = unsafePerformIO (newIORef (createStdGen 0))
#endif
#else
global_rng :: MutableVar RealWorld StdGen
global_rng = unsafePerformIO $ do
rng <- mkStdRNG 0
stToIO (newVar rng)
setStdGen :: StdGen -> IO ()
setStdGen sgen = stToIO (writeVar global_rng sgen)
getStdGen :: IO StdGen
getStdGen = stToIO (readVar global_rng)
#endif
newStdGen :: IO StdGen
newStdGen = do
rng <- getStdGen
let (a,b) = split rng
setStdGen a
return b
getStdRandom :: (StdGen -> (a,StdGen)) -> IO a
getStdRandom f = do
rng <- getStdGen
let (v, new_rng) = f rng
setStdGen new_rng
return v
|
