X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FRandom.lhs;h=25b4752d63455d5dda2300bc13e934b024f8c7d3;hb=f608faec774d5d2cd895240c1e0e66a48aa6cbe3;hp=faae80ae2e9e6905fa1bdaadbe8eef0d670f6951;hpb=28139aea50376444d56f43f0914291348a51a7e7;p=ghc-hetmet.git diff --git a/ghc/lib/std/Random.lhs b/ghc/lib/std/Random.lhs index faae80a..25b4752 100644 --- a/ghc/lib/std/Random.lhs +++ b/ghc/lib/std/Random.lhs @@ -1,5 +1,7 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1995-99 +% -This module implements a (good) random number generator. The June 1988 (v31 #6) issue of the Communications of the ACM has an article by Pierre L'Ecuyer called, "Efficient and Portable Combined @@ -8,51 +10,227 @@ 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.. + \begin{code} module Random ( - random, - randomIO - ) where + RandomGen(next, split) + , StdGen + , mkStdGen + , Random ( random, randomR, + randoms, randomRs, + randomIO, randomRIO ) + , getStdRandom + , getStdGen + , setStdGen + , newStdGen + ) where +#ifndef __HUGS__ import CPUTime (getCPUTime) +import PrelST +import PrelRead +import PrelShow +import PrelNum -- So we get fromInt, toInt +import PrelIOBase +import PrelNumExtra ( float2Double, double2Float ) +import PrelBase +import PrelArr import Time (getClockTime, ClockTime(..)) +#else +#endif +import Char ( isSpace, chr, ord ) +\end{code} + +\begin{code} +class RandomGen g where + next :: g -> (Int, g) + split :: g -> (g, g) + +\end{code} + +\begin{code} +data StdGen + = StdGen Int Int + +instance RandomGen StdGen where + next = stdNext + split = stdSplit + +#ifdef __HUGS__ +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) +\end{code} + +\begin{code} +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 + +\end{code} + +The class definition - see library report for details. + +\begin{code} +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 : randoms g' where (x,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) +\end{code} + +\begin{code} +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 -randomIO :: (Integer, Integer) -> IO [Integer] -randomIO lh = do +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? + +#ifdef __HUGS__ +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 + +\end{code} + + +\begin{code} +#ifdef __HUGS__ +mkStdRNG :: Integer -> IO StdGen +mkStdRNG o = return (createStdGen o) +#else +mkStdRNG :: Integer -> IO StdGen +mkStdRNG o = do ct <- getCPUTime (TOD sec _) <- getClockTime - return (random lh (sec * 12345 + ct)) - -random :: (Integer, Integer) -> Integer -> [Integer] -random (l, h) s = - if l > h then error "Random.random: Empty interval" else - if s < 0 then random (l, h) (-s) else - let (q, s1) = s `divMod` 2147483562 - s2 = q `mod` 2147483398 - k = h-l + 1 - b = 2147483561 - n = iLogBase b k - f is = let (xs, is') = splitAt n is - in foldr (\ i r -> fromInt i + r * b) 0 xs `mod` k + l : f is' - in f (randomInts (toInt (s1+1)) (toInt (s2+1))) + 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) --- Use seeds s1 in 1..2147483562 and s2 in 1..2147483398 to generate --- an infinite list of random Ints. -randomInts :: Int -> Int -> [Int] -randomInts s1 s2 = - if 1 <= s1 && s1 <= 2147483562 then - if 1 <= s2 && s2 <= 2147483398 then - rands s1 s2 - else - error "randomInts: Bad second seed." - else - error "randomInts: Bad first seed." - -rands :: Int -> Int -> [Int] -rands s1 s2 = z' : rands s1'' s2'' +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'' @@ -63,5 +241,64 @@ rands s1 s2 = z' : rands s1'' s2'' k' = s2 `quot` 52774 s2' = 40692 * (s2 - k' * 52774) - k' * 3791 s2'' = if s2' < 0 then s2' + 2147483399 else s2' - + +#ifdef __HUGS__ +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 +\end{code} + + +\begin{code} +#ifdef __HUGS__ +-- TODO: Hugs/setStdGen +setStdGen :: StdGen -> IO () +setStdGen sgen = error "not currently implemented in Stg Hugs" + +-- TODO: Hugs/getStdGen +getStdGen :: IO StdGen +getStdGen = error "not currently implemented in Stg Hugs" +#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 \end{code}