{-# LANGUAGE CPP #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif
module Random (
RandomGen(next, split, genRange)
, StdGen
, mkStdGen
, getStdRandom
, getStdGen
, setStdGen
, newStdGen
, Random ( random, randomR,
randoms, randomRs,
randomIO, randomRIO )
) where
import Prelude
import Data.Int
import System.CPUTime ( getCPUTime )
import Data.Time ( getCurrentTime, UTCTime(..) )
import Data.Ratio ( numerator, denominator )
import Data.Char ( isSpace, chr, ord )
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef
import Numeric ( readDec )
getTime :: IO (Integer, Integer)
getTime = do
utc <- getCurrentTime
let daytime = toRational $ utctDayTime utc
return $ quotRem (numerator daytime) (denominator daytime)
class RandomGen g where
next :: g -> (Int, g)
split :: g -> (g, g)
genRange :: g -> (Int,Int)
genRange _ = (minBound, maxBound)
data StdGen
= StdGen Int32 Int32
instance RandomGen StdGen where
next = stdNext
split = stdSplit
genRange _ = stdRange
instance Show StdGen where
showsPrec p (StdGen s1 s2) =
showsPrec p s1 .
showChar ' ' .
showsPrec p s2
instance Read StdGen where
readsPrec _p = \ r ->
case try_read r of
r'@[_] -> r'
_ -> [stdFromString r]
where
try_read r = do
(s1, r1) <- readDec (dropWhile isSpace r)
(s2, r2) <- readDec (dropWhile isSpace r1)
return (StdGen s1 s2, r2)
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
mkStdGen s = mkStdGen32 $ fromIntegral s
mkStdGen32 :: Int32 -> StdGen
mkStdGen32 s
| s < 0 = mkStdGen32 (-s)
| otherwise = StdGen (s1+1) (s2+1)
where
(q, s1) = s `divMod` 2147483562
s2 = q `mod` 2147483398
createStdGen :: Integer -> StdGen
createStdGen s = mkStdGen32 $ fromIntegral s
class Random a where
randomR :: RandomGen g => (a,a) -> g -> (a,g)
random :: RandomGen g => g -> (a, g)
randomRs :: RandomGen g => (a,a) -> g -> [a]
randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g
randoms :: RandomGen g => g -> [a]
randoms g = (\(x,g') -> x : randoms g') (random g)
randomRIO :: (a,a) -> IO a
randomRIO range = getStdRandom (randomR range)
randomIO :: IO a
randomIO = getStdRandom random
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 (bool2Int a, bool2Int b) g) of
(x, g') -> (int2Bool x, g')
where
bool2Int :: Bool -> Integer
bool2Int False = 0
bool2Int True = 1
int2Bool :: Int -> Bool
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
instance Random Float where
random g = randomIvalDouble (0::Double,1) realToFrac g
randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g
mkStdRNG :: Integer -> IO StdGen
mkStdRNG o = do
ct <- getCPUTime
(sec, psec) <- getTime
return (createStdGen (sec * 12345 + psec + ct + o))
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) (fromIntegral 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::Int32), toInteger (maxBound::Int32)) rng) of
(x, rng') ->
let
scaled_x =
fromDouble ((l+h)/2) +
fromDouble ((h-l) / realToFrac int32Count) *
fromIntegral (x::Int32)
in
(scaled_x, rng')
int32Count :: Integer
int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1
iLogBase :: Integer -> Integer -> Integer
iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b)
stdRange :: (Int,Int)
stdRange = (0, 2147483562)
stdNext :: StdGen -> (Int, StdGen)
stdNext (StdGen s1 s2) = (fromIntegral 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'
stdSplit :: StdGen -> (StdGen, StdGen)
stdSplit std@(StdGen s1 s2)
= (left, right)
where
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)
setStdGen :: StdGen -> IO ()
setStdGen sgen = writeIORef theStdGen sgen
getStdGen :: IO StdGen
getStdGen = readIORef theStdGen
theStdGen :: IORef StdGen
theStdGen = unsafePerformIO $ do
rng <- mkStdRNG 0
newIORef rng
newStdGen :: IO StdGen
newStdGen = atomicModifyIORef theStdGen split
getStdRandom :: (StdGen -> (a,StdGen)) -> IO a
getStdRandom f = atomicModifyIORef theStdGen (swap . f)
where swap (v,g) = (g,v)