module Synthesizer.Zip where

import qualified Synthesizer.Generic.Cut as CutG

import qualified Control.Arrow as Arrow
import Control.Arrow (Arrow, (<<<), (^<<), (<<^), )

import Data.Monoid (Monoid, mempty, mappend, )
import Data.Semigroup (Semigroup, (<>), )


{- |
Parallel combination of two signals of equal length.
-}
data T a b = Cons {forall a b. T a b -> a
first :: a, forall a b. T a b -> b
second :: b}

{- |
Zip together two signals.
It is a checked error if their lengths differ.
-}
consChecked ::
   (CutG.Read a, CutG.Read b) =>
   String -> a -> b -> T a b
consChecked :: forall a b. (Read a, Read b) => String -> a -> b -> T a b
consChecked String
name a
a b
b =
   let lenA :: Int
lenA = a -> Int
forall sig. Read sig => sig -> Int
CutG.length a
a
       lenB :: Int
lenB = b -> Int
forall sig. Read sig => sig -> Int
CutG.length b
b
   in  if Int
lenA Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lenB
         then a -> b -> T a b
forall a b. a -> b -> T a b
Cons a
a b
b
         else String -> T a b
forall a. HasCallStack => String -> a
error (String -> T a b) -> String -> T a b
forall a b. (a -> b) -> a -> b
$ String
"different lengths " String -> String -> String
forall a. [a] -> [a] -> [a]
++
              Int -> String
forall a. Show a => a -> String
show Int
lenA String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" vs. " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
lenB String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" in " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name

{- |
Zip together two signals
and shorten them to the length of the shorter one.
-}
consShorten ::
   (CutG.Transform a, CutG.Transform b) =>
   a -> b -> T a b
consShorten :: forall a b. (Transform a, Transform b) => a -> b -> T a b
consShorten a
a b
b =
   let len :: Int
len = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (a -> Int
forall sig. Read sig => sig -> Int
CutG.length a
a) (b -> Int
forall sig. Read sig => sig -> Int
CutG.length b
b)
   in  a -> b -> T a b
forall a b. a -> b -> T a b
Cons (Int -> a -> a
forall sig. Transform sig => Int -> sig -> sig
CutG.take Int
len a
a) (Int -> b -> b
forall sig. Transform sig => Int -> sig -> sig
CutG.take Int
len b
b)



arrowFirst ::
   Arrow arrow =>
   arrow a b -> arrow (T a c) (T b c)
arrowFirst :: forall (arrow :: * -> * -> *) a b c.
Arrow arrow =>
arrow a b -> arrow (T a c) (T b c)
arrowFirst arrow a b
arrow =
   (b -> c -> T b c) -> (b, c) -> T b c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> c -> T b c
forall a b. a -> b -> T a b
Cons
   ((b, c) -> T b c) -> arrow (T a c) (b, c) -> arrow (T a c) (T b c)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   arrow a b -> arrow (a, c) (b, c)
forall b c d. arrow b c -> arrow (b, d) (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arrow.first arrow a b
arrow
   arrow (a, c) (b, c) -> (T a c -> (a, c)) -> arrow (T a c) (b, c)
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^
   (\(Cons a
a c
b) -> (a
a,c
b))

arrowSecond ::
   Arrow arrow =>
   arrow a b -> arrow (T c a) (T c b)
arrowSecond :: forall (arrow :: * -> * -> *) a b c.
Arrow arrow =>
arrow a b -> arrow (T c a) (T c b)
arrowSecond arrow a b
arrow =
   (c -> b -> T c b) -> (c, b) -> T c b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry c -> b -> T c b
forall a b. a -> b -> T a b
Cons
   ((c, b) -> T c b) -> arrow (T c a) (c, b) -> arrow (T c a) (T c b)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   arrow a b -> arrow (c, a) (c, b)
forall b c d. arrow b c -> arrow (d, b) (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
Arrow.second arrow a b
arrow
   arrow (c, a) (c, b) -> (T c a -> (c, a)) -> arrow (T c a) (c, b)
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^
   (\(Cons c
a a
b) -> (c
a,a
b))

arrowFirstShorten ::
   (Arrow arrow, CutG.Transform b, CutG.Transform c) =>
   arrow a b -> arrow (T a c) (T b c)
arrowFirstShorten :: forall (arrow :: * -> * -> *) b c a.
(Arrow arrow, Transform b, Transform c) =>
arrow a b -> arrow (T a c) (T b c)
arrowFirstShorten arrow a b
arrow =
   (b -> c -> T b c) -> (b, c) -> T b c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> c -> T b c
forall a b. (Transform a, Transform b) => a -> b -> T a b
consShorten
   ((b, c) -> T b c) -> arrow (T a c) (b, c) -> arrow (T a c) (T b c)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   arrow a b -> arrow (a, c) (b, c)
forall b c d. arrow b c -> arrow (b, d) (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arrow.first arrow a b
arrow
   arrow (a, c) (b, c) -> (T a c -> (a, c)) -> arrow (T a c) (b, c)
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^
   (\(Cons a
a c
b) -> (a
a,c
b))

arrowSecondShorten ::
   (Arrow arrow, CutG.Transform b, CutG.Transform c) =>
   arrow a b -> arrow (T c a) (T c b)
arrowSecondShorten :: forall (arrow :: * -> * -> *) b c a.
(Arrow arrow, Transform b, Transform c) =>
arrow a b -> arrow (T c a) (T c b)
arrowSecondShorten arrow a b
arrow =
   (c -> b -> T c b) -> (c, b) -> T c b
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry c -> b -> T c b
forall a b. (Transform a, Transform b) => a -> b -> T a b
consShorten
   ((c, b) -> T c b) -> arrow (T c a) (c, b) -> arrow (T c a) (T c b)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   arrow a b -> arrow (c, a) (c, b)
forall b c d. arrow b c -> arrow (d, b) (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
Arrow.second arrow a b
arrow
   arrow (c, a) (c, b) -> (T c a -> (c, a)) -> arrow (T c a) (c, b)
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^
   (\(Cons c
a a
b) -> (c
a,a
b))


arrowFanout ::
   Arrow arrow =>
   arrow a b -> arrow a c -> arrow a (T b c)
arrowFanout :: forall (arrow :: * -> * -> *) a b c.
Arrow arrow =>
arrow a b -> arrow a c -> arrow a (T b c)
arrowFanout arrow a b
b arrow a c
c =
   (b -> c -> T b c) -> (b, c) -> T b c
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry b -> c -> T b c
forall a b. a -> b -> T a b
Cons  ((b, c) -> T b c) -> arrow a (b, c) -> arrow a (T b c)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
Arrow.^<<  arrow a b
b arrow a b -> arrow a c -> arrow a (b, c)
forall b c c'. arrow b c -> arrow b c' -> arrow b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
Arrow.&&& arrow a c
c

arrowSplit ::
   Arrow arrow =>
   arrow a c -> arrow b d -> arrow (T a b) (T c d)
arrowSplit :: forall (arrow :: * -> * -> *) a c b d.
Arrow arrow =>
arrow a c -> arrow b d -> arrow (T a b) (T c d)
arrowSplit arrow a c
x arrow b d
y =
   (c -> d -> T c d) -> (c, d) -> T c d
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry c -> d -> T c d
forall a b. a -> b -> T a b
Cons  ((c, d) -> T c d) -> arrow (T a b) (c, d) -> arrow (T a b) (T c d)
forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
Arrow.^<<  arrow a c
x arrow a c -> arrow b d -> arrow (a, b) (c, d)
forall b c b' c'. arrow b c -> arrow b' c' -> arrow (b, b') (c, c')
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
Arrow.*** arrow b d
y  arrow (a, b) (c, d) -> (T a b -> (a, b)) -> arrow (T a b) (c, d)
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
Arrow.<<^  (\(Cons a
a b
b) -> (a
a,b
b))


arrowFanoutShorten ::
   (Arrow arrow, CutG.Transform a, CutG.Transform b, CutG.Transform c) =>
   arrow a b -> arrow a c -> arrow a (T b c)
arrowFanoutShorten :: forall (arrow :: * -> * -> *) a b c.
(Arrow arrow, Transform a, Transform b, Transform c) =>
arrow a b -> arrow a c -> arrow a (T b c)
arrowFanoutShorten arrow a b
a arrow a c
b =
   arrow a b -> arrow a c -> arrow (T a a) (T b c)
forall (arrow :: * -> * -> *) a b c d.
(Arrow arrow, Transform a, Transform b, Transform c,
 Transform d) =>
arrow a c -> arrow b d -> arrow (T a b) (T c d)
arrowSplitShorten arrow a b
a arrow a c
b arrow (T a a) (T b c) -> (a -> T a a) -> arrow a (T b c)
forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^ (\a
x -> a -> a -> T a a
forall a b. a -> b -> T a b
Cons a
x a
x)

arrowSplitShorten ::
   (Arrow arrow,
    CutG.Transform a, CutG.Transform b, CutG.Transform c, CutG.Transform d) =>
   arrow a c -> arrow b d -> arrow (T a b) (T c d)
arrowSplitShorten :: forall (arrow :: * -> * -> *) a b c d.
(Arrow arrow, Transform a, Transform b, Transform c,
 Transform d) =>
arrow a c -> arrow b d -> arrow (T a b) (T c d)
arrowSplitShorten arrow a c
a arrow b d
b =
   arrow a c -> arrow (T a d) (T c d)
forall (arrow :: * -> * -> *) b c a.
(Arrow arrow, Transform b, Transform c) =>
arrow a b -> arrow (T a c) (T b c)
arrowFirstShorten arrow a c
a arrow (T a d) (T c d)
-> arrow (T a b) (T a d) -> arrow (T a b) (T c d)
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< arrow b d -> arrow (T a b) (T a d)
forall (arrow :: * -> * -> *) b c a.
(Arrow arrow, Transform b, Transform c) =>
arrow a b -> arrow (T c a) (T c b)
arrowSecondShorten arrow b d
b


instance (Semigroup a, Semigroup b) => Semigroup (T a b) where
   Cons a
a0 b
b0 <> :: T a b -> T a b -> T a b
<> Cons a
a1 b
b1 = a -> b -> T a b
forall a b. a -> b -> T a b
Cons (a
a0 a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
a1) (b
b0 b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
b1)

instance (Monoid a, Monoid b) => Monoid (T a b) where
   mempty :: T a b
mempty = a -> b -> T a b
forall a b. a -> b -> T a b
Cons a
forall a. Monoid a => a
mempty b
forall a. Monoid a => a
mempty
   mappend :: T a b -> T a b -> T a b
mappend (Cons a
a0 b
b0) (Cons a
a1 b
b1) =
      a -> b -> T a b
forall a b. a -> b -> T a b
Cons (a -> a -> a
forall a. Monoid a => a -> a -> a
mappend a
a0 a
a1) (b -> b -> b
forall a. Monoid a => a -> a -> a
mappend b
b0 b
b1)

instance (CutG.Read a, CutG.Read b) => CutG.Read (T a b) where
   {-# INLINE null #-}
   null :: T a b -> Bool
null (Cons a
a b
b) =
      case (a -> Bool
forall sig. Read sig => sig -> Bool
CutG.null a
a, b -> Bool
forall sig. Read sig => sig -> Bool
CutG.null b
b) of
         (Bool
False, Bool
False) -> Bool
False
         (Bool
True, Bool
True) -> Bool
True
         (Bool, Bool)
_ -> String -> Bool
forall a. HasCallStack => String -> a
error String
"Zipped signals: one is empty and the other one is not"
   {-# INLINE length #-}
   length :: T a b -> Int
length (Cons a
a b
b) =
      let lenA :: Int
lenA = a -> Int
forall sig. Read sig => sig -> Int
CutG.length a
a
          lenB :: Int
lenB = b -> Int
forall sig. Read sig => sig -> Int
CutG.length b
b
      in  if Int
lenA Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
lenB
            then Int
lenA
            else String -> Int
forall a. HasCallStack => String -> a
error String
"Zipped signals: the lengths differ"

{-
Parallel combination of two signals
where the combined signal has the length of the shorter member.
This is like in zipWith.

instance (CutG.Read a, CutG.Read b) => CutG.Read (Parallel a b) where
   null (Parallel a b) = CutG.null a || CutG.null b
   length (Parallel a b) = min (CutG.length a) (CutG.length b)
-}

instance (CutG.NormalForm a, CutG.NormalForm b) => CutG.NormalForm (T a b) where
   {-# INLINE evaluateHead #-}
   evaluateHead :: T a b -> ()
evaluateHead (Cons a
a b
b) =
      case (a -> ()
forall sig. NormalForm sig => sig -> ()
CutG.evaluateHead a
a, b -> ()
forall sig. NormalForm sig => sig -> ()
CutG.evaluateHead b
b) of
         ((), ()) -> ()

instance (CutG.Transform a, CutG.Transform b) => CutG.Transform (T a b) where
   {-# INLINE take #-}
   take :: Int -> T a b -> T a b
take Int
n (Cons a
a b
b) =
      a -> b -> T a b
forall a b. a -> b -> T a b
Cons (Int -> a -> a
forall sig. Transform sig => Int -> sig -> sig
CutG.take Int
n a
a) (Int -> b -> b
forall sig. Transform sig => Int -> sig -> sig
CutG.take Int
n b
b)
   {-# INLINE drop #-}
   drop :: Int -> T a b -> T a b
drop Int
n (Cons a
a b
b) =
      a -> b -> T a b
forall a b. a -> b -> T a b
Cons (Int -> a -> a
forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
n a
a) (Int -> b -> b
forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
n b
b)
   {-# INLINE splitAt #-}
   splitAt :: Int -> T a b -> (T a b, T a b)
splitAt Int
n (Cons a
a b
b) =
      let (a
a0,a
a1) = Int -> a -> (a, a)
forall sig. Transform sig => Int -> sig -> (sig, sig)
CutG.splitAt Int
n a
a
          (b
b0,b
b1) = Int -> b -> (b, b)
forall sig. Transform sig => Int -> sig -> (sig, sig)
CutG.splitAt Int
n b
b
      in  (a -> b -> T a b
forall a b. a -> b -> T a b
Cons a
a0 b
b0, a -> b -> T a b
forall a b. a -> b -> T a b
Cons a
a1 b
b1)
   {-# INLINE dropMarginRem #-}
   dropMarginRem :: Int -> Int -> T a b -> (Int, T a b)
dropMarginRem Int
n Int
m (Cons a
a0 b
b0) =
      let (Int
ka,a
a1) = Int -> Int -> a -> (Int, a)
forall sig. Transform sig => Int -> Int -> sig -> (Int, sig)
CutG.dropMarginRem Int
n Int
m a
a0
          (Int
kb,b
b1) = Int -> Int -> b -> (Int, b)
forall sig. Transform sig => Int -> Int -> sig -> (Int, sig)
CutG.dropMarginRem Int
n Int
m b
b0
      in  if Int
kaInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
kb
            then (Int
ka, a -> b -> T a b
forall a b. a -> b -> T a b
Cons a
a1 b
b1)
            else String -> (Int, T a b)
forall a. HasCallStack => String -> a
error String
"Zip.dropMarginRem: margins differ"
   {-# INLINE reverse #-}
   reverse :: T a b -> T a b
reverse (Cons a
a b
b) =
      a -> b -> T a b
forall a b. a -> b -> T a b
Cons (a -> a
forall sig. Transform sig => sig -> sig
CutG.reverse a
a) (b -> b
forall sig. Transform sig => sig -> sig
CutG.reverse b
b)