{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FlexibleContexts #-}
module Numeric.Covector
  ( Covector(..)
  -- * Covectors as linear functionals
  , counitM
  , unitM
  , comultM
  , multM
  , invM
  , coinvM
  , antipodeM
  , convolveM
  ) where

import Numeric.Additive.Class
import Numeric.Additive.Group
import Numeric.Algebra.Class
import Numeric.Algebra.Unital
import Numeric.Algebra.Idempotent
import Numeric.Algebra.Involutive
import Numeric.Algebra.Commutative
import Numeric.Algebra.Hopf
import Numeric.Rig.Class
import Numeric.Ring.Class
import Control.Applicative
import Control.Monad
import Data.Functor.Plus hiding (zero)
import qualified Data.Functor.Plus as Plus
import Data.Functor.Bind
import Prelude hiding ((+),(-),negate,subtract,replicate,(*))

-- | Linear functionals from elements of an (infinite) free module to a scalar

-- f $* (x + y) = (f $* x) + (f $* y)
-- f $* (a .* x) = a * (f $* x)

infixr 0 $*
newtype Covector r a = Covector { ($*) :: (a -> r) -> r }

instance Functor (Covector r) where
  fmap f m = Covector $ \k -> m $* k . f

instance Apply (Covector r) where
  mf <.> ma = Covector $ \k -> mf $* \f -> ma $* k . f

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

instance Bind (Covector r) where
  m >>- f = Covector $ \k -> m $* \a -> f a $* k
  
instance Monad (Covector r) where
  return a = Covector $ \k -> k a
  m >>= f = Covector $ \k -> m $* \a -> f a $* k

instance Additive r => Alt (Covector r) where
  Covector m <!> Covector n = Covector $ m + n

instance Monoidal r => Plus (Covector r) where
  zero = Covector zero 

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

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

instance Additive r => Additive (Covector r a) where
  Covector m + Covector n = Covector $ m + n
  sinnum1p n (Covector m) = Covector $ sinnum1p n m

instance Coalgebra r m => Multiplicative (Covector r m) where
  Covector f * Covector g = Covector $ \k -> f (\m -> g (comult k m))

instance (Commutative m, Coalgebra r m) => Commutative (Covector r m)

instance Coalgebra r m => Semiring (Covector r m)

instance CounitalCoalgebra r m => Unital (Covector r m) where
  one = Covector counit

instance (Rig r, CounitalCoalgebra r m) => Rig (Covector r m)

instance (Ring r, CounitalCoalgebra r m) => Ring (Covector r m)

instance Idempotent r => Idempotent (Covector r a)

instance (Idempotent r, IdempotentCoalgebra r a) => Band (Covector r a)

multM :: Coalgebra r c => c -> c -> Covector r c
multM a b = Covector $ \k -> comult k a b

unitM :: CounitalCoalgebra r c => Covector r c
unitM = Covector counit

comultM :: Algebra r a => a -> Covector r (a,a)
comultM c = Covector $ \k -> mult (curry k) c 

counitM :: UnitalAlgebra r a => a -> Covector r ()
counitM a = Covector $ \k -> unit (k ()) a

convolveM :: (Algebra r c, Coalgebra r a) => (c -> Covector r a) -> (c -> Covector r a) -> c -> Covector r a
convolveM f g c = do
   (c1,c2) <- comultM c
   a1 <- f c1
   a2 <- g c2
   multM a1 a2

invM :: InvolutiveAlgebra r h => h -> Covector r h
invM = Covector . flip inv

coinvM :: InvolutiveCoalgebra r h => h -> Covector r h
coinvM = Covector . flip coinv

-- | convolveM antipodeM return = convolveM return antipodeM = comultM >=> uncurry joinM
antipodeM :: HopfAlgebra r h => h -> Covector r h
antipodeM = Covector . flip antipode

-- TODO: we can also build up the augmentation ideal

instance Monoidal s => Monoidal (Covector s a) where
  zero = Covector zero
  sinnum n (Covector m) = Covector (sinnum n m)

instance Abelian s => Abelian (Covector s a)

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

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

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

instance Coalgebra r m => RightModule (Covector r m) (Covector r m) where
  (*.) = (*)

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