module FRP.NetWire.Tools
(
constant,
identity,
time,
timeFrom,
accum,
delay,
discrete,
hold,
keep,
forbid,
forbid_,
inhibit,
inhibit_,
require,
require_,
exhibit,
freeze,
sample,
swallow,
(-->),
(>--),
(-=>),
(>=-),
mapA,
dup,
fmod,
swap
)
where
import Control.Applicative
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
Left _ -> return (mx, 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
Left _ -> return (mx, 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')
return (mx, either (const (f >=- w)) (const w) mx)
accum :: Monad m => a -> Wire m (a -> a) a
accum x = mkGen $ \_ f -> x `seq` return (Right x, accum (f x))
constant :: Monad m => b -> Wire m a b
constant = pure
delay :: Monad m => a -> Wire m a a
delay r = mkGen $ \_ x -> return (Right r, delay x)
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)
forbid :: Monad m => Wire m (Bool, a) a
forbid =
mkGen $ \_ (b, x) ->
return (if b then Left (inhibitEx "Forbidden condition met") else Right x,
forbid)
forbid_ :: Monad m => Wire m Bool ()
forbid_ =
mkGen $ \_ b ->
return (if b then Left (inhibitEx "Forbidden condition met") else Right (),
forbid_)
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)
hold :: forall a b m. Monad m => Wire m a b -> Wire m a b
hold w' =
mkGen $ \ws x' -> do
(mx, w) <- toGen w' ws x'
case mx of
Right x -> return (mx, hold' x w)
Left _ -> return (mx, hold w)
where
hold' :: b -> Wire m a b -> Wire m a b
hold' x0 w' =
mkGen $ \ws x' -> do
(mx, w) <- toGen w' ws x'
case mx of
Left _ -> return (Right x0, hold' x0 w)
Right x -> return (Right x, hold' x 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)
inhibit_ :: Monad m => Wire m a b
inhibit_ = zeroArrow
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)
require_ :: Monad m => Wire m Bool ()
require_ =
mkGen $ \_ b ->
return (if b then Right () 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
(mmx, w) <- toGen w' (ws { wsDTime = t }) x''
let mx = either (const mx') (const mmx) mmx
nextT = fmod t int
() `seq` return (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 $ \(wsDTime -> dt) _ ->
let t = t' + dt
in t `seq` return (Right t, timeFrom t)