module Control.Comonad.Random
( module Control.Comonad
, module System.Random
, Rand ()
, mkRand
, mkRandR
, next
, left
, right
, extracts
)
where
import Control.Applicative
import Control.Comonad
import Control.Comonad.Cofree
import Control.Functor.Pointed
import Data.Function
import System.Random hiding (next)
newtype Three a = Three (a, a, a)
fst3 :: Three a -> a
fst3 (Three (x, _, _)) = x
snd3 :: Three a -> a
snd3 (Three (_, y, _)) = y
thd3 :: Three a -> a
thd3 (Three (_, _, z)) = z
instance Functor Three where
fmap f (Three ~(x, y, z)) = Three (f x, f y, f z)
instance Applicative Three where
pure x = Three (x, x, x)
Three ~(f, g, h) <*> Three ~(x, y, z) = Three (f x, g y, h z)
newtype Rand a = Rand { unRand :: Cofree Three a }
deriving (Functor, Copointed, Comonad)
inRand :: (Cofree Three a -> Cofree Three b) -> (Rand a -> Rand b)
inRand = (Rand .) . (. unRand)
instance Applicative Rand where
pure x = let tree = cofree x $ Three (tree, tree, tree)
in Rand tree
Rand a <*> Rand b = let ~(f, fs) = runCofree a
~(x, xs) = runCofree b
in Rand . cofree (f x) . fmap unRand .
liftA2 (<*>) (fmap Rand fs) . fmap Rand $ xs
mkRandWith :: RandomGen g => (g -> (a, g)) -> g -> Rand a
mkRandWith f g = let ~(x, g') = f g
~(l, r) = split g
in Rand . cofree x . fmap (unRand . mkRandWith f) . Three $ (l, g', r)
mkRand :: (RandomGen g, Random a) => g -> Rand a
mkRand = mkRandWith random
mkRandR :: (RandomGen g, Random a) => (a, a) -> g -> Rand a
mkRandR = mkRandWith . randomR
inner :: (forall b . Three b -> b) -> (Rand a -> Rand a)
inner f = inRand $ f . snd . runCofree
next :: Rand a -> Rand a
next = inner snd3
left :: Rand a -> Rand a
left = inner fst3
right :: Rand a -> Rand a
right = inner thd3
extracts :: (Rand a -> Rand a) -> Rand a -> [a]
extracts f = liftA2 (:) extract (extracts f . f)