-- Copyright (c) 2010, David Amos. All rights reserved.

{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, NoMonomorphismRestriction #-}

-- |A module defining the quantum plane and its symmetries
module Math.QuantumAlgebra.QuantumPlane where

-- Refs:
-- Kassel, Quantum Groups
-- Street, Quantum Groups

import Math.Algebra.Field.Base hiding (powers)

import Math.Algebras.VectorSpace
import Math.Algebras.TensorProduct
import Math.Algebras.Structures
import Math.Algebras.LaurentPoly
import Math.Algebras.NonCommutative
import qualified Data.List as L



qvar v = let V [(m,1)] = var v in V [(m,1 :: LaurentPoly Q)]


a = qvar "a"
b = qvar "b"
c = qvar "c"
d = qvar "d"

detq = a*d-unit q'*b*c


x = qvar "x"
y = qvar "y"
-- z = qvar "z"

u = qvar "u"
v = qvar "v"


-- Quantum plane Aq20

aq20 = [y*x-unit q*x*y]
-- Kassel p72, Street p10

newtype Aq20 v = Aq20 (NonComMonomial v) deriving (Eq,Ord)

instance (Eq v, Show v) => Show (Aq20 v) where show (Aq20 m) = show m

instance Monomial Aq20 where
    var v = V [(Aq20 (NCM 1 [v]),1)]
    powers (Aq20 m) = powers m

instance Algebra (LaurentPoly Q) (Aq20 String) where
    unit 0 = zerov -- V []
    unit x = V [(munit,x)] where munit = Aq20 (NCM 0 [])
    mult x = x''' where
        x' = mult $ fmap ( \(Aq20 a, Aq20 b) -> (a,b) ) x -- unwrap and multiply
        x'' = x' %% aq20 -- quotient by m2q relations while unwrapped
        x''' = fmap Aq20 x'' -- wrap the monomials up as Aq20 again


-- Quantum superplane Aq02

aq02 = [u^2, v^2, u*v+unit q*v*u]
-- Street p10

newtype Aq02 v = Aq02 (NonComMonomial v) deriving (Eq,Ord)

instance (Eq v, Show v) => Show (Aq02 v) where show (Aq02 m) = show m

instance Monomial Aq02 where
    var v = V [(Aq02 (NCM 1 [v]),1)]
    powers (Aq02 m) = powers m

instance Algebra (LaurentPoly Q) (Aq02 String) where
    unit 0 = zerov -- V []
    unit x = V [(munit,x)] where munit = Aq02 (NCM 0 [])
    mult x = x''' where
        x' = mult $ fmap ( \(Aq02 a, Aq02 b) -> (a,b) ) x -- unwrap and multiply
        x'' = x' %% aq02 -- quotient by m2q relations while unwrapped
        x''' = fmap Aq02 x'' -- wrap the monomials up as Aq02 again


-- M2q

m2q = [a*b-unit q'*b*a, a*c-unit q'*c*a, c*d-unit q'*d*c, b*d-unit q'*d*b,
       b*c-c*b, a*d-d*a-unit (q'-q)*b*c]
-- Kassel p78, Street p9
-- I think this is already a Groebner basis

newtype M2q v = M2q (NonComMonomial v) deriving (Eq,Ord)

instance (Eq v, Show v) => Show (M2q v) where show (M2q m) = show m

instance Monomial M2q where
    var v = V [(M2q (NCM 1 [v]),1)]
    powers (M2q m) = powers m

instance Algebra (LaurentPoly Q) (M2q String) where
    unit 0 = zerov -- V []
    unit x = V [(munit,x)] where munit = M2q (NCM 0 [])
    mult x = x''' where
        x' = mult $ fmap ( \(M2q a, M2q b) -> (a,b) ) x -- unwrap and multiply
        x'' = x' %% m2q -- quotient by m2q relations while unwrapped
        x''' = fmap M2q x'' -- wrap the monomials up as M2q again

-- Kassel p82-3
instance Coalgebra (LaurentPoly Q) (M2q String) where
    counit x = case x `bind` cu of
               V [] -> 0
               V [(M2q (NCM 0 []), c)] -> c
        where cu "a" = 1 :: Vect (LaurentPoly Q) (M2q String)
              cu "b" = 0
              cu "c" = 0
              cu "d" = 1
    comult x = x `bind` cm
        where cm "a" = a `te` a + b `te` c
              cm "b" = a `te` b + b `te` d
              cm "c" = c `te` a + d `te` c
              cm "d" = c `te` b + d `te` d

instance Bialgebra (LaurentPoly Q) (M2q String) where {}

{-
-- The following shows that the M2q relations are *sufficient*
-- for M2q to be symmetries of Aq20 and Aq02

> let x' = a*x+b*y :: Vect (LaurentPoly Q) (NonComMonomial String)
> let y' = c*x+d*y :: Vect (LaurentPoly Q) (NonComMonomial String)
> (y'*x'-unit q*x'*y') %% (m2q ++ aq20 ++ [s*t-t*s | s <- [a,b,c,d], t <- [x,y]])
0

> let u' = a*u+b*v :: Vect (LaurentPoly Q) (NonComMonomial String)
> let v' = c*u+d*v :: Vect (LaurentPoly Q) (NonComMonomial String)
> (u'^2) %% (m2q ++ aq02 ++ [s*t-t*s | s <- [a,b,c,d], t <- [u,v]])
0
> (v'^2) %% (m2q ++ aq02 ++ [s*t-t*s | s <- [a,b,c,d], t <- [u,v]])
0
> (u'*v'+unit q*v'*u') %% (m2q ++ aq02 ++ [s*t-t*s | s <- [a,b,c,d], t <- [u,v]])
0

-- To show that the M2q relations are necessary,
-- set the coefficients of x^2, yx, y^2, and vu == 0 in all of the following
> (y'*x'-unit q*x'*y') %% (aq20 ++ [p*q-q*p | p <- [a,b,c,d], q <- [x,y]])
-qx^2ac+x^2ca-yxad-qyxbc+q^-1yxcb+yxda-qy^2bd+y^2db
> (u'^2) %% (aq02 ++ [p*q-q*p | p <- [a,b,c,d], q <- [u,v]])
-qvuab+vuba
> (v'^2) %% (aq02 ++ [p*q-q*p | p <- [a,b,c,d], q <- [u,v]])
-qvucd+vudc
> (u'*v'+unit q*v'*u') %% (aq02 ++ [p*q-q*p | p <- [a,b,c,d], q <- [u,v]])
-qvuad+vubc-q^2vucb+qvuda

-- yx => -ad-qbc+q^-1cb+da == 0
-- vu => -qad+bc-q^2cb+qda == 0
-- qyx-vu => -q^2bc+cb-bc+q^2cb == 0 => bc == cb
-- Now substitute back into yx

-- We could probably have got gb to do this for us
-}

-- Kassel p85
instance Comodule (LaurentPoly Q) (M2q String) (Aq20 String) where
    coaction xy = xy `bind` ca where
        ca "x" = (a `te` x) + (b `te` y) -- we can use (+) instead of add since Aq20 is an algebra 
        ca "y" = (c `te` x) + (d `te` y)
-- coaction (x) = (a b) `te` (x)
--          (y)   (c d)      (y)


-- SL2q

sl2q = [a*b-unit q'*b*a, a*c-unit q'*c*a, c*d-unit q'*d*c, b*d-unit q'*d*b,
        b*c-c*b, a*d-d*a-unit (q'-q)*b*c,
        -unit q*c*b + d*a - 1] -- det q, but reduced
--        a*d-unit q'*b*c-1] -- det_q
-- We have to hand-reduce detq, or else call gb



newtype SL2q v = SL2q (NonComMonomial v) deriving (Eq,Ord)

instance (Eq v, Show v) => Show (SL2q v) where show (SL2q m) = show m

instance Monomial SL2q where
    var v = V [(SL2q (NCM 1 [v]),1)]
    powers (SL2q m) = powers m

instance Algebra (LaurentPoly Q) (SL2q String) where
    unit 0 = zerov -- V []
    unit x = V [(munit,x)] where munit = SL2q (NCM 0 [])
    mult x = x''' where
        x' = mult $ fmap ( \(SL2q a, SL2q b) -> (a,b) ) x -- unwrap and multiply
        x'' = x' %% sl2q -- quotient by sl2q relations while unwrapped
        x''' = fmap SL2q x'' -- wrap the monomials up as SL2q again

instance Coalgebra (LaurentPoly Q) (SL2q String) where
    counit x = case x `bind` cu of
               V [] -> 0
               V [(SL2q (NCM 0 []), c)] -> c
        where cu "a" = 1 :: Vect (LaurentPoly Q) (SL2q String)
              cu "b" = 0
              cu "c" = 0
              cu "d" = 1
    comult x = x `bind` cm
        where cm "a" = a `te` a + b `te` c
              cm "b" = a `te` b + b `te` d
              cm "c" = c `te` a + d `te` c
              cm "d" = c `te` b + d `te` d

instance Bialgebra (LaurentPoly Q) (SL2q String) where {}

-- Kassel p84
instance HopfAlgebra (LaurentPoly Q) (SL2q String) where
    antipode x = x `bind` antipode'
        where antipode' "a" = d
              antipode' "b" = - unit q * b
              antipode' "c" = - unit q' * c
              antipode' "d" = a
-- in the GL2q case we would need 1/detq factor as well



-- !! The following probably needs to be rehoused in separate module at some point
-- YANG-BAXTER OPERATOR

-- This is a Yang-Baxter operator, but not the only possible such
-- Street, p93
yb x = nf $ x >>= yb' where
    yb' (a,b) = case compare a b of
                 GT -> return (b,a)
                 LT -> return (b,a) + unit (q-q') * return (a,b)
                 EQ -> unit q * return (a,a)