+%
+% (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
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 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
+
+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
+
+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
-import CPUTime (getCPUTime)
-import Time (getClockTime, ClockTime(..))
+ int2Bool 0 = False
+ int2Bool _ = True
-randomIO :: (Integer, Integer) -> IO [Integer]
-randomIO lh = do
+ 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''
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__
+
+setStdGen :: StdGen -> IO ()
+setStdGen sgen = writeIORef theStdGen sgen
+
+getStdGen :: IO StdGen
+getStdGen = readIORef theStdGen
+
+theStdGen :: IORef StdGen
+theStdGen = primRunST (newIORef (createStdGen 0))
+
+#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}
projects / ghc-hetmet.git / blobdiff