-- 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