{-# 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.Transform (
type (**)
, type (++)
, Dual
, dual
, image'
, (!*)
, (*!)
, toTran
, fromTran
, Endo
, Tran
, arr
, tran
, image
, (!#)
, (#!)
, (!#!)
, dimap
, invmap
, init
, init'
, coinit
, coinit'
, braid
, cobraid
, join
, join'
, cojoin
, cojoin'
, split
, cosplit
, convolve
, convolve'
, commutator
, (.#)
, (#.)
, (.#.)
, outer
, inner
, quadrance
, trace
, transpose
, diag
, codiag
, scalar
, identity
, row
, rows
, col
, cols
, projl
, projr
, compl
, compr
, complr
, Representable(..)
) where
import safe Control.Arrow
import safe Control.Applicative
import safe Control.Category (Category, (>>>), (<<<))
import safe Data.Functor.Compose
import safe Data.Functor.Product
import safe Data.Functor.Rep hiding (Co)
import safe Data.Foldable (foldl')
import safe Data.Algebra
import safe Data.Semiring
import safe Data.Semimodule
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 Control.Monad as M
import safe Control.Monad (MonadPlus(..))
infixr 2 **
infixr 1 ++
type (f ** g) = Compose f g
type (f ++ g) = Product f g
infixr 3 `runDual`
newtype Dual a c = Dual { runDual :: (c -> a) -> a }
dual :: FreeCounital a f => f a -> Dual a (Rep f)
dual f = Dual $ \k -> f `inner` tabulate k
image' :: Semiring a => Foldable f => f (a, c) -> Dual a c
image' f = Dual $ \k -> foldl' (\acc (a, c) -> acc + a * k c) zero f
toTran :: (b -> Dual a c) -> Tran a b c
toTran f = Tran $ \k b -> f b !* k
fromTran :: Tran a b c -> b -> Dual a c
fromTran m b = Dual $ \k -> (m !# k) b
infixr 3 !*
(!*) :: Free f => Dual a (Rep f) -> f a -> a
(!*) f x = runDual f $ index x
infixl 3 *!
(*!) :: Free f => f a -> Dual a (Rep f) -> a
(*!) = flip (!*)
type Endo a b = Tran a b b
newtype Tran a b c = Tran { runTran :: (c -> a) -> b -> a }
tran :: Free f => FreeCounital a g => (f**g) a -> Tran a (Rep f) (Rep g)
tran m = Tran $ \k -> index $ m .# tabulate k
image :: Semiring a => (b -> [(a, c)]) -> Tran a b c
image f = Tran $ \k b -> sum [ a * k c | (a, c) <- f b ]
infixr 2 !#
(!#) :: Free f => Free g => Tran a (Rep f) (Rep g) -> g a -> f a
(!#) t = tabulate . runTran t . index
infixl 2 #!
(#!) :: Free f => Free g => g a -> Tran a (Rep f) (Rep g) -> f a
(#!) = flip (!#)
infix 2 !#!
(!#!) :: Tran a c d -> Tran a b c -> Tran a b d
Tran f !#! Tran g = Tran $ g . f
dimap :: (b1 -> b2) -> (c1 -> c2) -> Tran a b2 c1 -> Tran a b1 c2
dimap l r f = arr r <<< f <<< arr l
invmap :: (a1 -> a2) -> (a2 -> a1) -> Tran a1 b c -> Tran a2 b c
invmap f g (Tran t) = Tran $ \x -> t (x >>> g) >>> f
init :: Unital a b => Tran a b ()
init = Tran $ \k -> aempty $ k ()
init' :: Unital a b => b -> Dual a ()
init' b = Dual $ \k -> aempty (k ()) b
coinit :: Counital a c => Tran a () c
coinit = Tran $ \k () -> coempty k
coinit' :: Counital a c => Dual a c
coinit' = Dual coempty
braid :: Tran a (b , c) (c , b)
braid = arr swap
{-# INLINE braid #-}
cobraid :: Tran a (b + c) (c + b)
cobraid = arr eswap
{-# INLINE cobraid #-}
join :: Algebra a b => Tran a b (b,b)
join = Tran $ append . curry
join' :: Algebra a b => b -> Dual a (b,b)
join' b = Dual $ \k -> append (curry k) b
cojoin :: Coalgebra a c => Tran a (c,c) c
cojoin = Tran $ uncurry . coappend
cojoin' :: Coalgebra a c => c -> c -> Dual a c
cojoin' x y = Dual $ \k -> coappend k x y
split :: (b -> (b1 , b2)) -> Tran a b1 c -> Tran a b2 c -> Tran a b c
split f x y = dimap f fst $ x *** y
{-# INLINE split #-}
cosplit :: ((c1 + c2) -> c) -> Tran a b c1 -> Tran a b c2 -> Tran a b c
cosplit f x y = dimap Left f $ x +++ y
{-# INLINE cosplit #-}
convolve :: Algebra a b => Coalgebra a c => Tran a b c -> Tran a b c -> Tran a b c
convolve f g = cojoin <<< (f *** g) <<< join
convolve' :: Algebra a b => Coalgebra a c => (b -> Dual a c) -> (b -> Dual a c) -> b -> Dual a c
convolve' f g c = do
(c1,c2) <- join' c
a1 <- f c1
a2 <- g c2
cojoin' a1 a2
commutator :: (Additive-Group) a => Endo a b -> Endo a b -> Endo a b
commutator x y = (x <<< y) `subTran` (y <<< x)
infixr 7 .#
(.#) :: Free f => FreeCounital a g => (f**g) a -> g a -> f a
x .# y = tabulate (\i -> row i x `inner` y)
{-# INLINE (.#) #-}
infixl 7 #.
(#.) :: FreeCounital a f => Free g => f a -> (f**g) a -> g a
x #. y = tabulate (\j -> x `inner` col j y)
{-# INLINE (#.) #-}
infixr 7 .#.
(.#.) :: Free f => FreeCounital a g => Free h => (f**g) a -> (g**h) a -> (f**h) a
(.#.) x y = tabulate (\(i,j) -> row i x `inner` col j y)
{-# INLINE (.#.) #-}
outer :: Semiring a => Free f => Free g => f a -> g a -> (f**g) a
outer x y = Compose $ fmap (\z-> fmap (*z) y) x
infix 6 `inner`
inner :: FreeCounital a f => f a -> f a -> a
inner x y = counital $ liftR2 (*) x y
{-# INLINE inner #-}
quadrance :: FreeCounital a f => f a -> a
quadrance = M.join inner
{-# INLINE quadrance #-}
trace :: FreeBialgebra a f => (f**f) a -> a
trace = counital . codiag
transpose :: Free f => Free g => (f**g) a -> (g**f) a
transpose fg = braid !# fg
{-# INLINE transpose #-}
diag :: FreeCoalgebra a f => f a -> (f**f) a
diag f = cojoin !# f
codiag :: FreeAlgebra a f => (f**f) a -> f a
codiag f = join !# f
scalar :: FreeCoalgebra a f => a -> (f**f) a
scalar = diag . pureRep
identity :: FreeCoalgebra a f => (f**f) a
identity = scalar one
{-# INLINE identity #-}
row :: Free f => Rep f -> (f**g) a -> g a
row i = flip index i . getCompose
{-# INLINE row #-}
rows :: Free f => Free g => g a -> (f**g) a
rows g = arr snd !# g
{-# INLINE rows #-}
col :: Free f => Free g => Rep g -> (f**g) a -> f a
col j = flip index j . distributeRep . getCompose
{-# INLINE col #-}
cols :: Free f => Free g => f a -> (f**g) a
cols f = arr fst !# f
{-# INLINE cols #-}
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 => Tran a (Rep f1) (Rep f2) -> (f2**g) a -> (f1**g) a
compl t fg = first t !# fg
compr :: Free f => Free g1 => Free g2 => Tran 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 => Tran a (Rep f1) (Rep f2) -> Tran a (Rep g1) (Rep g2) -> (f2**g2) a -> (f1**g1) a
complr t1 t2 fg = t1 *** t2 !# fg
instance Functor (Dual a) where
fmap f m = Dual $ \k -> m `runDual` k . f
instance Applicative (Dual a) where
pure a = Dual $ \k -> k a
mf <*> ma = Dual $ \k -> mf `runDual` \f -> ma `runDual` k . f
instance Monad (Dual a) where
return a = Dual $ \k -> k a
m >>= f = Dual $ \k -> m `runDual` \a -> f a `runDual` k
instance (Additive-Monoid) a => Alternative (Dual a) where
Dual m <|> Dual n = Dual $ m + n
empty = Dual zero
instance (Additive-Monoid) a => MonadPlus (Dual a) where
Dual m `mplus` Dual n = Dual $ m + n
mzero = Dual zero
instance (Additive-Semigroup) a => Semigroup (Additive (Dual a b)) where
(<>) = liftA2 $ \(Dual m) (Dual n) -> Dual $ m + n
instance (Additive-Monoid) a => Monoid (Additive (Dual a b)) where
mempty = Additive $ Dual zero
instance Coalgebra a b => Semigroup (Multiplicative (Dual a b)) where
(<>) = liftA2 $ \(Dual f) (Dual g) -> Dual $ \k -> f (\m -> g (coappend k m))
instance Counital a b => Monoid (Multiplicative (Dual a b)) where
mempty = Multiplicative $ Dual coempty
instance Coalgebra a b => Presemiring (Dual a b)
instance Counital a b => Semiring (Dual a b)
instance (Additive-Group) a => Magma (Additive (Dual a b)) where
(<<) = liftA2 $ \(Dual m) (Dual n) -> Dual $ m - n
instance (Additive-Group) a => Quasigroup (Additive (Dual a b)) where
instance (Additive-Group) a => Loop (Additive (Dual a b)) where
instance (Additive-Group) a => Group (Additive (Dual a b)) where
instance (Ring a, Counital a b) => Ring (Dual a b)
instance Counital r m => LeftSemimodule (Dual r m) (Dual r m) where
lscale = (*)
instance LeftSemimodule r s => LeftSemimodule r (Dual s m) where
lscale s m = Dual $ \k -> s *. runDual m k
instance Counital r m => RightSemimodule (Dual r m) (Dual r m) where
rscale = (*)
instance RightSemimodule r s => RightSemimodule r (Dual s m) where
rscale s m = Dual $ \k -> runDual m k .* s
addTran :: (Additive-Semigroup) a => Tran a b c -> Tran a b c -> Tran a b c
addTran (Tran f) (Tran g) = Tran $ f + g
subTran :: (Additive-Group) a => Tran a b c -> Tran a b c -> Tran a b c
subTran (Tran f) (Tran g) = Tran $ \h -> f h - g h
instance Functor (Tran a b) where
fmap f m = Tran $ \k -> m !# k . f
instance Applicative (Tran a b) where
pure a = Tran $ \k _ -> k a
mf <*> ma = Tran $ \k b -> (mf !# \f -> (ma !# k . f) b) b
instance Monad (Tran a b) where
return a = Tran $ \k _ -> k a
m >>= f = Tran $ \k b -> (m !# \a -> (f a !# k) b) b
instance Category (Tran a) where
id = Tran id
(.) = (!#!)
instance Arrow (Tran a) where
arr f = Tran (. f)
first m = Tran $ \k (a,c) -> (m !# \b -> k (b,c)) a
second m = Tran $ \k (c,a) -> (m !# \b -> k (c,b)) a
m *** n = Tran $ \k (a,c) -> (m !# \b -> (n !# \d -> k (b,d)) c) a
m &&& n = Tran $ \k a -> (m !# \b -> (n !# \c -> k (b,c)) a) a
instance ArrowChoice (Tran a) where
left m = Tran $ \k -> either (m !# k . Left) (k . Right)
right m = Tran $ \k -> either (k . Left) (m !# k . Right)
m +++ n = Tran $ \k -> either (m !# k . Left) (n !# k . Right)
m ||| n = Tran $ \k -> either (m !# k) (n !# k)
instance ArrowApply (Tran a) where
app = Tran $ \k (f,a) -> (f !# k) a
instance (Additive-Monoid) a => ArrowZero (Tran a) where
zeroArrow = Tran zero
instance (Additive-Monoid) a => ArrowPlus (Tran a) where
(<+>) = addTran
instance (Additive-Semigroup) a => Semigroup (Additive (Tran a b c)) where
(<>) = liftA2 addTran
instance (Additive-Monoid) a => Monoid (Additive (Tran a b c)) where
mempty = pure . Tran $ const zero
instance Coalgebra a c => Semigroup (Multiplicative (Tran a b c)) where
(<>) = liftR2 $ \ f g -> Tran $ \k b -> (f !# \a -> (g !# coappend k a) b) b
instance Counital a c => Monoid (Multiplicative (Tran a b c)) where
mempty = pure . Tran $ \k _ -> coempty k
instance Coalgebra a c => Presemiring (Tran a b c)
instance Counital a c => Semiring (Tran a b c)
instance Counital a m => LeftSemimodule (Tran a b m) (Tran a b m) where
lscale = (*)
instance LeftSemimodule r s => LeftSemimodule r (Tran s b m) where
lscale s (Tran m) = Tran $ \k b -> s *. m k b
instance Counital a m => RightSemimodule (Tran a b m) (Tran a b m) where
rscale = (*)
instance RightSemimodule r s => RightSemimodule r (Tran s b m) where
rscale s (Tran m) = Tran $ \k b -> m k b .* s
instance (Additive-Group) a => Magma (Additive (Tran a b c)) where
(<<) = liftR2 subTran
instance (Additive-Group) a => Quasigroup (Additive (Tran a b c)) where
instance (Additive-Group) a => Loop (Additive (Tran a b c)) where
instance (Additive-Group) a => Group (Additive (Tran a b c)) where
instance (Ring a, Counital a c) => Ring (Tran a b c)