module Math.QuantumAlgebra.OrientedTangle where
import Math.Algebra.Field.Base
import Math.Algebras.LaurentPoly
import Math.QuantumAlgebra.TensorCategory
import Math.Algebras.VectorSpace
import Math.Algebras.TensorProduct
import Math.Algebras.Structures
data Oriented = Plus | Minus deriving (Eq,Ord,Show)
data HorizDir = ToL | ToR deriving (Eq,Ord,Show)
data OrientedTangle
instance Category OrientedTangle where
data Ob OrientedTangle = OT [Oriented] deriving (Eq,Ord,Show)
data Ar OrientedTangle = IdT [Oriented]
| CapT HorizDir
| CupT HorizDir
| XPlus | XMinus
| SeqT [Ar OrientedTangle]
| ParT [Ar OrientedTangle]
deriving (Eq,Ord,Show)
id_ (OT os) = IdT os
source (IdT os) = OT os
source (CapT _) = OT []
source (CupT toR) = OT [Plus,Minus]
source (CupT toL) = OT [Minus,Plus]
source XPlus = OT [Plus,Plus]
source XMinus = OT [Plus,Plus]
source (ParT as) = OT $ concatMap ((\(OT os) -> os) . source) as
source (SeqT as) = source (head as)
target (IdT os) = OT os
target (CapT toR) = OT [Minus,Plus]
target (CapT toL) = OT [Plus,Minus]
target (CupT _) = OT []
target XPlus = OT [Plus,Plus]
target XMinus = OT [Plus,Plus]
target (ParT as) = OT $ concatMap ((\(OT os) -> os) . target) as
target (SeqT as) = target (last as)
a >>> b | target a == source b = SeqT [a,b]
instance TensorCategory OrientedTangle where
tunit = OT []
tob (OT as) (OT bs) = OT (as++bs)
tar a b = ParT [a,b]
idV = id
idV' = id
evalV = \(T (E i) (E j)) -> if i + j == 0 then return () else zero
evalV' = \(T (E i) (E j)) -> if i + j == 0 then return () else zero
coevalV m = foldl (<+>) zero [e i `te` e (i) | i <- [1..m] ]
coevalV' m = foldl (<+>) zero [e (i) `te` e i | i <- [1..m] ]
lambda m = q' ^ m
c m (T (E i) (E j)) = case compare i j of
EQ -> (lambda m * q) *> return (T (E i) (E i))
LT -> lambda m *> return (T (E j) (E i))
GT -> lambda m *> (return (T (E j) (E i)) <+> (q q') *> return (T (E i) (E j)))
c' m (T (E i) (E j)) = case compare i j of
EQ -> (1/(lambda m * q)) *> return (T (E i) (E i))
LT -> (1/lambda m) *> (return (T (E j) (E i)) <+> (q'q) *> return (T (E i) (E j)))
GT -> (1/lambda m) *> return (T (E j) (E i))
testcc' m v = nf $ v >>= c m >>= c' m
mu m (E i) = (1 / (lambda m * q ^ (2*i1))) *> return (E i)
mu' m (E i) = (lambda m * q ^ (2*i1)) *> return (E i)
capRL m = coevalV m
capLR m = do
T i j <- coevalV' m
k <- mu' m j
return (T i k)
cupRL m = evalV
cupLR m (T i j) = do
k <- mu m i
evalV' (T k j)
xplus m = c m
xminus m = c' m
yplus m (T p q) = do
T r s <- capRL m
T t u <- xplus m (T q r)
cupRL m (T p t)
return (T u s)
yminus m (T p q) = do
T r s <- capRL m
T t u <- xminus m (T q r)
cupRL m (T p t)
return (T u s)
tplus m (T p q) = do
T r s <- capLR m
T t u <- xplus m (T s p)
cupLR m (T u q)
return (T r t)
tminus m (T p q) = do
T r s <- capLR m
T t u <- xminus m (T s p)
cupLR m (T u q)
return (T r t)
zplus m (T p q) = do
T r u <- capLR m
T s t <- capLR m
T v w <- xplus m (T t u)
cupLR m (T v q)
cupLR m (T w p)
return (T r s)
zminus m (T p q) = do
T r u <- capLR m
T s t <- capLR m
T v w <- xminus m (T t u)
cupLR m (T v q)
cupLR m (T w p)
return (T r s)
oloop m = nf $ do
T a b <- capLR m
cupRL m (T a b)
otrefoil m = nf $ do
T p q <- capLR m
T r s <- capLR m
T t u <- tminus m (T q r)
T v w <- zminus m (T p t)
T x y <- xminus m (T u s)
cupRL m (T w x)
cupRL m (T v y)
otrefoil' m = nf $ do
T p q <- capRL m
T r s <- capRL m
T t u <- yminus m (T q r)
T v w <- xminus m (T p t)
T x y <- zminus m (T u s)
cupLR m (T w x)
cupLR m (T v y)