{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
module Data.Semiring.Module where
import Data.Distributive
import Data.Functor.Compose
import Data.Foldable as Foldable (fold, foldl')
import Data.Semigroup.Foldable as Foldable1
import Data.Functor.Rep
import Data.Semiring
import Data.Group
import Data.Ring
import Data.Prd
import Data.Tuple
import Data.Int.Instance ()
import Prelude hiding (sum, negate)
type Free f = (Foldable1 f, Representable f, Eq (Rep f))
lensRep :: Eq (Rep f) => Representable f => Rep f -> forall g. Functor g => (a -> g a) -> f a -> g (f a)
lensRep i f s = setter s <$> f (getter s)
where getter = flip index i
setter s' b = tabulate (\j -> if i == j then b else index s' j)
{-# INLINE lensRep #-}
grateRep :: Representable f => forall g. Functor g => (Rep f -> g a -> b) -> g (f a) -> f b
grateRep iab s = tabulate $ \i -> iab i (fmap (`index` i) s)
{-# INLINE grateRep #-}
fempty :: Monoid a => Representable f => f a
fempty = pureRep mempty
{-# INLINE fempty #-}
neg :: Group a => Functor f => f a -> f a
neg = fmap negate
{-# INLINE neg #-}
infixl 6 `sum`
sum :: Semigroup a => Representable f => f a -> f a -> f a
sum = liftR2 (<>)
{-# INLINE sum #-}
infixl 6 `diff`
diff :: Group a => Representable f => f a -> f a -> f a
diff x y = x `sum` fmap negate y
{-# INLINE diff #-}
outer :: Semiring a => Functor f => Functor g => f a -> g a -> f (g a)
outer a b = fmap (\x->fmap (><x) b) a
{-# INLINE outer #-}
infixl 6 <.>
(<.>) :: Semiring a => Free f => f a -> f a -> a
(<.>) a b = fold1 $ liftR2 (><) a b
{-# INLINE (<.>) #-}
quadrance :: Semiring a => Free f => f a -> a
quadrance f = f <.> f
{-# INLINE quadrance #-}
qd :: Ring a => Free f => f a -> f a -> a
qd f g = quadrance $ f `diff` g
{-# INLINE qd #-}
lerp :: Ring a => Representable f => a -> f a -> f a -> f a
lerp a f g = fmap (a ><) f `sum` fmap ((sunit << a) ><) g
{-# INLINE lerp #-}
dirac :: Eq i => Unital a => i -> i -> a
dirac i j = if i == j then sunit else mempty
{-# INLINE dirac #-}
unit :: Unital a => Free f => Rep f -> f a
unit i = tabulate $ dirac i
{-# INLINE unit #-}