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 = forall sig. Read sig => sig -> Int
CutG.length a
a
       lenB :: Int
lenB = forall sig. Read sig => sig -> Int
CutG.length b
b
   in  if Int
lenA forall a. Eq a => a -> a -> Bool
== Int
lenB
         then forall a b. a -> b -> T a b
Cons a
a b
b
         else forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"different lengths " forall a. [a] -> [a] -> [a]
++
              forall a. Show a => a -> String
show Int
lenA forall a. [a] -> [a] -> [a]
++ String
" vs. " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
lenB forall a. [a] -> [a] -> [a]
++ String
" in " 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 = forall a. Ord a => a -> a -> a
min (forall sig. Read sig => sig -> Int
CutG.length a
a) (forall sig. Read sig => sig -> Int
CutG.length b
b)
   in  forall a b. a -> b -> T a b
Cons (forall sig. Transform sig => Int -> sig -> sig
CutG.take Int
len a
a) (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 =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. a -> b -> T a b
Cons
   forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arrow.first arrow a b
arrow
   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 =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. a -> b -> T a b
Cons
   forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
Arrow.second arrow a b
arrow
   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 =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (Transform a, Transform b) => a -> b -> T a b
consShorten
   forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
Arrow.first arrow a b
arrow
   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 =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. (Transform a, Transform b) => a -> b -> T a b
consShorten
   forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
^<<
   forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
Arrow.second arrow a b
arrow
   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 =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. a -> b -> T a b
Cons  forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
Arrow.^<<  arrow a b
b 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 =
   forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a b. a -> b -> T a b
Cons  forall (a :: * -> * -> *) c d b.
Arrow a =>
(c -> d) -> a b c -> a b d
Arrow.^<<  arrow a c
x forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
Arrow.*** arrow b d
y  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 =
   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 forall (a :: * -> * -> *) c d b.
Arrow a =>
a c d -> (b -> c) -> a b d
<<^ (\a
x -> 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 =
   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 forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
<<< 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 = forall a b. a -> b -> T a b
Cons (a
a0 forall a. Semigroup a => a -> a -> a
<> a
a1) (b
b0 forall a. Semigroup a => a -> a -> a
<> b
b1)

instance (Monoid a, Monoid b) => Monoid (T a b) where
   mempty :: T a b
mempty = forall a b. a -> b -> T a b
Cons forall a. Monoid a => a
mempty 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) =
      forall a b. a -> b -> T a b
Cons (forall a. Monoid a => a -> a -> a
mappend a
a0 a
a1) (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 (forall sig. Read sig => sig -> Bool
CutG.null a
a, 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)
_ -> 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 = forall sig. Read sig => sig -> Int
CutG.length a
a
          lenB :: Int
lenB = forall sig. Read sig => sig -> Int
CutG.length b
b
      in  if Int
lenA forall a. Eq a => a -> a -> Bool
== Int
lenB
            then Int
lenA
            else 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 (forall sig. NormalForm sig => sig -> ()
CutG.evaluateHead a
a, 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) =
      forall a b. a -> b -> T a b
Cons (forall sig. Transform sig => Int -> sig -> sig
CutG.take Int
n a
a) (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) =
      forall a b. a -> b -> T a b
Cons (forall sig. Transform sig => Int -> sig -> sig
CutG.drop Int
n a
a) (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) = forall sig. Transform sig => Int -> sig -> (sig, sig)
CutG.splitAt Int
n a
a
          (b
b0,b
b1) = forall sig. Transform sig => Int -> sig -> (sig, sig)
CutG.splitAt Int
n b
b
      in  (forall a b. a -> b -> T a b
Cons a
a0 b
b0, 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) = forall sig. Transform sig => Int -> Int -> sig -> (Int, sig)
CutG.dropMarginRem Int
n Int
m a
a0
          (Int
kb,b
b1) = forall sig. Transform sig => Int -> Int -> sig -> (Int, sig)
CutG.dropMarginRem Int
n Int
m b
b0
      in  if Int
kaforall a. Eq a => a -> a -> Bool
==Int
kb
            then (Int
ka, forall a b. a -> b -> T a b
Cons a
a1 b
b1)
            else 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) =
      forall a b. a -> b -> T a b
Cons (forall sig. Transform sig => sig -> sig
CutG.reverse a
a) (forall sig. Transform sig => sig -> sig
CutG.reverse b
b)