module Haste.Random (Random (..), Seed, next, mkSeed, newSeed) where
import Haste.JSType
import Data.Int
import Data.Word
import Data.List (unfoldr)
import Control.Monad.IO.Class
import System.IO.Unsafe
#ifdef __HASTE__
import Haste.Foreign
#else
import qualified System.Random as SR
#endif
#ifdef __HASTE__
newtype Seed = Seed Unpacked deriving (Pack, Unpack)
nxt :: Seed -> IO Seed
nxt = ffi "(function(s){return md51(s.join(','));})"
getN :: Seed -> IO Int
getN = ffi "(function(s){return s[0];})"
toSeed :: Int -> IO Seed
toSeed = ffi "(function(n){return md51(n.toString());})"
createSeed :: IO Seed
createSeed = ffi "(function(){return md51(jsRand().toString());})"
#else
newtype Seed = Seed (Int, SR.StdGen)
nxt :: Seed -> IO Seed
nxt (Seed (_, g)) = return . Seed $ SR.next g
getN :: Seed -> IO Int
getN (Seed (n, _)) = return n
toSeed :: Int -> IO Seed
toSeed = return . Seed . SR.next . SR.mkStdGen
createSeed :: IO Seed
createSeed = SR.newStdGen >>= return . Seed . SR.next
#endif
mkSeed :: Int -> Seed
mkSeed = unsafePerformIO . toSeed
newSeed :: MonadIO m => m Seed
newSeed = liftIO createSeed
next :: Seed -> Seed
next = unsafePerformIO . nxt
class Random a where
randomR :: (a, a) -> Seed -> (a, Seed)
randomRs :: (a, a) -> Seed -> [a]
randomRs bounds seed = unfoldr (Just . randomR bounds) seed
instance Random Int where
randomR (low, high) s
| low <= high =
let n = unsafePerformIO $ getN s
in (n `mod` (highlow+1) + low, next s)
| otherwise =
randomR (high, low) s
instance Random Int32 where
randomR (l,h) seed =
case randomR (convert l :: Int, convert h) seed of
(n, s) -> (convert n, s)
instance Random Word where
randomR (l,h) seed =
case randomR (convert l :: Int, convert h) seed of
(n, s) -> (convert n, s)
instance Random Word32 where
randomR (l,h) seed =
case randomR (convert l :: Int, convert h) seed of
(n, s) -> (convert n, s)
instance Random Double where
randomR (low, high) seed =
(f * (highlow) + low, s)
where
(n, s) = randomR (0, 2000000001 :: Int) seed
f = convert n / 2000000000