module FRP.NetWire.Tools
(
constant,
identity,
time,
timeFrom,
discrete,
keep,
inhibit,
require,
exhibit,
freeze,
sample,
swallow,
(-->),
(>--),
(-=>),
(>=-),
constantAfter,
initially,
mapA,
dup,
fmod,
swap
)
where
import Control.Arrow
import Control.Category hiding ((.))
import Control.Exception
import FRP.NetWire.Wire
import Prelude hiding (id)
(-->) :: Monad m => b -> Wire m a b -> Wire m a b
y --> w' =
WGen $ \ws x -> do
(mx, w) <- toGen w' ws x
case mx of
e@(Left _) -> return (e, y --> w)
Right _ -> return (Right y, w)
(>--) :: Monad m => a -> Wire m a b -> Wire m a b
x' >-- w' =
WGen $ \ws _ -> do
(mx, w) <- toGen w' ws x'
return (mx, either (const $ x' >-- w) (const w) mx)
(-=>) :: Monad m => (b -> b) -> Wire m a b -> Wire m a b
f -=> w' =
WGen $ \ws x' -> do
(mx, w) <- toGen w' ws x'
case mx of
e@(Left _) -> return (e, f -=> w)
Right x -> return (Right (f x), w)
(>=-) :: Monad m => (a -> a) -> Wire m a b -> Wire m a b
f >=- w' =
WGen $ \ws x' -> do
(mx, w) <- toGen w' ws (f x')
case mx of
e@(Left _) -> return (e, f >=- w)
Right _ -> return (mx, w)
constant :: b -> Wire m a b
constant = WConst
constantAfter :: Monad m => b -> b -> Wire m a b
constantAfter x1 x0 =
mkGen $ \_ _ -> return (Right x0, constant x1)
discrete :: forall a m. Monad m => Wire m (Time, a) a
discrete =
mkGen $ \(wsDTime -> dt) (_, x0) ->
return (Right x0, discrete' dt x0)
where
discrete' :: Time -> a -> Wire m (Time, a) a
discrete' t' x' =
mkGen $ \(wsDTime -> dt) (int, x) ->
let t = t' + dt in
if t >= int
then return (Right x, discrete' (fmod t int) x)
else return (Right x', discrete' t x')
dup :: a -> (a, a)
dup x = (x, x)
exhibit :: Monad m => Wire m a b -> Wire m a (Output b)
exhibit w' =
WGen $ \ws x' -> do
(mx, w) <- toGen w' ws x'
return (Right mx, exhibit w)
fmod :: Double -> Double -> Double
fmod _ 0 = 0
fmod n d = n d * realToFrac (floor $ n/d)
freeze :: Monad m => Wire m a b -> Wire m a b
freeze w =
WGen $ \ws x' -> do
(mx, _) <- toGen w ws x'
return (mx, w)
identity :: Monad m => Wire m a a
identity = id
inhibit :: (Exception e, Monad m) => Wire m e b
inhibit =
WGen $ \_ ex -> return (Left (toException ex), inhibit)
initially :: Monad m => a -> Wire m a a
initially x0 =
mkGen $ \_ _ -> return (Right x0, identity)
keep :: Monad m => Wire m a a
keep = mkGen $ \_ x -> return (Right x, constant x)
mapA :: ArrowChoice a => a b c -> a [b] [c]
mapA a =
proc x ->
case x of
[] -> returnA -< []
(x0:xs) -> arr (uncurry (:)) <<< a *** mapA a -< (x0, xs)
require :: Monad m => Wire m (Bool, a) a
require =
mkGen $ \_ (b, x) ->
return (if b then Right x else Left (inhibitEx "Required condition not met"),
require)
sample :: forall a b m. Monad m => Wire m a b -> Wire m (Time, a) b
sample w' =
WGen $ \ws@(wsDTime -> dt) (_, x') -> do
(mx, w) <- toGen w' ws x'
return (mx, sample' dt mx w)
where
sample' :: Time -> Output b -> Wire m a b -> Wire m (Time, a) b
sample' t' mx' w' =
WGen $ \ws@(wsDTime -> dt) (int, x'') ->
let t = t' + dt in
if t >= int || int <= 0
then do
(mx, w) <- toGen w' ws x''
let nextT = fmod t int
nextT `seq` return (either (const mx') (const mx) mx, sample' nextT mx' w)
else
return (mx', sample' t mx' w')
swallow :: Monad m => Wire m a b -> Wire m a b
swallow w' =
WGen $ \ws x' -> do
(mx, w) <- toGen w' ws x'
return (mx, either (const (swallow w)) constant mx)
swap :: (a, b) -> (b, a)
swap (x, y) = (y, x)
time :: Monad m => Wire m a Time
time = timeFrom 0
timeFrom :: Monad m => Time -> Wire m a Time
timeFrom t' =
mkGen $ \ws _ ->
let t = t' + wsDTime ws
in t `seq` return (Right t, timeFrom t)