-- |
-- Module      :  FRP.Yampa
-- Copyright   :  (c) Antony Courtney and Henrik Nilsson, Yale University, 2003
-- License     :  BSD-style (see the LICENSE file in the distribution)
--
-- Maintainer  :  ivan.perez@keera.co.uk
-- Stability   :  provisional
-- Portability :  non-portable (GHC extensions)
--
-- Apply SFs only under certain conditions.
module FRP.Yampa.Conditional (
    provided  -- :: (a -> Bool) -> SF a b -> SF a b -> SF a b
  , pause     -- :: b -> SF a b -> SF a Bool -> SF a b

  ) where

import Control.Arrow
import FRP.Yampa.Basic
import FRP.Yampa.InternalCore (SF(..), SF'(..), sfTF', Transition)
import FRP.Yampa.EventS
import FRP.Yampa.Switches

-- * Guards and automata-oriented combinators

-- | Runs a signal function only when a given predicate is satisfied, otherwise
-- runs the other signal function.
--
-- This is similar to 'ArrowChoice', except that this resets the SFs after each
-- transition.
--
-- For example, the following integrates the incoming input numbers, using one
-- integral if the numbers are even, and another if the input numbers are odd.
-- Note how, every time we "switch", the old value of the integral is
-- discarded.
--
-- >>> embed (provided (even . round) integral integral) (deltaEncode 1 [1, 1, 1, 2, 2, 2, 1, 1, 1, 2, 2, 2 :: Double])
-- [0.0,1.0,2.0,0.0,2.0,4.0,0.0,1.0,2.0,0.0,2.0,4.0]

provided :: (a -> Bool) -> SF a b -> SF a b -> SF a b
provided :: (a -> Bool) -> SF a b -> SF a b -> SF a b
provided a -> Bool
p SF a b
sft SF a b
sff =
    SF a (b, Event a) -> (a -> SF a b) -> SF a b
forall a b c. SF a (b, Event c) -> (c -> SF a b) -> SF a b
switch (b -> SF a b
forall b a. b -> SF a b
constant b
forall a. HasCallStack => a
undefined SF a b -> SF a (Event a) -> SF a (b, Event a)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& SF a (Event a)
forall a. SF a (Event a)
snap) ((a -> SF a b) -> SF a b) -> (a -> SF a b) -> SF a b
forall a b. (a -> b) -> a -> b
$ \a
a0 ->
      if a -> Bool
p a
a0 then SF a b
stt else SF a b
stf
    where
      stt :: SF a b
stt = SF a (b, Event ()) -> (() -> SF a b) -> SF a b
forall a b c. SF a (b, Event c) -> (c -> SF a b) -> SF a b
switch (SF a b
sft SF a b -> SF a (Event ()) -> SF a (b, Event ())
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p (a -> Bool) -> SF Bool (Event ()) -> SF a (Event ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>> SF Bool (Event ())
edge)) (SF a b -> () -> SF a b
forall a b. a -> b -> a
const SF a b
stf)
      stf :: SF a b
stf = SF a (b, Event ()) -> (() -> SF a b) -> SF a b
forall a b c. SF a (b, Event c) -> (c -> SF a b) -> SF a b
switch (SF a b
sff SF a b -> SF a (Event ()) -> SF a (b, Event ())
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (a -> Bool
p (a -> Bool) -> SF Bool (Event ()) -> SF a (Event ())
forall (a :: * -> * -> *) b c d.
Arrow a =>
(b -> c) -> a c d -> a b d
^>> SF Bool (Event ())
edge)) (SF a b -> () -> SF a b
forall a b. a -> b -> a
const SF a b
stt)

-- * Variable pause

-- | Given a value in an accumulator (b), a predicate signal function (sfC),
--   and a second signal function (sf), pause will produce the accumulator b
--   if sfC input is True, and will transform the signal using sf otherwise.
--   It acts as a pause with an accumulator for the moments when the
--   transformation is paused.
pause :: b -> SF a Bool -> SF a b -> SF a b
pause :: b -> SF a Bool -> SF a b -> SF a b
pause b
b_init (SF { sfTF :: forall a b. SF a b -> a -> Transition a b
sfTF = a -> Transition a Bool
tfP}) (SF {sfTF :: forall a b. SF a b -> a -> Transition a b
sfTF = a -> Transition a b
tf10}) = SF :: forall a b. (a -> Transition a b) -> SF a b
SF {sfTF :: a -> Transition a b
sfTF = a -> Transition a b
tf0}
 where
       -- Initial transformation (no time delta):
       -- If the condition is True, return the accumulator b_init)
       -- Otherwise transform the input normally and recurse.
       tf0 :: a -> Transition a b
tf0 a
a0 = case a -> Transition a Bool
tfP a
a0 of
                 (SF' a Bool
c, Bool
True)  -> (b -> (a -> Transition a b) -> SF' a Bool -> SF' a b
forall b a. b -> (a -> Transition a b) -> SF' a Bool -> SF' a b
pauseInit b
b_init a -> Transition a b
tf10 SF' a Bool
c, b
b_init)
                 (SF' a Bool
c, Bool
False) -> let (SF' a b
k, b
b0) = a -> Transition a b
tf10 a
a0
                               in (b -> SF' a b -> SF' a Bool -> SF' a b
forall b a. b -> SF' a b -> SF' a Bool -> SF' a b
pause' b
b0 SF' a b
k SF' a Bool
c, b
b0)

       -- Similar deal, but with a time delta
       pauseInit :: b -> (a -> Transition a b) -> SF' a Bool -> SF' a b
       pauseInit :: b -> (a -> Transition a b) -> SF' a Bool -> SF' a b
pauseInit b
b_init' a -> Transition a b
tf10' SF' a Bool
c = (DTime -> a -> Transition a b) -> SF' a b
forall a b. (DTime -> a -> Transition a b) -> SF' a b
SF' DTime -> a -> Transition a b
tf0'
         where tf0' :: DTime -> a -> Transition a b
tf0' DTime
dt a
a =
                case (SF' a Bool -> DTime -> a -> Transition a Bool
forall a b. SF' a b -> DTime -> a -> Transition a b
sfTF' SF' a Bool
c) DTime
dt a
a of
                  (SF' a Bool
c', Bool
True)  -> (b -> (a -> Transition a b) -> SF' a Bool -> SF' a b
forall b a. b -> (a -> Transition a b) -> SF' a Bool -> SF' a b
pauseInit b
b_init' a -> Transition a b
tf10' SF' a Bool
c', b
b_init')
                  (SF' a Bool
c', Bool
False) -> let (SF' a b
k, b
b0) = a -> Transition a b
tf10' a
a
                                 in (b -> SF' a b -> SF' a Bool -> SF' a b
forall b a. b -> SF' a b -> SF' a Bool -> SF' a b
pause' b
b0 SF' a b
k SF' a Bool
c', b
b0)

       -- Very same deal (almost alpha-renameable)
       pause' :: b -> SF' a b -> SF' a Bool -> SF' a b
       pause' :: b -> SF' a b -> SF' a Bool -> SF' a b
pause' b
b_init' SF' a b
tf10' SF' a Bool
tfP' = (DTime -> a -> Transition a b) -> SF' a b
forall a b. (DTime -> a -> Transition a b) -> SF' a b
SF' DTime -> a -> Transition a b
tf0'
         where tf0' :: DTime -> a -> Transition a b
tf0' DTime
dt a
a =
                 case (SF' a Bool -> DTime -> a -> Transition a Bool
forall a b. SF' a b -> DTime -> a -> Transition a b
sfTF' SF' a Bool
tfP') DTime
dt a
a of
                   (SF' a Bool
tfP'', Bool
True) -> (b -> SF' a b -> SF' a Bool -> SF' a b
forall b a. b -> SF' a b -> SF' a Bool -> SF' a b
pause' b
b_init' SF' a b
tf10' SF' a Bool
tfP'', b
b_init')
                   (SF' a Bool
tfP'', Bool
False) -> let (SF' a b
tf10'', b
b0') = (SF' a b -> DTime -> a -> Transition a b
forall a b. SF' a b -> DTime -> a -> Transition a b
sfTF' SF' a b
tf10') DTime
dt a
a
                                     in (b -> SF' a b -> SF' a Bool -> SF' a b
forall b a. b -> SF' a b -> SF' a Bool -> SF' a b
pause' b
b0' SF' a b
tf10'' SF' a Bool
tfP'', b
b0')