{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# OPTIONS_GHC -Wall #-}
#include "ConCat/AbsTy.inc"
AbsTyPragmas
module ConCat.AdditiveFun
( Additive1(..), type (-+>)(..), addFun, addFun', unAddFun
, module ConCat.Additive
) where
import Prelude hiding (id,(.),const,curry,uncurry,zipWith)
import Data.Constraint (Dict(..),(:-)(..))
import Data.Key (Zip)
import Data.Pointed (Pointed)
import Data.Functor.Rep (Representable(tabulate,index))
import ConCat.Orphans ()
import qualified ConCat.Category as Category
import ConCat.AltCat
import ConCat.Rep
import ConCat.Additive
import qualified ConCat.Inline.ClassOp as IC
AbsTyImports
infixr 1 -+>
newtype a -+> b = AddFun (a -> b)
unAddFun :: (a -+> b) -> (a -> b)
unAddFun :: forall a b. (a -+> b) -> a -> b
unAddFun (AddFun a -> b
f) = a -> b
f
{-# INLINE unAddFun #-}
instance HasRep (a -+> b) where
type Rep (a -+> b) = a -> b
abst :: Rep (a -+> b) -> a -+> b
abst Rep (a -+> b)
f = (a -> b) -> a -+> b
forall a b. (a -> b) -> a -+> b
AddFun Rep (a -+> b)
a -> b
f
repr :: (a -+> b) -> Rep (a -+> b)
repr (AddFun a -> b
f) = Rep (a -+> b)
a -> b
f
AbsTy(a -+> b)
#define OPINLINE INLINE
#define Abst(nm) nm = abst nm ; {-# INLINE nm #-}
instance Additive b => Additive (a -+> b) where
zero :: a -+> b
Abst(zero)
^+^ :: (a -+> b) -> (a -+> b) -> a -+> b
(^+^) = (Rep (a -+> b) -> Rep (a -+> b) -> Rep (a -+> b))
-> (a -+> b) -> (a -+> b) -> a -+> b
forall p q r.
(HasRep p, HasRep q, HasRep r) =>
(Rep p -> Rep q -> Rep r) -> p -> q -> r
inAbst2 Rep (a -+> b) -> Rep (a -+> b) -> Rep (a -+> b)
(a -> b) -> (a -> b) -> a -> b
forall a. Additive a => a -> a -> a
(^+^)
{-# OPINLINE (^+^) #-}
instance Category (-+>) where
type Ok (-+>) = Additive
Abst(id)
. :: forall b c a. Ok3 (-+>) a b c => (b -+> c) -> (a -+> b) -> a -+> c
(.) = (Rep (b -+> c) -> Rep (a -+> b) -> Rep (a -+> c))
-> (b -+> c) -> (a -+> b) -> a -+> c
forall p q r.
(HasRep p, HasRep q, HasRep r) =>
(Rep p -> Rep q -> Rep r) -> p -> q -> r
inAbst2 Rep (b -+> c) -> Rep (a -+> b) -> Rep (a -+> c)
(b -> c) -> (a -> b) -> a -> c
forall (k :: * -> * -> *) b c a.
(Category k, Ok3 k a b c) =>
k b c -> k a b -> k a c
(.)
{-# OPINLINE (.) #-}
instance MonoidalPCat (-+>) where
*** :: forall a b c d.
Ok4 (-+>) a b c d =>
(a -+> c) -> (b -+> d) -> Prod (-+>) a b -+> Prod (-+>) c d
(***) = (Rep (a -+> c) -> Rep (b -+> d) -> Rep ((a :* b) -+> (c :* d)))
-> (a -+> c) -> (b -+> d) -> (a :* b) -+> (c :* d)
forall p q r.
(HasRep p, HasRep q, HasRep r) =>
(Rep p -> Rep q -> Rep r) -> p -> q -> r
inAbst2 Rep (a -+> c) -> Rep (b -+> d) -> Rep ((a :* b) -+> (c :* d))
(a -> c) -> (b -> d) -> (a :* b) -> c :* d
forall (k :: * -> * -> *) a b c d.
(MonoidalPCat k, Ok4 k a b c d) =>
k a c -> k b d -> k (Prod k a b) (Prod k c d)
(***)
first :: forall a a' b.
Ok3 (-+>) a b a' =>
(a -+> a') -> Prod (-+>) a b -+> Prod (-+>) a' b
first = (Rep (a -+> a') -> Rep ((a :* b) -+> (a' :* b)))
-> (a -+> a') -> (a :* b) -+> (a' :* b)
forall p q. (HasRep p, HasRep q) => (Rep p -> Rep q) -> p -> q
inAbst Rep (a -+> a') -> Rep ((a :* b) -+> (a' :* b))
(a -> a') -> (a :* b) -> a' :* b
forall (k :: * -> * -> *) a c b.
(MonoidalPCat k, Ok3 k a b c) =>
k a c -> k (Prod k a b) (Prod k c b)
first
second :: forall a b b'.
Ok3 (-+>) a b b' =>
(b -+> b') -> Prod (-+>) a b -+> Prod (-+>) a b'
second = (Rep (b -+> b') -> Rep ((a :* b) -+> (a :* b')))
-> (b -+> b') -> (a :* b) -+> (a :* b')
forall p q. (HasRep p, HasRep q) => (Rep p -> Rep q) -> p -> q
inAbst Rep (b -+> b') -> Rep ((a :* b) -+> (a :* b'))
(b -> b') -> (a :* b) -> a :* b'
forall (k :: * -> * -> *) a b d.
(MonoidalPCat k, Ok3 k a b d) =>
k b d -> k (Prod k a b) (Prod k a d)
second
{-# OPINLINE (***) #-}
{-# OPINLINE first #-}
{-# OPINLINE second #-}
instance BraidedPCat (-+>) where
Abst(swapP)
instance ProductCat (-+>) where
Abst(exl)
Abst(exr)
Abst(dup)
instance UnitCat (-+>) where
Abst(lunit)
Abst(runit)
Abst(lcounit)
Abst(rcounit)
instance CoproductPCat (-+>) where
#if 1
inlP :: forall a b. Ok2 (-+>) a b => a -+> CoprodP (-+>) a b
inlP = Rep (a -+> CoprodP (-+>) a b) -> a -+> CoprodP (-+>) a b
forall a. HasRep a => Rep a -> a
abst (,b
forall a. Additive a => a
zero)
inrP :: forall a b. Ok2 (-+>) a b => b -+> CoprodP (-+>) a b
inrP = Rep (b -+> CoprodP (-+>) a b) -> b -+> CoprodP (-+>) a b
forall a. HasRep a => Rep a -> a
abst (a
forall a. Additive a => a
zero,)
jamP :: forall a. Ok (-+>) a => CoprodP (-+>) a a -+> a
jamP = Rep (CoprodP (-+>) a a -+> a) -> CoprodP (-+>) a a -+> a
forall a. HasRep a => Rep a -> a
abst ((a -> Exp (->) a a) -> CoprodP (-+>) a a -> a
forall (k :: * -> * -> *) a b c.
(ClosedCat k, Ok3 k a b c) =>
k a (Exp k b c) -> k (Prod k a b) c
uncurry a -> Exp (->) a a
forall a. Additive a => a -> a -> a
(^+^))
{-# INLINE inlP #-}
{-# INLINE inrP #-}
{-# INLINE jamP #-}
#else
Abst(inlP)
Abst(inrP)
Abst(jamP)
#endif
instance Num s => ScalarCat (-+>) s where
scale :: s -> s -+> s
scale s
s = Rep (s -+> s) -> s -+> s
forall a. HasRep a => Rep a -> a
abst (s
s s -> s -> s
forall a. Num a => a -> a -> a
*)
{-# OPINLINE scale #-}
instance Ok (-+>) b => ConstCat (-+>) b where
const :: forall a. Ok (-+>) a => ConstObj (-+>) b -> a -+> ConstObj (-+>) b
const ConstObj (-+>) b
b = Rep (a -+> ConstObj (-+>) b) -> a -+> ConstObj (-+>) b
forall a. HasRep a => Rep a -> a
abst (ConstObj (-+>) b -> a -> ConstObj (-+>) b
forall (k :: * -> * -> *) b a. (ConstCat k b, Ok k a) => b -> k a b
const ConstObj (-+>) b
b)
{-# OPINLINE const #-}
instance TerminalCat (-+>) where
it :: forall a. Ok (-+>) a => a -+> Unit (-+>)
it = Rep (a -+> Unit (-+>)) -> a -+> Unit (-+>)
forall a. HasRep a => Rep a -> a
abst Rep (a -+> Unit (-+>))
a -> Unit (-+>)
forall a. Additive a => a
zero
{-# OPINLINE it #-}
instance CoterminalCat (-+>) where
ti :: forall a. Ok (-+>) a => Unit (-+>) -+> a
ti = Rep (Unit (-+>) -+> a) -> Unit (-+>) -+> a
forall a. HasRep a => Rep a -> a
abst Rep (Unit (-+>) -+> a)
Unit (-+>) -> a
forall a. Additive a => a
zero
{-# OPINLINE ti #-}
instance CoerceCat (->) a b => CoerceCat (-+>) a b where
Abst(coerceC)
instance RepCat (->) a r => RepCat (-+>) a r where
Abst(reprC)
Abst(abstC)
instance Additive1 h => OkIxProd (-+>) h where
okIxProd :: forall a. Ok' (-+>) a |- Ok' (-+>) (h a)
okIxProd :: forall a. Ok' (-+>) a |- Ok' (-+>) (h a)
okIxProd = (Con (Sat Additive a) :- Con (Sat Additive (h a)))
-> Sat Additive a |- Sat Additive (h a)
forall a b. (Con a :- Con b) -> a |- b
Entail ((Additive a => Dict (Additive (h a)))
-> Additive a :- Additive (h a)
forall (a :: Constraint) (b :: Constraint). (a => Dict b) -> a :- b
Sub (Dict (Additive (h a))
Con (Sat Additive (h a)) => Dict (Additive (h a))
forall (a :: Constraint). a => Dict a
Dict (Con (Sat Additive (h a)) => Dict (Additive (h a)))
-> (Sat Additive a |- Sat Additive (h a)) -> Dict (Additive (h a))
forall a b r. Con a => (Con b => r) -> (a |- b) -> r
<+ forall (h :: * -> *) a.
Additive1 h =>
Sat Additive a |- Sat Additive (h a)
additive1 @h @a))
{-# OPINLINE okIxProd #-}
instance ( Zip h, Additive1 h) => IxMonoidalPCat (-+>) h where
crossF :: forall a b. Ok2 (-+>) a b => h (a -+> b) -> h a -+> h b
crossF = (h (Rep (a -+> b)) -> Rep (h a -+> h b))
-> h (a -+> b) -> h a -+> h b
forall p q (f :: * -> *).
(HasRep p, HasRep q, Functor f) =>
(f (Rep p) -> Rep q) -> f p -> q
inAbstF1 h (Rep (a -+> b)) -> Rep (h a -+> h b)
h (a -> b) -> h a -> h b
forall (k :: * -> * -> *) (h :: * -> *) a b.
(IxMonoidalPCat k h, Ok2 k a b) =>
h (k a b) -> k (h a) (h b)
crossF
{-# OPINLINE crossF #-}
instance (Representable h, Zip h, Pointed h, Additive1 h) => IxProductCat (-+>) h where
exF :: forall a. Ok (-+>) a => h (h a -+> a)
exF = Rep (h a -+> a) -> h a -+> a
(h a -> a) -> h a -+> a
forall a. HasRep a => Rep a -> a
abst ((h a -> a) -> h a -+> a) -> h (h a -> a) -> h (h a -+> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> h (h a -> a)
forall (k :: * -> * -> *) (h :: * -> *) a.
(IxProductCat k h, Ok k a) =>
h (k (h a) a)
exF
forkF :: forall a b. Ok2 (-+>) a b => h (a -+> b) -> a -+> h b
forkF = (h (Rep (a -+> b)) -> Rep (a -+> h b)) -> h (a -+> b) -> a -+> h b
forall p q (f :: * -> *).
(HasRep p, HasRep q, Functor f) =>
(f (Rep p) -> Rep q) -> f p -> q
inAbstF1 h (Rep (a -+> b)) -> Rep (a -+> h b)
h (a -> b) -> a -> h b
forall (k :: * -> * -> *) (h :: * -> *) a b.
(IxProductCat k h, Ok2 k a b) =>
h (k a b) -> k a (h b)
forkF
Abst(replF)
{-# OPINLINE exF #-}
{-# OPINLINE forkF #-}
inFF :: (Additive a, Summable h) => h (a -> h a)
inFF :: forall a (h :: * -> *). (Additive a, Summable h) => h (a -> h a)
inFF = (Rep h -> a -> h a) -> h (a -> h a)
forall a. (Rep h -> a) -> h a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (\ Rep h
i a
a -> (Rep h -> a) -> h a
forall a. (Rep h -> a) -> h a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (\ Rep h
j -> if Rep h
i Rep h -> Rep h -> Bool
forall a. Eq a => a -> a -> Bool
== Rep h
j then a
a else a
forall a. Additive a => a
zero))
instance (Summable h, Additive1 h) => IxCoproductPCat (-+>) h where
#if 1
inPF :: forall a. Ok (-+>) a => h (a -+> h a)
inPF = Rep (a -+> h a) -> a -+> h a
(a -> h a) -> a -+> h a
forall a. HasRep a => Rep a -> a
abst ((a -> h a) -> a -+> h a) -> h (a -> h a) -> h (a -+> h a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> h (a -> h a)
forall a (h :: * -> *). (Additive a, Summable h) => h (a -> h a)
inFF
jamPF :: forall a. Ok (-+>) a => h a -+> a
jamPF = Rep (h a -+> a) -> h a -+> a
forall a. HasRep a => Rep a -> a
abst Rep (h a -+> a)
h a -> a
forall (h :: * -> *) a. (Foldable h, Additive a) => h a -> a
sumA
#else
inPF = abst <$> inPF
Abst(jamPF)
#endif
{-# OPINLINE inPF #-}
instance OkAdd (-+>) where okAdd :: forall a. Ok' (-+>) a |- Sat Additive a
okAdd = (Con (Sat Additive a) :- Con (Sat Additive a))
-> Sat Additive a |- Sat Additive a
forall a b. (Con a :- Con b) -> a |- b
Entail ((Additive a => Dict (Additive a)) -> Additive a :- Additive a
forall (a :: Constraint) (b :: Constraint). (a => Dict b) -> a :- b
Sub Dict (Additive a)
Additive a => Dict (Additive a)
forall (a :: Constraint). a => Dict a
Dict)
#if 0
instance (Num s, Additive s) => NumCat (-+>) s where
Abst(addC)
Abst(negateC)
Abst(mulC)
Abst(powIC)
instance BoolCat (-+>) where
Abst(notC)
Abst(andC)
Abst(orC)
Abst(xorC)
instance Additive a => IfCat (-+>) a where
Abst(ifC)
#endif
instance Additive1 h => OkFunctor (-+>) h where
okFunctor :: forall a. Sat Additive a |- Sat Additive (h a)
okFunctor :: forall a. Sat Additive a |- Sat Additive (h a)
okFunctor = Sat Additive a |- Sat Additive (h a)
forall a. Sat Additive a |- Sat Additive (h a)
forall (h :: * -> *) a.
Additive1 h =>
Sat Additive a |- Sat Additive (h a)
additive1
{-# OPINLINE okFunctor #-}
instance (Functor h, Additive1 h) => FunctorCat (-+>) h where
fmapC :: forall a b. Ok2 (-+>) a b => (a -+> b) -> h a -+> h b
fmapC = (Rep (a -+> b) -> Rep (h a -+> h b)) -> (a -+> b) -> h a -+> h b
forall p q. (HasRep p, HasRep q) => (Rep p -> Rep q) -> p -> q
inAbst Rep (a -+> b) -> Rep (h a -+> h b)
(a -> b) -> h a -> h b
forall (k :: * -> * -> *) (h :: * -> *) a b.
(FunctorCat k h, Ok2 k a b) =>
k a b -> k (h a) (h b)
fmapC
Abst(unzipC)
{-# OPINLINE fmapC #-}
instance (Zip h, Additive1 h) => ZipCat (-+>) h where
zipC :: forall a b. Ok2 (-+>) a b => (h a :* h b) -+> h (a :* b)
Abst(zipC)
instance (Zip h, OkFunctor (-+>) h) => ZapCat (-+>) h where
zapC :: forall a b. Ok2 (-+>) a b => h (a -+> b) -> h a -+> h b
zapC h (a -+> b)
fs = Rep (h a -+> h b) -> h a -+> h b
forall a. HasRep a => Rep a -> a
abst (h (a -> b) -> h a -> h b
forall (k :: * -> * -> *) (h :: * -> *) a b.
(ZapCat k h, Ok2 k a b) =>
h (k a b) -> k (h a) (h b)
zapC ((a -+> b) -> Rep (a -+> b)
(a -+> b) -> a -> b
forall a. HasRep a => a -> Rep a
repr ((a -+> b) -> a -> b) -> h (a -+> b) -> h (a -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> h (a -+> b)
fs))
{-# OPINLINE zapC #-}
instance (Pointed h, Additive1 h, Additive a) => PointedCat (-+>) h a where
Abst(pointC)
instance (Summable h, Additive a) => AddCat (-+>) h a where
Abst(sumAC)
instance (Traversable t, Applicative f) => TraversableCat (-+>) t f where
Abst(sequenceAC)
instance Representable f => RepresentableCat (-+>) f where
tabulateC :: forall a. Ok (-+>) a => (Rep f -> a) -+> f a
tabulateC = Rep ((Rep f -> a) -+> f a) -> (Rep f -> a) -+> f a
forall a. HasRep a => Rep a -> a
abst (((Rep f -> a) -> f a) -> (Rep f -> a) -> f a
forall a. a -> a
IC.inline (Rep f -> a) -> f a
forall a. (Rep f -> a) -> f a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate)
indexC :: forall a. Ok (-+>) a => f a -+> (Rep f -> a)
indexC = Rep (f a -+> (Rep f -> a)) -> f a -+> (Rep f -> a)
forall a. HasRep a => Rep a -> a
abst ((f a -> Rep f -> a) -> f a -> Rep f -> a
forall a. a -> a
IC.inline f a -> Rep f -> a
forall a. f a -> Rep f -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index)
{-# OPINLINE tabulateC #-}
{-# OPINLINE indexC #-}
instance (Additive a, MinMaxCat (->) a) => MinMaxCat (-+>) a where
minC :: Prod (-+>) a a -+> a
Abst(minC)
maxC :: Prod (-+>) a a -+> a
Abst(maxC)
instance (Additive a, Additive1 h, MinMaxFFunctorCat (->) h a) => MinMaxFFunctorCat (-+>) h a where
minimumCF :: h a -> a :* (h a -+> a)
minimumCF = ((h a -> a) -> h a -+> a)
-> Prod (->) a (h a -> a) -> a :* (h a -+> a)
forall (k :: * -> * -> *) a b d.
(MonoidalPCat k, Ok3 k a b d) =>
k b d -> k (Prod k a b) (Prod k a d)
second Rep (h a -+> a) -> h a -+> a
(h a -> a) -> h a -+> a
forall a. HasRep a => Rep a -> a
abst (Prod (->) a (h a -> a) -> a :* (h a -+> a))
-> (h a -> Prod (->) a (h a -> a)) -> h a -> a :* (h a -+> a)
forall (k :: * -> * -> *) b c a.
(Category k, Ok3 k a b c) =>
k b c -> k a b -> k a c
. ((h a -> Prod (->) a (h a -> a)) -> h a -> Prod (->) a (h a -> a)
forall a. a -> a
IC.inline h a -> Prod (->) a (h a -> a)
forall (k :: * -> * -> *) (h :: * -> *) a.
(MinMaxFFunctorCat k h a, OkFunctor k h, Ok k a) =>
h a -> a :* k (h a) a
minimumCF)
{-# OPINLINE minimumCF #-}
maximumCF :: h a -> a :* (h a -+> a)
maximumCF = ((h a -> a) -> h a -+> a)
-> Prod (->) a (h a -> a) -> a :* (h a -+> a)
forall (k :: * -> * -> *) a b d.
(MonoidalPCat k, Ok3 k a b d) =>
k b d -> k (Prod k a b) (Prod k a d)
second Rep (h a -+> a) -> h a -+> a
(h a -> a) -> h a -+> a
forall a. HasRep a => Rep a -> a
abst (Prod (->) a (h a -> a) -> a :* (h a -+> a))
-> (h a -> Prod (->) a (h a -> a)) -> h a -> a :* (h a -+> a)
forall (k :: * -> * -> *) b c a.
(Category k, Ok3 k a b c) =>
k b c -> k a b -> k a c
. ((h a -> Prod (->) a (h a -> a)) -> h a -> Prod (->) a (h a -> a)
forall a. a -> a
IC.inline h a -> Prod (->) a (h a -> a)
forall (k :: * -> * -> *) (h :: * -> *) a.
(MinMaxFFunctorCat k h a, OkFunctor k h, Ok k a) =>
h a -> a :* k (h a) a
maximumCF)
{-# OPINLINE maximumCF #-}
addFun :: (a -> b) -> (a -> b)
addFun :: forall a b. (a -> b) -> a -> b
addFun a -> b
f = (a -+> b) -> Rep (a -+> b)
forall a. HasRep a => a -> Rep a
repr (forall (k :: * -> * -> *) a b. (a -> b) -> k a b
toCcc @(-+>) a -> b
f)
{-# INLINE addFun #-}
addFun' :: (a -> b) -> (a -> b)
addFun' :: forall a b. (a -> b) -> a -> b
addFun' a -> b
f = (a -+> b) -> Rep (a -+> b)
forall a. HasRep a => a -> Rep a
repr (forall (k :: * -> * -> *) a b. (a -> b) -> k a b
toCcc' @(-+>) a -> b
f)
{-# INLINE addFun' #-}