```{-# LANGUAGE
ConstraintKinds,
DeriveFunctor,
DeriveFoldable,
NoImplicitPrelude,
NoMonomorphismRestriction,
RebindableSyntax,
ScopedTypeVariables,
PatternGuards #-}
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

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 ^ (i-l-1)
_           -> idA ^ i
right =
case markPos of
MarkRight l -> idA ^ l * idB1 * idA ^ (k-l-1)
_           -> idA ^ k
idsMiddle =
case markPos of
MarkMiddle l -> idA ^ l * idB1 * idA ^ (j-l-1)
_            -> idA ^ j
permMiddle permute =
case markPos of
MarkMiddle l -> (idA * permute idA perm l * idB1 * idA ^ (j-l-1)) `oo`
(idA ^ (l+1) * permReduced * idA ^ (j-l-1)) `oo`
(idA ^ (l+1) * idB1 * permute idA perm (j-l-1))
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
```