-- 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 :: [a]
munit = []
    mmult :: [a] -> [a] -> [a]
mmult = [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++)

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

instance (Eq k, Num k, Ord a) => Algebra k [a] where
    unit :: k -> Vect k [a]
unit 0 = Vect k [a]
forall k b. Vect k b
zerov -- V []
    unit x :: k
x = [([a], k)] -> Vect k [a]
forall k b. [(b, k)] -> Vect k b
V [([a]
forall m. Mon m => m
munit,k
x)]
    mult :: Vect k (Tensor [a] [a]) -> Vect k [a]
mult = Vect k [a] -> Vect k [a]
forall k b. (Eq k, Num k, Ord b) => Vect k b -> Vect k b
nf (Vect k [a] -> Vect k [a])
-> (Vect k (Tensor [a] [a]) -> Vect k [a])
-> Vect k (Tensor [a] [a])
-> Vect k [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tensor [a] [a] -> [a]) -> Vect k (Tensor [a] [a]) -> Vect k [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(a :: [a]
a,b :: [a]
b) -> [a]
a [a] -> [a] -> [a]
forall m. Mon m => m -> m -> m
`mmult` [a]
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 (Ob Tangle -> Ob Tangle -> Bool
(Ob Tangle -> Ob Tangle -> Bool)
-> (Ob Tangle -> Ob Tangle -> Bool) -> Eq (Ob Tangle)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ob Tangle -> Ob Tangle -> Bool
$c/= :: Ob Tangle -> Ob Tangle -> Bool
== :: Ob Tangle -> Ob Tangle -> Bool
$c== :: Ob Tangle -> Ob Tangle -> Bool
Eq,Eq (Ob Tangle)
Eq (Ob Tangle) =>
(Ob Tangle -> Ob Tangle -> Ordering)
-> (Ob Tangle -> Ob Tangle -> Bool)
-> (Ob Tangle -> Ob Tangle -> Bool)
-> (Ob Tangle -> Ob Tangle -> Bool)
-> (Ob Tangle -> Ob Tangle -> Bool)
-> (Ob Tangle -> Ob Tangle -> Ob Tangle)
-> (Ob Tangle -> Ob Tangle -> Ob Tangle)
-> Ord (Ob Tangle)
Ob Tangle -> Ob Tangle -> Bool
Ob Tangle -> Ob Tangle -> Ordering
Ob Tangle -> Ob Tangle -> Ob Tangle
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 :: Ob Tangle -> Ob Tangle -> Ob Tangle
$cmin :: Ob Tangle -> Ob Tangle -> Ob Tangle
max :: Ob Tangle -> Ob Tangle -> Ob Tangle
$cmax :: Ob Tangle -> Ob Tangle -> Ob Tangle
>= :: Ob Tangle -> Ob Tangle -> Bool
$c>= :: Ob Tangle -> Ob Tangle -> Bool
> :: Ob Tangle -> Ob Tangle -> Bool
$c> :: Ob Tangle -> Ob Tangle -> Bool
<= :: Ob Tangle -> Ob Tangle -> Bool
$c<= :: Ob Tangle -> Ob Tangle -> Bool
< :: Ob Tangle -> Ob Tangle -> Bool
$c< :: Ob Tangle -> Ob Tangle -> Bool
compare :: Ob Tangle -> Ob Tangle -> Ordering
$ccompare :: Ob Tangle -> Ob Tangle -> Ordering
$cp1Ord :: Eq (Ob Tangle)
Ord,Int -> Ob Tangle -> ShowS
[Ob Tangle] -> ShowS
Ob Tangle -> String
(Int -> Ob Tangle -> ShowS)
-> (Ob Tangle -> String)
-> ([Ob Tangle] -> ShowS)
-> Show (Ob Tangle)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ob Tangle] -> ShowS
$cshowList :: [Ob Tangle] -> ShowS
show :: Ob Tangle -> String
$cshow :: Ob Tangle -> String
showsPrec :: Int -> Ob Tangle -> ShowS
$cshowsPrec :: Int -> Ob Tangle -> ShowS
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 (Ar Tangle -> Ar Tangle -> Bool
(Ar Tangle -> Ar Tangle -> Bool)
-> (Ar Tangle -> Ar Tangle -> Bool) -> Eq (Ar Tangle)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ar Tangle -> Ar Tangle -> Bool
$c/= :: Ar Tangle -> Ar Tangle -> Bool
== :: Ar Tangle -> Ar Tangle -> Bool
$c== :: Ar Tangle -> Ar Tangle -> Bool
Eq,Eq (Ar Tangle)
Eq (Ar Tangle) =>
(Ar Tangle -> Ar Tangle -> Ordering)
-> (Ar Tangle -> Ar Tangle -> Bool)
-> (Ar Tangle -> Ar Tangle -> Bool)
-> (Ar Tangle -> Ar Tangle -> Bool)
-> (Ar Tangle -> Ar Tangle -> Bool)
-> (Ar Tangle -> Ar Tangle -> Ar Tangle)
-> (Ar Tangle -> Ar Tangle -> Ar Tangle)
-> Ord (Ar Tangle)
Ar Tangle -> Ar Tangle -> Bool
Ar Tangle -> Ar Tangle -> Ordering
Ar Tangle -> Ar Tangle -> Ar Tangle
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 :: Ar Tangle -> Ar Tangle -> Ar Tangle
$cmin :: Ar Tangle -> Ar Tangle -> Ar Tangle
max :: Ar Tangle -> Ar Tangle -> Ar Tangle
$cmax :: Ar Tangle -> Ar Tangle -> Ar Tangle
>= :: Ar Tangle -> Ar Tangle -> Bool
$c>= :: Ar Tangle -> Ar Tangle -> Bool
> :: Ar Tangle -> Ar Tangle -> Bool
$c> :: Ar Tangle -> Ar Tangle -> Bool
<= :: Ar Tangle -> Ar Tangle -> Bool
$c<= :: Ar Tangle -> Ar Tangle -> Bool
< :: Ar Tangle -> Ar Tangle -> Bool
$c< :: Ar Tangle -> Ar Tangle -> Bool
compare :: Ar Tangle -> Ar Tangle -> Ordering
$ccompare :: Ar Tangle -> Ar Tangle -> Ordering
$cp1Ord :: Eq (Ar Tangle)
Ord,Int -> Ar Tangle -> ShowS
[Ar Tangle] -> ShowS
Ar Tangle -> String
(Int -> Ar Tangle -> ShowS)
-> (Ar Tangle -> String)
-> ([Ar Tangle] -> ShowS)
-> Show (Ar Tangle)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ar Tangle] -> ShowS
$cshowList :: [Ar Tangle] -> ShowS
show :: Ar Tangle -> String
$cshow :: Ar Tangle -> String
showsPrec :: Int -> Ar Tangle -> ShowS
$cshowsPrec :: Int -> Ar Tangle -> ShowS
Show)
    id_ :: Ob Tangle -> Ar Tangle
id_ (OT n) = Int -> Ar Tangle
IdT Int
n
    source :: Ar Tangle -> Ob Tangle
source (IdT n) = Int -> Ob Tangle
OT Int
n
    source CapT = Int -> Ob Tangle
OT 0
    source CupT = Int -> Ob Tangle
OT 2
    source OverT = Int -> Ob Tangle
OT 2
    source UnderT = Int -> Ob Tangle
OT 2
--    source (ParT a b) = OT (sa + sb) where OT sa = source a; OT sb = source b
    source (ParT as) = Int -> Ob Tangle
OT (Int -> Ob Tangle) -> Int -> Ob Tangle
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
sa | Ar Tangle
a <- [Ar Tangle]
as, let OT sa = Ar Tangle -> Ob Tangle
forall c. MCategory c => Ar c -> Ob c
source Ar Tangle
a]
--    source (SeqT a b) = source a
    source (SeqT as) = Ar Tangle -> Ob Tangle
forall c. MCategory c => Ar c -> Ob c
source ([Ar Tangle] -> Ar Tangle
forall a. [a] -> a
head [Ar Tangle]
as)
    target :: Ar Tangle -> Ob Tangle
target (IdT n) = Int -> Ob Tangle
OT Int
n
    target CapT = Int -> Ob Tangle
OT 2
    target CupT = Int -> Ob Tangle
OT 0
    target OverT = Int -> Ob Tangle
OT 2
    target UnderT = Int -> Ob Tangle
OT 2
--    target (ParT a b) = OT (ta + tb) where OT ta = target a; OT tb = target b
    target (ParT as) = Int -> Ob Tangle
OT (Int -> Ob Tangle) -> Int -> Ob Tangle
forall a b. (a -> b) -> a -> b
$ [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
ta | Ar Tangle
a <- [Ar Tangle]
as, let OT ta = Ar Tangle -> Ob Tangle
forall c. MCategory c => Ar c -> Ob c
target Ar Tangle
a]
--    target (SeqT a b) = target b
    target (SeqT as) = Ar Tangle -> Ob Tangle
forall c. MCategory c => Ar c -> Ob c
target ([Ar Tangle] -> Ar Tangle
forall a. [a] -> a
last [Ar Tangle]
as)
--    a >>> b | target a == source b = SeqT a b
    a :: Ar Tangle
a >>> :: Ar Tangle -> Ar Tangle -> Ar Tangle
>>> b :: Ar Tangle
b | Ar Tangle -> Ob Tangle
forall c. MCategory c => Ar c -> Ob c
target Ar Tangle
a Ob Tangle -> Ob Tangle -> Bool
forall a. Eq a => a -> a -> Bool
== Ar Tangle -> Ob Tangle
forall c. MCategory c => Ar c -> Ob c
source Ar Tangle
b = [Ar Tangle] -> Ar Tangle
SeqT [Ar Tangle
a,Ar Tangle
b]

instance Monoidal Tangle where
    tunit :: Ob Tangle
tunit = Int -> Ob Tangle
OT 0
    tob :: Ob Tangle -> Ob Tangle -> Ob Tangle
tob (OT a) (OT b) = Int -> Ob Tangle
OT (Int
aInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
b)
--    tar a b = ParT a b
    tar :: Ar Tangle -> Ar Tangle -> Ar Tangle
tar a :: Ar Tangle
a b :: Ar Tangle
b = [Ar Tangle] -> Ar Tangle
ParT [Ar Tangle
a,Ar Tangle
b]



-- KAUFFMAN BRACKET

data Oriented = Plus | Minus deriving (Oriented -> Oriented -> Bool
(Oriented -> Oriented -> Bool)
-> (Oriented -> Oriented -> Bool) -> Eq Oriented
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Oriented -> Oriented -> Bool
$c/= :: Oriented -> Oriented -> Bool
== :: Oriented -> Oriented -> Bool
$c== :: Oriented -> Oriented -> Bool
Eq,Eq Oriented
Eq Oriented =>
(Oriented -> Oriented -> Ordering)
-> (Oriented -> Oriented -> Bool)
-> (Oriented -> Oriented -> Bool)
-> (Oriented -> Oriented -> Bool)
-> (Oriented -> Oriented -> Bool)
-> (Oriented -> Oriented -> Oriented)
-> (Oriented -> Oriented -> Oriented)
-> Ord Oriented
Oriented -> Oriented -> Bool
Oriented -> Oriented -> Ordering
Oriented -> Oriented -> Oriented
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 :: Oriented -> Oriented -> Oriented
$cmin :: Oriented -> Oriented -> Oriented
max :: Oriented -> Oriented -> Oriented
$cmax :: Oriented -> Oriented -> Oriented
>= :: Oriented -> Oriented -> Bool
$c>= :: Oriented -> Oriented -> Bool
> :: Oriented -> Oriented -> Bool
$c> :: Oriented -> Oriented -> Bool
<= :: Oriented -> Oriented -> Bool
$c<= :: Oriented -> Oriented -> Bool
< :: Oriented -> Oriented -> Bool
$c< :: Oriented -> Oriented -> Bool
compare :: Oriented -> Oriented -> Ordering
$ccompare :: Oriented -> Oriented -> Ordering
$cp1Ord :: Eq Oriented
Ord,Int -> Oriented -> ShowS
[Oriented] -> ShowS
Oriented -> String
(Int -> Oriented -> ShowS)
-> (Oriented -> String) -> ([Oriented] -> ShowS) -> Show Oriented
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Oriented] -> ShowS
$cshowList :: [Oriented] -> ShowS
show :: Oriented -> String
$cshow :: Oriented -> String
showsPrec :: Int -> Oriented -> ShowS
$cshowsPrec :: Int -> Oriented -> ShowS
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 :: [Oriented] -> TangleRep [Oriented]
cap [] = [Oriented] -> TangleRep [Oriented]
forall (m :: * -> *) a. Monad m => a -> m a
return [Oriented
Plus, Oriented
Minus] TangleRep [Oriented]
-> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b.
(Eq k, Num k, Ord b) =>
Vect k b -> Vect k b -> Vect k b
<+> (-LaurentPoly Q
qLaurentPoly Q -> Integer -> LaurentPoly Q
forall a b. (Num a, Integral b) => a -> b -> a
^2) LaurentPoly Q -> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> [Oriented] -> TangleRep [Oriented]
forall (m :: * -> *) a. Monad m => a -> m a
return [Oriented
Minus, Oriented
Plus]

cup :: [Oriented] -> TangleRep [Oriented]
cup :: [Oriented] -> TangleRep [Oriented]
cup [Plus, Minus] = (-LaurentPoly Q
q'LaurentPoly Q -> Integer -> LaurentPoly Q
forall a b. (Num a, Integral b) => a -> b -> a
^2) LaurentPoly Q -> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> [Oriented] -> TangleRep [Oriented]
forall (m :: * -> *) a. Monad m => a -> m a
return []
cup [Minus, Plus] = [Oriented] -> TangleRep [Oriented]
forall (m :: * -> *) a. Monad m => a -> m a
return []
cup _ = TangleRep [Oriented]
forall k b. Vect k b
zerov

-- also called xminus
over :: [Oriented] -> TangleRep [Oriented]
over :: [Oriented] -> TangleRep [Oriented]
over [u :: Oriented
u, v :: Oriented
v] = LaurentPoly Q
q  LaurentPoly Q -> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> do {[Oriented]
_ <- [Oriented] -> TangleRep [Oriented]
cup [Oriented
u, Oriented
v]; [Oriented] -> TangleRep [Oriented]
cap []}
          TangleRep [Oriented]
-> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b.
(Eq k, Num k, Ord b) =>
Vect k b -> Vect k b -> Vect k b
<+> LaurentPoly Q
q' LaurentPoly Q -> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> [Oriented] -> TangleRep [Oriented]
forall (m :: * -> *) a. Monad m => a -> m a
return [Oriented
u, Oriented
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 :: [Oriented] -> TangleRep [Oriented]
under [u :: Oriented
u, v :: Oriented
v] = LaurentPoly Q
q' LaurentPoly Q -> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> do {[Oriented]
_ <- [Oriented] -> TangleRep [Oriented]
cup [Oriented
u, Oriented
v]; [Oriented] -> TangleRep [Oriented]
cap []}
           TangleRep [Oriented]
-> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b.
(Eq k, Num k, Ord b) =>
Vect k b -> Vect k b -> Vect k b
<+> LaurentPoly Q
q  LaurentPoly Q -> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> [Oriented] -> TangleRep [Oriented]
forall (m :: * -> *) a. Monad m => a -> m a
return [Oriented
u, Oriented
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 :: TangleRep [Oriented]
loop = TangleRep [Oriented] -> TangleRep [Oriented]
forall k b. (Eq k, Num k, Ord b) => Vect k b -> Vect k b
nf (TangleRep [Oriented] -> TangleRep [Oriented])
-> TangleRep [Oriented] -> TangleRep [Oriented]
forall a b. (a -> b) -> a -> b
$ do {[Oriented]
ij <- [Oriented] -> TangleRep [Oriented]
cap []; [Oriented] -> TangleRep [Oriented]
cup [Oriented]
ij}

{-
-- The following doesn't work, because the pattern matches can fail, but Vect has no MonadFail instance.
-- Commented out for now, pending figuring out the best fix
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 :: Ar Tangle -> TangleRep [Oriented] -> TangleRep [Oriented]
kauffman (IdT n) = TangleRep [Oriented] -> TangleRep [Oriented]
forall a. a -> a
id -- could be tf of n ids
kauffman CapT = ([Oriented] -> TangleRep [Oriented])
-> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear [Oriented] -> TangleRep [Oriented]
cap
kauffman CupT = ([Oriented] -> TangleRep [Oriented])
-> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear [Oriented] -> TangleRep [Oriented]
cup
kauffman OverT = ([Oriented] -> TangleRep [Oriented])
-> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear [Oriented] -> TangleRep [Oriented]
over
kauffman UnderT = ([Oriented] -> TangleRep [Oriented])
-> TangleRep [Oriented] -> TangleRep [Oriented]
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear [Oriented] -> TangleRep [Oriented]
under
kauffman (SeqT fs) = ((TangleRep [Oriented] -> TangleRep [Oriented])
 -> (TangleRep [Oriented] -> TangleRep [Oriented])
 -> TangleRep [Oriented]
 -> TangleRep [Oriented])
-> (TangleRep [Oriented] -> TangleRep [Oriented])
-> [TangleRep [Oriented] -> TangleRep [Oriented]]
-> TangleRep [Oriented]
-> TangleRep [Oriented]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (TangleRep [Oriented] -> TangleRep [Oriented])
-> (TangleRep [Oriented] -> TangleRep [Oriented])
-> TangleRep [Oriented]
-> TangleRep [Oriented]
forall a b c. (a -> b) -> (b -> c) -> a -> c
(>>>) TangleRep [Oriented] -> TangleRep [Oriented]
forall a. a -> a
id ([TangleRep [Oriented] -> TangleRep [Oriented]]
 -> TangleRep [Oriented] -> TangleRep [Oriented])
-> [TangleRep [Oriented] -> TangleRep [Oriented]]
-> TangleRep [Oriented]
-> TangleRep [Oriented]
forall a b. (a -> b) -> a -> b
$ (Ar Tangle -> TangleRep [Oriented] -> TangleRep [Oriented])
-> [Ar Tangle] -> [TangleRep [Oriented] -> TangleRep [Oriented]]
forall a b. (a -> b) -> [a] -> [b]
map Ar Tangle -> TangleRep [Oriented] -> TangleRep [Oriented]
kauffman [Ar Tangle]
fs
    where g :: a -> b
g >>> :: (a -> b) -> (b -> c) -> a -> c
>>> h :: b -> c
h = b -> c
h (b -> c) -> (a -> b) -> a -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
g
kauffman (ParT [f]) = Ar Tangle -> TangleRep [Oriented] -> TangleRep [Oriented]
kauffman Ar Tangle
f
kauffman (ParT (f:fs)) = Int
-> (TangleRep [Oriented] -> TangleRep [Oriented])
-> (TangleRep [Oriented] -> TangleRep [Oriented])
-> TangleRep [Oriented]
-> TangleRep [Oriented]
forall k b (m :: * -> *) (m :: * -> *) a.
(Num k, Ord b, Eq k, Show b, Algebra k b, Monad m, Monad m) =>
Int
-> (m [a] -> Vect k b)
-> (m [a] -> Vect k b)
-> Vect k [a]
-> Vect k b
tf Int
m (Ar Tangle -> TangleRep [Oriented] -> TangleRep [Oriented]
kauffman Ar Tangle
f) (Ar Tangle -> TangleRep [Oriented] -> TangleRep [Oriented]
kauffman ([Ar Tangle] -> Ar Tangle
ParT [Ar Tangle]
fs))
    where OT m = Ar Tangle -> Ob Tangle
forall c. MCategory c => Ar c -> Ob c
source Ar Tangle
f
          tf :: Int
-> (m [a] -> Vect k b)
-> (m [a] -> Vect k b)
-> Vect k [a]
-> Vect k b
tf m :: Int
m f' :: m [a] -> Vect k b
f' fs' :: m [a] -> Vect k b
fs' = ([a] -> Vect k b) -> Vect k [a] -> Vect k b
forall k b a.
(Eq k, Num k, Ord b) =>
(a -> Vect k b) -> Vect k a -> Vect k b
linear (\xs :: [a]
xs -> let (ls :: [a]
ls,rs :: [a]
rs) = Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
m [a]
xs in m [a] -> Vect k b
f' ([a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
ls) Vect k b -> Vect k b -> Vect k b
forall a. Num a => a -> a -> a
* m [a] -> Vect k b
fs' ([a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return [a]
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 :: Ar Tangle
loopT = [Ar Tangle] -> Ar Tangle
SeqT [Ar Tangle
CapT, Ar Tangle
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 :: Ar Tangle
trefoilT = [Ar Tangle] -> Ar Tangle
SeqT [
    [Ar Tangle] -> Ar Tangle
ParT [Ar Tangle
CapT, Ar Tangle
CapT],
    [Ar Tangle] -> Ar Tangle
ParT [Int -> Ar Tangle
IdT 1, Ar Tangle
UnderT, Int -> Ar Tangle
IdT 1],
    [Ar Tangle] -> Ar Tangle
ParT [Ar Tangle
OverT, Ar Tangle
OverT],
    [Ar Tangle] -> Ar Tangle
ParT [Int -> Ar Tangle
IdT 1, Ar Tangle
CupT, Int -> Ar Tangle
IdT 1],
    Ar Tangle
CupT]
-- eg kauffman (trefoilT) (return [])