module Knots.Khovanov where
import Knots.Prelude
import Knots.PD
import Knots.Util
import Knots.Morphism
import Knots.Free
import qualified Data.Map as Map
import qualified Data.Set as Set
data PartitionComparison a
= Split (Set (Set a)) (Set a) (Set (Set a)) (Set a) (Set (Set a))
| Merge (Set (Set a)) (Set a) (Set (Set a)) (Set a) (Set (Set a))
deriving (Eq,Show)
data ComparisonType = TypeSplit | TypeMerge
split3 p s1 s2 = let (p1,p2) = Set.split s1 p
(p21,p22) = Set.split s2 p2
in (p1,p21,p22)
partitionComparison :: Ord a => Set (Set a) -> Set (Set a) -> PartitionComparison a
partitionComparison p q =
let common = Set.intersection p q
only_in_p = Set.toList (Set.difference p q)
only_in_q = Set.toList (Set.difference q p)
in case (only_in_p, only_in_q) of
([_], [y,z]) -> let (p1,p2,p3) = split3 common y z
in Split p1 y p2 z p3
([y,z], [_]) -> let (p1,p2,p3) = split3 common y z
in Merge p1 y p2 z p3
_ -> error "bad knot data? giving up"
data MarkPosition =
None | MarkLeft Int | ReducedLeft | MarkMiddle Int | ReducedRight |
MarkRight Int
deriving (Eq,Show,Read)
markPosition :: Ord a => a -> PartitionComparison a -> MarkPosition
markPosition mark (Split p1 x p2 y p3) = markPosition' mark p1 x p2 y p3
markPosition mark (Merge p1 x p2 y p3) = markPosition' mark p1 x p2 y p3
markPosition' mark p1 x p2 y p3
| mark `Set.member` x = ReducedLeft
| mark `Set.member` y = ReducedRight
| Just offset <- findMark p1 = MarkLeft offset
| Just offset <- findMark p2 = MarkMiddle offset
| Just offset <- findMark p3 = MarkRight offset
| otherwise = None
where findMark p =
fmap (\(setWithMark,_) -> Set.findIndex setWithMark p)
. Set.minView
. Set.filter (Set.member mark)
$ p
toElMo :: (Ord a) => PartitionComparison a -> ElMo
toElMo (Split p1 _ p2 _ p3) = Comult (Set.size p1) (Set.size p2) (Set.size p3)
toElMo (Merge p1 _ p2 _ p3) = Mult (Set.size p1) (Set.size p2) (Set.size p3)
morphism :: Ord a => Set Int -> Set Int -> Set (Set a) -> Set (Set a) -> ElMo
morphism l m p q
| Set.isSubsetOf l m = let i = Set.findMin (m Set.\\ l)
sign = if odd (Set.size (Set.filter (> i) l))
then Neg
else id
cmp = partitionComparison p q
in sign (toElMo cmp)
| otherwise = error "I'm giving up"
morphism_ :: Ord a => a -> Set Int -> Set Int -> Set (Set a) -> Set (Set a) -> (ElMo,MarkPosition)
morphism_ mark l m p q
| Set.isSubsetOf l m = let i = Set.findMin (m Set.\\ l)
sign = if odd (Set.size (Set.filter (> i) l))
then Neg
else id
cmp = partitionComparison p q
in (sign (toElMo cmp), markPosition mark cmp)
| otherwise = error "I'm giving up"
toMorphism :: RingEq r => ElMo -> MarkPosition -> Morphism [B] r
toMorphism (Mult i j k) markPos = padMorphism TypeMerge i j k markPos
toMorphism (Comult i j k) markPos = padMorphism TypeSplit i j k markPos
toMorphism (Neg phi) markPos = fmap negate (toMorphism phi markPos)
padMorphism :: RingEq r => ComparisonType
-> Int -> Int -> Int
-> MarkPosition
-> Morphism [B] r
padMorphism typ i j k markPos = left * middle * right
where
left =
case markPos of
MarkLeft l -> idA ^ (l) * idB1 * idA ^ (il1)
_ -> idA ^ i
right =
case markPos of
MarkRight l -> idA ^ l * idB1 * idA ^ (kl1)
_ -> idA ^ k
idsMiddle =
case markPos of
MarkMiddle l -> idA ^ l * idB1 * idA ^ (jl1)
_ -> idA ^ j
permMiddle permute =
case markPos of
MarkMiddle l -> (idA * permute idA perm l * idB1 * idA ^ (jl1)) `oo`
(idA ^ (l+1) * permReduced * idA ^ (jl1)) `oo`
(idA ^ (l+1) * idB1 * permute idA perm (jl1))
ReducedLeft -> idB1 * permute idA perm j
ReducedRight -> idA * permute idB1 (fmap dual permReduced) j
_ -> idA * permute idA perm j
middle =
case (typ,markPos) of
(TypeSplit,ReducedLeft) -> permMiddle forwardPermute `oo` (comultReducedLeft * idsMiddle)
(TypeSplit,ReducedRight)-> permMiddle forwardPermute `oo` (comultReducedRight * idsMiddle)
(TypeSplit,_) -> permMiddle forwardPermute `oo` (comult * idsMiddle)
(TypeMerge,ReducedLeft) -> (multReducedLeft * idsMiddle) `oo` permMiddle backPermute
(TypeMerge,ReducedRight)-> (multReducedRight * idsMiddle) `oo` permMiddle backPermute
(TypeMerge,_) -> (mult * idsMiddle) `oo` permMiddle backPermute
khovanov :: Ord a => Maybe a -> PD a -> Map (Set Int, Set Int) (ElMo, MarkPosition)
khovanov mark pd =
let n = Set.fromList [0 .. length pd 1]
phi = maybe (\s t res1 res2 -> (morphism s t res1 res2, None))
morphism_
mark
in Map.fromList
[ ((t,s), phi s t res1 res2)
| t <- power n
, x <- Set.toList t
, let s = Set.delete x t
, let pd1 = switch' s pd
, let pd2 = switch' t pd
, let res1 = resolve_set pd1
, let res2 = resolve_set pd2
]
khovanovLine :: [ [[Int]] ] -> [ ElMo ]
khovanovLine ps = zipWith f ps (tail ps) where
f p q = toElMo (partitionComparison (toPartition p) (toPartition q))
where toPartition :: [[Int]] -> Set (Set Int)
toPartition = Set.fromList . map Set.fromList