{-# 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
    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 ^ (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