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

    {-# LANGUAGE FlexibleInstances #-}

    module Math.Projects.KnotTheory.TemperleyLieb where

    import Data.List ( (\\) )

    import Math.Algebra.Field.Base
    import Math.Algebra.NonCommutative.NCPoly as NP
    import Math.Algebra.NonCommutative.GSBasis

    import Math.Projects.KnotTheory.LaurentMPoly as LP
    import Math.Projects.KnotTheory.Braid

    -- TEMPERLEY-LIEB ALGEBRAS

    data TemperleyLiebGens = E Int deriving (TemperleyLiebGens -> TemperleyLiebGens -> Bool
    (TemperleyLiebGens -> TemperleyLiebGens -> Bool)
    -> (TemperleyLiebGens -> TemperleyLiebGens -> Bool)
    -> Eq TemperleyLiebGens
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    /= :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    $c/= :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    == :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    $c== :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    Eq,Eq TemperleyLiebGens
    Eq TemperleyLiebGens =>
    (TemperleyLiebGens -> TemperleyLiebGens -> Ordering)
    -> (TemperleyLiebGens -> TemperleyLiebGens -> Bool)
    -> (TemperleyLiebGens -> TemperleyLiebGens -> Bool)
    -> (TemperleyLiebGens -> TemperleyLiebGens -> Bool)
    -> (TemperleyLiebGens -> TemperleyLiebGens -> Bool)
    -> (TemperleyLiebGens -> TemperleyLiebGens -> TemperleyLiebGens)
    -> (TemperleyLiebGens -> TemperleyLiebGens -> TemperleyLiebGens)
    -> Ord TemperleyLiebGens
    TemperleyLiebGens -> TemperleyLiebGens -> Bool
    TemperleyLiebGens -> TemperleyLiebGens -> Ordering
    TemperleyLiebGens -> TemperleyLiebGens -> TemperleyLiebGens
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    min :: TemperleyLiebGens -> TemperleyLiebGens -> TemperleyLiebGens
    $cmin :: TemperleyLiebGens -> TemperleyLiebGens -> TemperleyLiebGens
    max :: TemperleyLiebGens -> TemperleyLiebGens -> TemperleyLiebGens
    $cmax :: TemperleyLiebGens -> TemperleyLiebGens -> TemperleyLiebGens
    >= :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    $c>= :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    > :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    $c> :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    <= :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    $c<= :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    < :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    $c< :: TemperleyLiebGens -> TemperleyLiebGens -> Bool
    compare :: TemperleyLiebGens -> TemperleyLiebGens -> Ordering
    $ccompare :: TemperleyLiebGens -> TemperleyLiebGens -> Ordering
    $cp1Ord :: Eq TemperleyLiebGens
    Ord)

    instance Show TemperleyLiebGens where
        show :: TemperleyLiebGens -> String
    show (E i :: Int
    i) = 'e'Char -> ShowS
    forall a. a -> [a] -> [a]
    : Int -> String
    forall a. Show a => a -> String
    show Int
    i

    e_ :: Int -> NPoly LPQ TemperleyLiebGens
    e_ i :: Int
    i = [(Monomial TemperleyLiebGens, LPQ)] -> NPoly LPQ TemperleyLiebGens
    forall r v. [(Monomial v, r)] -> NPoly r v
    NP [([TemperleyLiebGens] -> Monomial TemperleyLiebGens
    forall v. [v] -> Monomial v
    M [Int -> TemperleyLiebGens
    E Int
    i], 1)] :: NPoly LPQ TemperleyLiebGens

    -- d is the value of a closed loop

    d :: LPQ
    d = String -> LPQ
    forall r. Num r => String -> LaurentMPoly r
    LP.var "d"
    d' :: NPoly LPQ TemperleyLiebGens
    d' = LPQ -> NPoly LPQ TemperleyLiebGens
    forall r v. (Num r, Eq r, Eq v, Show v) => r -> NPoly r v
    NP.inject LPQ
    d :: NPoly LPQ TemperleyLiebGens

    e1 :: NPoly LPQ TemperleyLiebGens
    e1 = Int -> NPoly LPQ TemperleyLiebGens
    e_ 1
    e2 :: NPoly LPQ TemperleyLiebGens
    e2 = Int -> NPoly LPQ TemperleyLiebGens
    e_ 2
    e3 :: NPoly LPQ TemperleyLiebGens
    e3 = Int -> NPoly LPQ TemperleyLiebGens
    e_ 3
    e4 :: NPoly LPQ TemperleyLiebGens
    e4 = Int -> NPoly LPQ TemperleyLiebGens
    e_ 4

    -- Temperley-Lieb algebra An(d), generated by n-1 elts e1..e_n-1, together with relations

    tlRelations :: Int -> [NPoly LPQ TemperleyLiebGens]
    tlRelations n :: Int
    n =
        [Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    i NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    * Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    j NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    - Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    j NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    * Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    i | Int
    i <- [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1], Int
    j <- [Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +2..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1] ] [NPoly LPQ TemperleyLiebGens]
    -> [NPoly LPQ TemperleyLiebGens] -> [NPoly LPQ TemperleyLiebGens]
    forall a. [a] -> [a] -> [a]
    ++
        [Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    i NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    * Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    j NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    * Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    i NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    - Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    i | Int
    i <- [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1], Int
    j <- [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1], Int -> Int
    forall a. Num a => a -> a
    abs (Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    j) Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == 1 ] [NPoly LPQ TemperleyLiebGens]
    -> [NPoly LPQ TemperleyLiebGens] -> [NPoly LPQ TemperleyLiebGens]
    forall a. [a] -> [a] -> [a]
    ++
        [(Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    i)NPoly LPQ TemperleyLiebGens
    -> Integer -> NPoly LPQ TemperleyLiebGens
    forall a b. (Num a, Integral b) => a -> b -> a
    ^2 NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    - NPoly LPQ TemperleyLiebGens
    d' NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    * Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    i | Int
    i <- [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1] ]

    -- given an elt of the Temperley-Lieb algebra, return the dimension it's defined over (ie the number of points)

    dimTL :: NPoly r TemperleyLiebGens -> Int
    dimTL (NP ts :: [(Monomial TemperleyLiebGens, r)]
    ts) = 1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [Int] -> Int
    forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
    maximum (0 Int -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    : [Int
    i | (M bs :: [TemperleyLiebGens]
    bs,c :: r
    c) <- [(Monomial TemperleyLiebGens, r)]
    ts, E i :: Int
    i <- [TemperleyLiebGens]
    bs])

    -- Reduce to normal form

    tlnf :: NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    tlnf f :: NPoly LPQ TemperleyLiebGens
    f = NPoly LPQ TemperleyLiebGens
    f NPoly LPQ TemperleyLiebGens
    -> [NPoly LPQ TemperleyLiebGens] -> NPoly LPQ TemperleyLiebGens
    forall r v.
    (Fractional r, Ord v, Show v, Eq r) =>
    NPoly r v -> [NPoly r v] -> NPoly r v
    %% ([NPoly LPQ TemperleyLiebGens] -> [NPoly LPQ TemperleyLiebGens]
    forall v r.
    (Show v, Fractional r, Ord v, Ord r) =>
    [NPoly r v] -> [NPoly r v]
    gb ([NPoly LPQ TemperleyLiebGens] -> [NPoly LPQ TemperleyLiebGens])
    -> [NPoly LPQ TemperleyLiebGens] -> [NPoly LPQ TemperleyLiebGens]
    forall a b. (a -> b) -> a -> b
    $ Int -> [NPoly LPQ TemperleyLiebGens]
    tlRelations (Int -> [NPoly LPQ TemperleyLiebGens])
    -> Int -> [NPoly LPQ TemperleyLiebGens]
    forall a b. (a -> b) -> a -> b
    $ NPoly LPQ TemperleyLiebGens -> Int
    forall r. NPoly r TemperleyLiebGens -> Int
    dimTL NPoly LPQ TemperleyLiebGens
    f)

    -- Monomial basis for Temperley-Lieb algebra (as quotient of free algebra by Temperley-Lieb relations)

    tlBasis :: Int -> [NPoly LPQ TemperleyLiebGens]
    tlBasis n :: Int
    n = [NPoly LPQ TemperleyLiebGens]
    -> [NPoly LPQ TemperleyLiebGens] -> [NPoly LPQ TemperleyLiebGens]
    forall r v.
    (Eq r, Fractional r, Ord v, Show v) =>
    [NPoly r v] -> [NPoly r v] -> [NPoly r v]
    mbasisQA [Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    i | Int
    i <- [1..Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1]] ([NPoly LPQ TemperleyLiebGens] -> [NPoly LPQ TemperleyLiebGens]
    forall v r.
    (Show v, Fractional r, Ord v, Ord r) =>
    [NPoly r v] -> [NPoly r v]
    gb ([NPoly LPQ TemperleyLiebGens] -> [NPoly LPQ TemperleyLiebGens])
    -> [NPoly LPQ TemperleyLiebGens] -> [NPoly LPQ TemperleyLiebGens]
    forall a b. (a -> b) -> a -> b
    $ Int -> [NPoly LPQ TemperleyLiebGens]
    tlRelations Int
    n)

    -- trace function

    -- the trace of an elt is d^k, where k is the number of loops in its closure (ie join the top and bottom of the diagram to make an annulus)

    -- this is clearly the same as the number of cycles of the elt when thought of as an elt of Sn, with ei mapped to the transposition (i i+1)

    tr' :: Int -> Monomial TemperleyLiebGens -> LPQ
    tr' n :: Int
    n (M g :: [TemperleyLiebGens]
    g) = LPQ
    d LPQ -> Int -> LPQ
    forall a b. (Num a, Integral b) => a -> b -> a
    ^ ( -1 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    + [[Int]] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length ([TemperleyLiebGens] -> [Int] -> [[Int]]
    forall t. t -> [Int] -> [[Int]]
    orbits [TemperleyLiebGens]
    g [1..Int
    n]) ) where
        image :: Int -> [TemperleyLiebGens] -> Int
    image i :: Int
    i [] = Int
    i
        image i :: Int
    i (E j :: Int
    j : es :: [TemperleyLiebGens]
    es) | Int
    i Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    j    = Int -> [TemperleyLiebGens] -> Int
    image (Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +1) [TemperleyLiebGens]
    es
                           | Int
    i Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    jInt -> Int -> Int
    forall a. Num a => a -> a -> a
    +1  = Int -> [TemperleyLiebGens] -> Int
    image (Int
    iInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1) [TemperleyLiebGens]
    es
                           | Bool
    otherwise = Int -> [TemperleyLiebGens] -> Int
    image Int
    i [TemperleyLiebGens]
    es
        orbits :: t -> [Int] -> [[Int]]
    orbits g :: t
    g [] = []
        orbits g :: t
    g (i :: Int
    i:is :: [Int]
    is) = let i' :: [Int]
    i' = Int -> [Int] -> [Int]
    orbit Int
    i [] in [Int]
    i' [Int] -> [[Int]] -> [[Int]]
    forall a. a -> [a] -> [a]
    : t -> [Int] -> [[Int]]
    orbits t
    g ((Int
    iInt -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    :[Int]
    is) [Int] -> [Int] -> [Int]
    forall a. Eq a => [a] -> [a] -> [a]
    \\ [Int]
    i')
        orbit :: Int -> [Int] -> [Int]
    orbit j :: Int
    j js :: [Int]
    js = let j' :: Int
    j' = Int -> [TemperleyLiebGens] -> Int
    image Int
    j [TemperleyLiebGens]
    g in if Int
    j' Int -> [Int] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` (Int
    jInt -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    :[Int]
    js) then [Int] -> [Int]
    forall a. [a] -> [a]
    reverse (Int
    jInt -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    :[Int]
    js) else Int -> [Int] -> [Int]
    orbit Int
    j' (Int
    jInt -> [Int] -> [Int]
    forall a. a -> [a] -> [a]
    :[Int]
    js)
    -- Note, some authors define the trace so that tr 1 == 1.

    -- That is the same as this trace except for a factor of d^(n-1)

    tr :: Int -> NPoly LPQ TemperleyLiebGens -> LPQ
    tr n :: Int
    n f :: NPoly LPQ TemperleyLiebGens
    f@(NP ts :: [(Monomial TemperleyLiebGens, LPQ)]
    ts) = [LPQ] -> LPQ
    forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
    sum [LPQ
    c LPQ -> LPQ -> LPQ
    forall a. Num a => a -> a -> a
    * Int -> Monomial TemperleyLiebGens -> LPQ
    tr' Int
    n Monomial TemperleyLiebGens
    m | (m :: Monomial TemperleyLiebGens
    m,c :: LPQ
    c) <- [(Monomial TemperleyLiebGens, LPQ)]
    ts]

    -- JONES POLYNOMIAL

    a :: LPQ
    a = String -> LPQ
    forall r. Num r => String -> LaurentMPoly r
    LP.var "a"
    a' :: NPoly LPQ TemperleyLiebGens
    a' = LPQ -> NPoly LPQ TemperleyLiebGens
    forall r v. (Num r, Eq r, Eq v, Show v) => r -> NPoly r v
    NP.inject LPQ
    a :: NPoly LPQ TemperleyLiebGens

    -- Convert a braid to Temperley-Lieb algebra using Skein relation

    fromBraid :: NPoly LPQ BraidGens -> NPoly LPQ TemperleyLiebGens
    fromBraid f :: NPoly LPQ BraidGens
    f = NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    tlnf ([(NPoly LPQ BraidGens, NPoly LPQ TemperleyLiebGens)]
    -> NPoly LPQ BraidGens -> NPoly LPQ TemperleyLiebGens
    forall r1 v1 v2 r2.
    (Num r1, Ord v1, Show v1, Eq r1, Eq v2, Eq r2, Show r2, Show v2,
     Num r2) =>
    [(NPoly r2 v2, NPoly r1 v1)] -> NPoly r1 v2 -> NPoly r1 v1
    NP.subst [(NPoly LPQ BraidGens, NPoly LPQ TemperleyLiebGens)]
    skeinRelations NPoly LPQ BraidGens
    f) where
        skeinRelations :: [(NPoly LPQ BraidGens, NPoly LPQ TemperleyLiebGens)]
    skeinRelations = [[(NPoly LPQ BraidGens, NPoly LPQ TemperleyLiebGens)]]
    -> [(NPoly LPQ BraidGens, NPoly LPQ TemperleyLiebGens)]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat [ [(Int -> NPoly LPQ BraidGens
    s_ Int
    i, 1NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Fractional a => a -> a -> a
    /NPoly LPQ TemperleyLiebGens
    a' NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    * Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    i NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    + NPoly LPQ TemperleyLiebGens
    a'), (Int -> NPoly LPQ BraidGens
    s_ (-Int
    i), NPoly LPQ TemperleyLiebGens
    a' NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    * Int -> NPoly LPQ TemperleyLiebGens
    e_ Int
    i NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Num a => a -> a -> a
    + 1NPoly LPQ TemperleyLiebGens
    -> NPoly LPQ TemperleyLiebGens -> NPoly LPQ TemperleyLiebGens
    forall a. Fractional a => a -> a -> a
    /NPoly LPQ TemperleyLiebGens
    a')] | Int
    i <- [1..] ]

    -- Jones polynomial

    -- n the number of strings, f the braid

    jones :: Int -> NPoly LPQ BraidGens -> LPQ
    jones n :: Int
    n f :: NPoly LPQ BraidGens
    f = let kauffman :: LPQ
    kauffman = [(LPQ, LPQ)] -> LPQ -> LPQ
    forall r.
    (Eq r, Fractional r, Show r) =>
    [(LaurentMPoly r, LaurentMPoly r)]
    -> LaurentMPoly r -> LaurentMPoly r
    LP.subst [(LPQ
    d, - LPQ
    aLPQ -> Integer -> LPQ
    forall a b. (Num a, Integral b) => a -> b -> a
    ^2 LPQ -> LPQ -> LPQ
    forall a. Num a => a -> a -> a
    - 1LPQ -> LPQ -> LPQ
    forall a. Fractional a => a -> a -> a
    /LPQ
    aLPQ -> Integer -> LPQ
    forall a b. (Num a, Integral b) => a -> b -> a
    ^2)] (LPQ -> LPQ) -> LPQ -> LPQ
    forall a b. (a -> b) -> a -> b
    $ Int -> NPoly LPQ TemperleyLiebGens -> LPQ
    tr Int
    n (NPoly LPQ BraidGens -> NPoly LPQ TemperleyLiebGens
    fromBraid NPoly LPQ BraidGens
    f)
                    j :: LPQ
    j = (-LPQ
    a)LPQ -> Int -> LPQ
    forall a b. (Fractional a, Integral b) => a -> b -> a
    ^^(-3 Int -> Int -> Int
    forall a. Num a => a -> a -> a
    * NPoly LPQ BraidGens -> Int
    forall r. NPoly r BraidGens -> Int
    writhe NPoly LPQ BraidGens
    f) LPQ -> LPQ -> LPQ
    forall a. Num a => a -> a -> a
    * LPQ
    kauffman
                -- in halfExponents $ halfExponents $ LP.subst [(a,1/t)] j

                -- in quarterExponents' $ LP.subst [(a,1/t)] j

                in [(LPQ, LPQ)] -> LPQ -> LPQ
    forall r.
    (Eq r, Fractional r, Show r) =>
    [(LaurentMPoly r, LaurentMPoly r)]
    -> LaurentMPoly r -> LaurentMPoly r
    LP.subst [(LPQ
    a,1LPQ -> LPQ -> LPQ
    forall a. Fractional a => a -> a -> a
    /LPQ
    tLPQ -> Q -> LPQ
    forall a.
    (Eq a, Fractional a, Show a) =>
    LaurentMPoly a -> Q -> LaurentMPoly a
    ^^^(1Q -> Q -> Q
    forall a. Fractional a => a -> a -> a
    /4))] LPQ
    j