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

{-# LANGUAGE TypeFamilies, EmptyDataDecls #-}


module Math.QuantumAlgebra.OrientedTangle where

import Prelude hiding ( (*>) )

import Math.Algebra.Field.Base
import Math.Algebras.LaurentPoly -- hiding (lvar, q, q')

import Math.QuantumAlgebra.TensorCategory

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

-- import MathExperiments.Algebra.TAlgebra


-- ORIENTED TANGLE CATEGORY

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)

data HorizDir = ToL | ToR deriving (HorizDir -> HorizDir -> Bool
(HorizDir -> HorizDir -> Bool)
-> (HorizDir -> HorizDir -> Bool) -> Eq HorizDir
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HorizDir -> HorizDir -> Bool
$c/= :: HorizDir -> HorizDir -> Bool
== :: HorizDir -> HorizDir -> Bool
$c== :: HorizDir -> HorizDir -> Bool
Eq,Eq HorizDir
Eq HorizDir =>
(HorizDir -> HorizDir -> Ordering)
-> (HorizDir -> HorizDir -> Bool)
-> (HorizDir -> HorizDir -> Bool)
-> (HorizDir -> HorizDir -> Bool)
-> (HorizDir -> HorizDir -> Bool)
-> (HorizDir -> HorizDir -> HorizDir)
-> (HorizDir -> HorizDir -> HorizDir)
-> Ord HorizDir
HorizDir -> HorizDir -> Bool
HorizDir -> HorizDir -> Ordering
HorizDir -> HorizDir -> HorizDir
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 :: HorizDir -> HorizDir -> HorizDir
$cmin :: HorizDir -> HorizDir -> HorizDir
max :: HorizDir -> HorizDir -> HorizDir
$cmax :: HorizDir -> HorizDir -> HorizDir
>= :: HorizDir -> HorizDir -> Bool
$c>= :: HorizDir -> HorizDir -> Bool
> :: HorizDir -> HorizDir -> Bool
$c> :: HorizDir -> HorizDir -> Bool
<= :: HorizDir -> HorizDir -> Bool
$c<= :: HorizDir -> HorizDir -> Bool
< :: HorizDir -> HorizDir -> Bool
$c< :: HorizDir -> HorizDir -> Bool
compare :: HorizDir -> HorizDir -> Ordering
$ccompare :: HorizDir -> HorizDir -> Ordering
$cp1Ord :: Eq HorizDir
Ord,Int -> HorizDir -> ShowS
[HorizDir] -> ShowS
HorizDir -> String
(Int -> HorizDir -> ShowS)
-> (HorizDir -> String) -> ([HorizDir] -> ShowS) -> Show HorizDir
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HorizDir] -> ShowS
$cshowList :: [HorizDir] -> ShowS
show :: HorizDir -> String
$cshow :: HorizDir -> String
showsPrec :: Int -> HorizDir -> ShowS
$cshowsPrec :: Int -> HorizDir -> ShowS
Show)

data OrientedTangle

-- In GHCi 6.12.1, we appear to be limited to 8 value constructors within an associated data family
instance MCategory OrientedTangle where
    data Ob OrientedTangle = OT [Oriented] deriving (Ob OrientedTangle -> Ob OrientedTangle -> Bool
(Ob OrientedTangle -> Ob OrientedTangle -> Bool)
-> (Ob OrientedTangle -> Ob OrientedTangle -> Bool)
-> Eq (Ob OrientedTangle)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
$c/= :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
== :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
$c== :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
Eq,Eq (Ob OrientedTangle)
Eq (Ob OrientedTangle) =>
(Ob OrientedTangle -> Ob OrientedTangle -> Ordering)
-> (Ob OrientedTangle -> Ob OrientedTangle -> Bool)
-> (Ob OrientedTangle -> Ob OrientedTangle -> Bool)
-> (Ob OrientedTangle -> Ob OrientedTangle -> Bool)
-> (Ob OrientedTangle -> Ob OrientedTangle -> Bool)
-> (Ob OrientedTangle -> Ob OrientedTangle -> Ob OrientedTangle)
-> (Ob OrientedTangle -> Ob OrientedTangle -> Ob OrientedTangle)
-> Ord (Ob OrientedTangle)
Ob OrientedTangle -> Ob OrientedTangle -> Bool
Ob OrientedTangle -> Ob OrientedTangle -> Ordering
Ob OrientedTangle -> Ob OrientedTangle -> Ob OrientedTangle
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 OrientedTangle -> Ob OrientedTangle -> Ob OrientedTangle
$cmin :: Ob OrientedTangle -> Ob OrientedTangle -> Ob OrientedTangle
max :: Ob OrientedTangle -> Ob OrientedTangle -> Ob OrientedTangle
$cmax :: Ob OrientedTangle -> Ob OrientedTangle -> Ob OrientedTangle
>= :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
$c>= :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
> :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
$c> :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
<= :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
$c<= :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
< :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
$c< :: Ob OrientedTangle -> Ob OrientedTangle -> Bool
compare :: Ob OrientedTangle -> Ob OrientedTangle -> Ordering
$ccompare :: Ob OrientedTangle -> Ob OrientedTangle -> Ordering
$cp1Ord :: Eq (Ob OrientedTangle)
Ord,Int -> Ob OrientedTangle -> ShowS
[Ob OrientedTangle] -> ShowS
Ob OrientedTangle -> String
(Int -> Ob OrientedTangle -> ShowS)
-> (Ob OrientedTangle -> String)
-> ([Ob OrientedTangle] -> ShowS)
-> Show (Ob OrientedTangle)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ob OrientedTangle] -> ShowS
$cshowList :: [Ob OrientedTangle] -> ShowS
show :: Ob OrientedTangle -> String
$cshow :: Ob OrientedTangle -> String
showsPrec :: Int -> Ob OrientedTangle -> ShowS
$cshowsPrec :: Int -> Ob OrientedTangle -> ShowS
Show)
    data Ar OrientedTangle = IdT [Oriented]
                           | CapT HorizDir
                           | CupT HorizDir
                           | XPlus | XMinus
                           | SeqT [Ar OrientedTangle]
                           | ParT [Ar OrientedTangle]
                           deriving (Ar OrientedTangle -> Ar OrientedTangle -> Bool
(Ar OrientedTangle -> Ar OrientedTangle -> Bool)
-> (Ar OrientedTangle -> Ar OrientedTangle -> Bool)
-> Eq (Ar OrientedTangle)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
$c/= :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
== :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
$c== :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
Eq,Eq (Ar OrientedTangle)
Eq (Ar OrientedTangle) =>
(Ar OrientedTangle -> Ar OrientedTangle -> Ordering)
-> (Ar OrientedTangle -> Ar OrientedTangle -> Bool)
-> (Ar OrientedTangle -> Ar OrientedTangle -> Bool)
-> (Ar OrientedTangle -> Ar OrientedTangle -> Bool)
-> (Ar OrientedTangle -> Ar OrientedTangle -> Bool)
-> (Ar OrientedTangle -> Ar OrientedTangle -> Ar OrientedTangle)
-> (Ar OrientedTangle -> Ar OrientedTangle -> Ar OrientedTangle)
-> Ord (Ar OrientedTangle)
Ar OrientedTangle -> Ar OrientedTangle -> Bool
Ar OrientedTangle -> Ar OrientedTangle -> Ordering
Ar OrientedTangle -> Ar OrientedTangle -> Ar OrientedTangle
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 OrientedTangle -> Ar OrientedTangle -> Ar OrientedTangle
$cmin :: Ar OrientedTangle -> Ar OrientedTangle -> Ar OrientedTangle
max :: Ar OrientedTangle -> Ar OrientedTangle -> Ar OrientedTangle
$cmax :: Ar OrientedTangle -> Ar OrientedTangle -> Ar OrientedTangle
>= :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
$c>= :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
> :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
$c> :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
<= :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
$c<= :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
< :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
$c< :: Ar OrientedTangle -> Ar OrientedTangle -> Bool
compare :: Ar OrientedTangle -> Ar OrientedTangle -> Ordering
$ccompare :: Ar OrientedTangle -> Ar OrientedTangle -> Ordering
$cp1Ord :: Eq (Ar OrientedTangle)
Ord,Int -> Ar OrientedTangle -> ShowS
[Ar OrientedTangle] -> ShowS
Ar OrientedTangle -> String
(Int -> Ar OrientedTangle -> ShowS)
-> (Ar OrientedTangle -> String)
-> ([Ar OrientedTangle] -> ShowS)
-> Show (Ar OrientedTangle)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Ar OrientedTangle] -> ShowS
$cshowList :: [Ar OrientedTangle] -> ShowS
show :: Ar OrientedTangle -> String
$cshow :: Ar OrientedTangle -> String
showsPrec :: Int -> Ar OrientedTangle -> ShowS
$cshowsPrec :: Int -> Ar OrientedTangle -> ShowS
Show)
    id_ :: Ob OrientedTangle -> Ar OrientedTangle
id_ (OT os) = [Oriented] -> Ar OrientedTangle
IdT [Oriented]
os
    source :: Ar OrientedTangle -> Ob OrientedTangle
source (IdT os) = [Oriented] -> Ob OrientedTangle
OT [Oriented]
os
    source (CapT _) = [Oriented] -> Ob OrientedTangle
OT []
    source (CupT toR) = [Oriented] -> Ob OrientedTangle
OT [Oriented
Plus,Oriented
Minus]
    source (CupT toL) = [Oriented] -> Ob OrientedTangle
OT [Oriented
Minus,Oriented
Plus]
    source XPlus = [Oriented] -> Ob OrientedTangle
OT [Oriented
Plus,Oriented
Plus]
    source XMinus = [Oriented] -> Ob OrientedTangle
OT [Oriented
Plus,Oriented
Plus]
    source (ParT as) = [Oriented] -> Ob OrientedTangle
OT ([Oriented] -> Ob OrientedTangle)
-> [Oriented] -> Ob OrientedTangle
forall a b. (a -> b) -> a -> b
$ (Ar OrientedTangle -> [Oriented])
-> [Ar OrientedTangle] -> [Oriented]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\(OT os) -> [Oriented]
os) (Ob OrientedTangle -> [Oriented])
-> (Ar OrientedTangle -> Ob OrientedTangle)
-> Ar OrientedTangle
-> [Oriented]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ar OrientedTangle -> Ob OrientedTangle
forall c. MCategory c => Ar c -> Ob c
source) [Ar OrientedTangle]
as
    source (SeqT as) = Ar OrientedTangle -> Ob OrientedTangle
forall c. MCategory c => Ar c -> Ob c
source ([Ar OrientedTangle] -> Ar OrientedTangle
forall a. [a] -> a
head [Ar OrientedTangle]
as)
    target :: Ar OrientedTangle -> Ob OrientedTangle
target (IdT os) = [Oriented] -> Ob OrientedTangle
OT [Oriented]
os
    target (CapT ToR) = [Oriented] -> Ob OrientedTangle
OT [Oriented
Minus,Oriented
Plus]
    target (CapT ToL) = [Oriented] -> Ob OrientedTangle
OT [Oriented
Plus,Oriented
Minus]
    target (CupT _) = [Oriented] -> Ob OrientedTangle
OT []
    target XPlus = [Oriented] -> Ob OrientedTangle
OT [Oriented
Plus,Oriented
Plus]
    target XMinus = [Oriented] -> Ob OrientedTangle
OT [Oriented
Plus,Oriented
Plus]
    target (ParT as) = [Oriented] -> Ob OrientedTangle
OT ([Oriented] -> Ob OrientedTangle)
-> [Oriented] -> Ob OrientedTangle
forall a b. (a -> b) -> a -> b
$ (Ar OrientedTangle -> [Oriented])
-> [Ar OrientedTangle] -> [Oriented]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ((\(OT os) -> [Oriented]
os) (Ob OrientedTangle -> [Oriented])
-> (Ar OrientedTangle -> Ob OrientedTangle)
-> Ar OrientedTangle
-> [Oriented]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ar OrientedTangle -> Ob OrientedTangle
forall c. MCategory c => Ar c -> Ob c
target) [Ar OrientedTangle]
as
    target (SeqT as) = Ar OrientedTangle -> Ob OrientedTangle
forall c. MCategory c => Ar c -> Ob c
target ([Ar OrientedTangle] -> Ar OrientedTangle
forall a. [a] -> a
last [Ar OrientedTangle]
as)
    a :: Ar OrientedTangle
a >>> :: Ar OrientedTangle -> Ar OrientedTangle -> Ar OrientedTangle
>>> b :: Ar OrientedTangle
b | Ar OrientedTangle -> Ob OrientedTangle
forall c. MCategory c => Ar c -> Ob c
target Ar OrientedTangle
a Ob OrientedTangle -> Ob OrientedTangle -> Bool
forall a. Eq a => a -> a -> Bool
== Ar OrientedTangle -> Ob OrientedTangle
forall c. MCategory c => Ar c -> Ob c
source Ar OrientedTangle
b = [Ar OrientedTangle] -> Ar OrientedTangle
SeqT [Ar OrientedTangle
a,Ar OrientedTangle
b]

instance Monoidal OrientedTangle where
    tunit :: Ob OrientedTangle
tunit = [Oriented] -> Ob OrientedTangle
OT []
    tob :: Ob OrientedTangle -> Ob OrientedTangle -> Ob OrientedTangle
tob (OT as) (OT bs) = [Oriented] -> Ob OrientedTangle
OT ([Oriented]
as[Oriented] -> [Oriented] -> [Oriented]
forall a. [a] -> [a] -> [a]
++[Oriented]
bs)
    tar :: Ar OrientedTangle -> Ar OrientedTangle -> Ar OrientedTangle
tar a :: Ar OrientedTangle
a b :: Ar OrientedTangle
b = [Ar OrientedTangle] -> Ar OrientedTangle
ParT [Ar OrientedTangle
a,Ar OrientedTangle
b]



idV :: a -> a
idV = a -> a
forall a. a -> a
id
idV' :: a -> a
idV' = a -> a
forall a. a -> a
id

evalV :: (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
evalV  = \(E i :: Int
i, E j :: Int
j) -> if Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then () -> Vect (LaurentPoly Q) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else Vect (LaurentPoly Q) ()
forall k b. Vect k b
zerov
evalV' :: (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
evalV' = \(E i :: Int
i, E j :: Int
j) -> if Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
j Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 then () -> Vect (LaurentPoly Q) ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else Vect (LaurentPoly Q) ()
forall k b. Vect k b
zerov

coevalV :: Int -> Vect k (EBasis, EBasis)
coevalV  m :: Int
m = (Vect k (EBasis, EBasis)
 -> Vect k (EBasis, EBasis) -> Vect k (EBasis, EBasis))
-> Vect k (EBasis, EBasis)
-> [Vect k (EBasis, EBasis)]
-> Vect k (EBasis, EBasis)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Vect k (EBasis, EBasis)
-> Vect k (EBasis, EBasis) -> Vect k (EBasis, EBasis)
forall k b.
(Eq k, Num k, Ord b) =>
Vect k b -> Vect k b -> Vect k b
(<+>) Vect k (EBasis, EBasis)
forall k b. Vect k b
zerov [Int -> Vect k EBasis
forall (m :: * -> *). Monad m => Int -> m EBasis
e Int
i Vect k EBasis -> Vect k EBasis -> Vect k (EBasis, EBasis)
forall k a b. Num k => Vect k a -> Vect k b -> Vect k (Tensor a b)
`te` Int -> Vect k EBasis
forall (m :: * -> *). Monad m => Int -> m EBasis
e (-Int
i) | Int
i <- [1..Int
m] ]
coevalV' :: Int -> Vect k (EBasis, EBasis)
coevalV' m :: Int
m = (Vect k (EBasis, EBasis)
 -> Vect k (EBasis, EBasis) -> Vect k (EBasis, EBasis))
-> Vect k (EBasis, EBasis)
-> [Vect k (EBasis, EBasis)]
-> Vect k (EBasis, EBasis)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Vect k (EBasis, EBasis)
-> Vect k (EBasis, EBasis) -> Vect k (EBasis, EBasis)
forall k b.
(Eq k, Num k, Ord b) =>
Vect k b -> Vect k b -> Vect k b
(<+>) Vect k (EBasis, EBasis)
forall k b. Vect k b
zerov [Int -> Vect k EBasis
forall (m :: * -> *). Monad m => Int -> m EBasis
e (-Int
i) Vect k EBasis -> Vect k EBasis -> Vect k (EBasis, EBasis)
forall k a b. Num k => Vect k a -> Vect k b -> Vect k (Tensor a b)
`te` Int -> Vect k EBasis
forall (m :: * -> *). Monad m => Int -> m EBasis
e Int
i | Int
i <- [1..Int
m] ]

lambda :: b -> LaurentPoly Q
lambda m :: b
m = LaurentPoly Q
q' LaurentPoly Q -> b -> LaurentPoly Q
forall a b. (Num a, Integral b) => a -> b -> a
^ b
m -- q^-m

c :: b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
c m :: b
m (E i :: Int
i, E j :: Int
j) = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
i Int
j of
                      EQ -> (b -> LaurentPoly Q
forall b. Integral b => b -> LaurentPoly Q
lambda b
m LaurentPoly Q -> LaurentPoly Q -> LaurentPoly Q
forall a. Num a => a -> a -> a
* LaurentPoly Q
q) LaurentPoly Q
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> EBasis
E Int
i, Int -> EBasis
E Int
i)
                      LT -> b -> LaurentPoly Q
forall b. Integral b => b -> LaurentPoly Q
lambda b
m LaurentPoly Q
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> EBasis
E Int
j, Int -> EBasis
E Int
i)
                      GT -> b -> LaurentPoly Q
forall b. Integral b => b -> LaurentPoly Q
lambda b
m LaurentPoly Q
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> ((EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> EBasis
E Int
j, Int -> EBasis
E Int
i) Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k b.
(Eq k, Num k, Ord b) =>
Vect k b -> Vect k b -> Vect k b
<+> (LaurentPoly Q
q LaurentPoly Q -> LaurentPoly Q -> LaurentPoly Q
forall a. Num a => a -> a -> a
- LaurentPoly Q
q') LaurentPoly Q
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> EBasis
E Int
i, Int -> EBasis
E Int
j))

-- inverse of c
c' :: b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
c' m :: b
m (E i :: Int
i, E j :: Int
j) = case Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
i Int
j of
                       EQ -> (1LaurentPoly Q -> LaurentPoly Q -> LaurentPoly Q
forall a. Fractional a => a -> a -> a
/(b -> LaurentPoly Q
forall b. Integral b => b -> LaurentPoly Q
lambda b
m LaurentPoly Q -> LaurentPoly Q -> LaurentPoly Q
forall a. Num a => a -> a -> a
* LaurentPoly Q
q)) LaurentPoly Q
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> EBasis
E Int
i, Int -> EBasis
E Int
i)
                       LT -> (1LaurentPoly Q -> LaurentPoly Q -> LaurentPoly Q
forall a. Fractional a => a -> a -> a
/b -> LaurentPoly Q
forall b. Integral b => b -> LaurentPoly Q
lambda b
m) LaurentPoly Q
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> ((EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> EBasis
E Int
j, Int -> EBasis
E Int
i) Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k b.
(Eq k, Num k, Ord b) =>
Vect k b -> Vect k b -> Vect k b
<+> (LaurentPoly Q
q'LaurentPoly Q -> LaurentPoly Q -> LaurentPoly Q
forall a. Num a => a -> a -> a
-LaurentPoly Q
q) LaurentPoly Q
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> EBasis
E Int
i, Int -> EBasis
E Int
j))
                       GT -> (1LaurentPoly Q -> LaurentPoly Q -> LaurentPoly Q
forall a. Fractional a => a -> a -> a
/b -> LaurentPoly Q
forall b. Integral b => b -> LaurentPoly Q
lambda b
m) LaurentPoly Q
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> EBasis
E Int
j, Int -> EBasis
E Int
i)

testcc' :: b
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
testcc' m :: b
m v :: Vect (LaurentPoly Q) (EBasis, EBasis)
v = Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k b. (Eq k, Num k, Ord b) => Vect k b -> Vect k b
nf (Vect (LaurentPoly Q) (EBasis, EBasis)
 -> Vect (LaurentPoly Q) (EBasis, EBasis))
-> Vect (LaurentPoly Q) (EBasis, EBasis)
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall a b. (a -> b) -> a -> b
$ Vect (LaurentPoly Q) (EBasis, EBasis)
v Vect (LaurentPoly Q) (EBasis, EBasis)
-> ((EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis))
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
c b
m Vect (LaurentPoly Q) (EBasis, EBasis)
-> ((EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis))
-> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
c' b
m

mu :: b -> EBasis -> Vect (LaurentPoly Q) EBasis
mu m :: b
m (E i :: Int
i) = (1 LaurentPoly Q -> LaurentPoly Q -> LaurentPoly Q
forall a. Fractional a => a -> a -> a
/ (b -> LaurentPoly Q
forall b. Integral b => b -> LaurentPoly Q
lambda b
m LaurentPoly Q -> LaurentPoly Q -> LaurentPoly Q
forall a. Num a => a -> a -> a
* LaurentPoly Q
q LaurentPoly Q -> Int -> LaurentPoly Q
forall a b. (Num a, Integral b) => a -> b -> a
^ (2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-1))) LaurentPoly Q
-> Vect (LaurentPoly Q) EBasis -> Vect (LaurentPoly Q) EBasis
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> EBasis -> Vect (LaurentPoly Q) EBasis
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> EBasis
E Int
i)

mu' :: b -> EBasis -> Vect (LaurentPoly Q) EBasis
mu' m :: b
m (E i :: Int
i) = (b -> LaurentPoly Q
forall b. Integral b => b -> LaurentPoly Q
lambda b
m LaurentPoly Q -> LaurentPoly Q -> LaurentPoly Q
forall a. Num a => a -> a -> a
* LaurentPoly Q
q LaurentPoly Q -> Int -> LaurentPoly Q
forall a b. (Num a, Integral b) => a -> b -> a
^ (2Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-1)) LaurentPoly Q
-> Vect (LaurentPoly Q) EBasis -> Vect (LaurentPoly Q) EBasis
forall k b. (Eq k, Num k) => k -> Vect k b -> Vect k b
*> EBasis -> Vect (LaurentPoly Q) EBasis
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> EBasis
E Int
i)

-- The following are modified from Kassel. We compose diagrams downwards, whereas he composes them upwards.

capRL :: Int -> Vect k (EBasis, EBasis)
capRL m :: Int
m = Int -> Vect k (EBasis, EBasis)
forall k. (Eq k, Num k) => Int -> Vect k (EBasis, EBasis)
coevalV Int
m

capLR :: Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
capLR m :: Int
m = do
    (i :: EBasis
i,j :: EBasis
j) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k. (Eq k, Num k) => Int -> Vect k (EBasis, EBasis)
coevalV' Int
m
    EBasis
k <- Int -> EBasis -> Vect (LaurentPoly Q) EBasis
forall b. Integral b => b -> EBasis -> Vect (LaurentPoly Q) EBasis
mu' Int
m EBasis
j
    (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (EBasis
i,EBasis
k)

cupRL :: Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupRL m :: Int
m = (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
evalV

cupLR :: Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupLR m :: Int
m (i :: EBasis
i,j :: EBasis
j) = do
    EBasis
k <- Int -> EBasis -> Vect (LaurentPoly Q) EBasis
forall b. Integral b => b -> EBasis -> Vect (LaurentPoly Q) EBasis
mu Int
m EBasis
i
    (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
evalV' (EBasis
k,EBasis
j)    
-- linear evalV' . (linear (mu' m) `tf` idV)



xplus :: b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
xplus m :: b
m = b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
c b
m

xminus :: b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
xminus m :: b
m = b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
c' b
m

yplus :: Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
yplus m :: Int
m (p :: EBasis
p,q :: EBasis
q) = do
    (r :: EBasis
r,s :: EBasis
s) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k. (Eq k, Num k) => Int -> Vect k (EBasis, EBasis)
capRL Int
m
    (t :: EBasis
t,u :: EBasis
u) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
xplus Int
m (EBasis
q,EBasis
r)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupRL Int
m (EBasis
p,EBasis
t)
    (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (EBasis
u,EBasis
s)

yminus :: Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
yminus m :: Int
m (p :: EBasis
p,q :: EBasis
q) = do
    (r :: EBasis
r,s :: EBasis
s) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k. (Eq k, Num k) => Int -> Vect k (EBasis, EBasis)
capRL Int
m
    (t :: EBasis
t,u :: EBasis
u) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
xminus Int
m (EBasis
q,EBasis
r)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupRL Int
m (EBasis
p,EBasis
t)
    (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (EBasis
u,EBasis
s)

tplus :: Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
tplus m :: Int
m (p :: EBasis
p,q :: EBasis
q) = do
    (r :: EBasis
r,s :: EBasis
s) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
capLR Int
m
    (t :: EBasis
t,u :: EBasis
u) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
xplus Int
m (EBasis
s,EBasis
p)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupLR Int
m (EBasis
u,EBasis
q)
    (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (EBasis
r,EBasis
t)

tminus :: Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
tminus m :: Int
m (p :: EBasis
p,q :: EBasis
q) = do
    (r :: EBasis
r,s :: EBasis
s) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
capLR Int
m
    (t :: EBasis
t,u :: EBasis
u) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
xminus Int
m (EBasis
s,EBasis
p)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupLR Int
m (EBasis
u,EBasis
q)
    (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (EBasis
r,EBasis
t)

zplus :: Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
zplus m :: Int
m (p :: EBasis
p,q :: EBasis
q) = do
    (r :: EBasis
r,u :: EBasis
u) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
capLR Int
m
    (s :: EBasis
s,t :: EBasis
t) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
capLR Int
m
    (v :: EBasis
v,w :: EBasis
w) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
xplus Int
m (EBasis
t,EBasis
u)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupLR Int
m (EBasis
v,EBasis
q)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupLR Int
m (EBasis
w,EBasis
p)
    (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (EBasis
r,EBasis
s)

zminus :: Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
zminus m :: Int
m (p :: EBasis
p,q :: EBasis
q) = do
    (r :: EBasis
r,u :: EBasis
u) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
capLR Int
m
    (s :: EBasis
s,t :: EBasis
t) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
capLR Int
m
    (v :: EBasis
v,w :: EBasis
w) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
xminus Int
m (EBasis
t,EBasis
u)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupLR Int
m (EBasis
v,EBasis
q)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupLR Int
m (EBasis
w,EBasis
p)
    (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall (m :: * -> *) a. Monad m => a -> m a
return (EBasis
r,EBasis
s)

{-
Then we have for example the following:
> let v = e1 `te` e2 in nf $ v >>= xplus 2 >>= xminus 2
(e1,e2)
> let v = e (-1) `te` e2 in nf $ v >>= yplus 2 >>= tminus 2
(e-1,e2)
> let v = e (-1) `te` e (-2) in nf $ v >>= zplus 2 >>= zminus 2
(e-1,e-2)
-}


oloop :: Int -> Vect (LaurentPoly Q) ()
oloop m :: Int
m = Vect (LaurentPoly Q) () -> Vect (LaurentPoly Q) ()
forall k b. (Eq k, Num k, Ord b) => Vect k b -> Vect k b
nf (Vect (LaurentPoly Q) () -> Vect (LaurentPoly Q) ())
-> Vect (LaurentPoly Q) () -> Vect (LaurentPoly Q) ()
forall a b. (a -> b) -> a -> b
$ do
    (a :: EBasis
a,b :: EBasis
b) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
capLR Int
m
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupRL Int
m (EBasis
a,EBasis
b)

-- oriented trefoil
otrefoil :: Int -> Vect (LaurentPoly Q) ()
otrefoil m :: Int
m = Vect (LaurentPoly Q) () -> Vect (LaurentPoly Q) ()
forall k b. (Eq k, Num k, Ord b) => Vect k b -> Vect k b
nf (Vect (LaurentPoly Q) () -> Vect (LaurentPoly Q) ())
-> Vect (LaurentPoly Q) () -> Vect (LaurentPoly Q) ()
forall a b. (a -> b) -> a -> b
$ do
    (p :: EBasis
p,q :: EBasis
q) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
capLR Int
m
    (r :: EBasis
r,s :: EBasis
s) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
capLR Int
m
    (t :: EBasis
t,u :: EBasis
u) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
tminus Int
m (EBasis
q,EBasis
r)
    (v :: EBasis
v,w :: EBasis
w) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
zminus Int
m (EBasis
p,EBasis
t)
    (x :: EBasis
x,y :: EBasis
y) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
xminus Int
m (EBasis
u,EBasis
s)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupRL Int
m (EBasis
w,EBasis
x)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupRL Int
m (EBasis
v,EBasis
y)

-- oriented the other way
otrefoil' :: Int -> Vect (LaurentPoly Q) ()
otrefoil' m :: Int
m = Vect (LaurentPoly Q) () -> Vect (LaurentPoly Q) ()
forall k b. (Eq k, Num k, Ord b) => Vect k b -> Vect k b
nf (Vect (LaurentPoly Q) () -> Vect (LaurentPoly Q) ())
-> Vect (LaurentPoly Q) () -> Vect (LaurentPoly Q) ()
forall a b. (a -> b) -> a -> b
$ do
    (p :: EBasis
p,q :: EBasis
q) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k. (Eq k, Num k) => Int -> Vect k (EBasis, EBasis)
capRL Int
m
    (r :: EBasis
r,s :: EBasis
s) <- Int -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall k. (Eq k, Num k) => Int -> Vect k (EBasis, EBasis)
capRL Int
m
    (t :: EBasis
t,u :: EBasis
u) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
yminus Int
m (EBasis
q,EBasis
r)
    (v :: EBasis
v,w :: EBasis
w) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
forall b.
Integral b =>
b -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
xminus Int
m (EBasis
p,EBasis
t)
    (x :: EBasis
x,y :: EBasis
y) <- Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) (EBasis, EBasis)
zminus Int
m (EBasis
u,EBasis
s)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupLR Int
m (EBasis
w,EBasis
x)
    Int -> (EBasis, EBasis) -> Vect (LaurentPoly Q) ()
cupLR Int
m (EBasis
v,EBasis
y)


{-
-- REPRESENTATIONS OF THE TANGLE CATEGORY IN VECTOR SPACE CATEGORY
-- But we need to convert the above code to use TensorAlgebra first

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