gbu (empty) → 0.1
raw patch · 6 files changed
+928/−0 lines, 6 filesdep +Graphalyzedep +basedep +containerssetup-changed
Dependencies added: Graphalyze, base, containers, fgl, haskell98, mtl, regex-posix
Files
- Data/Graph/Embedding.hs +665/−0
- Data/Graph/InductivePlus.hs +122/−0
- Data/Graph/SimpleUtil.hs +74/−0
- LICENSE +28/−0
- Setup.hs +6/−0
- gbu.cabal +33/−0
+ Data/Graph/Embedding.hs view
@@ -0,0 +1,665 @@+-- (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+
+ Data/Graph/InductivePlus.hs view
@@ -0,0 +1,122 @@+-- (c) 2010 by Daneel S. Yaitskov+-- | additional functions for the graph structure defined in fgl library+module Data.Graph.InductivePlus (module Data.Graph.Inductive, module Data.Graph.InductivePlus) where++import Data.Maybe+import Data.List (nub,union)+import Control.Monad.State (execState, get, put, modify)+import Data.Graph.Inductive+import Debug.Trace+++delUEdge e@(v,w) g = delEdge e $ delEdge (w,v) g++unear n g = nub $ neighbors g n++-- | the function updates a label of v node in the graph g+setVLabel :: (Node, a) -- ^ node number paired with old node's label value+ -> a -- ^ new label value+ -> Gr a b + -> Gr a b +setVLabel (v,_) newL g =+ let ne = unear v g+ s = lsuc g v+ p = lpre g v+ g' = insNode (v,newL) $ delNode v g+ newEdges = [ (fst x,v, snd x) | x <- p ] ++ [ (v,fst x, snd x) | x <- s ]+ in insEdges newEdges g'++-- | the function updates a label of v node in the graph g+setVLabel' :: Node -> a -> Gr a b -> Gr a b+setVLabel' v newL g = setVLabel (v,newL) newL g++-- | the function extracts a label of v node from the graph g+getVLabel :: Node -> Gr a b -> a+getVLabel v g = fromJust $ lab g v++setELabel :: (Node, Node, a) -> a -> Gr b a -> Gr b a+setELabel (v,w,_) newL g =+ let g' = delEdge (v,w) g+ num = length . filter (w == ) $ suc g v+ in insEdges (replicate 1 {-num-} (v,w,newL)) g'++-- | the function version of setELabel for an undirected graph+setUELabel e@(v,w,_) newL g =+ setELabel e newL $ setELabel (w,v,newL) newL g++setELabel' (v,w) newL g = setELabel (v,w,newL) newL g+setUELabel' (v,w) newL g = setUELabel (v,w,newL) newL g+ +getELabel :: (Node, Node) -> Gr a b -> b+getELabel (v,w) g = fromJust . lookup w $ lsuc g v+getELabel' (v,w) g = lookup w $ lsuc g v++isEdge :: (Node, Node) -> Gr a b -> Bool+isEdge (v,w) g = w `elem` suc g v++-- | the function merges two graphs. E.i. if first graph hasn't got vertex v +-- but second one has got it then the node is inserted into first graph with +-- same label. Edges are processed too.+mergeTwoGraphs :: Gr a b -> Gr a b -> Gr a b+mergeTwoGraphs g1 g2 =+ let mergeNode n g = if n `gelem` g1+ then g+ else insNode (n, getVLabel n g2) g+ g1' = foldr mergeNode g1 $ nodes g2+ mergeEdge e@(v,w) g = if isEdge e g+ then g+ else insEdge (v,w, getELabel e g2) g+ in foldr mergeEdge g1' $ edges g2++-- | it finds and returns the path consiting of edges from first node to second one.+-- If the path doesn't exist then the function returns the empty list.+findPaths :: Node -> Node -> Gr a b -> [ Path ]+findPaths v0 w g = execState (f [] v0) []+ where+ f curP v =+ let nei = suc g v + subf nv = if nv == w+ then modify ( curP : ) + else if nv `elem` curP || nv == v0+ then return ()+ else f ( curP ++ [ nv ] ) nv + in mapM_ subf nei +++instance (Eq a, Eq b) => Eq (Gr a b) where+ g1 == g2 =+ let nsg1 = nodes g1+ nsg2 = nodes g2+ nsg12 = zip nsg1 nsg2+ cmpTwoNodes (n1,n2) =+ let neOf1 = lsuc g1 n1 + neOf2 = lsuc g2 n2+ len2 = length neOf2+ len1 = length neOf1 + in lab g1 n1 == lab g2 n2 &&+ {- trace ("v " ++ show n2 ++ "Len2 = " ++ show len2) -} len2 ==+ {- trace ("v " ++ show n2 ++ "Len1 = " ++ show len1) -} len1 &&+ length (neOf1 `union` neOf2) == len2+ in nsg1 == nsg2 && all cmpTwoNodes nsg12++++getSources g = filter (null . lpre g) $ nodes g++getSinks g = filter (null . lsuc g) $ nodes g+++filterVertexes predicate g =+ filter (uncurry predicate)+ . map (\n -> (n , getVLabel n g))+ $ nodes g++findVertex predicate g =+ let matching = filterVertexes predicate g+ in if null matching+ then error $ "findVertex: got empty list\n" ++ show g+ else head matching++fst3 (a,_,_) = a+snd3 (_, a,_) = a+thd3 (_, _, a) = a
+ Data/Graph/SimpleUtil.hs view
@@ -0,0 +1,74 @@+-- (c) 2010 by Daneel S. Yaitskov+-- very simple help function +module Data.Graph.SimpleUtil where+import Monad (liftM)+import Data.List+import qualified Debug.Trace as T+import System.Exit+import System.Environment+import Text.Regex.Posix ((=~))++map2 :: (a -> b) -> (a,a) -> (b,b)+map2 f (a,b) = (f a, f b)+++-- (length . fromJust) a == (length . fromJust) b+-- apa (==) (length . fromJust) a b+apa :: (a -> a -> b) -> (c -> a) -> c -> c -> b+apa f g a b = f (g a) (g b)+++-- map first element of a tuple+m1of2 f (a,b) = (f a, b)+-- map second element of a tuple+m2of2 f (a,b) = (a, f b)+infix 6 `m1of2`+infix 6 `m2of2`+++takeAfter :: Eq a => a -> [ a ] -> Maybe a+takeAfter x l =+ case dropWhile (x /= ) l of+ [] -> Nothing+ l' -> Just $ case tail l' of+ [] -> head l+ (a:_) -> a++takeBefore :: Eq a => a -> [ a ] -> Maybe a+takeBefore _ [] = Nothing+takeBefore x l =+ if x == head l+ then Just $ last l+ else case break (x == ) l of+ (_,[]) -> Nothing+ (l, _) -> Just $ last l++replace :: Eq a => [a] -> [a] -> [a] -> [a]+replace a b [] = []++replace a b s@(h:r) =+ let la = length a in+ if isPrefixOf a s+ then b ++ replace a b (drop la s)+ else h : replace a b r+++sublist first len lst = take len $ drop first lst++++(=~+) :: String -> String -> [ String ]+(=~+) str pattern =+ let (_,matched, rest, groups) = str =~ pattern :: (String, String, String, [String])+ in groups++compareDouble d1 d2 precision =+ if abs (d1 - d2) < precision+ then EQ+ else compare d1 d2+trace :: String -> a -> a+trace msg v = T.trace msg v++sign x = if abs x < 1e-9+ then 0+ else x / (abs x)
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2010, Daneel S. Yaitskov+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice,+ this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the author nor the names of its 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,6 @@+module Main(main) where++import Distribution.Simple+++main = defaultMain
+ gbu.cabal view
@@ -0,0 +1,33 @@+name: gbu+version: 0.1+cabal-version: >= 1.2.3+license: BSD3+license-file: LICENSE+author: Daneel S. Yaitskov <rtfm.rtfm.rtfm@gmail.com>+maintainer: Daneel S. Yaitskov <rtfm.rtfm.rtfm@gmail.com>+homepage: http://www.daneel0yaitskov.000space.com+category: Graph+synopsis: planar graph embedding into a plane+build-type: Simple+description:+ A library realizes one of the graph visualization process's + steps - graph embedding into a plane. The job of the step is+ such to order nodes' edges that there are capabilities to + draw them without any intersections. + +library + exposed-modules: Data.Graph.Embedding,+ Data.Graph.InductivePlus+ -- I haven't tested my code with older version used libraries.+ -- I have just taken used libraries' versions as minimal acceptable.+ build-depends: base >= 3 && < 5,+ fgl >= 5.4.2.2,+ Graphalyze >= 0.9.0.0,+ mtl >= 1.1.0.2,+ containers >= 0.2.0.0,+ regex-posix >= 0.94.1,+ haskell98+ other-modules: Data.Graph.SimpleUtil+ extensions: ScopedTypeVariables+-- ghc-options: CPP+