{-# LANGUAGE GADTs, Rank2Types, CPP #-}
-----------------------------------------------------------------------------------------
-- |
-- 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)
--
--
-- Domain-specific language embedded in Haskell for programming hybrid (mixed
-- discrete-time and continuous-time) systems. Yampa is based on the concepts
-- of Functional Reactive Programming (FRP) and is structured using arrow
-- combinators.
--
-- You can find examples, tutorials and documentation on Yampa here:
--
-- <www.haskell.org/haskellwiki/Yampa>
--
-- Structuring a hybrid system in Yampa is done based on two main concepts:
--
-- * Signal Functions: 'SF'. Yampa is based on the concept of Signal Functions,
-- which are functions from a typed input signal to a typed output signal.
-- Conceptually, signals are functions from Time to Value, where time are the
-- real numbers and, computationally, a very dense approximation (Double) is
-- used.
--
-- * Events: 'Event'. Values that may or may not occur (and would probably
-- occur rarely). It is often used for incoming network messages, mouse
-- clicks, etc. Events are used as values carried by signals.
--
-- A complete Yampa system is defined as one Signal Function from some
-- type @a@ to a type @b@. The execution of this signal transformer
-- with specific input can be accomplished by means of two functions:
-- 'reactimate' (which needs an initialization action,
-- an input sensing action and an actuation/consumer action and executes
-- until explicitly stopped), and 'react' (which executes only one cycle).
--
-- Apart from using normal functions and arrow syntax to define 'SF's, you
-- can also use several combinators. See [<#g:4>] for basic signals combinators,
-- [<#g:11>] for ways of switching from one signal transformation to another,
-- and [<#g:16>] for ways of transforming Event-carrying signals into continuous
-- signals, [<#g:19>] for ways of delaying signals, and [<#g:21>] for ways to
-- feed a signal back to the same signal transformer.
--
-- Ways to define Event-carrying signals are given in [<#g:7>], and
-- "FRP.Yampa.Event" defines events and event-manipulation functions.
--
-- Finally, see [<#g:26>] for sources of randomness (useful in games).

-- CHANGELOG:
--
-- - Adds (most) documentation.
--
-- - New version using GADTs.
--
-- ToDo:
--
-- - Specialize def. of repeatedly. Could have an impact on invaders.
--
-- - New defs for accs using SFAcc
--
-- - Make sure opt worked: e.g.
--
-- - >     repeatedly >>> count >>> arr (fmap sqr)
--
-- - Introduce SFAccHld.
--
-- - See if possible to unify AccHld wity Acc??? They are so close.
--
-- - Introduce SScan. BUT KEEP IN MIND: Most if not all opts would
-- - have been possible without GADTs???
--
-- - Look into pairs. At least pairing of SScan ought to be interesting.
--
-- - Would be nice if we could get rid of first & second with impunity
-- - thanks to Id optimizations. That's a clear win, with or without
-- - an explicit pair combinator.
--
-- - delayEventCat is a bit complicated ...
--
--
-- Random ideas:
--
-- - What if one used rules to optimize
--   - (arr :: SF a ()) to (constant ())
--   - (arr :: SF a a) to identity
--   But inspection of invader source code seem to indicate that
--   these are not very common cases at all.
--
-- - It would be nice if it was possible to come up with opt. rules
--   that are invariant of how signal function expressions are
--   parenthesized. Right now, we have e.g.
--       arr f >>> (constant c >>> sf)
--   being optimized to
--       cpAuxA1 f (cpAuxC1 c sf)
--   whereas it clearly should be possible to optimize to just
--       cpAuxC1 c sf
--   What if we didn't use SF' but
--      SFComp :: <tfun> -> SF' a b -> SF' b c -> SF' a c
--   ???
--
-- - The transition function would still be optimized in (pretty much)
--   the current way, but it would still be possible to look "inside"
--   composed signal functions for lost optimization opts.
--   Seems to me this could be done without too much extra effort/no dupl.
--   work.
--   E.g. new cpAux, the general case:
--
-- @
--      cpAux sf1 sf2 = SFComp tf sf1 sf2
--          where
--              tf dt a = (cpAux sf1' sf2', c)
--                  where
--                      (sf1', b) = (sfTF' sf1) dt a
--                      (sf2', c) = (sfTF' sf2) dt b
-- @
--
-- - The ONLY change was changing the constructor from SF' to SFComp and
--   adding sf1 and sf2 to the constructor app.!
--
-- - An optimized case:
--     cpAuxC1 b sf1 sf2               = SFComp tf sf1 sf2
--   So cpAuxC1 gets an extra arg, and we change the constructor.
--   But how to exploit without writing 1000s of rules???
--   Maybe define predicates on SFComp to see if the first or second
--   sf are "interesting", and if so, make "reassociate" and make a
--   recursive call? E.g. we're in the arr case, and the first sf is another
--   arr, so we'd like to combine the two.
--
-- - It would also be intersting, then, to know when to STOP playing this
--   game, due to the overhead involved.
--
-- - Why don't we have a "SWITCH" constructor that indicates that the
--   structure will change, and thus that it is worthwile to keep
--   looking for opt. opportunities, whereas a plain "SF'" would
--   indicate that things NEVER are going to change, and thus we can just
--   as well give up?
-----------------------------------------------------------------------------------------

module FRP.Yampa.InternalCore (
    module Control.Arrow,
    -- SF is an instance of Arrow and ArrowLoop. Method instances:
    -- arr      :: (a -> b) -> SF a b
    -- (>>>)    :: SF a b -> SF b c -> SF a c
    -- (<<<)    :: SF b c -> SF a b -> SF a c
    -- first    :: SF a b -> SF (a,c) (b,c)
    -- second   :: SF a b -> SF (c,a) (c,b)
    -- (***)    :: SF a b -> SF a' b' -> SF (a,a') (b,b')
    -- (&&&)    :: SF a b -> SF a b' -> SF a (b,b')
    -- returnA  :: SF a a
    -- loop     :: SF (a,c) (b,c) -> SF a b

    -- * Basic definitions
    -- ** Time
    Time,       -- [s] Both for time w.r.t. some reference and intervals.
    DTime,      -- [s] Sampling interval, always > 0.

    -- ** Signal Functions
    SF(..),             -- Signal Function.

    -- ** Future Signal Function
    SF'(..),            -- Signal Function.
    Transition,
    sfTF',
    sfId,
    sfConst,
    sfArrG,

    -- *** Scanning
    sfSScan,

    -- ** Function descriptions
    FunDesc(..),
    fdFun,

    -- ** Lifting
    arrPrim,
    arrEPrim, -- For optimization
    epPrim

) where

#if __GLASGOW_HASKELL__ < 710
import Control.Applicative (Applicative(..))
#endif

import Control.Arrow

#if __GLASGOW_HASKELL__ >= 610
import qualified Control.Category (Category(..))
#endif

import FRP.Yampa.Diagnostics
import FRP.Yampa.Event

------------------------------------------------------------------------------
-- Basic type definitions with associated utilities
------------------------------------------------------------------------------

-- The time type is really a bit boguous, since, as time passes, the minimal
-- interval between two consecutive floating-point-represented time points
-- increases. A better approach might be to pick a reasonable resolution
-- and represent time and time intervals by Integer (giving the number of
-- "ticks").
--
-- That might also improve the timing of time-based event sources.
-- One might actually pick the overall resolution in reactimate,
-- to be passed down, possibly in the form of a global parameter
-- record, to all signal functions on initialization. (I think only
-- switch would need to remember the record, since it is the only place
-- where signal functions get started. So it wouldn't cost all that much.


-- | Time is used both for time intervals (duration), and time w.r.t. some
-- agreed reference point in time.

--  Conceptually, Time = R, i.e. time can be 0 -- or even negative.
type Time = Double      -- [s]


-- | DTime is the time type for lengths of sample intervals. Conceptually,
-- DTime = R+ = { x in R | x > 0 }. Don't assume Time and DTime have the
-- same representation.
type DTime = Double     -- [s]

-- Representation of signal function in initial state.
-- (Naming: "TF" stands for Transition Function.)

-- | Signal function that transforms a signal carrying values of some type 'a'
-- into a signal carrying values of some type 'b'. You can think of it as
-- (Signal a -> Signal b). A signal is, conceptually, a
-- function from 'Time' to value.
data SF a b = SF {sfTF :: a -> Transition a b}


-- | Signal function in "running" state.
--
--   It can also be seen as a Future Signal Function, meaning,
--   an SF that, given a time delta or a time in the future, it will
--   be an SF.

-- Possibly better design for Inv.
--   Problem: tension between on the one hand making use of the
--   invariant property, and on the other keeping track of how something
--   has been constructed (SFCpAXA, in particular).
--   Idea: Add a boolean field to SFCpAXA and SF' that classifies
--   a signal function as being invarying.
--   A function sfIsInv computes to True for SFArr, SFAcc (and SFSScan,
--   possibly more), extracts the field in other cases.
--
--  Motivation for using a function (Event a -> b) in SFArrE
--  rather than (a -> Event b) or (a -> b) or even (Event a -> Event b).
--    The result type should be just "b" as opposed to "Event b" for
--    increased flexibility (e.g. matching "routing functions").
--    When the result type actually IS (Event b), and this fact is
--    exploitable, we'll be in a context where is it clear that
--    this is a fact, so we don't lose anything.
--    Since the idea is that the function is only going to be applied
--    when the there is an event, one could imagine the input type
--    just "a". But that's not the type of function we're given,
--    so it would have to be "massaged" a bit (precomposing with Event)
--    to fit. This will gain nothing, and potentially we will lose if
--    we actually need to recover the original function.
--    In fact, we sometimes really need to recover the original function
--    (e.g. currently in switch), and to do it correctly (also handling
--    NoEvent), we'd have to work quite hard introducing further
--    inefficiencies.
--  Summary: Make use of what we are given and only wrap things up later
--  when it is clear whatthe need is going to be, thus avoiding costly
--  "unwrapping".

-- GADTs needed in particular for SFEP, but also e.g. SFSScan
-- exploits them since there are more type vars than in the type con.
-- But one could use existentials for those.

data SF' a b where
    SFArr   :: !(DTime -> a -> Transition a b) -> !(FunDesc a b) -> SF' a b
    -- The b is intentionally unstrict as the initial output sometimes
    -- is undefined (e.g. when defining pre). In any case, it isn't
    -- necessarily used and should thus not be forced.
    SFSScan :: !(DTime -> a -> Transition a b)
               -> !(c -> a -> Maybe (c, b)) -> !c -> b
               -> SF' a b
    SFEP   :: !(DTime -> Event a -> Transition (Event a) b)
              -> !(c -> a -> (c, b, b)) -> !c -> b
              -> SF' (Event a) b
    SFCpAXA :: !(DTime -> a -> Transition a d)
               -> !(FunDesc a b) -> !(SF' b c) -> !(FunDesc c d)
               -> SF' a d
    --  SFPair :: ...
    SF' :: !(DTime -> a -> Transition a b) -> SF' a b

-- | A transition is a pair of the next state (in the form of a future signal
-- function) and the output at the present time step.

type Transition a b = (SF' a b, b)

-- | Obtain the function that defines a running SF.
sfTF' :: SF' a b -> (DTime -> a -> Transition a b)
sfTF' (SFArr tf _)       = tf
sfTF' (SFSScan tf _ _ _) = tf
sfTF' (SFEP tf _ _ _)    = tf
sfTF' (SFCpAXA tf _ _ _) = tf
sfTF' (SF' tf)           = tf


-- !!! 2005-06-30
-- Unclear why, but the isInv mechanism seems to do more
-- harm than good.
-- Disable completely and see what happens.
{-
sfIsInv :: SF' a b -> Bool
-- sfIsInv _ = False
sfIsInv (SFArr _ _)           = True
-- sfIsInv (SFAcc _ _ _ _)       = True
sfIsInv (SFEP _ _ _ _)        = True
-- sfIsInv (SFSScan ...) = True
sfIsInv (SFCpAXA _ inv _ _ _) = inv
sfIsInv (SF' _ inv)           = inv
-}

-- "Smart" constructors. The corresponding "raw" constructors should not
-- be used directly for construction.

-- | Constructor for a lifted structured function.
sfArr :: FunDesc a b -> SF' a b
sfArr FDI         = sfId
sfArr (FDC b)     = sfConst b
sfArr (FDE f fne) = sfArrE f fne
sfArr (FDG f)     = sfArrG f

-- | SF constructor for the identity function.
sfId :: SF' a a
sfId = sf
    where
        sf = SFArr (\_ a -> (sf, a)) FDI

-- | SF constructor for the constant function.
sfConst :: b -> SF' a b
sfConst b = sf
    where
        sf = SFArr (\_ _ -> (sf, b)) (FDC b)

-- sfNever :: SF' a (Event b)
-- sfNever = sfConst NoEvent

-- Assumption: fne = f NoEvent
sfArrE :: (Event a -> b) -> b -> SF' (Event a) b
sfArrE f fne = sf
    where
        sf  = SFArr (\_ ea -> (sf, case ea of NoEvent -> fne ; _ -> f ea))
                    (FDE f fne)

-- | SF constructor for a general function.
sfArrG :: (a -> b) -> SF' a b
sfArrG f = sf
    where
        sf = SFArr (\_ a -> (sf, f a)) (FDG f)


-- | Versatile zero-order hold SF' with folding.
--
--   This function returns an SF that, if there is an input, runs it
--   through the given function and returns part of its output and, if not,
--   returns the last known output.
--
--   The auxiliary function returns the value of the current output and
--   the future held output, thus making it possible to have to distinct
--   outputs for the present and the future.

-- epPrim is used to define hold, accum, and other event-processing
-- functions.
epPrim :: (c -> a -> (c, b, b)) -> c -> b -> SF (Event a) b
epPrim f c bne = SF {sfTF = tf0}
    where
        tf0 NoEvent   = (sfEP f c bne, bne)
        tf0 (Event a) = let
                            (c', b, bne') = f c a
                        in
                            (sfEP f c' bne', b)

-- The event-processing function *could* accept the present NoEvent
-- output as an extra state argument. That would facilitate composition
-- of event-processing functions somewhat, but would presumably incur an
-- extra cost for the more common and simple case of non-composed event
-- processors.
--

-- | Constructor for a zero-order hold SF' with folding.
--
--   This function returns a running SF that, if there is an input, runs it
--   through the given function and returns part of its output and, if not,
--   returns the last known output.
--
--   The auxiliary function returns the value of the current output and
--   the future held output, thus making it possible to have to distinct
--   outputs for the present and the future.
sfEP :: (c -> a -> (c, b, b)) -> c -> b -> SF' (Event a) b
sfEP f c bne = sf
    where
        sf = SFEP (\_ ea -> case ea of
                                 NoEvent -> (sf, bne)
                                 Event a -> let
                                                (c', b, bne') = f c a
                                            in
                                                (sfEP f c' bne', b))
                  f
                  c
                  bne


{-
-- !!! Maybe something like this?
-- !!! But one problem is that the invarying marking would be lost
-- !!! if the signal function is taken apart and re-constructed from
-- !!! the function description and subordinate signal function in
-- !!! cases like SFCpAXA.
sfMkInv :: SF a b -> SF a b
sfMkInv sf = SF {sfTF = ...}

    sfMkInvAux :: SF' a b -> SF' a b
    sfMkInvAux sf@(SFArr _ _) = sf
    -- sfMkInvAux sf@(SFAcc _ _ _ _) = sf
    sfMkInvAux sf@(SFEP _ _ _ _) = sf
    sfMkInvAux sf@(SFCpAXA tf inv fd1 sf2 fd3)
        | inv       = sf
        | otherwise = SFCpAXA tf' True fd1 sf2 fd3
        where
            tf' = \dt a -> let (sf', b) = tf dt a in (sfMkInvAux sf', b)
    sfMkInvAux sf@(SF' tf inv)
        | inv       = sf
        | otherwise = SF' tf' True
            tf' =

-}

-- Motivation for event-processing function type
-- (alternative would be function of type a->b plus ensuring that it
-- only ever gets invoked on events):
-- * Now we need to be consistent with other kinds of arrows.
-- * We still want to be able to get hold of the original function.
-- 2005-02-30: OK, for FDE, invarant is that the field of type b =
-- f NoEvent.

-- | Structured function definition.
--
--   This type represents functions with a bit more structure, providing
--   specific constructors for the identity, constant and event-based
--   functions, helping optimise arrow combinators for special cases.
data FunDesc a b where
    FDI :: FunDesc a a                                  -- Identity function
    FDC :: b -> FunDesc a b                             -- Constant function
    FDE :: (Event a -> b) -> b -> FunDesc (Event a) b   -- Event-processing fun
    FDG :: (a -> b) -> FunDesc a b                      -- General function

-- | Turns a function into a structured function.
fdFun :: FunDesc a b -> (a -> b)
fdFun FDI       = id
fdFun (FDC b)   = const b
fdFun (FDE f _) = f
fdFun (FDG f)   = f

-- | Composition for structured functions.
fdComp :: FunDesc a b -> FunDesc b c -> FunDesc a c
fdComp FDI           fd2     = fd2
fdComp fd1           FDI     = fd1
fdComp (FDC b)       fd2     = FDC ((fdFun fd2) b)
fdComp _             (FDC c) = FDC c

-- Hardly worth the effort?
-- 2005-03-30: No, not only not worth the effort as the only thing saved
-- would be an application of f2. Also wrong since current invariant does
-- not imply that f1ne = NoEvent. Moreover, we cannot really adopt that
-- invariant as it is not totally impossible for a user to create a function
-- that breaks it.
-- fdComp (FDE f1 f1ne) (FDE f2 f2ne) =
--    FDE (f2 . f1) (vfyNoEvent (f1 NoEvent) f2ne)
fdComp (FDE f1 f1ne) fd2 = FDE (f2 . f1) (f2 f1ne)
    where
        f2 = fdFun fd2
fdComp (FDG f1) (FDE f2 f2ne) = FDG f
    where
        f a = case f1 a of
                  NoEvent -> f2ne
                  f1a     -> f2 f1a
fdComp (FDG f1) fd2 = FDG (fdFun fd2 . f1)

-- | Parallel application of structured functions.
fdPar :: FunDesc a b -> FunDesc c d -> FunDesc (a,c) (b,d)
fdPar FDI     FDI     = FDI
fdPar FDI     (FDC d) = FDG (\(~(a, _)) -> (a, d))
fdPar FDI     fd2     = FDG (\(~(a, c)) -> (a, (fdFun fd2) c))
fdPar (FDC b) FDI     = FDG (\(~(_, c)) -> (b, c))
fdPar (FDC b) (FDC d) = FDC (b, d)
fdPar (FDC b) fd2     = FDG (\(~(_, c)) -> (b, (fdFun fd2) c))
fdPar fd1     fd2     = FDG (\(~(a, c)) -> ((fdFun fd1) a, (fdFun fd2) c))

-- | Parallel application with broadcasting for structured functions.
fdFanOut :: FunDesc a b -> FunDesc a c -> FunDesc a (b,c)
fdFanOut FDI     FDI     = FDG (\a -> (a, a))
fdFanOut FDI     (FDC c) = FDG (\a -> (a, c))
fdFanOut FDI     fd2     = FDG (\a -> (a, (fdFun fd2) a))
fdFanOut (FDC b) FDI     = FDG (\a -> (b, a))
fdFanOut (FDC b) (FDC c) = FDC (b, c)
fdFanOut (FDC b) fd2     = FDG (\a -> (b, (fdFun fd2) a))
fdFanOut (FDE f1 f1ne) (FDE f2 f2ne) = FDE f1f2 f1f2ne
    where
       f1f2 NoEvent      = f1f2ne
       f1f2 ea@(Event _) = (f1 ea, f2 ea)

       f1f2ne = (f1ne, f2ne)
fdFanOut fd1 fd2 =
    FDG (\a -> ((fdFun fd1) a, (fdFun fd2) a))


-- Verifies that the first argument is NoEvent. Returns the value of the
-- second argument that is the case. Raises an error otherwise.
-- Used to check that functions on events do not map NoEvent to Event
-- wherever that assumption is exploited.
vfyNoEv :: Event a -> b -> b
vfyNoEv NoEvent b = b
vfyNoEv _       _  = usrErr "AFRP" "vfyNoEv" "Assertion failed: Functions on events must not map NoEvent to Event."



------------------------------------------------------------------------------
-- Arrow instance and implementation
------------------------------------------------------------------------------

#if __GLASGOW_HASKELL__ >= 610
-- | Composition and identity for SFs.
instance Control.Category.Category SF where
     (.) = flip compPrim
     id = SF $ \x -> (sfId,x)
#endif

-- | Choice of which SF to run based on the value of a signal.
instance ArrowChoice SF where
  -- (+++) :: forall b c b' c' . SF b c -> SF d e -> SF (Either b d) (Either c e)
  sfL +++ sfR = SF $ \a ->
    case a of
      Left b  -> let (sf', c) = sfTF sfL b
                 in (chooseL sf' sfR, Left c)
      Right d -> let (sf', e) = sfTF sfR d
                 in (chooseR sfL sf', Right e)

    where

      -- (+++) for an initialized SF and an SF
      --
      -- chooseL :: SF' b c -> SF d e -> SF' (Either b d) (Either c e)
      chooseL sfCL sfR = SF' $ \dt a ->
        case a of
          Left b  -> let (sf', c) = sfTF' sfCL dt b
                     in (chooseL sf' sfR, Left c)
          Right d -> let (sf', e) = sfTF sfR d
                     in (choose sfCL sf', Right e)

      -- (+++) for an SF and an initialized SF
      --
      -- chooseR :: SF b c -> SF' d e -> SF' (Either b d) (Either c e)
      chooseR sfL sfCR = SF' $ \dt a ->
        case a of
          Left b  -> let (sf', c) = sfTF sfL b
                     in (choose sf' sfCR, Left c)
          Right d -> let (sf', e) = sfTF' sfCR dt d
                     in (chooseR sfL sf', Right e)

      -- (+++) for initialized SFs
      --
      -- choose :: SF' b c -> SF' d e -> SF' (Either b d) (Either c e)
      choose sfCL sfCR = SF' $ \dt a ->
        case a of
          Left b  -> let (sf', c) = sfTF' sfCL dt b
                     in (choose sf' sfCR, Left c)
          Right d -> let (sf', e) = sfTF' sfCR dt d
                     in (choose sfCL sf', Right e)



-- | Signal Functions as Arrows. See "The Yampa Arcade", by Courtney, Nilsson
--   and Peterson.
instance Arrow SF where
    arr    = arrPrim
    first  = firstPrim
    second = secondPrim
    (***)  = parSplitPrim
    (&&&)  = parFanOutPrim

#if __GLASGOW_HASKELL__ >= 610
#else
    (>>>)  = compPrim
#endif

-- | Functor instance for applied SFs.
instance Functor (SF a) where
  fmap f = (>>> arr f)

-- | Applicative Functor instance (allows classic-frp style signals and
-- composition using applicative style).
instance Applicative (SF a) where
  pure x = arr (const x)
  f <*>  x  = (f &&& x) >>> arr (uncurry ($))


-- * Lifting.

-- | Lifts a pure function into a signal function (applied pointwise).
{-# NOINLINE arrPrim #-}
arrPrim :: (a -> b) -> SF a b
arrPrim f = SF {sfTF = \a -> (sfArrG f, f a)}

-- | Lifts a pure function into a signal function applied to events
--   (applied pointwise).
{-# RULES "arrPrim/arrEPrim" arrPrim = arrEPrim #-}
arrEPrim :: (Event a -> b) -> SF (Event a) b
arrEPrim f = SF {sfTF = \a -> (sfArrE f (f NoEvent), f a)}


-- * Composition.
-- The definition exploits the following identities:
--     sf         >>> identity   = sf                           -- New
--     identity   >>> sf         = sf                           -- New
--     sf         >>> constant c = constant c
--     constant c >>> arr f      = constant (f c)
--     arr f      >>> arr g      = arr (g . f)
--
-- !!! Notes/Questions:
-- !!! How do we know that the optimizations terminate?
-- !!! Probably by some kind of size argument on the SF tree.
-- !!! E.g. (Hopefully) all compPrim optimizations are such that
-- !!! the number of compose nodes decrease.
-- !!! Should verify this!
--
-- !!! There is a tension between using SFInv to signal to superior
-- !!! signal functions that the subordinate signal function will not
-- !!! change form, and using SFCpAXA to allow fusion in the context
-- !!! of some suitable superior signal function.
compPrim :: SF a b -> SF b c -> SF a c
compPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
    where
        tf0 a0 = (cpXX sf1 sf2, c0)
            where
                (sf1, b0) = tf10 a0
                (sf2, c0) = tf20 b0

-- The following defs are not local to compPrim because cpAXA needs to be
-- called from parSplitPrim.
-- Naming convention: cp<X><Y> where  <X> and <Y> is one of:
-- X - arbitrary signal function
-- A - arbitrary pure arrow
-- C - constant arrow
-- E - event-processing arrow
-- G - arrow known not to be identity, constant (C) or
--     event-processing (E).

cpXX :: SF' a b -> SF' b c -> SF' a c
cpXX (SFArr _ fd1)       sf2               = cpAX fd1 sf2
cpXX sf1                 (SFArr _ fd2)     = cpXA sf1 fd2
{-
-- !!! 2005-07-07: Too strict.
-- !!! But the question is if it is worth to define pre in terms of sscan ...
-- !!! It is slower than the simplest possible pre, and the kind of coding
-- !!! required to ensure that the laziness props of the second SF are
-- !!! preserved might just slow things down further ...
cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) =
    sfSScan f (s1, b, s2, c) c
    where
        f (s1, b, s2, c) a =
            case f1 s1 a of
                Nothing ->
                    case f2 s2 b of
                        Nothing        -> Nothing
                        Just (s2', c') -> Just ((s1, b, s2', c'), c')
                Just (s1', b') ->
                    case f2 s2 b' of
                        Nothing        -> Just ((s1', b', s2, c), c)
                        Just (s2', c') -> Just ((s1', b', s2', c'), c')
-}
-- !!! 2005-07-07: Indeed, this is a bit slower than the code above (14%).
-- !!! But both are better than not composing (35% faster and 26% faster)!
cpXX (SFSScan _ f1 s1 b) (SFSScan _ f2 s2 c) =
    sfSScan f (s1, b, s2, c) c
    where
        f (s1, b, s2, c) a =
            let
                (u, s1',  b') = case f1 s1 a of
                                    Nothing       -> (True, s1, b)
                                    Just (s1',b') -> (False,  s1', b')
            in
                case f2 s2 b' of
                    Nothing | u         -> Nothing
                            | otherwise -> Just ((s1', b', s2, c), c)
                    Just (s2', c') -> Just ((s1', b', s2', c'), c')
cpXX (SFSScan _ f1 s1 eb) (SFEP _ f2 s2 cne) =
    sfSScan f (s1, eb, s2, cne) cne
    where
        f (s1, eb, s2, cne) a =
            case f1 s1 a of
                Nothing ->
                    case eb of
                        NoEvent -> Nothing
                        Event b ->
                            let (s2', c, cne') = f2 s2 b
                            in
                                Just ((s1, eb, s2', cne'), c)
                Just (s1', eb') ->
                    case eb' of
                        NoEvent -> Just ((s1', eb', s2, cne), cne)
                        Event b ->
                            let (s2', c, cne') = f2 s2 b
                            in
                                Just ((s1', eb', s2', cne'), c)
-- !!! 2005-07-09: This seems to yield only a VERY marginal speedup
-- !!! without seq. With seq, substantial speedup!
cpXX (SFEP _ f1 s1 bne) (SFSScan _ f2 s2 c) =
    sfSScan f (s1, bne, s2, c) c
    where
        f (s1, bne, s2, c) ea =
            let (u, s1', b', bne') = case ea of
                                         NoEvent -> (True, s1, bne, bne)
                                         Event a ->
                                             let (s1', b, bne') = f1 s1 a
                                             in
                                                  (False, s1', b, bne')
            in
                case f2 s2 b' of
                    Nothing | u         -> Nothing
                            | otherwise -> Just (seq s1' (s1', bne', s2, c), c)
                    Just (s2', c') -> Just (seq s1' (s1', bne', s2', c'), c')
-- The function "f" is invoked whenever an event is to be processed. It then
-- computes the output, the new state, and the new NoEvent output.
-- However, when sequencing event processors, the ones in the latter
-- part of the chain may not get invoked since previous ones may
-- decide not to "fire". But a "new" NoEvent output still has to be
-- produced, i.e. the old one retained. Since it cannot be computed by
-- invoking the last event-processing function in the chain, it has to
-- be remembered. Since the composite event-processing function remains
-- constant/unchanged, the NoEvent output has to be part of the state.
-- An alternarive would be to make the event-processing function take an
-- extra argument. But that is likely to make the simple case more
-- expensive. See note at sfEP.
cpXX (SFEP _ f1 s1 bne) (SFEP _ f2 s2 cne) =
    sfEP f (s1, s2, cne) (vfyNoEv bne cne)
    where
        f (s1, s2, cne) a =
            case f1 s1 a of
                (s1', NoEvent, NoEvent) -> ((s1', s2, cne), cne, cne)
                (s1', Event b, NoEvent) ->
                    let (s2', c, cne') = f2 s2 b in ((s1', s2', cne'), c, cne')
                _ -> usrErr "AFRP" "cpXX" "Assertion failed: Functions on events must not map NoEvent to Event."
-- !!! 2005-06-28: Why isn't SFCpAXA (FDC ...) checked for?
-- !!! No invariant rules that out, and it would allow to drop the
-- !!! event processor ... Does that happen elsewhere?
cpXX sf1@(SFEP{}) (SFCpAXA _ (FDE f21 f21ne) sf22 fd23) =
    cpXX (cpXE sf1 f21 f21ne) (cpXA sf22 fd23)
-- f21 will (hopefully) be invoked less frequently if merged with the
-- event processor.
cpXX sf1@(SFEP{}) (SFCpAXA _ (FDG f21) sf22 fd23) =
    cpXX (cpXG sf1 f21) (cpXA sf22 fd23)
-- Only functions whose domain is known to be Event can be merged
-- from the left with event processors.
cpXX (SFCpAXA _ fd11 sf12 (FDE f13 f13ne)) sf2@(SFEP{}) =
    cpXX (cpAX fd11 sf12) (cpEX f13 f13ne sf2)
-- !!! Other cases to look out for:
-- !!! any sf >>> SFCpAXA = SFCpAXA if first arr is const.
-- !!! But the following will presumably not work due to type restrictions.
-- !!! Need to reconstruct sf2 I think.
-- cpXX sf1 sf2@(SFCpAXA _ _ (FDC b) sf22 fd23) = sf2
cpXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) =
    -- Termination: The first argument to cpXX is no larger than
    -- the current first argument, and the second is smaller.
    cpAXA fd11 (cpXX (cpXA sf12 (fdComp fd13 fd21)) sf22) fd23
-- !!! 2005-06-27: The if below accounts for a significant slowdown.
-- !!! One would really like a cheme where opts only take place
-- !!! after a structural change ...
-- cpXX sf1 sf2 = cpXXInv sf1 sf2
-- cpXX sf1 sf2 = cpXXAux sf1 sf2
cpXX sf1 sf2 = SF' tf --  False
    -- if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False
    where
        tf dt a = (cpXX sf1' sf2', c)
            where
                (sf1', b) = (sfTF' sf1) dt a
                (sf2', c) = (sfTF' sf2) dt b


{-
cpXXAux sf1@(SF' _ _) sf2@(SF' _ _) = SF' tf False
    where
        tf dt a = (cpXXAux sf1' sf2', c)
            where
                (sf1', b) = (sfTF' sf1) dt a
                (sf2', c) = (sfTF' sf2) dt b
cpXXAux sf1 sf2 = SF' tf False
    where
        tf dt a = (cpXXAux sf1' sf2', c)
            where
                (sf1', b) = (sfTF' sf1) dt a
                (sf2', c) = (sfTF' sf2) dt b
-}

{-
cpXXAux sf1 sf2 | unsimplifiable sf1 sf2 = SF' tf False
                | otherwise = cpXX sf1 sf2
    where
        tf dt a = (cpXXAux sf1' sf2', c)
            where
                (sf1', b) = (sfTF' sf1) dt a
                (sf2', c) = (sfTF' sf2) dt b

        unsimplifiable sf1@(SF' _ _) sf2@(SF' _ _) = True
        unsimplifiable sf1           sf2           = True
-}

{-
-- wrong ...
cpXXAux sf1@(SF' _ False)           sf2                         = SF' tf False
cpXXAux sf1@(SFCpAXA _ False _ _ _) sf2                         = SF' tf False
cpXXAux sf1                         sf2@(SF' _ False)           = SF' tf False
cpXXAux sf1                         sf2@(SFCpAXA _ False _ _ _) = SF' tf False
cpXXAux sf1 sf2 =
    if sfIsInv sf1 && sfIsInv sf2 then cpXXInv sf1 sf2 else SF' tf False
    where
        tf dt a = (cpXXAux sf1' sf2', c)
            where
                (sf1', b) = (sfTF' sf1) dt a
                (sf2', c) = (sfTF' sf2) dt b
-}

{-
cpXXInv sf1 sf2 = SF' tf True
    where
        tf dt a = sf1 `seq` sf2 `seq` (cpXXInv sf1' sf2', c)
            where
                (sf1', b) = (sfTF' sf1) dt a
                (sf2', c) = (sfTF' sf2) dt b
-}

-- !!! No. We need local defs. Keep fd1 and fd2. Extract f1 and f2
-- !!! once and fo all. Get rid of FDI and FDC at the top level.
-- !!! First local def. analyse sf2. SFArr, SFAcc etc. tf in
-- !!! recursive case just make use of f1 and f3.
-- !!! if sf2 is SFInv, that's delegated to a second local
-- !!! recursive def. that does not analyse sf2.

cpAXA :: FunDesc a b -> SF' b c -> FunDesc c d -> SF' a d
-- Termination: cpAX/cpXA, via cpCX, cpEX etc. only call cpAXA if sf2
-- is SFCpAXA, and then on the embedded sf and hence on a smaller arg.
cpAXA FDI     sf2 fd3     = cpXA sf2 fd3
cpAXA fd1     sf2 FDI     = cpAX fd1 sf2
cpAXA (FDC b) sf2 fd3     = cpCXA b sf2 fd3
cpAXA _       _   (FDC d) = sfConst d
cpAXA fd1     sf2 fd3     =
    cpAXAAux fd1 (fdFun fd1) fd3 (fdFun fd3) sf2
    where
        -- Really: cpAXAAux :: SF' b c -> SF' a d
        -- Note: Event cases are not optimized (EXA etc.)
        cpAXAAux :: FunDesc a b -> (a -> b) -> FunDesc c d -> (c -> d)
                    -> SF' b c -> SF' a d
        cpAXAAux fd1 _ fd3 _ (SFArr _ fd2) =
            sfArr (fdComp (fdComp fd1 fd2) fd3)
        cpAXAAux fd1 _ fd3 _ sf2@(SFSScan {}) =
            cpAX fd1 (cpXA sf2 fd3)
        cpAXAAux fd1 _ fd3 _ sf2@(SFEP {}) =
            cpAX fd1 (cpXA sf2 fd3)
        cpAXAAux fd1 _ fd3 _ (SFCpAXA _ fd21 sf22 fd23) =
            cpAXA (fdComp fd1 fd21) sf22 (fdComp fd23 fd3)
        cpAXAAux fd1 f1 fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3
{-
            if sfIsInv sf2 then
                cpAXAInv fd1 f1 fd3 f3 sf2
            else
                SFCpAXA tf False fd1 sf2 fd3
-}
            where
                tf dt a = (cpAXAAux fd1 f1 fd3 f3 sf2', f3 c)
                    where
                        (sf2', c) = (sfTF' sf2) dt (f1 a)

{-
        cpAXAInv fd1 f1 fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3
            where
                tf dt a = sf2 `seq` (cpAXAInv fd1 f1 fd3 f3 sf2', f3 c)
                    where
                        (sf2', c) = (sfTF' sf2) dt (f1 a)
-}

cpAX :: FunDesc a b -> SF' b c -> SF' a c
cpAX FDI           sf2 = sf2
cpAX (FDC b)       sf2 = cpCX b sf2
cpAX (FDE f1 f1ne) sf2 = cpEX f1 f1ne sf2
cpAX (FDG f1)      sf2 = cpGX f1 sf2

cpXA :: SF' a b -> FunDesc b c -> SF' a c
cpXA sf1 FDI           = sf1
cpXA _   (FDC c)       = sfConst c
cpXA sf1 (FDE f2 f2ne) = cpXE sf1 f2 f2ne
cpXA sf1 (FDG f2)      = cpXG sf1 f2

-- Don't forget that the remaining signal function, if it is
-- SF', later could turn into something else, like SFId.
cpCX :: b -> SF' b c -> SF' a c
cpCX b (SFArr _ fd2) = sfConst ((fdFun fd2) b)
-- 2005-07-01:  If we were serious about the semantics of sscan being required
-- to be independent of the sampling interval, I guess one could argue for a
-- fixed-point computation here ... Or maybe not.
-- cpCX b (SFSScan _ _ _ _) = sfConst <fixed point comp>
cpCX b (SFSScan _ f s c) = sfSScan (\s _ -> f s b) s c
cpCX b (SFEP _ _ _ cne) = sfConst (vfyNoEv b cne)
cpCX b (SFCpAXA _ fd21 sf22 fd23) =
    cpCXA ((fdFun fd21) b) sf22 fd23
cpCX b sf2 = SFCpAXA tf (FDC b) sf2 FDI
{-
    if sfIsInv sf2 then
        cpCXInv b sf2
    else
        SFCpAXA tf False (FDC b) sf2 FDI
-}
    where
        tf dt _ = (cpCX b sf2', c)
            where
                (sf2', c) = (sfTF' sf2) dt b


{-
cpCXInv b sf2 = SFCpAXA tf True (FDC b) sf2 FDI
    where
        tf dt _ = sf2 `seq` (cpCXInv b sf2', c)
            where
                (sf2', c) = (sfTF' sf2) dt b
-}


cpCXA :: b -> SF' b c -> FunDesc c d -> SF' a d
cpCXA b sf2 FDI     = cpCX b sf2
cpCXA _ _   (FDC c) = sfConst c
cpCXA b sf2 fd3     = cpCXAAux (FDC b) b fd3 (fdFun fd3) sf2
    where
        -- fd1 = FDC b
        -- f3  = fdFun fd3

        -- Really: SF' b c -> SF' a d
        cpCXAAux :: FunDesc a b -> b -> FunDesc c d -> (c -> d)
                    -> SF' b c -> SF' a d
        cpCXAAux _ b _ f3 (SFArr _ fd2)     = sfConst (f3 ((fdFun fd2) b))
        cpCXAAux _ b _ f3 (SFSScan _ f s c) = sfSScan f' s (f3 c)
            where
                f' s _ = case f s b of
                             Nothing -> Nothing
                             Just (s', c') -> Just (s', f3 c')
        cpCXAAux _ b _   f3 (SFEP _ _ _ cne) = sfConst (f3 (vfyNoEv b cne))
        cpCXAAux _ b fd3 _  (SFCpAXA _ fd21 sf22 fd23) =
            cpCXA ((fdFun fd21) b) sf22 (fdComp fd23 fd3)
        cpCXAAux fd1 b fd3 f3 sf2 = SFCpAXA tf fd1 sf2 fd3
{-
            if sfIsInv sf2 then
                cpCXAInv fd1 b fd3 f3 sf2
            else
                SFCpAXA tf False fd1 sf2 fd3
-}
            where
                tf dt _ = (cpCXAAux fd1 b fd3 f3 sf2', f3 c)
                    where
                        (sf2', c) = (sfTF' sf2) dt b

{-
        -- For some reason, seq on sf2' in tf is faster than making
        -- cpCXAInv strict in sf2 by seq-ing on the top level (which would
        -- be similar to pattern matching on sf2).
        cpCXAInv fd1 b fd3 f3 sf2 = SFCpAXA tf True fd1 sf2 fd3
            where
                tf dt _ = sf2 `seq` (cpCXAInv fd1 b fd3 f3 sf2', f3 c)
                    where
                        (sf2', c) = (sfTF' sf2) dt b
-}


cpGX :: (a -> b) -> SF' b c -> SF' a c
cpGX f1 sf2 = cpGXAux (FDG f1) f1 sf2
    where
        cpGXAux :: FunDesc a b -> (a -> b) -> SF' b c -> SF' a c
        cpGXAux fd1 _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)
        -- We actually do know that (fdComp (FDG f1) fd21) is going to
        -- result in an FDG. So we *could* call a cpGXA here. But the
        -- price is "inlining" of part of fdComp.
        cpGXAux _ f1 (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c
        -- We really shouldn't see an EP here, as that would mean
        -- an arrow INTRODUCING events ...
        cpGXAux fd1 _ (SFCpAXA _ fd21 sf22 fd23) =
            cpAXA (fdComp fd1 fd21) sf22 fd23
        cpGXAux fd1 f1 sf2 = SFCpAXA tf fd1 sf2 FDI
{-
            if sfIsInv sf2 then
                cpGXInv fd1 f1 sf2
            else
                SFCpAXA tf False fd1 sf2 FDI
-}
            where
                tf dt a = (cpGXAux fd1 f1 sf2', c)
                    where
                        (sf2', c) = (sfTF' sf2) dt (f1 a)

{-
        cpGXInv fd1 f1 sf2 = SFCpAXA tf True fd1 sf2 FDI
            where
                tf dt a = sf2 `seq` (cpGXInv fd1 f1 sf2', c)
                    where
                        (sf2', c) = (sfTF' sf2) dt (f1 a)
-}


cpXG :: SF' a b -> (b -> c) -> SF' a c
cpXG sf1 f2 = cpXGAux (FDG f2) f2 sf1
    where
        -- Really: cpXGAux :: SF' a b -> SF' a c
        cpXGAux :: FunDesc b c -> (b -> c) -> SF' a b -> SF' a c
        cpXGAux fd2 _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2)
        cpXGAux _ f2 (SFSScan _ f s b) = sfSScan f' s (f2 b)
            where
                f' s a = case f s a of
                             Nothing -> Nothing
                             Just (s', b') -> Just (s', f2 b')
        cpXGAux _ f2 (SFEP _ f1 s bne) = sfEP f s (f2 bne)
            where
                f s a = let (s', b, bne') = f1 s a in (s', f2 b, f2 bne')
        cpXGAux fd2 _ (SFCpAXA _ fd11 sf12 fd22) =
            cpAXA fd11 sf12 (fdComp fd22 fd2)
        cpXGAux fd2 f2 sf1 = SFCpAXA tf FDI sf1 fd2
{-
            if sfIsInv sf1 then
                cpXGInv fd2 f2 sf1
            else
                SFCpAXA tf False FDI sf1 fd2
-}
            where
                tf dt a = (cpXGAux fd2 f2 sf1', f2 b)
                    where
                        (sf1', b) = (sfTF' sf1) dt a

{-
        cpXGInv fd2 f2 sf1 = SFCpAXA tf True FDI sf1 fd2
            where
                tf dt a = (cpXGInv fd2 f2 sf1', f2 b)
                    where
                        (sf1', b) = (sfTF' sf1) dt a
-}

cpEX :: (Event a -> b) -> b -> SF' b c -> SF' (Event a) c
cpEX f1 f1ne sf2 = cpEXAux (FDE f1 f1ne) f1 f1ne sf2
    where
        cpEXAux :: FunDesc (Event a) b -> (Event a -> b) -> b
                   -> SF' b c -> SF' (Event a) c
        cpEXAux fd1 _ _ (SFArr _ fd2) = sfArr (fdComp fd1 fd2)
        cpEXAux _ f1 _   (SFSScan _ f s c) = sfSScan (\s a -> f s (f1 a)) s c
        -- We must not capture cne in the f closure since cne can change!
        -- See cpXX the SFEP/SFEP case for a similar situation. However,
        -- FDE represent a state-less signal function, so *its* NoEvent
        -- value never changes. Hence we only need to verify that it is
        -- NoEvent once.
        cpEXAux _ f1 f1ne (SFEP _ f2 s cne) =
            sfEP f (s, cne) (vfyNoEv f1ne cne)
            where
                f scne@(s, cne) a =
                    case f1 (Event a) of
                        NoEvent -> (scne, cne, cne)
                        Event b ->
                            let (s', c, cne') = f2 s b in ((s', cne'), c, cne')
        cpEXAux fd1 _ _ (SFCpAXA _ fd21 sf22 fd23) =
            cpAXA (fdComp fd1 fd21) sf22 fd23
        -- The rationale for the following is that the case analysis
        -- is typically not going to be more expensive than applying
        -- the function and possibly a bit cheaper. Thus if events
        -- are sparse, we might win, and if not, we don't loose to
        -- much.
        cpEXAux fd1 f1 f1ne sf2 = SFCpAXA tf fd1 sf2 FDI
{-
            if sfIsInv sf2 then
                cpEXInv fd1 f1 f1ne sf2
            else
                SFCpAXA tf False fd1 sf2 FDI
-}
            where
                tf dt ea = (cpEXAux fd1 f1 f1ne sf2', c)
                    where
                        (sf2', c) =
                            case ea of
                                NoEvent -> (sfTF' sf2) dt f1ne
                                _       -> (sfTF' sf2) dt (f1 ea)

{-
        cpEXInv fd1 f1 f1ne sf2 = SFCpAXA tf True fd1 sf2 FDI
            where
                tf dt ea = sf2 `seq` (cpEXInv fd1 f1 f1ne sf2', c)
                    where
                        (sf2', c) =
                            case ea of
                                NoEvent -> (sfTF' sf2) dt f1ne
                                _       -> (sfTF' sf2) dt (f1 ea)
-}

cpXE :: SF' a (Event b) -> (Event b -> c) -> c -> SF' a c
cpXE sf1 f2 f2ne = cpXEAux (FDE f2 f2ne) f2 f2ne sf1
    where
        cpXEAux :: FunDesc (Event b) c -> (Event b -> c) -> c
                   -> SF' a (Event b) -> SF' a c
        cpXEAux fd2 _ _ (SFArr _ fd1) = sfArr (fdComp fd1 fd2)
        cpXEAux _ f2 f2ne (SFSScan _ f s eb) = sfSScan f' s (f2 eb)
            where
                f' s a = case f s a of
                             Nothing -> Nothing
                             Just (s', NoEvent) -> Just (s', f2ne)
                             Just (s', eb')     -> Just (s', f2 eb')
        cpXEAux _ f2 f2ne (SFEP _ f1 s ebne) =
            sfEP f s (vfyNoEv ebne f2ne)
            where
                f s a =
                    case f1 s a of
                        (s', NoEvent, NoEvent) -> (s', f2ne,  f2ne)
                        (s', eb,      NoEvent) -> (s', f2 eb, f2ne)
                        _ -> usrErr "AFRP" "cpXEAux" "Assertion failed: Functions on events must not map NoEvent to Event."
        cpXEAux fd2 _ _ (SFCpAXA _ fd11 sf12 fd13) =
            cpAXA fd11 sf12 (fdComp fd13 fd2)
        cpXEAux fd2 f2 f2ne sf1 = SFCpAXA tf FDI sf1 fd2
{-
            if sfIsInv sf1 then
                cpXEInv fd2 f2 f2ne sf1
            else
                SFCpAXA tf False FDI sf1 fd2
-}
            where
                tf dt a = (cpXEAux fd2 f2 f2ne sf1',
                           case eb of NoEvent -> f2ne; _ -> f2 eb)
                    where
                        (sf1', eb) = (sfTF' sf1) dt a

{-
        cpXEInv fd2 f2 f2ne sf1 = SFCpAXA tf True FDI sf1 fd2
            where
                tf dt a = sf1 `seq` (cpXEInv fd2 f2 f2ne sf1',
                           case eb of NoEvent -> f2ne; _ -> f2 eb)
                    where
                        (sf1', eb) = (sfTF' sf1) dt a
-}


-- * Widening.
-- The definition exploits the following identities:
--     first identity     = identity                            -- New
--     first (constant b) = arr (\(_, c) -> (b, c))
--     (first (arr f))    = arr (\(a, c) -> (f a, c))
firstPrim :: SF a b -> SF (a,c) (b,c)
firstPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
    where
        tf0 ~(a0, c0) = (fpAux sf1, (b0, c0))
            where
                (sf1, b0) = tf10 a0


-- Also used in parSplitPrim
fpAux :: SF' a b -> SF' (a,c) (b,c)
fpAux (SFArr _ FDI)       = sfId                        -- New
fpAux (SFArr _ (FDC b))   = sfArrG (\(~(_, c)) -> (b, c))
fpAux (SFArr _ fd1)       = sfArrG (\(~(a, c)) -> ((fdFun fd1) a, c))
fpAux sf1 = SF' tf
    -- if sfIsInv sf1 then fpInv sf1 else SF' tf False
    where
        tf dt ~(a, c) = (fpAux sf1', (b, c))
            where
                (sf1', b) = (sfTF' sf1) dt a


{-
fpInv :: SF' a b -> SF' (a,c) (b,c)
fpInv sf1 = SF' tf True
    where
        tf dt ~(a, c) = sf1 `seq` (fpInv sf1', (b, c))
            where
                (sf1', b) = (sfTF' sf1) dt a
-}


-- Mirror image of first.
secondPrim :: SF a b -> SF (c,a) (c,b)
secondPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
    where
        tf0 ~(c0, a0) = (spAux sf1, (c0, b0))
            where
                (sf1, b0) = tf10 a0


-- Also used in parSplitPrim
spAux :: SF' a b -> SF' (c,a) (c,b)
spAux (SFArr _ FDI)       = sfId                        -- New
spAux (SFArr _ (FDC b))   = sfArrG (\(~(c, _)) -> (c, b))
spAux (SFArr _ fd1)       = sfArrG (\(~(c, a)) -> (c, (fdFun fd1) a))
spAux sf1 = SF' tf
    -- if sfIsInv sf1 then spInv sf1 else SF' tf False
    where
        tf dt ~(c, a) = (spAux sf1', (c, b))
            where
                (sf1', b) = (sfTF' sf1) dt a


{-
spInv :: SF' a b -> SF' (c,a) (c,b)
spInv sf1 = SF' tf True
    where
        tf dt ~(c, a) = sf1 `seq` (spInv sf1', (c, b))
            where
                (sf1', b) = (sfTF' sf1) dt a
-}


-- * Parallel composition.
-- The definition exploits the following identities (that hold for SF):
--     identity   *** identity   = identity             -- New
--     sf         *** identity   = first sf             -- New
--     identity   *** sf         = second sf            -- New
--     constant b *** constant d = constant (b, d)
--     constant b *** arr f2     = arr (\(_, c) -> (b, f2 c)
--     arr f1     *** constant d = arr (\(a, _) -> (f1 a, d)
--     arr f1     *** arr f2     = arr (\(a, b) -> (f1 a, f2 b)
parSplitPrim :: SF a b -> SF c d  -> SF (a,c) (b,d)
parSplitPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
    where
        tf0 ~(a0, c0) = (psXX sf1 sf2, (b0, d0))
            where
                (sf1, b0) = tf10 a0
                (sf2, d0) = tf20 c0

        -- Naming convention: ps<X><Y> where  <X> and <Y> is one of:
        -- X - arbitrary signal function
        -- A - arbitrary pure arrow
        -- C - constant arrow

        psXX :: SF' a b -> SF' c d -> SF' (a,c) (b,d)
        psXX (SFArr _ fd1)       (SFArr _ fd2)       = sfArr (fdPar fd1 fd2)
        psXX (SFArr _ FDI)       sf2                 = spAux sf2        -- New
        psXX (SFArr _ (FDC b))   sf2                 = psCX b sf2
        psXX (SFArr _ fd1)       sf2                 = psAX (fdFun fd1) sf2
        psXX sf1                 (SFArr _ FDI)       = fpAux sf1        -- New
        psXX sf1                 (SFArr _ (FDC d))   = psXC sf1 d
        psXX sf1                 (SFArr _ fd2)       = psXA sf1 (fdFun fd2)
-- !!! Unclear if this really is a gain.
-- !!! potentially unnecessary tupling and untupling.
-- !!! To be investigated.
-- !!! 2005-07-01: At least for MEP 6, the corresponding opt for
-- !!! &&& was harmfull. On that basis, disable it here too.
--        psXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) =
--            cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23)
        psXX sf1 sf2 = SF' tf
{-
            if sfIsInv sf1 && sfIsInv sf2 then
                psXXInv sf1 sf2
            else
                SF' tf False
-}
            where
                tf dt ~(a, c) = (psXX sf1' sf2', (b, d))
                    where
                        (sf1', b) = (sfTF' sf1) dt a
                        (sf2', d) = (sfTF' sf2) dt c

{-
        psXXInv :: SF' a b -> SF' c d -> SF' (a,c) (b,d)
        psXXInv sf1 sf2 = SF' tf True
            where
                tf dt ~(a, c) = sf1 `seq` sf2 `seq` (psXXInv sf1' sf2',
                                                       (b, d))
                    where
                        (sf1', b) = (sfTF' sf1) dt a
                        (sf2', d) = (sfTF' sf2) dt c
-}

        psCX :: b -> SF' c d -> SF' (a,c) (b,d)
        psCX b (SFArr _ fd2)       = sfArr (fdPar (FDC b) fd2)
        psCX b sf2                 = SF' tf
{-
            if sfIsInv sf2 then
                psCXInv b sf2
            else
                SF' tf False
-}
            where
                tf dt ~(_, c) = (psCX b sf2', (b, d))
                    where
                        (sf2', d) = (sfTF' sf2) dt c

{-
        psCXInv :: b -> SF' c d -> SF' (a,c) (b,d)
        psCXInv b sf2 = SF' tf True
            where
                tf dt ~(_, c) = sf2 `seq` (psCXInv b sf2', (b, d))
                    where
                        (sf2', d) = (sfTF' sf2) dt c
-}

        psXC :: SF' a b -> d -> SF' (a,c) (b,d)
        psXC (SFArr _ fd1)       d = sfArr (fdPar fd1 (FDC d))
        psXC sf1                 d = SF' tf
{-
            if sfIsInv sf1 then
                psXCInv sf1 d
            else
                SF' tf False
-}
            where
                tf dt ~(a, _) = (psXC sf1' d, (b, d))
                    where
                        (sf1', b) = (sfTF' sf1) dt a

{-
        psXCInv :: SF' a b -> d -> SF' (a,c) (b,d)
        psXCInv sf1 d = SF' tf True
            where
                tf dt ~(a, _) = sf1 `seq` (psXCInv sf1' d, (b, d))
                    where
                        (sf1', b) = (sfTF' sf1) dt a
-}

        psAX :: (a -> b) -> SF' c d -> SF' (a,c) (b,d)
        psAX f1 (SFArr _ fd2)       = sfArr (fdPar (FDG f1) fd2)
        psAX f1 sf2                 = SF' tf
{-
            if sfIsInv sf2 then
                psAXInv f1 sf2
            else
                SF' tf False
-}
            where
                tf dt ~(a, c) = (psAX f1 sf2', (f1 a, d))
                    where
                        (sf2', d) = (sfTF' sf2) dt c

{-
        psAXInv :: (a -> b) -> SF' c d -> SF' (a,c) (b,d)
        psAXInv f1 sf2 = SF' tf True
            where
                tf dt ~(a, c) = sf2 `seq` (psAXInv f1 sf2', (f1 a, d))
                    where
                        (sf2', d) = (sfTF' sf2) dt c
-}

        psXA :: SF' a b -> (c -> d) -> SF' (a,c) (b,d)
        psXA (SFArr _ fd1)       f2 = sfArr (fdPar fd1 (FDG f2))
        psXA sf1                 f2 = SF' tf
{-
            if sfIsInv sf1 then
                psXAInv sf1 f2
            else
                SF' tf False
-}
            where
                tf dt ~(a, c) = (psXA sf1' f2, (b, f2 c))
                    where
                        (sf1', b) = (sfTF' sf1) dt a

{-
        psXAInv :: SF' a b -> (c -> d) -> SF' (a,c) (b,d)
        psXAInv sf1 f2 = SF' tf True
            where
                tf dt ~(a, c) = sf1 `seq` (psXAInv sf1' f2, (b, f2 c))
                    where
                        (sf1', b) = (sfTF' sf1) dt a
-}


-- !!! Hmmm. Why don't we optimize the FDE cases here???
-- !!! Seems pretty obvious that we should!
-- !!! It should also be possible to optimize an event processor in
-- !!! parallel with another event processor or an Arr FDE.

parFanOutPrim :: SF a b -> SF a c -> SF a (b, c)
parFanOutPrim (SF {sfTF = tf10}) (SF {sfTF = tf20}) = SF {sfTF = tf0}
    where
        tf0 a0 = (pfoXX sf1 sf2, (b0, c0))
            where
                (sf1, b0) = tf10 a0
                (sf2, c0) = tf20 a0

        -- Naming convention: pfo<X><Y> where  <X> and <Y> is one of:
        -- X - arbitrary signal function
        -- A - arbitrary pure arrow
        -- I - identity arrow
        -- C - constant arrow

        pfoXX :: SF' a b -> SF' a c -> SF' a (b ,c)
        pfoXX (SFArr _ fd1)       (SFArr _ fd2)       = sfArr(fdFanOut fd1 fd2)
        pfoXX (SFArr _ FDI)       sf2                 = pfoIX sf2
        pfoXX (SFArr _ (FDC b))   sf2                 = pfoCX b sf2
        pfoXX (SFArr _ fd1)       sf2                 = pfoAX (fdFun fd1) sf2
        pfoXX sf1                 (SFArr _ FDI)       = pfoXI sf1
        pfoXX sf1                 (SFArr _ (FDC c))   = pfoXC sf1 c
        pfoXX sf1                 (SFArr _ fd2)       = pfoXA sf1 (fdFun fd2)
-- !!! Unclear if this really would be a gain
-- !!! 2005-07-01: NOT a win for MEP 6.
--        pfoXX (SFCpAXA _ fd11 sf12 fd13) (SFCpAXA _ fd21 sf22 fd23) =
--            cpAXA (fdPar fd11 fd21) (psXX sf12 sf22) (fdPar fd13 fd23)
        pfoXX sf1 sf2 = SF' tf
{-
            if sfIsInv sf1 && sfIsInv sf2 then
                pfoXXInv sf1 sf2
            else
                SF' tf False
-}
            where
                tf dt a = (pfoXX sf1' sf2', (b, c))
                    where
                        (sf1', b) = (sfTF' sf1) dt a
                        (sf2', c) = (sfTF' sf2) dt a

{-
        pfoXXInv :: SF' a b -> SF' a c -> SF' a (b ,c)
        pfoXXInv sf1 sf2 = SF' tf True
            where
                tf dt a = sf1 `seq` sf2 `seq` (pfoXXInv sf1' sf2', (b, c))
                    where
                        (sf1', b) = (sfTF' sf1) dt a
                        (sf2', c) = (sfTF' sf2) dt a
-}

        pfoIX :: SF' a c -> SF' a (a ,c)
        pfoIX (SFArr _ fd2) = sfArr (fdFanOut FDI fd2)
        pfoIX sf2 = SF' tf
{-
            if sfIsInv sf2 then
                pfoIXInv sf2
            else
                SF' tf False
-}
            where
                tf dt a = (pfoIX sf2', (a, c))
                    where
                        (sf2', c) = (sfTF' sf2) dt a

{-
        pfoIXInv :: SF' a c -> SF' a (a ,c)
        pfoIXInv sf2 = SF' tf True
            where
                tf dt a = sf2 `seq` (pfoIXInv sf2', (a, c))
                    where
                        (sf2', c) = (sfTF' sf2) dt a
-}

        pfoXI :: SF' a b -> SF' a (b ,a)
        pfoXI (SFArr _ fd1) = sfArr (fdFanOut fd1 FDI)
        pfoXI sf1 = SF' tf
{-
            if sfIsInv sf1 then
                pfoXIInv sf1
            else
                SF' tf False
-}
            where
                tf dt a = (pfoXI sf1', (b, a))
                    where
                        (sf1', b) = (sfTF' sf1) dt a

{-
        pfoXIInv :: SF' a b -> SF' a (b ,a)
        pfoXIInv sf1 = SF' tf True
            where
                tf dt a = sf1 `seq` (pfoXIInv sf1', (b, a))
                    where
                        (sf1', b) = (sfTF' sf1) dt a
-}

        pfoCX :: b -> SF' a c -> SF' a (b ,c)
        pfoCX b (SFArr _ fd2) = sfArr (fdFanOut (FDC b) fd2)
        pfoCX b sf2 = SF' tf
{-
            if sfIsInv sf2 then
                pfoCXInv b sf2
            else
                SF' tf False
-}
            where
                tf dt a = (pfoCX b sf2', (b, c))
                    where
                        (sf2', c) = (sfTF' sf2) dt a

{-
        pfoCXInv :: b -> SF' a c -> SF' a (b ,c)
        pfoCXInv b sf2 = SF' tf True
            where
                tf dt a = sf2 `seq` (pfoCXInv b sf2', (b, c))
                    where
                        (sf2', c) = (sfTF' sf2) dt a
-}

        pfoXC :: SF' a b -> c -> SF' a (b ,c)
        pfoXC (SFArr _ fd1) c = sfArr (fdFanOut fd1 (FDC c))
        pfoXC sf1 c = SF' tf
{-
            if sfIsInv sf1 then
                pfoXCInv sf1 c
            else
                SF' tf False
-}
            where
                tf dt a = (pfoXC sf1' c, (b, c))
                    where
                        (sf1', b) = (sfTF' sf1) dt a

{-
        pfoXCInv :: SF' a b -> c -> SF' a (b ,c)
        pfoXCInv sf1 c = SF' tf True
            where
                tf dt a = sf1 `seq` (pfoXCInv sf1' c, (b, c))
                    where
                        (sf1', b) = (sfTF' sf1) dt a
-}

        pfoAX :: (a -> b) -> SF' a c -> SF' a (b ,c)
        pfoAX f1 (SFArr _ fd2) = sfArr (fdFanOut (FDG f1) fd2)
        pfoAX f1 sf2 = SF' tf
{-
            if sfIsInv sf2 then
                pfoAXInv f1 sf2
            else
                SF' tf False
-}
            where
                tf dt a = (pfoAX f1 sf2', (f1 a, c))
                    where
                        (sf2', c) = (sfTF' sf2) dt a

{-
        pfoAXInv :: (a -> b) -> SF' a c -> SF' a (b ,c)
        pfoAXInv f1 sf2 = SF' tf True
            where
                tf dt a = sf2 `seq` (pfoAXInv f1 sf2', (f1 a, c))
                    where
                        (sf2', c) = (sfTF' sf2) dt a
-}

        pfoXA :: SF' a b -> (a -> c) -> SF' a (b ,c)
        pfoXA (SFArr _ fd1) f2 = sfArr (fdFanOut fd1 (FDG f2))
        pfoXA sf1 f2 = SF' tf
{-
            if sfIsInv sf1 then
                pfoXAInv sf1 f2
            else
                SF' tf False
-}
            where
                tf dt a = (pfoXA sf1' f2, (b, f2 a))
                    where
                        (sf1', b) = (sfTF' sf1) dt a

{-
        pfoXAInv :: SF' a b -> (a -> c) -> SF' a (b ,c)
        pfoXAInv sf1 f2 = SF' tf True
            where
                tf dt a = sf1 `seq` (pfoXAInv sf1' f2, (b, f2 a))
                    where
                        (sf1', b) = (sfTF' sf1) dt a
-}


-- * ArrowLoop instance and implementation

-- | Creates a feedback loop without delay.
instance ArrowLoop SF where
    loop = loopPrim

loopPrim :: SF (a,c) (b,c) -> SF a b
loopPrim (SF {sfTF = tf10}) = SF {sfTF = tf0}
    where
        tf0 a0 = (loopAux sf1, b0)
            where
                (sf1, (b0, c0)) = tf10 (a0, c0)

        loopAux :: SF' (a,c) (b,c) -> SF' a b
        loopAux (SFArr _ FDI) = sfId
        loopAux (SFArr _ (FDC (b, _))) = sfConst b
        loopAux (SFArr _ fd1) =
            sfArrG (\a -> let (b,c) = (fdFun fd1) (a,c) in b)
        loopAux sf1 = SF' tf
{-
            if sfIsInv sf1 then
                loopInv sf1
            else
                SF' tf False
-}
            where
                tf dt a = (loopAux sf1', b)
                    where
                        (sf1', (b, c)) = (sfTF' sf1) dt (a, c)

{-
        loopInv :: SF' (a,c) (b,c) -> SF' a b
        loopInv sf1 = SF' tf True
            where
                tf dt a = sf1 `seq` (loopInv sf1', b)
                    where
                        (sf1', (b, c)) = (sfTF' sf1) dt (a, c)
-}

-- * Scanning

-- | Constructor for a zero-order hold with folding.
--
--   This function returns a running SF that takes an input, runs it through a
--   function and, if there is an output, returns it, otherwise, returns the
--   previous value. Additionally, an accumulator or folded value is kept
--   internally.
sfSScan :: (c -> a -> Maybe (c, b)) -> c -> b -> SF' a b
sfSScan f c b = sf
    where
        sf = SFSScan tf f c b
        tf _ a = case f c a of
                     Nothing       -> (sf, b)
                     Just (c', b') -> (sfSScan f c' b', b')

-- Vim modeline
-- vim:set tabstop=8 expandtab: