-- (c) 2010 by Daneel S. Yaitskov -- | Graph embedding algorithm is based on one of a graph planarity testing which -- described in the book \"Graph Drawing. Algorithms for the Visualization of Graphs\". -- Its authors are Giuseppe Di Battista, Peter Eades, Roberto Tamassia and Ioannis G. Tollis. module Data.Graph.Embedding (embedGraph,embedDiGraph) where import qualified Data.Set as Set import qualified Data.Map as Map import Data.List (partition, sortBy, union, foldl', (\\), sort, find, nub) import Data.Maybe (fromJust,isJust) import Data.Graph.SimpleUtil (takeAfter, takeBefore, map2, apa) import Control.Monad.State (get, put, execState,State) import Data.Graph.InductivePlus import Data.Graph.Analysis.Algorithms data EdgeLabel = StubLabel | FreeEdge EdgeLabel | FixedEdge EdgeLabel | PieceOrder (Maybe PieceId) Int EdgeLabel deriving (Show, Eq) isFreeELabel (FixedEdge _) = False isFreeELabel _ = True lastNumLabel (FixedEdge rest) = lastNumLabel rest lastNumLabel (FreeEdge rest ) = lastNumLabel rest lastNumLabel StubLabel = Nothing lastNumLabel (PieceOrder _ n _) = Just n continueLabel mayPid pos lbl@(FixedEdge rest) = error $ "continueLabel: try to continue fixed edge label\npos = " ++ show pos ++ "\nlbl = " ++ show lbl continueLabel mayPid pos lbl@(FreeEdge rest) = FreeEdge $ PieceOrder mayPid pos rest continueLabel mayPid pos lbl = FreeEdge $ PieceOrder mayPid pos lbl fixELabel mayPid pos lbl = case continueLabel mayPid pos lbl of FreeEdge lbl -> FixedEdge lbl StubLabel -> FixedEdge StubLabel _ -> error "fixELabel: COOL!" edgeLabelToList StubLabel = [] edgeLabelToList lbl@(FreeEdge _) = error $ "edgeLabelToList: convertation is impossible cause the edge label is free: " ++ show lbl edgeLabelToList (FixedEdge rest) = reverse $ edgeLabelToList rest edgeLabelToList (PieceOrder _ pos rest) = pos : edgeLabelToList rest instance Ord EdgeLabel where compare l1 l2 = let (ll1,ll2) = map2 edgeLabelToList (l1,l2) in compare ll1 ll2 type MyInGr = Gr () EdgeLabel data OldC = OldC { oldCAsSet :: Set.Set Node, oldCAsList :: [ Node ] } deriving (Show, Eq) data C = C { cAsList :: [ Node ], cAsSet :: Set.Set Node, oldCC :: Maybe OldC } deriving (Show,Eq) hasOldC c = isJust $ oldCC c newC c = C { cAsList = c, cAsSet = Set.fromList c, oldCC = Nothing } data Side = Inside | Outside deriving (Show,Eq) notSide Inside = Outside notSide Outside = Inside type LegOfPiece = Set.Set Node {- ws \not \in C -} data Piece = Piece { pieceAsSubgraph :: MyInGr, nodesAlsoInC :: Set.Set Node, sideOfpiece :: Side, legsOfpiece :: Map.Map Node {- v \in C -} LegOfPiece } deriving (Show,Eq) instance Ord Piece where p1 > p2 = (sort . edges $ pieceAsSubgraph p1) > (sort . edges $ pieceAsSubgraph p2) p1 < p2 = (sort . edges $ pieceAsSubgraph p1) < (sort . edges $ pieceAsSubgraph p2) p1 >= p2 = p1 > p2 || p1 == p2 p1 <= p2 = p1 < p2 || p1 == p2 type Pieces = [ Piece ] type PieceId = Int type MapPieces = Map.Map PieceId Piece type EdgeMapPiece = Map.Map (Node{- v \in C -},Node {- w \not \in C -}) PieceId type VertexMapPiece = Map.Map Node (Set.Set PieceId) emptyPiece = Piece { pieceAsSubgraph = buildGr [], nodesAlsoInC = Set.empty, sideOfpiece = Inside, legsOfpiece = Map.empty } {-| The 'embedGraph' function embeds a planar biconnected undirected graph into a plane. Edge's label of an embedded graph is a position of the edge in its source node. In undirected graph each edge is presented a pair of directed edges. Therefore it's enough each edge keeps only its position in the source node. -} embedGraph :: Gr a b -> Gr a Int embedGraph g = let ug = nmap (\_ -> () ) $ emap (\_ -> StubLabel) g firstC = snd . head . filter (\x -> fst x > 2 ) . map (\xc -> (length xc, xc) ) $ cyclesIn' ug c = newC firstC in extractGraph g $ execState (embedWithC c Nothing Nothing Nothing) ug {-| The 'embedDiGraph' function embeds a planar directed graph into a plane. The source graph must be biconnected if throw off edges' directions and also any two nodes v and w can have either edge (v,w) or (w,v) but not both. Edge's label of an embedded graph consists of a pair integers. First element is a position of the edge in its source node and second one is a position of the edge in its destination node. -} embedDiGraph :: Gr a b -> Gr a (Int,Int) embedDiGraph g = let ug = nmap (\_ -> () ) $ emap (\_ -> StubLabel) g ulg = undir ug firstC = snd . head . filter (\x -> fst x > 2 ) . map (\xc -> (length xc, xc) ) $ cyclesIn' ulg c = newC firstC in orientGraph g $ execState (embedWithC c Nothing Nothing Nothing) ulg embedWithC :: C -> Maybe VertexMapPiece -> Maybe EdgeMapPiece -> Maybe MapPieces -> State MyInGr () embedWithC c oldVmp oldEmp oldMp = do g <- get let mp = fst $ findPiecesWithC c g emp = makeEMP mp vmp = makeVMP mp groupedMP = groupPieces c mp g (fromJust oldMp) (fromJust oldVmp) (fromJust oldEmp) (g', mp') = foldr (\vinc (g,mp) -> orderEdgesOfNode vinc c g mp vmp emp oldEmp oldMp) (g,groupedMP) $ cAsList c (pathPieces,otherPieces) = Map.partition isPath mp' g'' = Map.foldWithKey orderPathPiece g' pathPieces cg0 = delNodes (nodes g'' \\ cAsList c) g'' cg = Map.fold (\p cg -> case Set.toList $ nodesAlsoInC p of [a,b] -> delEdges [ (a,b), (b,a) ] cg _ -> cg ) cg0 pathPieces lstOtherPieces = map snd $ Map.toList otherPieces in put g'' >> mapM_ (\p_i -> get >>= \gx -> let p = mergeTwoGraphs cg $ pieceAsSubgraph p_i c' = genNextC c p_i in do put p embedWithC c' (Just vmp) (Just emp) (Just mp' ) p' <- get put $ patchEdgesGraph gx p' p_i ) lstOtherPieces isPath p = let subg = pieceAsSubgraph p outN = nodesAlsoInC p pre v = outdeg subg v == 1 [ firstOut, secondOut ] = Set.toList outN numEqDeg2 = foldr (\v n -> if outdeg subg v == 2 then n + 1 else n) 0 $ nodes subg in Set.size outN == 2 && pre firstOut && pre secondOut && numEqDeg2 == length (nodes subg) - 2 findPiecesWithC :: C -> MyInGr -> ( MapPieces, MyInGr ) findPiecesWithC c g = let findPiece' v s@(mapPieces, g, freePID) = let subgOfv = buildGr [ ([], v, (), []) ] newp = emptyPiece { pieceAsSubgraph = subgOfv } (newPiece, g') = execState (findPiece v c) ( newp, g ) in if v `gelem` g then (Map.insert freePID newPiece mapPieces, g', freePID + 1) else s allNeighbours = foldr (\vinc an -> an `union` neighboursOfCV vinc ) [] $ cAsList c neighboursOfCV vinc = suc g vinc \\ cAsList c in findPathPiecesWithC c $ foldr findPiece' (Map.empty, g, 0) allNeighbours findPathPiecesWithC :: C -> (MapPieces, MyInGr, PieceId) -> (MapPieces, MyInGr) findPathPiecesWithC c (mp, g, freePID) = let findEdgePiece vinc (mp, g, freePID) = let wa = fromJust $ takeAfter vinc $ cAsList c wb = fromJust $ takeBefore vinc $ cAsList c edgePieces = suc g vinc \\ [wa, wb] g' = foldr (\w g -> delUEdge (vinc,w) g) g edgePieces buildPiece w (mp,freePID) = let freePID' = freePID + 1 legs = map Set.fromList [ [ w ], [ vinc ] ] subG = insEdges [ (w,vinc, getELabel (w,vinc) g), (vinc,w, getELabel (vinc,w) g) ] . insNodes [ (w,()), (vinc, ()) ] $ buildGr [] newPiece = Piece { pieceAsSubgraph = subG, nodesAlsoInC = Set.fromList [ w, vinc], sideOfpiece = Inside, legsOfpiece = Map.fromList $ zip [vinc, w] legs } in (Map.insert freePID newPiece mp, freePID') (mp',freePID') = foldr buildPiece (mp,freePID) edgePieces in (mp', g', freePID') (mp', g', _) = foldr findEdgePiece (mp, g, freePID) $ cAsList c in (mp', g') findPiece :: Node -> C -> State (Piece, MyInGr) () findPiece v c = do (p,g) <- get let nei = suc g v (inC, g') = if v `Set.member` cAsSet c then (True, g) else (False, delNode v g) p' = insertIntoPiece v c inC p nei g in if v `gelem` g then do put ( p',g') if inC then return () else mapM_ (\v -> findPiece v c ) nei else return () insertIntoPiece :: Node -> C -> Bool -> Piece -> [ Node ] -> MyInGr -> Piece insertIntoPiece v c inC p nei g = let p' = if inC then p { nodesAlsoInC = Set.insert v $ nodesAlsoInC p } else let fNei wNei legs = if wNei `Set.member` cAsSet c then case Map.lookup wNei legs of Nothing -> Map.insert wNei (Set.singleton v) legs Just leg -> Map.insert wNei (Set.insert v leg) legs else legs in p { legsOfpiece = foldr fNei (legsOfpiece p) nei } newNei = filter (\n -> not (n `gelem` pieceAsSubgraph p')) nei nei' = zip newNei $ cycle [ () ] ls = map (\(w,l) -> (v,w,l) ) $ lsuc g v lp = map (\(w,l) -> (w, v, l) ) $ lpre g v subg' = insEdges ls . insEdges lp . insNodes nei' $ pieceAsSubgraph p' in if inC then p' else p' { pieceAsSubgraph = subg' } type PieceAndS = (Bool, PieceId, Piece, [ Set.Set Node ]) groupPieces :: C -> MapPieces -> MyInGr -> MapPieces -> VertexMapPiece -> EdgeMapPiece -> MapPieces groupPieces c mp g oldMp oldVmp oldEmp = let (freePieces, fixedPieces) = Map.partition (isFreePiece c) mp (fixedInside, fixedOutside, mp') = Map.foldWithKey (detectSideOfFixedPiece oldMp oldEmp oldVmp g c) (Map.empty, Map.empty, mp) fixedPieces (fixI, fixO ) = map2 (map snd . Map.toList . Map.mapWithKey (\k p -> (True, k, p, getS p c))) (fixedInside, fixedOutside) freP = Map.mapWithKey (\k p -> (False, k, p, getS p c)) freePieces (_,_,res) = Map.foldWithKey (arrangePiece fixI fixO ) ([], [], mp') freP in res where arrangePiece :: [PieceAndS] -> [PieceAndS] -> PieceId -> PieceAndS -> ([PieceAndS], [PieceAndS], MapPieces) -> ([PieceAndS], [PieceAndS], MapPieces) arrangePiece fixedInside fixedOutside pid ps@(isFree,_,p,s) (inside, outside, mp) = let allOutside = fixedOutside ++ outside allInside = fixedInside ++ inside in case interlaced' ps fixedInside of ([],_) -> case interlaced' ps inside of ([],_) -> usualResult Inside mp (psInterIn,notInterIn) -> case interlaced' ps fixedOutside of ([],_) -> case interlaced' ps outside of ([], _) -> usualResult Outside mp (psInterOut,notInterOut) -> if any (\psiin -> any (interlaced psiin) allOutside) psInterIn then if any (\psio -> any (interlaced psio) allInside) psInterOut then errGraphIsntPlanar "psInterOut interlaced with inside and vice versa" else fixToInSide mp psInterOut notInterOut else fixToOutSide mp psInterIn notInterIn (conFixOut,_) -> if any (\psiin -> any (interlaced psiin) allOutside ) psInterIn then errGraphIsntPlanar "psInterIn interlaced with allOutside and the piece interlaced with conFixOut" else fixToOutSide mp psInterIn notInterIn (conFixIn,_) -> case interlaced' ps fixedOutside of ([],_) -> case interlaced' ps outside of ([], _) -> usualResult Outside mp (psInterOut,notInterOut) -> if any (\psio -> any (interlaced psio) allInside) psInterOut then errGraphIsntPlanar "psInterOut interlace with allInside and the piece interlace with conFixIn" else fixToInSide mp psInterOut notInterOut (conFixOut,_) -> errGraphIsntPlanar "both side consist confliting fixed pieces" where errGraphIsntPlanar msg = error ( "arrangePiece: The graph isn't a planar. " ++ "I can't arrange a piece:\n" ++ "Conflict pid " ++ show pid ++ "\npiece: " ++ show p ++ "\nMessage: " ++ msg ) setSide s mp = Map.insert pid p { sideOfpiece = s } mp usualResult side mp = case side of Inside -> ( (isFree, pid, p, s) : inside, outside, setSide side mp ) Outside -> ( inside, (isFree, pid, p, s) : outside, setSide side mp ) fixToInSide mp psInterOut notInterOut = (psInterOut ++ inside, (isFree, pid, p, s) : notInterOut, setSide Outside $ foldr (\(isFree, pid, p, s) mp -> Map.adjust (\p -> p { sideOfpiece = Inside } ) pid mp) mp psInterOut) fixToOutSide mp psInterIn notInterIn = ( (isFree, pid, p, s) : notInterIn, psInterIn ++ outside, setSide Inside $ foldr (\(isFree, pid, p, s) mp -> Map.adjust (\p -> p { sideOfpiece = Outside } ) pid mp) mp psInterIn) interlaced' :: PieceAndS -> [ PieceAndS ] -> ([ PieceAndS ],[ PieceAndS ]) interlaced' ps xside = partition (interlaced ps) xside isFreePiece c p = let outv = nodesAlsoInC p oldc = fromJust $ oldCC c cs = cAsSet c cl = cAsList c ocl = oldCAsList oldc ocs = oldCAsSet oldc gp = pieceAsSubgraph p shared = Set.toList $ ocs `Set.intersection` cs a = fromJust $ find (\v -> apa (/=) (takeAfter v) ocl cl) shared b = fromJust $ find (\v -> apa (/=) (takeBefore v) ocl cl) shared pre v = let lbls = map snd $ lsuc gp v testTP aorb = v == aorb && all isFreeELabel lbls in (v `Set.notMember` ocs) || testTP a || testTP b in if hasOldC c then all pre $ Set.toList outv else True detectSideOfFixedPiece :: MapPieces -> EdgeMapPiece -> VertexMapPiece -> MyInGr -> C -> PieceId -> Piece -> (MapPieces, MapPieces, MapPieces) -> (MapPieces, MapPieces, MapPieces) detectSideOfFixedPiece mp emp vmp g c kpid p (fixi, fixo, newMp) = let anodes = nodes $ pieceAsSubgraph p oc = fromJust $ oldCC c cs = cAsSet c cl = cAsList c ocl = oldCAsList oc ocs = oldCAsSet oc nodesInC = nodesAlsoInC p theSide = if all (`Set.member` ocs ) anodes then let [ outv1, outv2 ] = case Set.toList $ nodesAlsoInC p of [a,b] -> [a,b] _ -> error ("piece from oldc hasn't gon 2 outer vertexes\n" ++ show p ++ "\n C = " ++ show c ++ "\n G = " ++ show g ++ "\n old mp = " ++ show mp ++ "\n" ) [ piecesWithV1, piecesWithV2 ] = map (\v -> fromJust $ Map.lookup v vmp) [ outv1, outv2 ] maybePieces = piecesWithV1 `Set.union` piecesWithV2 nodesOfWantedPiece = Set.toList $ cAsSet c `Set.difference` ocs thePid = head . Set.toList $ Set.filter (\pid -> let p = fromJust $ Map.lookup pid mp gofp = pieceAsSubgraph p in all (`gelem` gofp) nodesOfWantedPiece ) maybePieces theP = fromJust $ Map.lookup thePid mp in notSide $ sideOfpiece theP else let outv = head . Set.toList $ nodesAlsoInC p `Set.intersection` ocs neiOutV = head . Set.toList . fromJust . Map.lookup outv $ legsOfpiece p thePid = fromJust $ Map.lookup (outv, neiOutV) emp -- emp is old emp piece = fromJust $ Map.lookup thePid mp -- mp is old mp in sideOfpiece piece setS p = p { sideOfpiece = theSide } p' = setS p in case theSide of Inside -> (Map.insert kpid p' fixi, fixo, Map.adjust setS kpid newMp) Outside -> (fixi, Map.insert kpid p' fixo, Map.adjust setS kpid newMp) interlaced :: PieceAndS -> PieceAndS -> Bool interlaced (_,_,p1,s1) (_,_,p2,s2) = let a1 = nodesAlsoInC p1 in all (\subs2 -> a1 `Set.intersection` subs2 /= a1 ) s2 getS :: Piece -> C -> [ Set.Set Node ] getS p c = foldl' f [] c' where vinc = head . Set.toList $ nodesAlsoInC p (a,b) = span (vinc /= ) $ cAsList c c' = b ++ a ++ [ head b ] f :: [ Set.Set Node ] -> Node -> [ Set.Set Node ] f l vinc = if vinc `Set.member` nodesAlsoInC p then if null l then [ Set.singleton vinc ] else if vinc == head c' then (Set.insert vinc $ head l ) : tail l else Set.singleton vinc : (Set.insert vinc $ head l ) : tail l else if null l then [ Set.singleton vinc ] else ( Set.insert vinc $ head l ) : tail l patchEdgesGraph beingImprovedG (itsSubG :: MyInGr ) p_i = let allEdgesPI = concat $ map (\n -> map (\(w,l) -> (n,w,l) ) $ lsuc itsSubG n) (nodes $ pieceAsSubgraph p_i) fEdge (v,w,l) g = setELabel' (v,w) l g in foldr fEdge beingImprovedG allEdgesPI orientGraph :: Gr a b -> MyInGr -> Gr a (Int,Int) orientGraph srcG embeddedG = let srcG' = emap (\_ -> (0,0)) srcG conEdgeLabels v sg = let outgoing = map (\(w,l) -> (v,w,l) ) $ lsuc embeddedG v sortedOut= sortBy (\(_,_,l1) (_,_,l2) -> if isFreeELabel l1 || isFreeELabel l2 then error $ "outgoing contains free edgelabel !outgoing = \n " ++ show outgoing else compare l1 l2) outgoing sout = map (\(n, (v,w,_)) -> (n,v,w) ) $ zip [0..] sortedOut in foldr (\(n,v,w) sg -> case find ((w == ) . fst) $ lsuc sg v of Nothing -> case find ((v == ) . fst) $ lsuc sg w of Nothing -> error $ "orientGraph: can't find edge " ++ show (v,w) ++ " or " ++ show (w,v) Just (_,(right,_)) -> setELabel' (w,v) (right,n) sg Just (_,(_,back)) -> setELabel' (v,w) (n,back) sg ) sg sout in foldr conEdgeLabels srcG' $ nodes embeddedG -- analog of orientGraph but for undirected graph -- edge label of final graph is an position edge in set outgoing edges of the node extractGraph :: Gr a b -> MyInGr -> Gr a Int extractGraph srcG embeddedG = let srcG' = emap (\_ -> 0) srcG conEdgeLabels v sg = let outgoing = map (\(w,l) -> (v,w,l) ) $ lsuc embeddedG v sortedOut= sortBy (\(_,_,l1) (_,_,l2) -> if isFreeELabel l1 || isFreeELabel l2 then error $ "outgoing contains free edgelabel !outgoing = \n " ++ show outgoing else compare l1 l2) outgoing -- here is outging edges are ordered and are numbered sout = map (\(n, (v,w,_)) -> (n,v,w) ) $ zip [0..] sortedOut in foldr (\(n,v,w) sg -> setELabel' (v,w) n sg ) sg sout in foldr conEdgeLabels srcG' $ nodes embeddedG genNextC :: C -> Piece -> C genNextC oldc p_i = let a = nodesAlsoInC p_i firstInA = head $ Set.toList a (_, afterF) = span (firstInA /= ) . cycle $ cAsList oldc (_, rest) = break ( `Set.member` a) $ tail afterF secondInA = head rest newPart = head . findPaths firstInA secondInA $ pieceAsSubgraph p_i (leavingPart, _) = break ( == firstInA ) $ tail rest nc = ( firstInA : newPart ) ++ ( secondInA : leavingPart ) in (newC nc) { oldCC = Just OldC { oldCAsSet = cAsSet oldc, oldCAsList = cAsList oldc } } orderPathPiece pid p g = let s = nodesAlsoInC p procOneV v g = if v `Set.notMember` s then let nei = zip [0..] $ suc g v in foldr (\(n,w) g -> setELabel' (v,w) (FixedEdge . PieceOrder (Just pid) n $ StubLabel) g) g nei else g in foldr procOneV g . nodes $ pieceAsSubgraph p orderEdgesOfNode :: Node -> C -> MyInGr -> MapPieces -> VertexMapPiece -> EdgeMapPiece -> Maybe EdgeMapPiece -> Maybe MapPieces -> (MyInGr, MapPieces) orderEdgesOfNode v c g mp vmp emp oldEmp oldMp = let cl = cAsList c allPiecesOfv = map (\pid -> (pid, fromJust $ Map.lookup pid mp) ) . Set.toList $ case Map.lookup v vmp of Nothing -> Set.empty Just x -> x apv = filter (\(_,p) -> any isFreeELabel . map snd $ lsuc (pieceAsSubgraph p) v ) allPiecesOfv (insidePieces,outsidePieces) = partition ((== Inside) . sideOfpiece . snd ) apv orderPieces pieces cmp = map (\((pid,p),_) -> (p, Just pid )) . sortBy cmp $ map (\p -> (p, distanceToNearestW v c $ snd p )) pieces cmpOut a@((pida,pa),wa) b@((pidb, pb),wb) = case compare wb wa of EQ -> let [ la, lb ] = map legsOfpiece [pa,pb] [(w, sa), (_,sb) ] = map (\legs -> if Map.size legs == 2 then head . Map.toList $ Map.delete v legs else error $ "legs must be 2\nlegs = " ++ show legs) [la,lb] checkEquality labels = if length ( nub labels ) == 1 then labels else error $ "Labels aren't equal: " ++ show labels [firstLbl , secondLbl ] = map (\s -> head . checkEquality . map (\wNei -> lastNumLabel $ getELabel (w, wNei ) g ) $ Set.toList s) [sa,sb] in if apa (/=) Map.keys la lb then error $ "embedGraphWithC: unknown state:\na = " ++ show a ++ "\nb = " ++ show b else case compare secondLbl firstLbl of LT -> GT GT -> LT EQ -> EQ other -> other outsidePieces' = orderPieces outsidePieces cmpOut insidePieces' = orderPieces insidePieces (flip cmpOut) wBeforeV = fromJust $ takeBefore v cl wAfterV = fromJust $ takeAfter v cl pieceBeforeV = emptyPiece { legsOfpiece = Map.singleton v $ Set.fromList [ wBeforeV ] } pieceAfterV = emptyPiece { legsOfpiece = Map.singleton v $ Set.fromList [ wAfterV ] } lblBefore = getELabel (v, wBeforeV) g lblAfter = getELabel (v,wAfterV) g lstt = let rest = concat [ outsidePieces', if isFreeELabel lblAfter then [ (pieceAfterV, Nothing) ] else [], insidePieces' ] in if isFreeELabel lblBefore then let omp = fromJust oldMp oemp = fromJust oldEmp previousPid = Map.lookup (v, wBeforeV) oemp previousP = fromJust $ Map.lookup (fromJust previousPid) omp legOfv = fromJust . Map.lookup v $ legsOfpiece previousP (insidePieces'', togetherBefore) = span (\(p, _) -> all ( `Set.notMember` legOfv ) . nodes $ pieceAsSubgraph p) insidePieces' in if isJust oldMp && isJust previousPid && v `Set.member` (oldCAsSet . fromJust $ oldCC c) then concat [ togetherBefore, [ (pieceBeforeV, Nothing) ], outsidePieces', if isFreeELabel lblAfter then [ (pieceAfterV, Nothing) ] else [], insidePieces'' ] else (pieceBeforeV, Nothing) : rest else rest apieces = zip [0..] lstt markAllEdgesOfPiece (n,(p, mayPid)) (g,mp) = let neiNodesInP = fromJust . Map.lookup v $ legsOfpiece p modGofP f mp pid = Map.adjust (\p -> p { pieceAsSubgraph = f $ pieceAsSubgraph p }) pid mp in if Set.size neiNodesInP == 1 then let w = head $ Set.toList neiNodesInP vwlbl = getELabel (v,w) g vwlbl' = fixELabel mayPid n vwlbl modg g = setELabel' (v, w ) vwlbl' g in (modg g, maybe mp (modGofP modg mp) mayPid ) else let markEdgeOfPiece w g = let vwlbl = getELabel (v,w) g vwlbl' = continueLabel mayPid n vwlbl in setELabel' (v,w) vwlbl' g modg g = Set.fold markEdgeOfPiece g neiNodesInP in (modg g, maybe mp (modGofP modg mp) mayPid ) in foldr markAllEdgesOfPiece (g,mp) apieces distanceToNearestW v c p = let (beforeV,vAndAfter) = span (v /= ) $ cAsList c c' = vAndAfter ++ beforeV outer = nodesAlsoInC p in map fst . filter ((`Set.member` outer) . snd) $ zip [ 0..] c' makeEMP :: MapPieces -> EdgeMapPiece makeEMP mp = let fPiece pid p emp = let legs = legsOfpiece p fLeg v leg emp = Set.fold (\w emp -> Map.insert (v,w) pid emp) emp leg in Map.foldWithKey fLeg emp legs in Map.foldWithKey fPiece Map.empty mp makeVMP :: MapPieces -> VertexMapPiece makeVMP mp = let fPiece pid p vmp = let fVertex v vmp = let a = case Map.lookup v vmp of Nothing -> Set.singleton pid Just s -> Set.insert pid s in Map.insert v a vmp in Set.fold fVertex vmp $ nodesAlsoInC p in Map.foldWithKey fPiece Map.empty mp