diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Adam Saltz (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Adam Saltz nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/KappaView.hs b/app/KappaView.hs new file mode 100644 --- /dev/null +++ b/app/KappaView.hs @@ -0,0 +1,36 @@ +module KappaView +where + +import System.Environment (getArgs) +import Data.Maybe (isJust, fromJust ) +import Diagrams (QDiagram) +import Diagrams.TwoD.Types (V2) +import Diagrams.TwoD.Size (mkHeight) +import Diagrams.Backend.SVG (renderSVG, B) +import Data.Monoid (Any) +import Control.Monad (forM_) + +import Braids (Braid) +import Kappa (computeKappa') +import Parse +import Braiddiagrams +import qualified Data.Map as M (keys) + +main :: IO () +main = do + input <- getArgs + let braid = parse input + let imagesNumbered = zip (images braid) [1..] + let maybeKappa = computeKappa' braid + if isJust maybeKappa then do + putStrLn ("Kappa is " ++ (show . fst . fromJust $ maybeKappa) ++ ".") + forM_ imagesNumbered (\(image, number) -> + renderSVG ("psiKiller" ++ (show number) ++ ".svg") (mkHeight 2000) image >> + putStrLn ("Canceling element printed to psiKiller" ++ (show number) ++ ".svg.") + ) + else putStrLn "Psi does not vanish for this braid." + +images :: Braid -> [QDiagram B V2 Double Any] +images b = fmap (printCube . bigGeneratorD b) gens where + Just (_, mors) = computeKappa' b + gens = M.keys $ mors diff --git a/braid.cabal b/braid.cabal new file mode 100644 --- /dev/null +++ b/braid.cabal @@ -0,0 +1,69 @@ +name: braid +version: 0.1.0.0 +synopsis: Types and functions to work with braids and Khovanov homology. +description: A library to work with [braids](https://en.wikipedia.org/wiki/Braid_theory) and [Khovanov homology](https://en.wikipedia.org/wiki/Khovanov_homology). The main focus of the package is computing (the braid invariant \kappa)[http://arxiv.org/abs/1507.06263] defined by (the package author)[adamsaltz.com] and (Diana Hubbard)[https://sites.google.com/site/dianadhubbard/]. + + Braids are encoded by their index/width and a word in the standard [Artin generators](https://en.wikipedia.org/wiki/Braid_group#Generators_and_relations). To represent the 4-strand braid \sigma_1\sigma_2\sigma^(-1)_3 use + . + > Braid [1,2,-3] 4 + . + The function 'computeKappa' in the module `Kappa` returns 'Just kappa' if kappa is finite and 'Nothing' otherwise. More helper functions for working with Khovanov homology and reduced Khovanov homology will be included soon. + . + The module 'Braiddiagrams' creates diagrams for braids, their closures, and their resolutions. E.g. to dra + . + The executable 'KappaView' draws the pre-images of the (transverse invariant \psi)[http://arxiv.org/abs/math/0412184] with lowest k-grading. The minus-labeled components are indicated by dots. +homepage: http://github.com/githubuser/braid#readme +license: BSD3 +license-file: LICENSE +author: Adam Saltz +maintainer: saltz.adam@gmail.com +copyright: 2016, Adam Saltz +category: Math +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Braids, Cancellation, Complex, ExampleBraids, + Kappa, Kh, Parse, Util, Braiddiagrams + build-depends: base >= 4.7 && < 5, + containers, + split, + diagrams-core, + diagrams-lib, + diagrams-contrib, + diagrams-svg + default-language: Haskell2010 + +executable KappaView + hs-source-dirs: app, src + main-is: KappaView.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N -O2 -main-is KappaView + build-depends: base >= 4.7 && < 5, + containers, + split, + diagrams-core, + diagrams-lib, + diagrams-contrib, + diagrams-svg + default-language: Haskell2010 + other-modules: Braiddiagrams, + Braids, + Cancellation, + Complex, + Kappa, + Kh, + Parse, + Util, + ExampleBraids + +-- test-suite braid-test +-- type: exitcode-stdio-1.0 +-- hs-source-dirs: test +-- main-is: Spec.hs +-- build-depends: base +-- , braid +-- ghc-options: -threaded -rtsopts -with-rtsopts=-N +-- default-language: Haskell2010 + diff --git a/src/Braiddiagrams.hs b/src/Braiddiagrams.hs new file mode 100644 --- /dev/null +++ b/src/Braiddiagrams.hs @@ -0,0 +1,217 @@ +{-| +Module : Braiddiagrams +Description : Draws braids, their closures, and Khovanov generators. +Copyright : Adam Saltz +License : BSD3 +Maintainer : saltz.adam@gmail.com +Stability : experimental + +Longer description to come. +-} +{-# LANGUAGE NoMonomorphismRestriction, FlexibleInstances #-} + +module Braiddiagrams +where +import Prelude hiding (exp) +import Diagrams.Prelude +import Diagrams.Backend.SVG.CmdLine +import Diagrams.TwoD.Path.Metafont +import Diagrams.Direction +import qualified Data.Map as M +import qualified Data.Set as S +import Data.List (group, sort, maximumBy, find) +import qualified Diagrams.TwoD.Size as Size +import Control.Arrow ((&&&), second) +import Data.Tuple (swap) +import Control.Monad (replicateM) +import Data.Maybe (fromMaybe) + +import Braids -- (Braid, braidWord, braidWidth, Node (Join), Resolution) +import Complex --(Generator, components, signs, resolution) +import Util + +type ArcLabel = Int +type Height = Int +type BraidIndex = Int +type ArtinGen = Int + +-- | A @newtype@ wrapper for 'Node' to create an `IsName` instance. +newtype NameNode = NameNode (Node ArcLabel) deriving (Ord, Eq, Show) +instance IsName NameNode + + +-- | The identity braid of index @index@. +identity :: BraidIndex -> Diagram B +identity index = hsep 1 (fmap vrule (replicate index 1)) + +-- | The identity braid of index @index@ with arc names starting at @lastlabel + 1@. +identityAt :: BraidIndex -> ArcLabel -> Diagram B -- lastLabel is the last label of the diagram above +identityAt index lastLabel = hsep 1 (fmap (\x -> named (name x) $ vrule 1) [1 .. index]) + where + --name :: Int -> Node Int + name x = NameNode (Join (lastLabel + x) (lastLabel + x + index)) + +-- | A negative crossing. +negativeCrossing :: Diagram B +negativeCrossing = metafont (p2 (-0.5,0.5) .- leaving unit_Y <> arriving unit_Y -. endpt (p2 (0.5,-0.5))) + <> metafont (p2 (0.5,0.5) .- leaving unit_Y <> arriving (unit_Y + unit_X) -. endpt (p2 (0.1,0.1))) + <> metafont (p2 (-0.5,-0.5) .- leaving unitY <> arriving (unitY + unitX) -. endpt (p2 (-0.1,-0.1))) + +-- | Draws a positive crossing. +positiveCrossing :: Diagram B +positiveCrossing = metafont (p2 (0.5,0.5) .- leaving unit_Y <> arriving unit_Y -. endpt (p2 (-0.5,-0.5))) + <> metafont (p2 (-0.5,0.5) .- leaving unit_Y <> arriving (unit_Y + unitX) -. endpt (p2 (-0.1,0.1))) + <> metafont (p2 (0.5,-0.5) .- leaving unitY <> arriving (unitY + unit_X) -. endpt (p2 (0.1,-0.1))) + +-- | A cup-cap combo. +cupCap :: Diagram B +cupCap = metafont (p2 (0.5,0.5) .- leaving unit_Y <> arriving unit_X + -. p2 (0,0.3) .- leaving unit_X <> arriving unitY + -. endpt (p2 (-0.5,0.5))) + <> metafont (p2 (-0.5,-0.5) .- leaving unitY <> arriving unitX + -. p2 (0, -0.3) .- arriving unit_Y <> leaving unitX + -. endpt (p2 (0.5,-0.5))) + +-- | A cup-cap combo with names starting at @lastLabel + 1@. +cupCapLevelAt :: BraidIndex -> ArcLabel -> ArtinGen -> Diagram B +cupCapLevelAt index lastLabel gen = hsep 1 + [ hsep 1 (fmap (\x -> named (name x) $ vrule 1) [1 .. spot - 1]) + {-, vsep 0.6 [metafont (p2 (0.5,0.5) .- leaving unit_Y <> arriving unit_X + -. p2 (0,0.3) .- leaving unit_X <> arriving unitY + -. endpt (p2 (-0.5,0.5))) # named (Join (lastLabel + spot) (lastLabel + spot + 1)) + ,metafont (p2 (-0.5,-0.5) .- leaving unitY <> arriving unitX + -. p2 (0, -0.3) .- arriving unit_Y <> leaving unitX + -. endpt (p2 (0.5,-0.5))) # named (Join (lastLabel + spot + index) (lastLabel + spot + index + 1))]-} + , vsep 0.6 [metafont (p2 (0.5,0.1) .- leaving unit_Y <> arriving unit_X + -. p2 (0,-0.1) .- leaving unit_X <> arriving unitY + -. endpt (p2 (-0.5,0.1))) # named (NameNode (Join (lastLabel + spot) (lastLabel + spot + 1))) # translateY 0.4 + , metafont (p2 (-0.5,-0.1) .- leaving unitY <> arriving unitX + -. p2 (0, 0.1) .- arriving unit_Y <> leaving unitX + -. endpt (p2 (0.5,-0.1))) # named (NameNode (Join (lastLabel + spot + index) (lastLabel + spot + index + 1))) # translateY (-0.4) + ] + + , hsep 1 (fmap (\x -> named (name x) $ vrule 1) [spot + 2 .. index]) + ] + where + name x = NameNode (Join (lastLabel + x) (lastLabel + x + index)) + spot = abs gen + +-- | The @k@th Artin generator of the braid group on @n@ strands. +-- To draw the inverse of the @k@th generator, use @-k@. +artin :: BraidIndex -> ArtinGen -> Diagram B +artin n k = case compare k 0 of + GT -> hsep 1 [identity (k-1) , positiveCrossing, identity (n-k-1)] + LT -> hsep 1 [identity (-k-1), negativeCrossing, identity (n-(-k)-1)] + EQ -> identity n + +-- | Draws a braid. +drawBraid :: Braid -> Diagram B +drawBraid b = vcat $ alignL <$> fmap (artin index) word where + index = braidWidth b + word = braidWord b + +-- | Draws a braid closure. +drawBraidClosure :: Braid -> Diagram B +drawBraidClosure b = alignL (mconcat [arc' r (dir unitX) (pi @@ rad) | r <- [1.0..fromIntegral index]]) + === + alignL (drawBraid b ||| strutX 2 ||| vcat (replicate (length word) (identity index))) + === + alignL (mconcat [arc' r (dir unit_X) (pi @@ rad) | r <- [1.0..fromIntegral index]]) + where + index = braidWidth b + word = braidWord b + +-- | Draws the @r@ resolution of the @k@th Artin generator in the @n@ strand braid group. +-- To draw the inverse of the @k@th generator, use @-k@. +resolutionD :: Int -> BraidIndex -> ArtinGen -> Diagram B +resolutionD r n k = if r == 0 + then case compare k 0 of + GT -> identity n + LT -> hsep 1 [identity (-k-1), cupCap, identity (n-(-k)-1)] + EQ -> identity n + else case compare k 0 of + GT -> hsep 1 [identity (k-1), cupCap, identity (n-(k)-1)] + LT -> identity n + EQ -> identity n + +-- | Draws the @r@ resolution of the @k@th Artin generator in the @n@ strand braid group with names starting at @lastLabel + 1@. +-- To draw the inverse of the @k@th generator, use @-k@. +resolutionAt :: Int -> BraidIndex -> ArtinGen -> Height -> Diagram B +resolutionAt r index gen height = if r == 0 + then case compare gen 0 of + GT -> identityAt index (height * index) + LT -> cupCapLevelAt index (height * index) gen + EQ -> identityAt index (height * index) + else case compare gen 0 of + GT -> cupCapLevelAt index (height * index) gen + LT -> identityAt index (height * index) + EQ -> identityAt index (height * index) + +-- | Draws the braid @b@ resolved according to @rs@. +resolveD :: Resolution -> Braid -> Diagram B +resolveD rs b = vcat $ alignL + <$> zipWith ($) (map uncurry (fmap (`resolutionAt` index) rs)) (zip word [0..]) + where + index = braidWidth b + word = braidWord b + +-- | Draws the closure of the braid @b@ resolved according to @rs@. +resolveClosureD :: Resolution -> Braid -> Diagram B +resolveClosureD rs b = alignL (mconcat [arc' r (dir unitX) (pi @@ rad) | r <- [1.0..fromIntegral index]]) + === + alignL (resolveD rs b ||| strutX 2 ||| vcat (replicate (length word) (identity index))) + === + alignL (mconcat [arc' r (dir unit_X) (pi @@ rad) | r <- [1.0..fromIntegral index]]) + where + index = braidWidth b + word = braidWord b + +-- | A `Map` from `Resolution`s to a diagram of the corresponding resolution of the braid @b@. +cubeOfResolutionsD :: Braid -> M.Map Resolution (Diagram B) +cubeOfResolutionsD b = M.fromList $ fmap (\rs -> (rs, resolveD rs b)) ress + where + ress = replicateM (length word) [0,1] + word = braidWord b + +-- | A `Map` from `Resolution`s to a diagram of the corresponding resolution of the closure of the braid @b@. +cubeOfResolutionsClosureD :: Braid -> M.Map Resolution (Diagram B) +cubeOfResolutionsClosureD b = M.fromList $ fmap (\rs -> (rs, resolveClosureD rs b)) ress + where + ress = replicateM (length word) [0,1] + word = braidWord b + +-- | Prints `Map`s like the output of `cubeOfResolutionsD` and `cubeOfResolutionsClosureD.` +printCube :: M.Map [Int] (Diagram B) -> Diagram B +printCube cube = lw veryThin + . hcat' (with & sep .~ maxWidth) -- . fmap (translateY) + . fmap center + . M.elems + . fmap (vcat' (with & sep .~ maxHeight / 3)) -- Map Int Diagram B + . M.mapKeysWith (++) sum -- Map Weight [Diagrams] + . fmap (:[]) -- Map Int [Diagram B] -- Map Key [Diagram] + $ cubeWithText where + maxHeight = maximum . fmap height . M.elems $ cube :: Double + cubeWithText = M.mapWithKey (\k a -> vcat' (with & sep .~ 1) [a -- Map Key Diagram + , (text . show $ k) -- # fontSize (local 1) -- put resolution below each diagram + # translateX (Size.width a / 2)]) cube + maxWidth = maximum . fmap Size.width . M.elems $ cubeWithText :: Double + +-- | Diagrams for an `AlgGen` indexed by their resolutions. +bigGeneratorD :: Braid -> AlgGen -> M.Map [Int] (Diagram B) +bigGeneratorD braid gens = M.fromList $ fmap (second (generatorD braid) . swap . graph resolution) (S.toList . toSet $ gens) + +-- | Diagram for a single `Generator` -- mostly exists to be called by `bigGeneratorD`. +generatorD :: Braid -> Generator -> Diagram B +generatorD b gen = markComponents (signs gen) flatDiagram + where + flatDiagram = resolveClosureD (resolution gen) b :: Diagram B + markComponents :: M.Map Component Sign -> Diagram B -> Diagram B + markComponents theSigns diag = compose (M.elems (M.mapWithKey (markIn diag) theSigns)) diag + +-- | Marks a component of diagram. +markIn :: Diagram B -> Component -> Sign -> (Diagram B -> Diagram B) +markIn diag comp s = withName myNameIsMyName $ atop . place (circle 0.1 # fc purple) . location + where + possibleJoins = toName . NameNode . uncurry Join <$> cartesian (S.toList comp) (S.toList comp) + myNameIsMyName = fromMaybe (toName (NameNode (Join 1 1 :: Node Int))) + (find (`elem` possibleJoins) (fmap fst (names diag))) diff --git a/src/Braids.hs b/src/Braids.hs new file mode 100644 --- /dev/null +++ b/src/Braids.hs @@ -0,0 +1,143 @@ +{-| +Module : Braids +Description : All the topology is here. +Copyright : Adam Saltz +License : BSD3 +Maintainer : saltz.adam@gmail.com +Stability : experimental + +Longer description to come. +-} +{-# LANGUAGE FlexibleInstances, DataKinds, DeriveFoldable, DeriveDataTypeable #-} +module Braids +( Braid(..), + Node(..), + Resolution, + Component, + BDiagram(..), + braidToPD, + crossingToNodes, + resolve, + resolutions, + resolutionToComponents, + cubeOfResolutions, + braidCube, + mirror, + allRes +) +where +import Data.Graph as Graph +import Data.List +import Data.Tree as Tree +import Data.Typeable (Typeable) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Foldable as F + +-- | A 'Braid' is a width and word. +-- Integers in the word represent Artin generators and their invereses. E.g. @[1,3,-2]@ represents the word \sigma_1\sigma_3\sigma_2^{-1}. +data Braid = Braid { braidWidth :: Int + , braidWord :: [Int]} + deriving (Eq, Show, Read) + +-- | Returns the mirror of @b@. +mirror :: Braid -> Braid +mirror b = Braid {braidWidth = braidWidth b, + braidWord = mirror' (braidWord b) } where + mirror' :: [Int] -> [Int] + mirror' = fmap (* (-1)) . reverse + +-- | A braid can also be written as a collection of 'Node's. See knotatlas for more info on 'Cross' and 'Join'. +data Node a = Cross a a a a | Join a a + deriving (Show, Read, Ord, F.Foldable, Typeable, Eq) + +-- | A 'PD' (Planar BDiagram) is a collection of 'Node's. +type PD = [Node Int] + +-- | A 'Resolution' is a collection of integers. These should all be 0 or 1. At some point I will change this to +-- @type Resolution = [Resolution']@ and @data Resolution' = One | Zero deriving (Show, Eq, Ord)@ or somesuch. +type Resolution = [Int] -- change to [Resolution'] + +-- | A `Component` is represented by a set of integer labels for its arcs. +type Component = Set Int + +-- | A resolved 'BDiagram' has a 'Resolution' and a set of 'Component's. +data BDiagram = BDiagram { resolution' :: Resolution + , components' :: Set Component} + deriving (Eq, Show) + +-- | Turn a 'Braid' into a 'PD'. +braidToPD :: Braid -> PD +braidToPD braid = concat [crossingToNodes c (braidWidth braid) d | (c,d) <- zip word [1..]] + ++ [Join a (a + len * braidWidth braid) | a<-[1..(braidWidth braid)]] + where + word = braidWord braid + len = length . braidWord $ braid + +-- | Turn a crossing into a 'Node'. +crossingToNodes :: Int -> Int -> Int -> [Node Int] +crossingToNodes crossing width level = concatMap toNode [initial..(initial + width - 1)] where + initial = 1 + (level - 1)*width + --range = [initial..(initial + width - 1)] + cAfter = abs crossing + initial - 1 + toNode :: Int -> [Node Int] + toNode k | k == cAfter && crossing < 0 = [Cross (k+1) k (k + width) (k + width + 1)] + toNode k | k == cAfter && crossing > 0 = [Cross k (k + width) (k + width + 1) (k+1)] + toNode k | k == cAfter + 1 = [] + toNode k | otherwise = [Join k (k + width)] + +isCross :: Node Int -> Bool +isCross n = case n of + Cross{} -> True + Join{} -> False + +-- | Utility function to return all the resolutions of a planar diagram. This amounts to all sequences of 0s and 1s of some length. +allRes :: PD -> [Resolution] +allRes pd = sequence binary where + binary = replicate (length $ filter isCross pd) [0,1] + +-- | Take a 'PD' and a 'Resolution' and returns the resolved 'PD'. +-- Note that the output is always a list of 'Join's. +resolve :: PD -> Resolution -> PD +resolve (Join a b : ns ) res = Join a b : resolve ns res +resolve (Cross a b c d:ns) (r:res) | r == 0 = [Join a b, Join c d] ++ resolve ns res + | r == 1 = [Join a d, Join b c] ++ resolve ns res +resolve [] _ = [] +resolve x _ = x + +-- | Compute all resolutions of a 'PD'. +resolutions :: PD -> [PD] +resolutions pd = map (($ pd) . flip resolve) (allRes pd) + +-- | This is the only use for "Data.Graph". +resolutionToComponents :: PD -> Set Component +resolutionToComponents pd = Set.fromList . fmap Set.fromList . map (sort . Tree.flatten) $ Graph.components resAsGraph where + graphAsList = [(v,vs) | v <- allArcs pd, vs <- delete v $ allArcs $ connectedTo v pd] + resAsGraph = Graph.buildG (minArc pd, maxArc pd) graphAsList + + maxArc :: PD -> Int + maxArc [] = 0 + maxArc pd' = maximum $ map F.maximum pd' where + + minArc :: PD -> Int + minArc [] = 0 + minArc pd' = minimum $ map F.minimum pd' where + + allArcs :: [Node Int] -> [Int] + allArcs = nub . concatMap F.toList + + connectedTo :: Int -> [Node Int] -> [Node Int] + connectedTo a' = filter (a' `F.elem`) where + + +-- | Take a 'PD' and returns a list of all the 'BDiagram's of its 'Resolution's. +cubeOfResolutions :: PD -> [BDiagram] +cubeOfResolutions pd = [BDiagram {resolution' = res, components' = comps res} | res <- allRes pd] where + comps res = resolutionToComponents $ resolve pd res + +-- | The total cube of resolutions for a braid. +braidCube :: Braid -> [BDiagram] +braidCube b = do + res <- allRes . braidToPD $ b + let diagram res' = resolutionToComponents . resolve (braidToPD b) $ res' + return BDiagram {resolution' = res, components' = diagram res} diff --git a/src/Cancellation.hs b/src/Cancellation.hs new file mode 100644 --- /dev/null +++ b/src/Cancellation.hs @@ -0,0 +1,104 @@ +{-| +Module : Cancellation +Description : Implements the "cancellation lemma". Most of the work to compute kappa is here. +Copyright : Adam Saltz +License : BSD3 +Maintainer : saltz.adam@gmail.com +Stability : experimental + +Longer description to come. +-} + +module Cancellation +( kFilteredMorphisms, + whoHasPsi, + kWhoHasPsi, + psiKillers, + kPsiKillers, + cancelKey, + kSimplify, + kSimplifyComplex, + kDoesPsiVanish + ) +where +import Complex +import Util +import Kh +import Data.Set (member, Set) +import qualified Data.Set as S +import Data.Map.Strict ((!), mapWithKey, keys) +import qualified Data.Map as M + +-- | Return the complex simplified at (g,g') +simplifyEdgeGraph :: (AlgGen, AlgGen) -> Morphisms -> Morphisms +simplifyEdgeGraph (g,g') mors = addMod2Map (changeBasis g newArrows) + . changeBasis g + . deleteEdge (g,g') + $ mors where + fromG = S.delete g' $ mors ! g :: Set AlgGen + toG' = S.fromList . M.keys . M.delete g . M.filter (S.member g') $ mors :: Set AlgGen + newArrows = M.fromListWith addMod2Set (toG' `fromTo` fromG) :: Morphisms + deleteEdge :: (AlgGen, AlgGen) -> Morphisms -> Morphisms + deleteEdge (h,h') mors' = fmap (S.delete h) + . M.delete h + . fmap (S.delete h') + . M.delete h' + $ mors' :: Morphisms + changeBasis x = compose (fmap (addToKey x) (S.toList toG')) + +-- | Compute all morphisms which change the k-grading by less than k. +kFilteredMorphisms :: Int -> Morphisms -> Morphisms +kFilteredMorphisms k mors = M.filter (not . S.null) + . mapWithKey (\g x -> S.filter (\y -> kDrop' g y <= k) x) + $ mors + +-- | Compute all 'Generator's which map to psi'. +whoHasPsi :: AlgGen -> Morphisms -> Set AlgGen +whoHasPsi psi' mors = S.fromList + . filter (\g -> psi' `member` (mors ! g)) $ keys mors + +-- | Compute all 'Generator's which map to psi' with 'kDrop' less than k. +-- (I've tried to stick to this pattern throughout: the k-version of a function just filters by kDrop.) +kWhoHasPsi :: Int -> AlgGen -> Morphisms -> Set AlgGen +kWhoHasPsi k psi' = S.filter (\g -> kgrade' g <= kgrade' psi' + k) + . whoHasPsi psi' + +-- | 'True' if and only if the 'Generator' is the source of a single arrow. +soloArrow :: AlgGen -> Morphisms -> Bool +soloArrow g mors = S.size (mors ! g) == 1 + +-- | Determine which generators have single arrows to psi'. +psiKillers :: AlgGen -> Morphisms -> Set AlgGen +psiKillers psi' mors = S.filter (`soloArrow` mors) . whoHasPsi psi' $ mors + +-- | Same as `psiKillers` but only checks for arrows which shift the filtration by @k@ or less. +kPsiKillers :: Int -> AlgGen -> Morphisms -> Set AlgGen +kPsiKillers k psi' = S.filter (\g -> kgrade' g <= kgrade' psi' + k) . psiKillers psi' + +-- | Cancel g in mors while dodging psi'. +cancelKey :: AlgGen -> Morphisms -> AlgGen -> Morphisms +cancelKey psi' mors g = let targets' = M.lookup g mors in + case targets' of + Nothing -> mors + Just targets -> if S.null targets || targets == S.singleton psi' + then mors + else simplifyEdgeGraph (g, head . S.toList . S.delete psi' $ targets) mors + +-- | Simplify the complex at filtration k while dodging psi' +-- Uses the Writer monad to keep track of what's canceled (but that information isn't used, presently) +kSimplify :: Int -> AlgGen -> Morphisms -> Morphisms +kSimplify k psi' mors | null . kWhoHasPsi k psi' $ mors = mors + | kWhoHasPsi k psi' mors == kPsiKillers k psi' mors = mors + | otherwise = kSimplify k psi' mors' where + g = head . S.toList $ (kWhoHasPsi k psi' mors S.\\ kPsiKillers k psi' mors) + mors' = cancelKey psi' mors g + +-- | Simplify the complex up to filtration k while dodging psi'. +kSimplifyComplex :: Int -> AlgGen -> Morphisms -> Morphisms +kSimplifyComplex k psi' mors = foldl (\mor k' -> kSimplify k' psi' mor) mors [0,2..k] where + +-- | Test whether psi' dies at filtration k. +kDoesPsiVanish :: Int -> AlgGen -> Morphisms -> Bool +kDoesPsiVanish k psi' mors = any (`soloArrow` mors) . S.filter rightK . whoHasPsi psi' $ mors where + rightK g = kgrade' g - kgrade' psi' <= k + diff --git a/src/Complex.hs b/src/Complex.hs new file mode 100644 --- /dev/null +++ b/src/Complex.hs @@ -0,0 +1,91 @@ +{-| +Module : Complex +Description : Mod 2 vector space. +Copyright : Adam Saltz +License : BSD3 +Maintainer : saltz.adam@gmail.com +Stability : experimental + +Longer description to come. +-} + +module Complex +( Generator(..), + Sign(..), + signToNum, + AlgGen(..), + wrapGen, + toSet, + Morphisms, + addMod2, + addMod2Set, + addMod2Map, + addToKey, + fromTo ) +where +import Braids +import Data.Set (Set) +import qualified Data.Set as S +import Data.Map (Map, (!)) +import qualified Data.Map as M +import Data.Monoid + +{- | A 'Generator' is a 'Set' of 'Components' labled with 'Sign's. Strictly speaking, we could make do + without components, as @components = Data.Set.fromList . Data.Map.keys $ signs@. + kgrade depends totally on signs, so it should be taken out too. -} + +data Generator = Generator { resolution :: Resolution + , components :: Set Component + , signs :: Map Component Sign + , kgrade :: Int} + deriving (Eq, Ord, Show) + + +-- | These stand for v_+ and v_- in Khovanov homology. We could include some more algebra here, but +-- | for now I don't see a reason to. +data Sign = Plus | Minus deriving (Eq, Show, Ord) + +signToNum :: Sign -> Int +signToNum Plus = 1 +signToNum Minus = (-1) + +-- | Stands for sums of generators modulo 2. 'wrapGen' wraps a single generator. +-- | Should be a type synonym instead? +-- | This is something like an implementation of mod 2 vector spaces. Could this be done better with vector-spaces or linear? +newtype AlgGen = AlgGen (Set Generator) deriving (Show, Ord, Eq) + +wrapGen :: Generator -> AlgGen +wrapGen = AlgGen . S.singleton + +toSet :: AlgGen -> Set Generator +toSet (AlgGen s) = s + +instance Monoid AlgGen where + mempty = AlgGen S.empty + mappend (AlgGen s) (AlgGen s') = AlgGen (addMod2Set s s') + +-- | 'Morphisms' is a map from (a linear combination of) 'Generator's to a set of (linear combinations of) 'Generator's. +type Morphisms = Map AlgGen (Set AlgGen) + +-- | Generates all arrows from elements of @s@ to elements of @s'@ with the latter wrapped as singleton `Set`s. +-- This is purely algebraic -- the function doesn't check if their ought to be any such arrows. +fromTo :: Set AlgGen -> Set AlgGen -> [(AlgGen, Set AlgGen)] +fromTo s s' = [(x,S.singleton y) | x <- S.toList s, y <- S.toList s'] + +-- | The next three functions implement mod 2 addition at the level of 'Set's and 'Map's. +addMod2 :: (Eq a, Ord a) => a -> Set a -> Set a +addMod2 b set = if S.member b set then S.delete b set else S.insert b set + +addMod2Set :: (Eq a, Ord a) => Set a -> Set a -> Set a +addMod2Set bs set = S.foldr addMod2 set bs + +addMod2Map :: (Ord a, Ord k) => Map k (Set a) -> Map k (Set a) -> Map k (Set a) +addMod2Map x y = M.filter (not . S.null) (M.unionWith addMod2Set x y) + +-- | Adds a x to the key key (but only if key is a key of mors). +addToKey :: (Ord k, Monoid k, Monoid a) => k -> k -> Map k a -> Map k a +addToKey x key mors = if key `M.member` mors + then M.insert (x <> key) (mors ! key) + . M.delete key + $ mors + else mors diff --git a/src/ExampleBraids.hs b/src/ExampleBraids.hs new file mode 100644 --- /dev/null +++ b/src/ExampleBraids.hs @@ -0,0 +1,13 @@ +module ExampleBraids +where +import Braids + +-- | Construct a family of braids from . This will fail if either input is negative. +ngkLeft :: (Int, Int) -> Braid +ngkRight (a, b) = Braid {braidWord = [3,-2,-2] ++ replicate (2 + 2*a) 3 ++ [2,-3,-1,2] ++ replicate (2 + 2*b) 1 + , braidWidth = 4} + +ngkRight :: (Int, Int) -> Braid +ngkLeft (a, b) = Braid {braidWord = [3,-2,-2] ++ replicate (2 + 2*a) 3 ++ [2,-3] ++ replicate (2 + 2*b) 1 ++ [2,-1] + , braidWidth = 4} + diff --git a/src/Kappa.hs b/src/Kappa.hs new file mode 100644 --- /dev/null +++ b/src/Kappa.hs @@ -0,0 +1,71 @@ +{-| +Module : Kappa +Description : Functions to compute kappa. +Copyright : Adam Saltz +License : BSD3 +Maintainer : saltz.adam@gmail.com +Stability : experimental + +Longer description to come. +-} + +module Kappa +where +import Cancellation +import Kh +import Complex +import Braids + +import Data.Map (Map, (!)) +import qualified Data.Map as M +import Data.Set (Set) +import qualified Data.Set as S +import Control.Arrow (second) +import Data.List (find) + +-- | Return @(Maybe kappa, Maybe the simplified complex)@. +computeKappa' :: Braid -> Maybe (Int, Morphisms) +computeKappa' braid = fmap (second (M.filter ((S.singleton . wrapGen . psi $ braid) ==))) + . find (\(k, c) -> kDoesPsiVanish k psi' c) + $ fmap (\k -> (k, kSimplifyComplex k psi' morphisms )) [0,2..2*braidWidth braid] where + morphisms = M.unionsWith S.union . fmap (filteredComplexLevel (2*braidWidth braid) gens) $ [0..(1 + length (braidWord braid))] :: Morphisms + gens = khovanovComplex (braidWidth braid) (psiCube braid) :: Map Int (Set Generator) + psi' = wrapGen (psi braid) :: AlgGen + +-- | Returns @Just kappa@ if kappa is finite. Otherwise, returns @Nothing@. +computeKappa :: Braid -> Maybe Int +computeKappa braid = case computeKappa' braid of + Nothing -> Nothing + Just (kap, _) -> Just kap +{- +computeReducedKappa :: Braid -> Int -> (Maybe Int, Maybe (Writer Cancellations Morphisms)) +computeReducedKappa braid m = maybeTuple + . find (\(k, c) -> isKappaK k psi' . fst . runWriter $ c) + $ map (\k -> (k, kSimplifyComplex k psi' morphisms )) [0,2..2*braidWidth braid] where + morphisms = M.unionsWith S.union . fmap (filteredComplexLevel (2*braidWidth braid) gens) $ [0..(1 + length (braidWord braid))] + gens = reducedKhovanovComplex m (braidWidth braid) (psiCube braid) + psi' = psi braid + +computeQuotientKappa :: Braid -> Int -> (Maybe Int, Maybe (Writer Cancellations Morphisms)) +computeQuotientKappa braid m = first (fmap (+2)) . maybeTuple + . find (\(k, c) -> isKappaK k psi' . fst . runWriter $ c) + $ map (\k -> (k, kSimplifyComplex k psi' morphisms )) [0,2..2*braidWidth braid] where + morphisms = M.unionsWith S.union . fmap (filteredComplexLevel (2*braidWidth braid) gens) $ [0..(1 + length (braidWord braid))] + gens = quotientKhovanovComplex m (braidWidth braid) (psiCube braid) + psi' = quotPsi braid m + +computeKappaNum :: Braid -> Maybe Int +computeKappaNum = fst . computeKappa + +computeReducedKappaNum :: Braid -> Int -> Maybe Int +computeReducedKappaNum b m = fst $ computeReducedKappa b m + +computeQuotientKappaNum :: Braid -> Int -> Maybe Int +computeQuotientKappaNum b m = fst $ computeQuotientKappa b m + +computeKappaComplex :: Braid -> Maybe (Writer Cancellations Morphisms) +computeKappaComplex = snd . computeKappa + +wordProblem :: Braid -> Bool +wordProblem b = (computeKappaNum b == Just 2) && (computeKappaNum (mirror b) == Just 2) +-} diff --git a/src/Kh.hs b/src/Kh.hs new file mode 100644 --- /dev/null +++ b/src/Kh.hs @@ -0,0 +1,192 @@ +{-| +Module : Kh +Description : Implements the Khovanov "functor". +Copyright : Adam Saltz +License : BSD3 +Maintainer : saltz.adam@gmail.com +Stability : experimental + +Longer description to come. +-} +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 + +-- | Return the diagram underlying a 'Generator'. +gToD :: Generator -> BDiagram +gToD g = BDiagram {resolution' = resolution g, components' = components g} + +-- | Compute the homological grading of a 'Generator'. +homGrading :: Generator -> Int +homGrading gen = sum . resolution $ gen + +-- | Compute the q-grading of a 'Generator'. In this convention, the Khovanov differential *lowers* the q-grading by 1. +qGrading :: Generator -> Int +qGrading gen = sum . fmap signToNum . signs $ gen where + +-- | Data type to represent whether a circle is trivial or not. Used to be Bool' but I got confused about which was @True@ and which was @False@. +data Triviality = Trivial | NonTrivial deriving (Ord, Eq, Show) + +{- | Determine if a component is non-trivial. + To compute the mod 2 winding number about the braid axis, check how many of the \'top arcs\' live in a component. -} +nonTrivialCircle :: Int -> Component -> Triviality +nonTrivialCircle width arcs = if odd $ length (filter (`elem` [1..width]) (S.toList arcs)) + then NonTrivial + else Trivial + +-- | Compute the k-grading of a 'Generator'. +kGrading :: (Resolution, Set Component, Map Component Sign) -> Int -> Int +kGrading (_,_,ss) width = ks ! NonTrivial where + ks = M.mapKeysWith (+) (nonTrivialCircle width) . fmap signToNum $ ss + +{- | "Apply the filtered Khovanov functor to a diagram." + We still need the braid width as input to get the k-grading. -} +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] -- this is a slick and dumb way of making sequences of (-1) and 1 +{- +-- | Returns the sign at mark. +markedSign :: Int -> Generator -> Int +markedSign mark gen = case findIndex (elem mark) (components gen) of + Just x -> (!!) (signs gen) x + Nothing -> -1 -- should thrown a exception + + +-- | "Apply the reduced Khovanov functor to a diagram" +reducedKhovanov :: Int -> Int -> BDiagram -> [Generator] +reducedKhovanov mark width cube = filter (\g -> (-1) == markedSign mark g) (khovanov width cube) + +-- | "Apply the quotient Khovanov functor to a diagram" +quotientKhovanov :: Int -> Int -> BDiagram -> [Generator] +quotientKhovanov mark width cube = filter (\g -> (1) == markedSign mark g) (khovanov width cube) +-} + +-- | The next three functions apply the Khovanov functor to the vertices of a cube of resolutions. +khovanovComplex :: Int -> [BDiagram] -> Map Int (Set Generator) +khovanovComplex width cube = M.fromListWith S.union [(homGrading g, S.singleton g) | g <- concatMap (khovanov width) cube] +{- +reducedKhovanovComplex :: Int -> Int -> [BDiagram] -> Map Int (Set Generator) +reducedKhovanovComplex mark width cube = M.fromListWith S.union [(homGrading g, S.singleton g) | g <- concatMap (reducedKhovanov mark width) cube] + +quotientKhovanovComplex :: Int -> Int -> [BDiagram] -> Map Int (Set Generator) +quotientKhovanovComplex mark width cube = M.fromListWith S.union [(homGrading g, S.singleton g) | g <- concatMap (quotientKhovanov mark width) cube] +-} +-- | An elementary morphism is determined by 'Components'. We distinguish between 'Merge' and 'Split' 'ElMo's +data ElMo -- | elementary morphisms. The abbreviation is borrowed from Milatz. + = Merge (Set Component) (Set Component) -- ^ merges the first set to the second + | Split (Set Component) (Set Component) -- ^ splits the first set into the second + deriving (Show) + +-- | Take two diagrams and returns the 'ElMo's between them, if there is one. +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') + +-- | Take a morphism and two generators and returns @True@ if there should be a 'Morphism from one to the other. +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 + +-- | Compute the difference in k-grading between two 'Generator's. +kDrop :: Generator -> Generator -> Int +kDrop g g' = kgrade g - kgrade g' + +-- | Compute the filtration level of an 'AlgGen'. +kgrade' :: AlgGen -> Int +kgrade' (AlgGen gs) = maximum . S.map kgrade $ gs + +kDrop' :: AlgGen -> AlgGen -> Int +kDrop' gs gs' = kgrade' gs - kgrade' gs' + +-- | Like 'morphismAction', but only connects two 'Generators' if the drop in k-grading from one to the other is less than or equal to \a\. +filteredMorphismAction :: Int -> Maybe ElMo -> Generator -> Generator -> Bool +filteredMorphismAction k e g g' | kDrop g g' <= k = morphismAction e g g' + | otherwise = False + +-- | Return 'Morphisms' from the 'Generator' into the set with 'kDrop' less than or equal to \k\. +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') + +-- | Applies 'filteredMorphismsFrom' to every 'Generator' in a list into the same list. +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) + +-- | Produces the 'Generator' corresponding to the transverse invariant of a braid. +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 +{- +-- | Produces the generator corresponding to the QUOTIENT transverse invariant of a braid +quotPsi :: Braid -> Int -> Generator +quotPsi b p = 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 + Just c = findIndex (elem p) comps + ss = uncurry (++) . second (\xs -> 1:xs) . second tail . splitAt c $ replicate (length comps)(-1) + k = kGrading (res, comps, ss) (braidWidth b) +-} +{- |Produces the portion of the cube of resolutions of a braid which is relevant for computing kappa. + This means only using resolutions whose weights are less than or equal to psi's. + Note that this only uses the homological grading of psi, so we don't need a separate function for the quotient. -} +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} diff --git a/src/Parse.hs b/src/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Parse.hs @@ -0,0 +1,55 @@ +{-| +Module : Parse +Description : Reads commandline input and prints Morphisms nicely. +Copyright : Adam Saltz +License : BSD3 +Maintainer : saltz.adam@gmail.com +Stability : experimental + +Longer description to come. +-} + +module Parse +where +import Braids +import Complex +import Kh + +import qualified Data.Map as M (toList) +import Data.Set (Set) +import qualified Data.Set as S (toList) +import Data.List (sortBy) +import Data.List.Split (splitOneOf) + +-- | Parse command line input into a braid. +-- | e.g. @Parse "[1,2,-2,-3] 4" == Braid [1,2,-2,-3] 4f +parse :: [String] -> Braid +parse input = braid where + braid = Braid {braidWord = parseWord word, braidWidth = width} + parseWord = fmap (read :: String -> Int) . filter (not . null) . splitOneOf ",][" + (word, width) = (input !! 0, read $ input !! 1 :: Int) + +-- | Prints kappa in a nice way. +showKappa' :: Maybe (Int, Morphisms) -> [String] +showKappa' s = case s of + Nothing -> ["Psi doesn't vanish!"] + Just (kappa, mors) -> ("Kappa is " ++ show kappa) : showMorphisms mors + +-- | Prints Morphisms nicely. +showMorphisms :: Morphisms -> [String] +showMorphisms mors = fmap fst + . sortBy (\(i, _) (i',_) -> compare i i') + . fmap showMorphism + . M.toList + $ mors + +-- | Prints a single morphism nicely. +showMorphism :: (AlgGen, Set AlgGen) -> (String, Int) +showMorphism (gs,gs') = ( "Filtration level: " ++ show (kgrade' gs) ++ ".\n" + ++ show (S.toList . toSet $ gs) ++ "\n" + ++ "|\n" + ++ "|\n" + ++ "|\n" + ++ "V\n" + ++ show (S.toList gs') ++ "\n\n" + , kgrade' gs) diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,37 @@ +module Util +where +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Foldable as Foldable +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.List as List + +deleteAt :: Int -> [a] -> [a] +deleteAt i xs = ys ++ tail zs where + (ys,zs) = splitAt i xs + +maybeTuple :: Maybe (a,b) -> (Maybe a, Maybe b) +maybeTuple (Just (a,b)) = (Just a, Just b) +maybeTuple Nothing = (Nothing, Nothing) + +compose :: [(a -> a)] -> (a -> a) +compose = foldr (.) id + +graph :: (a -> b) -> a -> (a,b) +graph f x = (x, f x) + +isNotASubsetOf :: Ord k => Set k -> Set k -> Bool +isNotASubsetOf s s' = not (Set.isSubsetOf s s') + +getSubmap :: (Ord k, Foldable f) => Map k a -> f k -> Map k a +getSubmap theMap theKeys = Map.fromList $ graph (theMap Map.!) <$> List.nub (Foldable.toList theKeys) + +deleteKeys :: (Ord k, Foldable f) => Map k a -> f k -> Map k a +deleteKeys theMap theKeys = compose (Map.delete <$> List.nub (Foldable.toList theKeys)) theMap + +cartesian :: [a] -> [b] -> [(a,b)] +cartesian xs ys = [(x,y) | x <- xs, y <- ys] + +exp :: Monoid a => a -> Int -> a +exp x n = mconcat (replicate n x)