{- |
Adaption of "Control.Arrow" to signal processes involving amplitudes.
This class unifies "Synthesizer.Dimensional.Map"
and "Synthesizer.Dimensional.Causal.Process".
-}
module Synthesizer.Dimensional.Arrow where

import qualified Synthesizer.Dimensional.Map as Map
import Data.Tuple.HT (mapFst, mapSnd, mapPair, )

import qualified Prelude as P
import Prelude hiding (map, id, fst, snd, )


class C arrow where
   map ::
      Map.T amp0 amp1 yv0 yv1 ->
      arrow amp0 amp1 yv0 yv1
   (>>>) ::
      arrow amp0 amp1 yv0 yv1 ->
      arrow amp1 amp2 yv1 yv2 ->
      arrow amp0 amp2 yv0 yv2
   first ::
      arrow amp0 amp1 yv0 yv1 ->
      arrow (amp0, amp) (amp1, amp) (yv0, yv) (yv1, yv)
   second ::
      arrow amp0 amp1 yv0 yv1 ->
      arrow (amp, amp0) (amp, amp1) (yv, yv0) (yv, yv1)
   (***) ::
      arrow amp0 amp1 yv0 yv1 ->
      arrow amp2 amp3 yv2 yv3 ->
      arrow (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3)
   (&&&) ::
      arrow amp amp0 yv yv0 ->
      arrow amp amp1 yv yv1 ->
      arrow amp (amp0, amp1) yv (yv0, yv1)

   {-# INLINE second #-}
   second arr = Map.swap ^<< first arr <<^ Map.swap
   {-# INLINE (***) #-}
   f *** g = first f <<< second g
   {-# INLINE (&&&) #-}
   f &&& g = f***g <<^ Map.double


instance C Map.T where
   map = P.id
   (Map.Cons f) >>> (Map.Cons g) =
      Map.Cons $ \x ->
         let (y, h) = f x
             (z, k) = g y
         in  (z, k . h)
   first (Map.Cons f) =
      Map.Cons $ \(x,z) ->
         let (y, g) = f x
         in  ((y,z), mapFst g)
   second (Map.Cons f) =
      Map.Cons $ \(z,x) ->
         let (y, g) = f x
         in  ((z,y), mapSnd g)
   (Map.Cons f) *** (Map.Cons g) =
      Map.Cons $ \(x,y) ->
         let (z, h) = f x
             (w, k) = g y
         in  ((z,w), mapPair (h,k))
   (Map.Cons f) &&& (Map.Cons g) =
      Map.Cons $ \x ->
         let (y, h) = f x
             (z, k) = g x
         in  ((y,z), \s -> (h s, k s))


infixr 3 ***
infixr 3 &&&
infixr 1 >>>, ^>>, >>^
infixr 1 <<<, ^<<, <<^


{-# INLINE compose #-}
compose :: (C arrow) =>
   arrow amp0 amp1 yv0 yv1 ->
   arrow amp1 amp2 yv1 yv2 ->
   arrow amp0 amp2 yv0 yv2
compose = (>>>)

{-# INLINE (<<<) #-}
(<<<) :: (C arrow) =>
   arrow amp1 amp2 yv1 yv2 ->
   arrow amp0 amp1 yv0 yv1 ->
   arrow amp0 amp2 yv0 yv2
(<<<) = flip (>>>)


{-# INLINE split #-}
split :: (C arrow) =>
   arrow amp0 amp1 yv0 yv1 ->
   arrow amp2 amp3 yv2 yv3 ->
   arrow (amp0, amp2) (amp1, amp3) (yv0, yv2) (yv1, yv3)
split = (***)

{-# INLINE fanout #-}
fanout :: (C arrow) =>
   arrow amp amp0 yv yv0 ->
   arrow amp amp1 yv yv1 ->
   arrow amp (amp0, amp1) yv (yv0, yv1)
fanout = (&&&)

-- * map functions

{-# INLINE (^>>) #-}
-- | Precomposition with a pure function.
(^>>) :: (C arrow) =>
   Map.T amp0 amp1 yv0 yv1 ->
   arrow amp1 amp2 yv1 yv2 ->
   arrow amp0 amp2 yv0 yv2
f ^>> a = map f >>> a

{-# INLINE (>>^) #-}
-- | Postcomposition with a pure function.
(>>^) :: (C arrow) =>
   arrow amp0 amp1 yv0 yv1 ->
   Map.T amp1 amp2 yv1 yv2 ->
   arrow amp0 amp2 yv0 yv2
a >>^ f = a >>> map f

{-# INLINE (<<^) #-}
-- | Precomposition with a pure function (right-to-left variant).
(<<^) :: (C arrow) =>
   arrow amp1 amp2 yv1 yv2 ->
   Map.T amp0 amp1 yv0 yv1 ->
   arrow amp0 amp2 yv0 yv2
a <<^ f = a <<< map f

{-# INLINE (^<<) #-}
-- | Postcomposition with a pure function (right-to-left variant).
(^<<) :: (C arrow) =>
   Map.T amp1 amp2 yv1 yv2 ->
   arrow amp0 amp1 yv0 yv1 ->
   arrow amp0 amp2 yv0 yv2
f ^<< a = map f <<< a