-- | This module contains the classic stream transformer arrow, defined by
--
-- > newtype SF a b = SF { unSF :: a -> (b, SF a b) }
--
-- together with the standard (and some not-that-standard) combinators.
--
-- In particular, we take the viewpoint that each operation for products (pairs)
-- have to have a dual for sums (`Either'). Unfortunately, the Arrow class breaks
-- this symmetry: It favours products by putting the lifting of pure functions
-- there, which should in a separate class instead (there are interesting arrows without 
-- meaningful lifting from Haskell functions).

module Control.Arrow.SF where

--------------------------------------------------------------------------------

import Prelude hiding (init , (.) , id)
import Control.Arrow
import Control.Category 

--------------------------------------------------------------------------------

newtype SF a b = SF { unSF :: a -> (b, SF a b) }

runSF :: SF a b -> [a] -> [b]
runSF (SF f0) = go f0 where 
  go f (x:xs) = let (y, SF f') = f x in y : go f' xs
  go _ [] = []
 
--------------------------------------------------------------------------------

instance Category SF where
  id  = sf_id
  (.) = flip sf_comp

instance Arrow SF where
  arr    = sf_arr
  first  = sf_first
  second = sf_second
  
instance ArrowLoop SF where
  loop = sf_loop

instance ArrowChoice SF where
  left  = sf_left  
  right = sf_right
  
--------------------------------------------------------------------------------
-- * Category

sf_id :: SF a a  
sf_id = u where u = SF $ \x -> (x, u)  

sf_comp :: SF a b -> SF b c -> SF a c
sf_comp f g = SF (g `comp` f) where 
  g `comp` f = \x -> 
    let (y, f') = unSF f x
        (z, g') = unSF g y
    in (z, SF (g' `comp` f')) 

--------------------------------------------------------------------------------
-- * Lift

sf_arr :: (a -> b) -> SF a b      
sf_arr f = u where u = SF $ \x -> (f x, u)

--------------------------------------------------------------------------------
-- * Products
    
sf_first :: SF a b -> SF (a,x) (b,x)
sf_first = u where 
  u r = SF $ \(x,t) -> 
    let (y,r') = unSF r x
    in ((y,t) , u r')

sf_second :: SF a b -> SF (x,a) (x,b)
sf_second = u where 
  u r = SF $ \(t,x) -> 
    let (y,r') = unSF r x
    in ((t,y) , u r')

--------------------------------------------------------------------------------
-- * Sums
    
sf_left :: SF a b -> SF (Either a x) (Either b x)
sf_left = u where
  u cont = SF $ \ei -> case ei of  
    Left  x -> let (y,cont') = unSF cont x in (Left y, u cont')
    Right z -> (Right z, u cont)

sf_right :: SF a b -> SF (Either x a) (Either x b)
sf_right = u where
  u cont = SF $ \ei -> case ei of  
    Right x -> let (y,cont') = unSF cont x in (Right y, u cont')
    Left  z -> (Left z, u cont)

--------------------------------------------------------------------------------
-- * Loop (product)

sf_loop :: SF (a,s) (b,s) -> SF a b
sf_loop f = SF (h f) where
  h f x = let (~(y,z),f') = unSF f (x,z)
          in  (y, SF (h f'))

--------------------------------------------------------------------------------
-- * Loop (sum)

-- | The dual of `loop'. 
sf_eitherLoop :: SF (Either a c) (Either b c) -> SF a b
sf_eitherLoop big = SF (go1 big) where

  go1 ::  SF (Either a c) (Either b c) -> a -> (b, SF a b)
  go1 big = \x -> (go2 big) (Left x) where  
 
  go2 ::  SF (Either a c) (Either b c) -> Either a c -> (b, SF a b)
  go2 big = \ei ->
    let (ei',big') = unSF big ei
    in  case ei' of
          Left  y -> (y, SF (go1 big'))
          Right z -> (go2 big') (Right z)

--------------------------------------------------------------------------------
-- * Delay

-- | An initialized delay.
sf_init :: a -> SF a a
sf_init i = SF (h i) where h i x = (i, SF (h x))

-- | Loop with delay (that is, a state machine).
sf_loopD :: s -> ((a,s) -> (b,s)) -> SF a b
sf_loopD j f = sf_loop (sf_arr f >>> sf_second (sf_init j))

--------------------------------------------------------------------------------
-- * State machine

-- | This is actually equivalent to `sf_loopD'.
sf_mealy_ :: s -> (a -> s -> (b,s)) -> SF a b
sf_mealy_ s0 f = go s0 where
  go s = SF $ \x -> let (y,t) = f x s in (y, go t)

sf_mealy :: s -> (a -> s -> (b,s)) -> SF a (b,s)
sf_mealy s0 f = go s0 where
  go s = SF $ \x -> let yt@(y,t) = f x s in (yt, go t)

-- | This is the dual of `sf_loopD'. It looks a bit strange, but basically what
-- happens is that state transitions happen only when then input triggers them,
-- and meantime it is sleeping, remembering the old state. The new state will
-- depend only on the input when the transition was triggered, and the new output
-- will depend on the old state.
sf_eitherMachine :: s -> (Either a s -> Either b s) -> SF a b
sf_eitherMachine s0 f = sf_eitherLoop (sf_arr f >>> sf_right (sf_init s0))

--------------------------------------------------------------------------------
-- * Delta \/ merge

-- | These are actually pure functions.
sf_delta :: SF a (a,a)
sf_delta = sf_arr $ \x -> (x,x)

sf_merge :: SF (Either a a) a
sf_merge = sf_arr $ \ei -> case ei of { Left x -> x ; Right y -> y }

--------------------------------------------------------------------------------
-- * Maybe

sf_compMaybe :: SF a (Maybe b) -> SF b c -> SF a (Maybe c)
sf_compMaybe f g = SF (g `comp` f) where  -- sf_comp f (sf_liftMaybe g)
  g `comp` f = \x -> 
    let (my, f') = unSF f x
        (mz, g') = case my of
          Just y  -> let (z,g') = unSF g y in (Just z, g')
          Nothing -> (Nothing, g)
    in (mz, SF (g' `comp` f')) 
  
sf_liftMaybe :: SF a b -> SF (Maybe a) (Maybe b)  
sf_liftMaybe = u where
  u cont = SF $ \ei -> case ei of  
    Just x  -> let (y,cont') = unSF cont x in (Just y, u cont')
    Nothing -> (Nothing, u cont) 

-- | This is a pure function, too.
sf_justA :: SF a (Maybe a)      
sf_justA    = go where go = SF $ \x -> (Just x  , go)

sf_nothingA :: SF x (Maybe a)      
sf_nothingA = go where go = SF $ \_ -> (Nothing , go)
      
--------------------------------------------------------------------------------