{-# LANGUAGE CPP #-}
{-# LANGUAGE Safe #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
module Data.Semimodule.Transform (
type (**)
, type (++)
, type Dim
, type Endo
, Tran(..)
, app
, arr
, invmap
, rows
, cols
, projl
, projr
, compl
, compr
, complr
, transpose
, braid
, sbraid
, first
, second
, left
, right
, (***)
, (+++)
, (&&&)
, (|||)
, ($$$)
, adivide
, adivide'
, aselect
, aselect'
) where
import safe Control.Category (Category, (>>>))
import safe Data.Functor.Compose
import safe Data.Functor.Product
import safe Data.Functor.Rep
import safe Data.Profunctor
import safe Data.Semimodule
import safe Data.Tuple (swap)
import safe Prelude hiding (Num(..), Fractional(..), negate, sum, product)
import safe Test.Logic
import safe qualified Control.Category as C
import safe qualified Data.Bifunctor as B
infixr 2 **
infixr 1 ++
type (f ** g) = Compose f g
type (f ++ g) = Product f g
type Dim b c = forall a . Tran a b c
type Endo a b = Tran a b b
newtype Tran a b c = Tran { runTran :: (c -> a) -> (b -> a) } deriving Functor
instance Category (Tran a) where
id = Tran id
Tran f . Tran g = Tran $ g . f
instance Profunctor (Tran a) where
lmap f (Tran t) = Tran $ \ca -> t ca . f
rmap = fmap
app :: Basis2 b c f g => Tran a b c -> g a -> f a
app t = tabulate . runTran t . index
arr :: (b -> c) -> Tran a b c
arr f = Tran (. f)
invmap :: (a1 -> a2) -> (a2 -> a1) -> Tran a1 b c -> Tran a2 b c
invmap f g (Tran t) = Tran $ \x -> t (x >>> g) >>> f
rows :: Basis2 b c f g => g a -> (f**g) a
rows = app $ arr snd
{-# INLINE rows #-}
cols :: Basis2 b c f g => f a -> (f**g) a
cols = app $ arr fst
{-# INLINE cols #-}
projl :: Basis2 b c f g => (f++g) a -> f a
projl = app $ arr Left
{-# INLINE projl #-}
projr :: Basis2 b c f g => (f++g) a -> g a
projr = app $ arr Right
{-# INLINE projr #-}
compl :: Basis3 b c d f1 f2 g => Dim b c -> (f2**g) a -> (f1**g) a
compl f = app (first f)
compr :: Basis3 b c d f g1 g2 => Dim c d -> (f**g2) a -> (f**g1) a
compr f = app (second f)
complr :: Basis2 b1 c1 f1 f2 => Basis2 b2 c2 g1 g2 => Dim b1 c1 -> Dim b2 c2 -> (f2**g2) a -> (f1**g1) a
complr f g = app (f *** g)
transpose :: Basis2 b c f g => (f**g) a -> (g**f) a
transpose = app braid
{-# INLINE transpose #-}
braid :: Dim (a , b) (b , a)
braid = arr swap
{-# INLINE braid #-}
sbraid :: Dim (a + b) (b + a)
sbraid = arr eswap
{-# INLINE sbraid #-}
first :: Dim b c -> Dim (b , d) (c , d)
first (Tran caba) = Tran $ \cda -> cda . B.first (caba id)
second :: Dim b c -> Dim (d , b) (d , c)
second (Tran caba) = Tran $ \cda -> cda . B.second (caba id)
left :: Dim b c -> Dim (b + d) (c + d)
left (Tran caba) = Tran $ \cda -> cda . B.first (caba id)
right :: Dim b c -> Dim (d + b) (d + c)
right (Tran caba) = Tran $ \cda -> cda . B.second (caba id)
infixr 3 ***
(***) :: Dim a1 b1 -> Dim a2 b2 -> Dim (a1 , a2) (b1 , b2)
x *** y = first x >>> arr swap >>> first y >>> arr swap
{-# INLINE (***) #-}
infixr 2 +++
(+++) :: Dim a1 b1 -> Dim a2 b2 -> Dim (a1 + a2) (b1 + b2)
x +++ y = left x >>> arr eswap >>> left y >>> arr eswap
{-# INLINE (+++) #-}
infixr 3 &&&
(&&&) :: Dim a b1 -> Dim a b2 -> Dim a (b1 , b2)
x &&& y = dimap fork id $ x *** y
{-# INLINE (&&&) #-}
infixr 2 |||
(|||) :: Dim a1 b -> Dim a2 b -> Dim (a1 + a2) b
x ||| y = dimap id join $ x +++ y
{-# INLINE (|||) #-}
infixr 0 $$$
($$$) :: Dim a (b -> c) -> Dim a b -> Dim a c
($$$) f x = dimap fork apply (f *** x)
{-# INLINE ($$$) #-}
adivide :: (a -> (a1 , a2)) -> Dim a1 b -> Dim a2 b -> Dim a b
adivide f x y = dimap f fst $ x *** y
{-# INLINE adivide #-}
adivide' :: Dim a1 b -> Dim a2 b -> Dim (a1 , a2) b
adivide' = adivide id
{-# INLINE adivide' #-}
aselect :: ((b1 + b2) -> b) -> Dim a b1 -> Dim a b2 -> Dim a b
aselect f x y = dimap Left f $ x +++ y
{-# INLINE aselect #-}
aselect' :: Dim a b1 -> Dim a b2 -> Dim a (b1 + b2)
aselect' = aselect id
{-# INLINE aselect' #-}