braid (empty) → 0.1.0.0
raw patch · 13 files changed
+1060/−0 lines, 13 filesdep +basedep +containersdep +diagrams-contribsetup-changed
Dependencies added: base, containers, diagrams-contrib, diagrams-core, diagrams-lib, diagrams-svg, split
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- app/KappaView.hs +36/−0
- braid.cabal +69/−0
- src/Braiddiagrams.hs +217/−0
- src/Braids.hs +143/−0
- src/Cancellation.hs +104/−0
- src/Complex.hs +91/−0
- src/ExampleBraids.hs +13/−0
- src/Kappa.hs +71/−0
- src/Kh.hs +192/−0
- src/Parse.hs +55/−0
- src/Util.hs +37/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/KappaView.hs view
@@ -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
+ braid.cabal view
@@ -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+
+ src/Braiddiagrams.hs view
@@ -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)))
+ src/Braids.hs view
@@ -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}
+ src/Cancellation.hs view
@@ -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 +
+ src/Complex.hs view
@@ -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
+ src/ExampleBraids.hs view
@@ -0,0 +1,13 @@+module ExampleBraids+where+import Braids++-- | Construct a family of braids from <Ng and Khandawit's paper http://www.math.duke.edu/~ng/math/papers/nonsimple.pdf>. 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}+
+ src/Kappa.hs view
@@ -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) +-}
+ src/Kh.hs view
@@ -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}
+ src/Parse.hs view
@@ -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)
+ src/Util.hs view
@@ -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)