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

{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, FlexibleInstances, EmptyDataDecls #-}

-- |A module defining the category of tangles, and representations into the category of vector spaces
-- (specifically, knot invariants).
module Math.QuantumAlgebra.Tangle where

-- import qualified Data.List as L

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

import Math.Algebra.Field.Base
import Math.Algebras.LaurentPoly

import Math.QuantumAlgebra.TensorCategory

instance Mon [a] where
munit = []
mmult = (++)

-- type TensorAlgebra k a = Vect k [a]

instance (Num k, Ord a) => Algebra k [a] where
unit 0 = zero -- V []
unit x = V [(munit,x)]
mult = nf . fmap (\(a,b) -> a `mmult` b)

-- Could make TensorAlgebra k a into an instance of Category, TensorCategory

-- TANGLE CATEGORY
-- (Unoriented)

data Tangle

instance Category Tangle where
data Ob Tangle = OT Int deriving (Eq,Ord,Show)
data Ar Tangle = IdT Int
| CapT
| CupT
| OverT
| UnderT
--                   | SeqT (Ar Tangle) (Ar Tangle)
| SeqT [Ar Tangle]
--                   | ParT (Ar Tangle) (Ar Tangle)
| ParT [Ar Tangle]
deriving (Eq,Ord,Show)
id_ (OT n) = IdT n
source (IdT n) = OT n
source CapT = OT 0
source CupT = OT 2
source OverT = OT 2
source UnderT = OT 2
--    source (ParT a b) = OT (sa + sb) where OT sa = source a; OT sb = source b
source (ParT as) = OT \$ sum [sa | a <- as, let OT sa = source a]
--    source (SeqT a b) = source a
source (SeqT as) = source (head as)
target (IdT n) = OT n
target CapT = OT 2
target CupT = OT 0
target OverT = OT 2
target UnderT = OT 2
--    target (ParT a b) = OT (ta + tb) where OT ta = target a; OT tb = target b
target (ParT as) = OT \$ sum [ta | a <- as, let OT ta = target a]
--    target (SeqT a b) = target b
target (SeqT as) = target (last as)
--    a >>> b | target a == source b = SeqT a b
a >>> b | target a == source b = SeqT [a,b]

instance TensorCategory Tangle where
tunit = OT 0
tob (OT a) (OT b) = OT (a+b)
--    tar a b = ParT a b
tar a b = ParT [a,b]

-- KAUFFMAN BRACKET

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

type TangleRep b = Vect (LaurentPoly Q) b

-- adapted from http://blog.sigfpe.com/2008/10/untangling-with-continued-fractions.html
cap :: [Oriented] -> TangleRep [Oriented]
cap [] = return [Plus, Minus] <+> (-q^2) *> return [Minus, Plus]

cup :: [Oriented] -> TangleRep [Oriented]
cup [Plus, Minus] = (-q'^2) *> return []
cup [Minus, Plus] = return []
cup _ = zero

-- also called xminus
over :: [Oriented] -> TangleRep [Oriented]
over [u, v] = q  *> do {[] <- cup [u, v]; cap []}
<+> q' *> return [u, v]

{-
-- if you expand "over" into terms, you find that it equals the following,
-- which strongly resembles c' below
over' (T i j) = case compare i j of
EQ -> q' *> return (T i i)                                       -- ++ -> q' ++, -- -> q' --
LT -> q  *> return (T j i)                                       -- +- -> q -+
GT -> q  *> (return (T j i) <+> (q'^2 - q^2) *> return (T i j))  -- -+ -> q +- + (q'-q^3) -+
-}
-- also called xplus
under :: [Oriented] -> TangleRep [Oriented]
under [u, v] = q' *> do {[] <- cup [u, v]; cap []}
<+> q  *> return [u, v]

{-
-- if you expand "under" into terms, you find that it equals the following,
-- which strongly resembles c below
under' (T i j) = case compare i j of
EQ -> q  *> return (T i i)                                       -- ++ -> q ++, -- -> q --
LT -> q' *> (return (T j i) <+> (q^2 - q'^2) *> return (T i j))  -- +- -> q' -+ + (q-q^-3) -+
GT -> q' *> return (T j i)                                       -- -+ -> q' +-
-}
loop = nf \$ do {[i, j] <- cap []; cup [i, j]}

trefoil = nf \$ do
[i, j] <- cap []
[k, l] <- cap []
[m, n] <- under [j, k]
[p, q] <- over [i, m]
[r, s] <- over [n, l]
cup [p, s]
cup [q, r]

-- KAUFFMAN BRACKET AS A REPRESENTATION FROM TANGLE TO VECT

-- But this isn't quite the Kauffman bracket - we still need to divide by (-q^2-q^-2)
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) )
{-
kauffman (ParT f g) = tf m n (kauffman f) (kauffman g)
where OT m = source f
OT n = source g
tf m n f' g' = linear (\xs -> let (ls,rs) = splitAt m xs in f' (return ls) * g' (return rs) )
-}

-- loopT = SeqT CapT CupT
loopT = SeqT [CapT, CupT]

{-
trefoilT = (ParT CapT CapT) `SeqT` (ParT (IdT 1) (ParT UnderT (IdT 1)))
`SeqT` (ParT OverT OverT) `SeqT` (ParT (IdT 1) (ParT CupT (IdT 1))) `SeqT` CupT

trefoilT = ParT [CapT, CapT]
`SeqT` ParT [IdT 1, UnderT, IdT 1]
`SeqT` ParT [OverT, OverT]
`SeqT` ParT [IdT 1, CupT, IdT 1]
`SeqT` CupT
-}
trefoilT = SeqT [
ParT [CapT, CapT],
ParT [IdT 1, UnderT, IdT 1],
ParT [OverT, OverT],
ParT [IdT 1, CupT, IdT 1],
CupT]
-- eg kauffman (trefoilT) (return [])
```