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, (<>), )
data T a b = Cons {forall a b. T a b -> a
first :: a, forall a b. T a b -> b
second :: b}
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
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"
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)