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
data Braid = Braid { braidWidth :: Int
, braidWord :: [Int]}
deriving (Eq, Show, Read)
mirror :: Braid -> Braid
mirror b = Braid {braidWidth = braidWidth b,
braidWord = mirror' (braidWord b) } where
mirror' :: [Int] -> [Int]
mirror' = fmap (* (1)) . reverse
data Node a = Cross a a a a | Join a a
deriving (Show, Read, Ord, F.Foldable, Typeable, Eq)
type PD = [Node Int]
type Resolution = [Int]
type Component = Set Int
data BDiagram = BDiagram { resolution' :: Resolution
, components' :: Set Component}
deriving (Eq, Show)
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
crossingToNodes :: Int -> Int -> Int -> [Node Int]
crossingToNodes crossing width level = concatMap toNode [initial..(initial + width 1)] where
initial = 1 + (level 1)*width
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
allRes :: PD -> [Resolution]
allRes pd = sequence binary where
binary = replicate (length $ filter isCross pd) [0,1]
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
resolutions :: PD -> [PD]
resolutions pd = map (($ pd) . flip resolve) (allRes pd)
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
cubeOfResolutions :: PD -> [BDiagram]
cubeOfResolutions pd = [BDiagram {resolution' = res, components' = comps res} | res <- allRes pd] where
comps res = resolutionToComponents $ resolve pd res
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}