```{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeFamilies #-}
module Numeric.Map
( Map(..)
, (\$@)
, multMap
, unitMap
, memoMap
, comultMap
, counitMap
, invMap
, coinvMap
, antipodeMap
, convolveMap
) where

import Control.Applicative
import Control.Arrow
import Control.Categorical.Bifunctor
import Control.Category
import Control.Category.Associative
import Control.Category.Braided
import Control.Category.Cartesian
import Control.Category.Cartesian.Closed
import Control.Category.Distributive
import qualified Control.Category.Monoidal as C
import Control.Category.Monoidal (Id)
import Data.Key
import Data.Functor.Representable
import Data.Functor.Representable.Trie
import Data.Functor.Bind
import Data.Functor.Plus hiding (zero)
import qualified Data.Functor.Plus as Plus
import Data.Semigroupoid
import Data.Void
import Numeric.Algebra
import Prelude hiding ((*), (+), negate, subtract,(-), recip, (/), foldr, sum, product, replicate, concat, (.), id, curry, uncurry, fst, snd)

-- | linear maps from elements of a free module to another free module over r
--
-- > f \$# x + y = (f \$# x) + (f \$# y)
-- > f \$# (r .* x) = r .* (f \$# x)
--
--
-- @Map r b a@ represents a linear mapping from a free module with basis @a@ over @r@ to a free module with basis @b@ over @r@.
--
-- Note well the reversed direction of the arrow, due to the contravariance of change of basis!
--
-- This way enables we can employ arbitrary pure functions as linear maps by lifting them using `arr`, or build them
-- by using the monad instance for Map r b.  As a consequence Map is an instance of, well, almost everything.

infixr 0 \$#
newtype Map r b a = Map ((a -> r) -> b -> r)

(\$#) :: (Indexable v, Representable w) => Map r (Key w) (Key v) -> v r -> w r
(\$#) (Map m) = tabulate . m . index

infixr 0 \$@
-- | extract a linear functional from a linear map
(\$@) :: Map r b a -> b -> Covector r a
m \$@ b = Covector \$ \k -> (m \$# k) b

-- NB: due to contravariance (>>>) to get the usual notion of composition!
instance Category (Map r) where
id = Map id
Map f . Map g = Map (g . f)

instance Semigroupoid (Map r) where
Map f `o` Map g = Map (g . f)

instance Functor (Map r b) where
fmap f m = Map \$ \k -> m \$# k . f

instance Apply (Map r b) where
mf <.> ma = Map \$ \k b -> (mf \$# \f -> (ma \$# k . f) b) b

instance Applicative (Map r b) where
pure a = Map \$ \k _ -> k a
mf <*> ma = Map \$ \k b -> (mf \$# \f -> (ma \$# k . f) b) b

instance Bind (Map r b) where
Map m >>- f = Map \$ \k b -> m (\a -> (f a \$# k) b) b

instance Monad (Map r b) where
return a = Map \$ \k _ -> k a
m >>= f = Map \$ \k b -> (m \$# \a -> (f a \$# k) b) b

instance PFunctor (,) (Map r) (Map r)
instance QFunctor (,) (Map r) (Map r)
instance Bifunctor (,) (Map r) (Map r) (Map r) where
bimap m n = Map \$ \k (a,c) -> (m \$# \b -> (n \$# \d -> k (b,d)) c) a

instance Associative (Map r) (,) where
associate = arr associate
disassociate = arr disassociate

instance Braided (Map r) (,) where
braid = arr braid

instance Symmetric (Map r) (,)

instance C.Monoidal (Map r) (,) where
type Id (Map r) (,) = ()
idl = arr C.idl
idr = arr C.idr
coidl = arr C.coidl
coidr = arr C.coidr

instance Cartesian (Map r) where
type Product (Map r) = (,)
fst = arr fst
snd = arr snd
diag = arr diag
f &&& g = Map \$ \k a -> (f \$# \b -> (g \$# \c -> k (b,c)) a) a

instance CCC (Map r) where
type Exp (Map r) = Map r
apply = Map \$ \k (f,a) -> (f \$# k) a
curry m = Map \$ \k a -> k (Map \$ \k' b -> (m \$# k') (a, b))
uncurry m = Map \$ \k (a, b) -> (m \$# (\m' -> (m' \$# k) b)) a

instance Distributive (Map r) where
distribute = Map \$ \k (a,p) -> k \$ bimap ((,) a) ((,)a) p

instance PFunctor Either (Map r) (Map r)
instance QFunctor Either (Map r) (Map r)
instance Bifunctor Either (Map r) (Map r) (Map r) where
bimap m n = Map \$ \k -> either (m \$# k . Left) (n \$# k . Right)

instance Associative (Map r) Either where
associate = arr associate
disassociate = arr disassociate

instance Braided (Map r) Either where
braid = arr braid

instance Symmetric (Map r) Either

instance CoCartesian (Map r) where
type Sum (Map r) = Either
inl = arr inl
inr = arr inr
codiag = arr codiag
m ||| n = Map \$ \k -> either (m \$# k) (n \$# k)

instance C.Monoidal (Map r) Either where
type Id (Map r) Either = Void
idl = arr C.idl
idr = arr C.idr
coidl = arr C.coidl
coidr = arr C.coidr

instance Arrow (Map r) where
arr f = Map (. f)
first m = Map \$ \k (a,c) -> (m \$# \b -> k (b,c)) a
second m = Map \$ \k (c,a) -> (m \$# \b -> k (c,b)) a
m *** n = Map \$ \k (a,c) -> (m \$# \b -> (n \$# \d -> k (b,d)) c) a
m &&& n = Map \$ \k a -> (m \$# \b -> (n \$# \c -> k (b,c)) a) a

instance ArrowApply (Map r) where
app = Map \$ \k (f,a) -> (f \$# k) a

instance MonadReader b (Map r b) where
local f m = Map \$ \k -> (m \$# k) . f

-- While the following typechecks, it isn't correct,
-- callCC is non-linear, the internal Map ignores the functional it is given!
--
--instance MonadCont (Map r b) where
--  callCC f = Map \$ \k -> (f \$# \a -> Map \$ \_ _ -> k a) k

-- label :: ((a -> r) -> Map r b a) -> Map r b a
-- label f = Map \$ \k -> f k \$# k

-- break :: (a -> r) -> a -> Map r b a

instance Monoidal r => ArrowZero (Map r) where
zeroArrow = Map zero

instance Monoidal r => ArrowPlus (Map r) where
Map m <+> Map n = Map \$ m + n

instance ArrowChoice (Map r) where
left m = Map \$ \k -> either (m \$# k . Left) (k . Right)
right m = Map \$ \k -> either (k . Left) (m \$# k . Right)
m +++ n =  Map \$ \k -> either (m \$# k . Left) (n \$# k . Right)
m ||| n = Map \$ \k -> either (m \$# k) (n \$# k)

-- TODO: ArrowLoop?

-- TODO: more categories instances for (Map r) & Either to get to precocartesian!

instance Additive r => Additive (Map r b a) where
Map m + Map n = Map \$ m + n
sinnum1p n (Map m) = Map \$ sinnum1p n m

instance Coalgebra r m => Multiplicative (Map r b m) where
f * g = Map \$ \k b -> (f \$# \a -> (g \$# comult k a) b) b
instance CounitalCoalgebra r m => Unital (Map r b m) where
one = Map \$ \k _ -> counit k

instance Coalgebra r m => Semiring (Map r b m)

instance Coalgebra r m => LeftModule (Map r b m) (Map r b m) where
(.*) = (*)

instance LeftModule r s => LeftModule r (Map s b m) where
s .* Map m = Map \$ \k b -> s .* m k b

instance Coalgebra r m => RightModule (Map r b m) (Map r b m) where (*.) = (*)
instance RightModule r s => RightModule r (Map s b m) where
Map m *. s = Map \$ \k b -> m k b *. s

instance Additive r => Alt (Map r b) where
Map m <!> Map n = Map \$ m + n

instance Monoidal r => Plus (Map r b) where
zero = Map zero

instance Monoidal r => Alternative (Map r b) where
Map m <|> Map n = Map \$ m + n
empty = Map zero

instance Monoidal r => MonadPlus (Map r b) where
Map m `mplus` Map n = Map \$ m + n
mzero = Map zero

instance Monoidal s => Monoidal (Map s b a) where
zero = Map zero
sinnum n (Map m) = Map \$ sinnum n m

instance Abelian s => Abelian (Map s b a)

instance Group s => Group (Map s b a) where
Map m - Map n = Map \$ m - n
negate (Map m) = Map \$ negate m
subtract (Map m) (Map n) = Map \$ subtract m n
times n (Map m) = Map \$ times n m

instance (Commutative m, Coalgebra r m) => Commutative (Map r b m)

instance (Rig r, CounitalCoalgebra r m) => Rig (Map r b m)

instance (Ring r, CounitalCoalgebra r m) => Ring (Map r a m)

-- | (inefficiently) combine a linear combination of basis vectors to make a map.
-- arrMap :: (Monoidal r, Semiring r) => (b -> [(r, a)]) -> Map r b a
-- arrMap f = Map \$ \k b -> sum [ r * k a | (r, a) <- f b ]

-- | Memoize the results of this linear map
memoMap :: HasTrie a => Map r a a
memoMap = Map memo

comultMap :: Algebra r a => Map r a (a,a)
comultMap = Map \$ mult . curry

multMap :: Coalgebra r c => Map r (c,c) c
multMap = Map \$ uncurry . comult

counitMap :: UnitalAlgebra r a => Map r a ()
counitMap = Map \$ \k -> unit \$ k ()

unitMap :: CounitalCoalgebra r c => Map r () c
unitMap = Map \$ \k () -> counit k

-- | convolution given an associative algebra and coassociative coalgebra
convolveMap :: (Algebra r a, Coalgebra r c) => Map r a c -> Map r a c -> Map r a c
convolveMap f g = multMap . (f *** g) . comultMap

-- convolveMap antipodeMap id = convolveMap id antipodeMap = unit . counit
antipodeMap :: HopfAlgebra r h => Map r h h
antipodeMap = Map antipode

coinvMap :: InvolutiveAlgebra r a => Map r a a
coinvMap = Map inv

invMap :: InvolutiveCoalgebra r c => Map r c c
invMap = Map coinv

{-
-- ring homomorphism from r -> r^a
embedMap :: (Unital m, CounitalCoalgebra r m) => (b -> r) -> Map r b m
embedMap f = Map \$ \k b -> f b * k one

-- if the characteristic of s does not divide the order of a, then s[a] is semisimple
-- and if a has a length function, we can build a filtered algebra

-- | The augmentation ring homomorphism from r^a -> r
augmentMap :: Unital s => Map s b m -> b -> s
augmentMap m = m \$# const one
-}

```