diff --git a/Data/Graph/Embedding.hs b/Data/Graph/Embedding.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/Embedding.hs @@ -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 + diff --git a/Data/Graph/InductivePlus.hs b/Data/Graph/InductivePlus.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/InductivePlus.hs @@ -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 diff --git a/Data/Graph/SimpleUtil.hs b/Data/Graph/SimpleUtil.hs new file mode 100644 --- /dev/null +++ b/Data/Graph/SimpleUtil.hs @@ -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) diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main(main) where + +import Distribution.Simple + + +main = defaultMain diff --git a/gbu.cabal b/gbu.cabal new file mode 100644 --- /dev/null +++ b/gbu.cabal @@ -0,0 +1,33 @@ +name: gbu +version: 0.1 +cabal-version: >= 1.2.3 +license: BSD3 +license-file: LICENSE +author: Daneel S. Yaitskov +maintainer: Daneel S. Yaitskov +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 +