#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Trustworthy #-}
#endif




































#include "MachDeps.h"

module System.Random
        (

        

        

#ifdef ENABLE_SPLITTABLEGEN
          RandomGen(next, genRange)
        , SplittableGen(split)
#else
          RandomGen(next, genRange, split)
#endif
        
        , StdGen
        , mkStdGen

        

        

        , getStdRandom
        , getStdGen
        , setStdGen
        , newStdGen

        
        , Random ( random,   randomR,
                   randoms,  randomRs,
                   randomIO, randomRIO )

        
        

        ) where

import Prelude

import Data.Bits
import Data.Int
import Data.Word
import Foreign.C.Types

#ifdef __NHC__
import CPUTime          ( getCPUTime )
import Foreign.Ptr      ( Ptr, nullPtr )
import Foreign.C        ( CTime, CUInt )
#else
import System.CPUTime   ( getCPUTime )
import Data.Time        ( getCurrentTime, UTCTime(..) )
import Data.Ratio       ( numerator, denominator )
#endif
import Data.Char        ( isSpace, chr, ord )
import System.IO.Unsafe ( unsafePerformIO )
import Data.IORef       ( IORef, newIORef, readIORef, writeIORef )
#if MIN_VERSION_base (4,6,0)
import Data.IORef       ( atomicModifyIORef' )
#else
import Data.IORef       ( atomicModifyIORef )
#endif
import Numeric          ( readDec )

#ifdef __GLASGOW_HASKELL__
import GHC.Exts         ( build )
#else

{-# INLINE build #-}
build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a]
build g = g (:) []
#endif

#if !MIN_VERSION_base (4,6,0)
atomicModifyIORef' :: IORef a -> (a -> (a,b)) -> IO b
atomicModifyIORef' ref f = do
    b <- atomicModifyIORef ref
            (\x -> let (a, b) = f x
                    in (a, a `seq` b))
    b `seq` return b
#endif




#ifdef __NHC__
foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime
getTime :: IO (Integer, Integer)
getTime = do CTime t <- readtime nullPtr;  return (toInteger t, 0)
#else
getTime :: IO (Integer, Integer)
getTime = do
  utc <- getCurrentTime
  let daytime = toRational $ utctDayTime utc
  return $ quotRem (numerator daytime) (denominator daytime)
#endif




#ifdef ENABLE_SPLITTABLEGEN

#else

#endif

class RandomGen g where

   
   
   
   next     :: g -> (Int, g)

   
   
   
   
   
   
   
   
   
   
   
   
   
   
   
   
   
   genRange :: g -> (Int,Int)

   
   genRange _ = (minBound, maxBound)

#ifdef ENABLE_SPLITTABLEGEN


class SplittableGen g where
#endif
   
   
   
   
   
   
   split    :: g -> (g, g)



data StdGen
 = StdGen !Int32 !Int32

instance RandomGen StdGen where
  next  = stdNext
  genRange _ = stdRange

#ifdef ENABLE_SPLITTABLEGEN
instance SplittableGen StdGen where
#endif
  split = stdSplit

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 sMaybeNegative = StdGen (s1+1) (s2+1)
      where
        
        
        s       = sMaybeNegative .&. maxBound
        (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)

  
  
  {-# INLINE randomRs #-}
  randomRs :: RandomGen g => (a,a) -> g -> [a]
  randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g)

  
  
  {-# INLINE randoms #-}
  randoms  :: RandomGen g => g -> [a]
  randoms  g      = build (\cons _nil -> buildRandoms cons random g)

  
  
  randomRIO :: (a,a) -> IO a
  randomRIO range  = getStdRandom (randomR range)

  
  
  randomIO  :: IO a
  randomIO         = getStdRandom random


{-# INLINE buildRandoms #-}
buildRandoms :: RandomGen g
             => (a -> as -> as)  
             -> (g -> (a,g))     
             -> g                
             -> as
buildRandoms cons rand = go
  where
    
    go g = x `seq` (x `cons` go g') where (x,g') = rand g


instance Random Integer where
  randomR ival g = randomIvalInteger ival g
  random g       = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g

instance Random Int        where randomR = randomIvalIntegral; random = randomBounded
instance Random Int8       where randomR = randomIvalIntegral; random = randomBounded
instance Random Int16      where randomR = randomIvalIntegral; random = randomBounded
instance Random Int32      where randomR = randomIvalIntegral; random = randomBounded
instance Random Int64      where randomR = randomIvalIntegral; random = randomBounded

#ifndef __NHC__

instance Random Word       where randomR = randomIvalIntegral; random = randomBounded
#endif
instance Random Word8      where randomR = randomIvalIntegral; random = randomBounded
instance Random Word16     where randomR = randomIvalIntegral; random = randomBounded
instance Random Word32     where randomR = randomIvalIntegral; random = randomBounded
instance Random Word64     where randomR = randomIvalIntegral; random = randomBounded

instance Random CChar      where randomR = randomIvalIntegral; random = randomBounded
instance Random CSChar     where randomR = randomIvalIntegral; random = randomBounded
instance Random CUChar     where randomR = randomIvalIntegral; random = randomBounded
instance Random CShort     where randomR = randomIvalIntegral; random = randomBounded
instance Random CUShort    where randomR = randomIvalIntegral; random = randomBounded
instance Random CInt       where randomR = randomIvalIntegral; random = randomBounded
instance Random CUInt      where randomR = randomIvalIntegral; random = randomBounded
instance Random CLong      where randomR = randomIvalIntegral; random = randomBounded
instance Random CULong     where randomR = randomIvalIntegral; random = randomBounded
instance Random CPtrdiff   where randomR = randomIvalIntegral; random = randomBounded
instance Random CSize      where randomR = randomIvalIntegral; random = randomBounded
instance Random CWchar     where randomR = randomIvalIntegral; random = randomBounded
instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded
instance Random CLLong     where randomR = randomIvalIntegral; random = randomBounded
instance Random CULLong    where randomR = randomIvalIntegral; random = randomBounded
instance Random CIntPtr    where randomR = randomIvalIntegral; random = randomBounded
instance Random CUIntPtr   where randomR = randomIvalIntegral; random = randomBounded
instance Random CIntMax    where randomR = randomIvalIntegral; random = randomBounded
instance Random CUIntMax   where randomR = randomIvalIntegral; random = randomBounded

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

{-# INLINE randomRFloating #-}
randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomRFloating (l,h) g
    | l>h       = randomRFloating (h,l) g
    | otherwise = let (coef,g') = random g in
                  (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g')  

instance Random Double where
  randomR = randomRFloating
  random rng     =
    case random rng of
      (x,rng') ->
          
          ((fromIntegral (mask53 .&. (x::Int64)) :: Double)
           /  fromIntegral twoto53, rng')
   where
    twoto53 = (2::Int64) ^ (53::Int64)
    mask53 = twoto53 - 1

instance Random Float where
  randomR = randomRFloating
  random rng =
    
    case random rng of
      (x,rng') ->
          
          ((fromIntegral (mask24 .&. (x::Int32)) :: Float)
           /  fromIntegral twoto24, rng')
         
         

   where
     mask24 = twoto24 - 1
     twoto24 = (2::Int32) ^ (24::Int32)


instance Random CFloat where
  randomR = randomRFloating
  random rng = case random rng of
                 (x,rng') -> (realToFrac (x::Float), rng')

instance Random CDouble where
  randomR = randomRFloating
  
  
  
  random  = randomFrac
  
  

mkStdRNG :: Integer -> IO StdGen
mkStdRNG o = do
    ct          <- getCPUTime
    (sec, psec) <- getTime
    return (createStdGen (sec * 12345 + psec + ct + o))

randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g)
randomBounded = randomR (minBound, maxBound)


randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g)
randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h)

{-# SPECIALIZE randomIvalInteger :: (Num a) =>
    (Integer, Integer) -> StdGen -> (a, StdGen) #-}

randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g)
randomIvalInteger (l,h) rng
 | l > h     = randomIvalInteger (h,l) rng
 | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng')
     where
       (genlo, genhi) = genRange rng
       b = fromIntegral genhi - fromIntegral genlo + 1

       
       
       

       
       
       q = 1000
       k = h - l + 1
       magtgt = k * q

       
       f mag v g | mag >= magtgt = (v, g)
                 | otherwise = v' `seq`f (mag*b) v' g' where
                        (x,g') = next g
                        v' = (v * b + (fromIntegral x - fromIntegral genlo))



randomFrac :: (RandomGen g, Fractional a) => g -> (a, g)
randomFrac = randomIvalDouble (0::Double,1) realToFrac

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 (0.5*l + 0.5*h) +                   
                fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) *  
                fromIntegral (x::Int32)
            in
            (scaled_x, rng')

int32Count :: Integer
int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1  

stdRange :: (Int,Int)
stdRange = (1, 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)