    -- Copyright (c) 2010-2015, 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 Prelude hiding ( (*>) )

    -- 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 hiding (Vect)

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

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

    instance (Eq k, Num k, Ord a) => Algebra k [a] where
        unit 0 = zerov -- 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 MCategory 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 Monoidal 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 _ = zerov

    -- 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 [])