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

{-# LANGUAGE TypeFamilies, EmptyDataDecls #-}


module Math.QuantumAlgebra.OrientedTangle where

import Prelude hiding ( (*>) )

import Math.Algebra.Field.Base
import Math.Algebras.LaurentPoly -- hiding (lvar, q, q')

import Math.QuantumAlgebra.TensorCategory

import Math.Algebras.VectorSpace
import Math.Algebras.TensorProduct
import Math.Algebras.Structures

-- import MathExperiments.Algebra.TAlgebra


-- ORIENTED TANGLE CATEGORY

data Oriented = Plus | Minus deriving (Eq,Ord,Show)

data HorizDir = ToL | ToR deriving (Eq,Ord,Show)

data OrientedTangle

-- In GHCi 6.12.1, we appear to be limited to 8 value constructors within an associated data family
instance MCategory 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 Monoidal OrientedTangle where
    tunit = OT []
    tob (OT as) (OT bs) = OT (as++bs)
    tar a b = ParT [a,b]



idV = id
idV' = id

evalV  = \(E i, E j) -> if i + j == 0 then return () else zerov
evalV' = \(E i, E j) -> if i + j == 0 then return () else zerov

coevalV  m = foldl (<+>) zerov [e i `te` e (-i) | i <- [1..m] ]
coevalV' m = foldl (<+>) zerov [e (-i) `te` e i | i <- [1..m] ]

lambda m = q' ^ m -- q^-m

c m (E i, E j) = case compare i j of
                      EQ -> (lambda m * q) *> return (E i, E i)
                      LT -> lambda m *> return (E j, E i)
                      GT -> lambda m *> (return (E j, E i) <+> (q - q') *> return (E i, E j))

-- inverse of c
c' m (E i, E j) = case compare i j of
                       EQ -> (1/(lambda m * q)) *> return (E i, E i)
                       LT -> (1/lambda m) *> (return (E j, E i) <+> (q'-q) *> return (E i, E j))
                       GT -> (1/lambda m) *> return (E j, E i)

testcc' m v = nf $ v >>= c m >>= c' m

mu m (E i) = (1 / (lambda m * q ^ (2*i-1))) *> return (E i)

mu' m (E i) = (lambda m * q ^ (2*i-1)) *> return (E i)

-- The following are modified from Kassel. We compose diagrams downwards, whereas he composes them upwards.

capRL m = coevalV m

capLR m = do
    (i,j) <- coevalV' m
    k <- mu' m j
    return (i,k)

cupRL m = evalV

cupLR m (i,j) = do
    k <- mu m i
    evalV' (k,j)
-- linear evalV' . (linear (mu' m) `tf` idV)



xplus m = c m

xminus m = c' m

yplus m (p,q) = do
    (r,s) <- capRL m
    (t,u) <- xplus m (q,r)
    cupRL m (p,t)
    return (u,s)

yminus m (p,q) = do
    (r,s) <- capRL m
    (t,u) <- xminus m (q,r)
    cupRL m (p,t)
    return (u,s)

tplus m (p,q) = do
    (r,s) <- capLR m
    (t,u) <- xplus m (s,p)
    cupLR m (u,q)
    return (r,t)

tminus m (p,q) = do
    (r,s) <- capLR m
    (t,u) <- xminus m (s,p)
    cupLR m (u,q)
    return (r,t)

zplus m (p,q) = do
    (r,u) <- capLR m
    (s,t) <- capLR m
    (v,w) <- xplus m (t,u)
    cupLR m (v,q)
    cupLR m (w,p)
    return (r,s)

zminus m (p,q) = do
    (r,u) <- capLR m
    (s,t) <- capLR m
    (v,w) <- xminus m (t,u)
    cupLR m (v,q)
    cupLR m (w,p)
    return (r,s)

{-
Then we have for example the following:
> let v = e1 `te` e2 in nf $ v >>= xplus 2 >>= xminus 2
(e1,e2)
> let v = e (-1) `te` e2 in nf $ v >>= yplus 2 >>= tminus 2
(e-1,e2)
> let v = e (-1) `te` e (-2) in nf $ v >>= zplus 2 >>= zminus 2
(e-1,e-2)
-}


oloop m = nf $ do
    (a,b) <- capLR m
    cupRL m (a,b)

-- oriented trefoil
otrefoil m = nf $ do
    (p,q) <- capLR m
    (r,s) <- capLR m
    (t,u) <- tminus m (q,r)
    (v,w) <- zminus m (p,t)
    (x,y) <- xminus m (u,s)
    cupRL m (w,x)
    cupRL m (v,y)

-- oriented the other way
otrefoil' m = nf $ do
    (p,q) <- capRL m
    (r,s) <- capRL m
    (t,u) <- yminus m (q,r)
    (v,w) <- xminus m (p,t)
    (x,y) <- zminus m (u,s)
    cupLR m (w,x)
    cupLR m (v,y)


{-
-- REPRESENTATIONS OF THE TANGLE CATEGORY IN VECTOR SPACE CATEGORY
-- But we need to convert the above code to use TensorAlgebra first

kauffman :: Ar Tangle -> TangleRep [Oriented] -> TangleRep [Oriented]
kauffman (IdT n) = id -- could be tf of n ids
kauffman CapT = linear cap
kauffman CupT = linear cup
kauffman OverT = linear over
kauffman UnderT = linear under
kauffman (SeqT fs) = foldl (>>>) id $ map kauffman fs
    where g >>> h = h . g
kauffman (ParT [f]) = kauffman f
kauffman (ParT (f:fs)) = tf m (kauffman f) (kauffman (ParT fs))
    where OT m = source f
          tf m f' fs' = linear (\xs -> let (ls,rs) = splitAt m xs in f' (return ls) * fs' (return rs) )
-}