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 FRP.NetWire.Wire
import Prelude hiding (id)
(-->) :: b -> Wire a b -> Wire a b
y --> w' =
WGen $ \ws x -> do
(mx, w) <- toGen w' ws x
case mx of
Nothing -> return (Nothing, y --> w)
Just _ -> return (Just y, w)
(>--) :: a -> Wire a b -> Wire a b
x' >-- w' =
WGen $ \ws _ -> do
(mx, w) <- toGen w' ws x'
return (mx, maybe (x' >-- w) (const w) mx)
(-=>) :: (b -> b) -> Wire a b -> Wire a b
f -=> w' =
WGen $ \ws x' -> do
(mx, w) <- toGen w' ws x'
case mx of
Nothing -> return (Nothing, f -=> w)
Just x -> return (Just (f x), w)
(>=-) :: (a -> a) -> Wire a b -> Wire a b
f >=- w' =
WGen $ \ws x' -> do
(mx, w) <- toGen w' ws (f x')
case mx of
Nothing -> return (Nothing, f >=- w)
Just x -> return (Just x, w)
constant :: b -> Wire a b
constant = WConst
constantAfter :: b -> b -> Wire a b
constantAfter x1 x0 =
mkGen $ \_ _ -> return (Just x0, constant x1)
discrete :: forall a. Wire (DTime, a) a
discrete =
mkGen $ \(wsDTime -> dt) (_, x0) ->
return (Just x0, discrete' dt x0)
where
discrete' :: Time -> a -> Wire (DTime, a) a
discrete' t' x' =
mkGen $ \(wsDTime -> dt) (int, x) ->
let t = t' + dt in
if t >= int
then return (Just x, discrete' (fmod t int) x)
else return (Just x', discrete' t x')
dup :: a -> (a, a)
dup x = (x, x)
exhibit :: Wire a b -> Wire a (Maybe b)
exhibit w' =
WGen $ \ws x' -> do
(mx, w) <- toGen w' ws x'
return (Just mx, exhibit w)
fmod :: Double -> Double -> Double
fmod _ 0 = 0
fmod n d = n d * realToFrac (floor $ n/d)
freeze :: Wire a b -> Wire a b
freeze w =
WGen $ \ws x' -> do
(mx, _) <- toGen w ws x'
return (mx, w)
identity :: Wire a a
identity = id
inhibit :: Wire a b
inhibit = zeroArrow
initially :: a -> Wire a a
initially x0 =
mkGen $ \_ _ -> return (Just x0, identity)
keep :: Wire a a
keep = mkGen $ \_ x -> return (Just 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 :: Wire (Bool, a) a
require =
mkGen $ \_ (b, x) ->
return (if b then Just x else Nothing, require)
sample :: Wire a b -> Wire (DTime, 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 -> Maybe b -> Wire a b -> Wire (DTime, 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
case mx of
Nothing -> nextT `seq` return (mx', sample' nextT mx' w)
Just _ -> nextT `seq` return (mx, sample' nextT mx w)
else
return (mx', sample' t mx' w')
swallow :: Wire a b -> Wire a b
swallow w' =
WGen $ \ws x' -> do
(mx, w) <- toGen w' ws x'
case mx of
Nothing -> return (Nothing, swallow w)
Just x -> do
return (Just x, constant x)
swap :: (a, b) -> (b, a)
swap (x, y) = (y, x)
time :: Wire a Time
time = timeFrom 0
timeFrom :: Time -> Wire a Time
timeFrom t' =
mkGen $ \ws _ ->
let t = t' + wsDTime ws
in t `seq` return (Just t, timeFrom t)