{-# LANGUAGE
    MultiParamTypeClasses,
    FlexibleContexts,
    FlexibleInstances,
    UndecidableInstances,
    ExistentialQuantification,
    TypeSynonymInstances,
    Rank2Types,
    NoMonomorphismRestriction #-}

module SigOp(SigOp(..)
            ,sigOpComp
            ,int, dif, z
            ,Sig, sigRun, sigInf, sigFun
            ,dirac, ndirac
            ,step, nstep
            ,ramp, nramp
            ) where

import SigState

import Prelude hiding ((.), id)
import Control.Category
import Control.Applicative
import Control.Monad
import Control.Arrow
import Data.Functor.Identity
import Control.Monad.State

{-

The SigOp data type abstracts causal sequence operators.

Causality refers to the principle that the operator cannot use
"future" sequence data.

SigOps are represented by an update equation bundled with an
initial condition.  


The code is split in two parts: low-level operations and data type.



1. Primitives & compositions
----------------------------

Composing SigOps is like composing functions, placing them in
series linking the output of one to input of another.  The state
inputs/outputs of both SigOps are bundled in parallel.

Note that state is *private*.  It is not threaded between both
elements that are composed, i.e. this is not a State Monad.

-}

ssmSer :: ((s1, b)     -> (s1, c)) ->
          ((s2, a)     -> (s2, b)) ->
          ((s1,s2), a) -> ((s1,s2), c)
              
ssmSer f g = fg where
  fg ((s1,s2), a) = ((s1',s2'), c) where
    (s2', b) = g (s2, a)
    (s1', c) = f (s1, b)
    
{-

Another way to compose operators is to take their product, placing
them in parallel.

-}
  
ssmPar :: ((s1, a)         -> (s1, c)) ->
          ((s2, b)         -> (s2, d)) ->
          ((s1,s2), (a,b)) -> ((s1,s2), (c,d))
ssmPar f g = fg where          
  fg ((s1,s2), (a,b)) = ((s1',s2'), (c,d)) where
    (s1',c) = f (s1, a)
    (s2',d) = g (s2, b)
    
{-

Lifting pure functions.  A pure function is an SigOp with void
state.

-}

ssmPure :: (a -> b) -> ((), a) -> ((), b)
ssmPure f ((), a) = ((), f a)

{-

2. Data type
------------

Define a data type to bundle initial state together with update
functions that support the operations above.

The goal is to make this SigOp an instance of Category & Arrow.

Unfortunately it's not possible to expose the state type as a
parameter in SigOp:

   data SigOp s i o = SigOp s ((s, i) -> (s, o))

Composing 2 of these will have the type

   SigOp s1 b c -> SigOp s2 a b -> SigOp (s1,s2) a b

which will not fit the expected kind for Category: * -> * -> *.  To
hide the non-constant state type we use an existential quantification.

To be able to get at the state later (i.e. for abstract evaluation) an
interface SigState is imposed.


-}
  
data SigOp i o = forall s. (SigState s) => SigOp ((s, i) -> (s, o)) s


-- Some lifting functions to write the Category and Arrow composition
-- operations in terms of ssmSer and ssmPar which use (,) for state
-- product expressed in terms of StateProd
a `sp` b = StateProd (a,b)
spl f = f' where
  f' ((StateProd s), i) = ((StateProd s'), o) where
    (s', o) = f (s, i)



-- SigOp can be composed by composing the update functions and the
-- initial state variables.  This gives rise to Category.  

instance Category SigOp where
  (.) (SigOp f f0) (SigOp g g0) = SigOp (spl (f `ssmSer` g)) (f0 `sp` g0)
  id  = SigOp id ()
  
-- Adding also parallel composition and lifting of pure functions
-- gives an Arrow instance.  
  
-- ( Note that arr and first are enough, but we already have (***) so
-- use that to implement first. )
instance Arrow SigOp where
  arr f = SigOp (ssmPure f) ()
  (***) (SigOp f f0) (SigOp g g0) = SigOp (spl (f `ssmPar` g)) (f0 `sp` g0)
  first   a = a *** (arr id)
  second  a = (arr id) *** a
  
  
{- 

Note that these Arrows can not be the Kleisli arrows of a Monad
because of a value to type dependency that prevents composition.

In short, the following types are not isomorphic:

  i -> (SigOp () o)
  SigOp i o

In the former, the hidden s type can depend on i, in the latter it
cannot.

-}


-- Define some well-known linear SigOp.
sigOp0 fn = SigOp fn 0

-- id = int . dif = dif . int
int = sigOp0 $ \(s, i) -> let o = i+s in (o, o)
dif = sigOp0 $ \(s, i) -> let o = i-s in (i, o)

z   = sigOp0 $ \(s, i) -> (i, s)


-- Sig are SigOp without input.  Applying an SigOp to a
-- Sig using (.) produces another Sig.
type Sig a = SigOp () a

-- Sig can be unfolded to infinite lists.  
sigRun :: Sig a -> [a]
sigRun (SigOp update init) = f init where
  f s = (o:os) where
    (s', o) = update (s, ())
    os = f s'


-- Infinite lists can be converted to Sig by allowing infinite state
-- size.  This defeats the point of having a finite initial state and
-- update equation for abstract evaluation.  However, it's useful for
-- testing SigOp with inputs that cannot be represented as a Sig, i.e
-- live input from a DAC.
-- sigInf :: SigState [a] => [a] -> Sig a
sigInf = SigOp $ \(d:ds, ()) -> (ds, d)


-- Define some well-known signals.
ndirac :: (Num n, SigState n) => n -> Sig n
ndirac n0 = SigOp update n0 where
  update (n, i) = (n-1, if (n == 0) then 1 else 0)
  
nstep n = int . (ndirac n)
nramp n = int . (nstep n)

dirac = ndirac 0
step  = nstep 0
ramp  = nramp 0   -- [1,2,..]


-- Lift sequences represented as functions to Sig.
-- sigFun :: (Num n, SigState n) => (n -> a) -> SigOp () a
sigFun f = (arr f) . ramp



-- Define Functor and Applicative instances for the output of SigOp.
-- This is useful for lifting arithmetic to SigOp / Sig.
instance Functor (SigOp i) where
  fmap f op = (arr f) . op
instance Applicative (SigOp i) where
  pure f = arr $ \_ -> f
  (<*>) f a = fmap (uncurry ($)) (f &&& a)


  
-- Other queries.
stateSize (SigOp _ s0) = n where
  (n, _) = stateIndex 0 s0



-- Evaluate a single tick, using an indexed initial state.


sigOpComp i (SigOp u s0) = report where
  report = ([stateShow si,
             stateShow s0,
             stateShow so],
            stateShow o) where
  si = snd $ stateIndex 0 s0
  (so,o) = u (si, i)