module Kh
where
import Util
import Complex
import Braids
import Data.Set (Set, (\\))
import Data.List (sort)
import qualified Data.Set as S
import Data.Map (Map, (!))
import qualified Data.Map as M
import Control.Monad
gToD :: Generator -> BDiagram
gToD g = BDiagram {resolution' = resolution g, components' = components g}
homGrading :: Generator -> Int
homGrading gen = sum . resolution $ gen
qGrading :: Generator -> Int
qGrading gen = sum . fmap signToNum . signs $ gen where
data Triviality = Trivial | NonTrivial deriving (Ord, Eq, Show)
nonTrivialCircle :: Int -> Component -> Triviality
nonTrivialCircle width arcs = if odd $ length (filter (`elem` [1..width]) (S.toList arcs))
then NonTrivial
else Trivial
kGrading :: (Resolution, Set Component, Map Component Sign) -> Int -> Int
kGrading (_,_,ss) width = ks ! NonTrivial where
ks = M.mapKeysWith (+) (nonTrivialCircle width) . fmap signToNum $ ss
khovanov :: Int -> BDiagram -> [Generator]
khovanov width d = do
ss <- generateSigns . components' $ d
return Generator {resolution = resolution' d,
components = components' d,
signs = M.fromList $ zip (S.toList $ components' d) ss,
kgrade = kGrading (resolution' d, components' d, M.fromList $ zip (S.toList $ components' d) ss) width}
where
generateSigns cs = Control.Monad.replicateM (length cs) [Minus,Plus]
khovanovComplex :: Int -> [BDiagram] -> Map Int (Set Generator)
khovanovComplex width cube = M.fromListWith S.union [(homGrading g, S.singleton g) | g <- concatMap (khovanov width) cube]
data ElMo
= Merge (Set Component) (Set Component)
| Split (Set Component) (Set Component)
deriving (Show)
whichMorphism :: BDiagram -> BDiagram -> Maybe ElMo
whichMorphism d d' | not (succRes d d') = Nothing
| length cs2' == 2 && length cs1' == 1 = Just $ Split cs1' cs2'
| length cs1' == 2 && length cs2' == 1 = Just $ Merge cs1' cs2'
| otherwise = Nothing
where
cs2' = components' d' \\ components' d
cs1' = components' d \\ components' d'
succRes :: BDiagram -> BDiagram -> Bool
succRes e e' = all (>=0) diff && (sum diff == 1) where
diff = zipWith subtract (resolution' e) (resolution' e')
morphismAction :: Maybe ElMo -> Generator -> Generator -> Bool
morphismAction (Just (Merge cs12 c3)) g g' | (cs12 `isNotASubsetOf` gcs) || (c3 `isNotASubsetOf` g'cs) = False
| (g'cs \\ c3) /= (gcs \\ cs12) = False
| ss `deleteKeys` cs12 /= ss' `deleteKeys` c3 = False
| M.elems (ss `getSubmap` cs12) == [Plus,Plus] && M.elems (ss' `getSubmap` c3) == [Plus] = True
| sort (M.elems (ss `getSubmap` cs12)) == [Plus,Minus] && M.elems (ss' `getSubmap` c3) == [Minus] = True
| otherwise = False
where
gcs = components g
g'cs = components g'
ss = signs g
ss' = signs g'
morphismAction (Just (Split c1 cs23)) g g' | (c1 `isNotASubsetOf` gcs) || (cs23 `isNotASubsetOf` g'cs) = False
| (g'cs \\ cs23) /= (gcs \\ c1) = False
| ss `deleteKeys` c1 /= ss' `deleteKeys` cs23 = False
| M.elems (ss `getSubmap` c1) == [Plus] && sort (M.elems (ss' `getSubmap` cs23)) == [Plus, Minus] = True
| M.elems (ss `getSubmap` c1) == [Minus] && M.elems (ss' `getSubmap` cs23) == [Minus, Minus] = True
| otherwise = False
where
gcs = components g
g'cs = components g'
ss = signs g
ss' = signs g'
morphismAction (Nothing) _ _ = False
kDrop :: Generator -> Generator -> Int
kDrop g g' = kgrade g kgrade g'
kgrade' :: AlgGen -> Int
kgrade' (AlgGen gs) = maximum . S.map kgrade $ gs
kDrop' :: AlgGen -> AlgGen -> Int
kDrop' gs gs' = kgrade' gs kgrade' gs'
filteredMorphismAction :: Int -> Maybe ElMo -> Generator -> Generator -> Bool
filteredMorphismAction k e g g' | kDrop g g' <= k = morphismAction e g g'
| otherwise = False
filteredMorphismsFrom :: Int -> Generator -> Set Generator -> Morphisms
filteredMorphismsFrom k g gs = M.singleton (wrapGen g) gs' where
gs' = S.map wrapGen
. S.filter (\g' -> filteredMorphismAction k (mor g') g g')
$ gs
mor g' = whichMorphism (gToD g) (gToD g')
filteredComplexLevel :: Int -> Map Int (Set Generator) -> Int -> Morphisms
filteredComplexLevel k gs i = case M.lookup (i+1) gs of
Nothing -> M.empty
otherwise -> M.unionsWith S.union . S.toList . S.map (\g -> filteredMorphismsFrom k g gsi1) $ gsi where
gsi = gs ! i
gsi1 = gs ! (i+1)
psi :: Braid -> Generator
psi b = Generator {resolution = res, components = comps, signs = ss, kgrade = k} where
res = fmap (\x -> if x >= 0 then 0 else 1) (braidWord b)
comps = resolutionToComponents . flip resolve res . braidToPD $ b
ss = M.fromList $ zip (S.toList comps) (repeat Minus)
k = (1)* braidWidth b
psiCube :: Braid -> [BDiagram]
psiCube b = do
res <- allRes (braidToPD b)
let diagram = resolutionToComponents . resolve (braidToPD b)
guard (sum res <= (sum . resolution . psi $ b))
return BDiagram {resolution' = res, components' = diagram res}