{-| 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}