{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
module Data.Semimodule.Free (
type Free
, Vec(..)
, vmap
, join
, init
, (!*)
, (*!)
, (!*!)
, Cov(..)
, images
, cmap
, cojoin
, coinit
, comult
, Lin(..)
, End
, image
, invmap
, augment
, (!#)
, (#!)
, (!#!)
, braid
, cobraid
, split
, cosplit
, projl
, projr
, compl
, compr
, complr
, diagonal
, codiagonal
, initial
, coinitial
, convolve
) where
import safe Control.Applicative
import safe Control.Arrow
import safe Control.Category (Category, (<<<), (>>>))
import safe Control.Monad (MonadPlus(..))
import safe Data.Foldable (foldl')
import safe Data.Functor.Apply
import safe Data.Functor.Contravariant (Contravariant(..))
import safe Data.Functor.Rep
import safe Data.Profunctor
import safe Data.Profunctor.Sieve
import safe Data.Semimodule
import safe Data.Semiring
import safe Data.Tuple (swap)
import safe Prelude hiding (Num(..), Fractional(..), init, negate, sum, product)
import safe Test.Logic hiding (join)
import safe qualified Control.Category as C
import safe qualified Data.Profunctor.Rep as PR
infixr 3 `runVec`
newtype Vec a b = Vec { runVec :: b -> a }
infixr 7 !*
(!*) :: Vec a b -> Cov a b -> a
(!*) = flip (*!)
infixl 7 *!
(*!) :: Cov a b -> Vec a b -> a
(*!) f = runCov f . runVec
vmap :: Lin a b c -> Vec a c -> Vec a b
vmap f g = Vec $ runLin f (runVec g)
join :: Algebra a b => Vec a (b, b) -> Vec a b
join = vmap diagonal
init :: Unital a b => a -> Vec a b
init = Vec . unital
infixr 7 !*!
(!*!) :: Algebra a b => Vec a b -> Vec a b -> Vec a b
(!*!) x y = Vec $ joined (\i j -> runVec x i * runVec y j)
infixr 3 `runCov`
newtype Cov a c = Cov { runCov :: (c -> a) -> a }
images :: Semiring a => Foldable f => f (a, c) -> Cov a c
images f = Cov $ \k -> foldl' (\acc (a, c) -> acc + a * k c) zero f
cmap :: Lin a b c -> Cov a b -> Cov a c
cmap f g = Cov $ runCov g . runLin f
cojoin :: Coalgebra a c => Cov a (c, c) -> Cov a c
cojoin = cmap codiagonal
coinit :: Counital a c => Cov a c
coinit = Cov counital
infixr 7 `comult`
comult :: Coalgebra a c => Cov a c -> Cov a c -> Cov a c
comult (Cov f) (Cov g) = Cov $ \k -> f (\m -> g (cojoined k m))
newtype Lin a b c = Lin { runLin :: (c -> a) -> b -> a }
type End a b = Lin a b b
image :: Semiring a => (b -> [(a, c)]) -> Lin a b c
image f = Lin $ \k b -> sum [ a * k c | (a, c) <- f b ]
invmap :: (a1 -> a2) -> (a2 -> a1) -> Lin a1 b c -> Lin a2 b c
invmap f g (Lin t) = Lin $ \x -> t (x >>> g) >>> f
augment :: Semiring a => Lin a b c -> b -> a
augment l = l !# const one
infixr 2 !#
(!#) :: Free f => Free g => Lin a (Rep f) (Rep g) -> g a -> f a
(!#) t = tabulate . runLin t . index
infixl 2 #!
(#!) :: Free f => Free g => g a -> Lin a (Rep f) (Rep g) -> f a
(#!) = flip (!#)
infixr 2 !#!
(!#!) :: Lin a c d -> Lin a b c -> Lin a b d
(!#!) = (C..)
braid :: Lin a (b , c) (c , b)
braid = arr swap
{-# INLINE braid #-}
cobraid :: Lin a (b + c) (c + b)
cobraid = arr eswap
{-# INLINE cobraid #-}
split :: (b -> (b1 , b2)) -> Lin a b1 c -> Lin a b2 c -> Lin a b c
split f x y = dimap f fst $ x *** y
{-# INLINE split #-}
cosplit :: ((c1 + c2) -> c) -> Lin a b c1 -> Lin a b c2 -> Lin a b c
cosplit f x y = dimap Left f $ x +++ y
{-# INLINE cosplit #-}
projl :: Free f => Free g => (f++g) a -> f a
projl fg = arr Left !# fg
{-# INLINE projl #-}
projr :: Free f => Free g => (f++g) a -> g a
projr fg = arr Right !# fg
{-# INLINE projr #-}
compl :: Free f1 => Free f2 => Free g => Lin a (Rep f1) (Rep f2) -> (f2**g) a -> (f1**g) a
compl t fg = first t !# fg
compr :: Free f => Free g1 => Free g2 => Lin a (Rep g1) (Rep g2) -> (f**g2) a -> (f**g1) a
compr t fg = second t !# fg
complr :: Free f1 => Free f2 => Free g1 => Free g2 => Lin a (Rep f1) (Rep f2) -> Lin a (Rep g1) (Rep g2) -> (f2**g2) a -> (f1**g1) a
complr t1 t2 fg = t1 *** t2 !# fg
diagonal :: Algebra a b => Lin a b (b,b)
diagonal = Lin $ joined . curry
codiagonal :: Coalgebra a c => Lin a (c,c) c
codiagonal = Lin $ uncurry . cojoined
initial :: Unital a b => Lin a b ()
initial = Lin $ \k -> unital $ k ()
coinitial :: Counital a c => Lin a () c
coinitial = Lin $ const . counital
convolve :: Algebra a b => Coalgebra a c => Lin a b c -> Lin a b c -> Lin a b c
convolve f g = codiagonal <<< (f *** g) <<< diagonal
addVec :: (Additive-Semigroup) a => Vec a b -> Vec a b -> Vec a b
addVec (Vec f) (Vec g) = Vec $ \b -> f b + g b
subVec :: (Additive-Group) a => Vec a b -> Vec a b -> Vec a b
subVec (Vec f) (Vec g) = Vec $ \b -> f b - g b
instance Contravariant (Vec a) where
contramap f g = Vec (runVec g . f)
instance Category Vec where
id = Vec id
Vec f . Vec g = Vec (g . f)
instance (Additive-Semigroup) a => Semigroup (Additive (Vec a b)) where
(<>) = liftA2 addVec
instance (Additive-Monoid) a => Monoid (Additive (Vec a b)) where
mempty = Additive . Vec $ const zero
instance (Additive-Group) a => Magma (Additive (Vec a b)) where
(<<) = liftA2 subVec
instance (Additive-Group) a => Quasigroup (Additive (Vec a b))
instance (Additive-Group) a => Loop (Additive (Vec a b))
instance (Additive-Group) a => Group (Additive (Vec a b))
instance Semiring a => LeftSemimodule a (Vec a b) where
lscale a v = Vec $ \b -> a *. runVec v b
instance Semiring a => LeftSemimodule (End a b) (Vec a b) where
lscale = vmap
instance Semiring a => RightSemimodule a (Vec a b) where
rscale a v = Vec $ \b -> runVec v b .* a
instance Semiring a => RightSemimodule (End a b) (Vec a b) where
rscale = vmap
instance Semiring a => Bisemimodule (End a b) (End a b) (Vec a b)
instance Bisemimodule a a a => Bisemimodule a a (Vec a b)
instance Functor (Cov a) where
fmap f m = Cov $ \k -> m `runCov` k . f
instance Applicative (Cov a) where
pure a = Cov $ \k -> k a
mf <*> ma = Cov $ \k -> mf `runCov` \f -> ma `runCov` k . f
instance Monad (Cov a) where
return a = Cov $ \k -> k a
m >>= f = Cov $ \k -> m `runCov` \a -> f a `runCov` k
instance (Additive-Monoid) a => Alternative (Cov a) where
Cov m <|> Cov n = Cov $ m + n
empty = Cov zero
instance (Additive-Monoid) a => MonadPlus (Cov a) where
Cov m `mplus` Cov n = Cov $ m + n
mzero = Cov zero
instance (Additive-Semigroup) a => Semigroup (Additive (Cov a b)) where
(<>) = liftA2 $ \(Cov m) (Cov n) -> Cov $ m + n
instance (Additive-Monoid) a => Monoid (Additive (Cov a b)) where
mempty = Additive $ Cov zero
instance (Additive-Group) a => Magma (Additive (Cov a b)) where
(<<) = liftA2 $ \(Cov m) (Cov n) -> Cov $ m - n
instance (Additive-Group) a => Quasigroup (Additive (Cov a b))
instance (Additive-Group) a => Loop (Additive (Cov a b))
instance (Additive-Group) a => Group (Additive (Cov a b))
instance Semiring a => LeftSemimodule a (Cov a b) where
lscale s m = Cov $ \k -> s *. runCov m k
instance Counital a b => LeftSemimodule (End a b) (Cov a b) where
lscale = cmap
instance Semiring a => RightSemimodule a (Cov a b) where
rscale s m = Cov $ \k -> runCov m k .* s
instance Counital a b => RightSemimodule (End a b) (Cov a b) where
rscale = cmap
instance Counital a b => Bisemimodule (End a b) (End a b) (Cov a b)
instance Bisemimodule a a a => Bisemimodule a a (Cov a b)
addLin :: (Additive-Semigroup) a => Lin a b c -> Lin a b c -> Lin a b c
addLin (Lin f) (Lin g) = Lin $ f + g
subLin :: (Additive-Group) a => Lin a b c -> Lin a b c -> Lin a b c
subLin (Lin f) (Lin g) = Lin $ \h -> f h - g h
instance Functor (Lin a b) where
fmap f m = Lin $ \k -> m !# k . f
instance Category (Lin a) where
id = Lin id
Lin f . Lin g = Lin $ g . f
instance Apply (Lin a b) where
mf <.> ma = Lin $ \k b -> (mf !# \f -> (ma !# k . f) b) b
instance Applicative (Lin a b) where
pure a = Lin $ \k _ -> k a
(<*>) = (<.>)
instance Profunctor (Lin a) where
dimap l r f = arr r <<< f <<< arr l
instance Strong (Lin a) where
first' = first
second' = second
instance Choice (Lin a) where
left' = left
right' = right
instance Sieve (Lin a) (Cov a) where
sieve l b = Cov $ \k -> (l !# k) b
instance PR.Representable (Lin a) where
type Rep (Lin a) = Cov a
tabulate f = Lin $ \k b -> runCov (f b) k
instance Monad (Lin a b) where
return a = Lin $ \k _ -> k a
m >>= f = Lin $ \k b -> (m !# \a -> (f a !# k) b) b
instance Arrow (Lin a) where
arr f = Lin (. f)
first m = Lin $ \k (a,c) -> (m !# \b -> k (b,c)) a
second m = Lin $ \k (c,a) -> (m !# \b -> k (c,b)) a
m *** n = Lin $ \k (a,c) -> (m !# \b -> (n !# \d -> k (b,d)) c) a
m &&& n = Lin $ \k a -> (m !# \b -> (n !# \c -> k (b,c)) a) a
instance ArrowChoice (Lin a) where
left m = Lin $ \k -> either (m !# k . Left) (k . Right)
right m = Lin $ \k -> either (k . Left) (m !# k . Right)
m +++ n = Lin $ \k -> either (m !# k . Left) (n !# k . Right)
m ||| n = Lin $ \k -> either (m !# k) (n !# k)
instance ArrowApply (Lin a) where
app = Lin $ \k (f,a) -> (f !# k) a
instance (Additive-Semigroup) a => Semigroup (Additive (Lin a b c)) where
(<>) = liftA2 addLin
instance (Additive-Monoid) a => Monoid (Additive (Lin a b c)) where
mempty = pure . Lin $ const zero
instance Presemiring a => Semigroup (Multiplicative (End a b)) where
(<>) = liftA2 (<<<)
instance Semiring a => Monoid (Multiplicative (End a b)) where
mempty = pure C.id
instance Presemiring a => Presemiring (End a b)
instance Semiring a => Semiring (End a b)
instance Ring a => Ring (End a b)
instance Counital a b => LeftSemimodule (Lin a b b) (Lin a b c) where
lscale = (>>>)
instance Semiring a => LeftSemimodule a (Lin a b c) where
lscale l (Lin m) = Lin $ \k b -> l *. m k b
instance Counital a c => RightSemimodule (Lin a c c) (Lin a b c) where
rscale = (<<<)
instance (Counital a b, Counital a c) => Bisemimodule (Lin a b b) (Lin a c c) (Lin a b c)
instance Semiring a => RightSemimodule a (Lin a b m) where
rscale r (Lin m) = Lin $ \k b -> m k b .* r
instance Bisemimodule a a a => Bisemimodule a a (Lin a b c)
instance (Additive-Group) a => Magma (Additive (Lin a b c)) where
(<<) = liftR2 subLin
instance (Additive-Group) a => Quasigroup (Additive (Lin a b c))
instance (Additive-Group) a => Loop (Additive (Lin a b c))
instance (Additive-Group) a => Group (Additive (Lin a b c))