Map.hs

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

import Control.Applicative
import Control.Arrow
import Control.Category
import Control.Monad
import Control.Monad.Reader.Class
import Data.Functor.Rep
import Data.Functor.Bind
import Data.Functor.Plus hiding (zero)
import qualified Data.Functor.Plus as Plus
import Data.Semigroupoid
import Numeric.Algebra
import Prelude hiding ((*), (+), negate, subtract,(-), recip, (/), foldr, sum, product, replicate, concat, (.), id, 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)

($#) :: (Representable v, Representable w) => Map r (Rep w) (Rep 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 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
  ask = id
  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 ]

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
-}