packages feed

libgraph (empty) → 1.3

raw patch · 12 files changed

+724/−0 lines, 12 filesdep +arraydep +basedep +containerssetup-changed

Dependencies added: array, base, containers, monads-tf, process, union-find

Files

+ Data/Graph/Libgraph.hs view
@@ -0,0 +1,40 @@+module Data.Graph.Libgraph+( Graph(..)+, Arc(..)+, (-->)+, succs+, preds+, isSucc+, isPred+, mapGraph+, mapArcs+, Dfs+, EdgeType(..)+, getDfs+, getEdgetype+, getPreorder+, getPostorder+, isAncestor+, Domsets+, getDomsets+, getDominators+, CycleTree(..)+, getCycles+, getRedHeaders+, dagify+, findFaulty+, findFaulty_dag+, Judgement(..)+, showWith+, escape+, display+, collapse+, remove+) where+import Data.Graph.Libgraph.Core+import Data.Graph.Libgraph.DepthFirst+import Data.Graph.Libgraph.Dominance+import Data.Graph.Libgraph.Cycles+import Data.Graph.Libgraph.Dagify+import Data.Graph.Libgraph.Dot+import Data.Graph.Libgraph.AlgoDebug
+ Data/Graph/Libgraph/AlgoDebug.hs view
@@ -0,0 +1,15 @@+module Data.Graph.Libgraph.AlgoDebug where+import Data.Graph.Libgraph.Core+import Data.Graph.Libgraph.Dagify(collapse,remove)+import Prelude hiding (Right)++data Judgement = Right | Wrong | Unassessed deriving (Eq,Show,Ord)++findFaulty_dag :: (Ord v, Eq a, Show v) => (v -> Judgement) -> Graph v a -> [v]+findFaulty_dag judge g = filter isFaulty (vertices g)+  where isFaulty v =  (judge v == Wrong)+                   && (null $ filter ((/=Right) . judge) (succs g v))++findFaulty :: (Ord v, Eq a, Show v) +           => (v -> Judgement) -> ([v]->v) -> Graph v a -> [v]+findFaulty isWrong merge = (findFaulty_dag isWrong) . (collapse merge) . remove
+ Data/Graph/Libgraph/Core.hs view
@@ -0,0 +1,100 @@+module Data.Graph.Libgraph.Core where+import Data.Maybe+import Data.List+import Debug.Trace(traceStack)++--------------------------------------------------------------------------------+-- External representation of graphs++data Arc vertex arc +  = Arc { source :: vertex, target :: vertex, arc :: arc}+    deriving (Eq, Show)++data SimpleArc vertex+  = SimpleArc { source' :: vertex, target' :: vertex }+    deriving Eq++data Graph vertex arc+  = Graph { root     :: vertex+          , vertices :: [vertex]+          , arcs     :: [Arc vertex arc]+          }++data SimpleGraph vertex+  = SimpleGraph { root'     :: vertex+                , vertices' :: [vertex]+                , arcs'     :: [SimpleArc vertex]+                }++-- | Create an arc between two vertices.+(-->) :: vertex -> vertex -> SimpleArc vertex+(-->) = SimpleArc++-- | Remove types from arcs.+simpleGraph :: Graph vertex arc -> SimpleGraph vertex+simpleGraph g = SimpleGraph (root g) (vertices g) (map simpleArc $ arcs g)+  where simpleArc (Arc v w _) = SimpleArc v w++unitGraph :: Graph vertex arc -> Graph vertex ()+unitGraph g = g { arcs = map unitArc (arcs g) }+  where unitArc a = a { arc = () }++--------------------------------------------------------------------------------+-- Successors and predecessors++-- | Direct successors of a vertex.+succs :: Eq vertex => Graph vertex arc -> vertex -> [vertex]+succs g v = map target $ filter ((== v) . source) (arcs g)++-- | Direct predecessors of a vertex.+preds :: Eq vertex => Graph vertex arc -> vertex -> [vertex]+preds g v = map source $ filter ((== v) . target) (arcs g)++-- | Is first vertex a successor of second?+isSucc :: Eq vertex => Graph vertex arc -> vertex -> vertex -> Bool+isSucc g w v = w `elem` succs g v++-- | Is first vertex a predecessor of second?+isPred :: Eq vertex => Graph vertex arc -> vertex -> vertex -> Bool+isPred g w v = w `elem` preds g v++--------------------------------------------------------------------------------+-- Graph conversion++mapGraph :: (a -> b) -> Graph a c -> Graph b c+mapGraph f (Graph r vs as) = Graph (f r) (map f vs) (mapArcsV f as)++mapArcs :: (a -> b) -> Graph c a -> Graph c b+mapArcs f (Graph r vs as) = Graph r vs (map (mapArc f) as)++mapArcsV :: (a -> b) -> [Arc a c] -> [Arc b c]+mapArcsV = map . mapArcV++mapArcV :: (a -> b) -> Arc a c -> Arc b c+mapArcV f (Arc src tgt t) = Arc (f src) (f tgt) t++mapArc :: (a->b) -> Arc v a -> Arc v b+mapArc f (Arc v w t) = Arc v w (f t)++filterArc :: (Arc vertex arc->Bool) -> Graph vertex arc -> Graph vertex arc+filterArc p (Graph r vs as) = Graph r vs (filter p as)++--------------------------------------------------------------------------------+-- Some other helper functions++lookup' :: Eq a => a -> [(a, b)] -> String -> b+lookup' x ys msg = case lookup x ys of+  Nothing -> error msg+  Just y  -> y++fstElem :: Eq a => a -> [(a, b)] -> Bool+fstElem x = isJust . (lookup x)++update :: Eq a => (a,b) -> [(a,b)] -> [(a,b)]+update (x,y) xys = map (\(x',y') -> if x == x' then (x,y) else (x',y')) xys++sndList :: [(a,b)] -> [b]+sndList = snd . unzip++fstList :: [(a,b)] -> [a]+fstList = fst . unzip
+ Data/Graph/Libgraph/Cycles.hs view
@@ -0,0 +1,227 @@+module Data.Graph.Libgraph.Cycles+( CycleTree(..)+, getCycles+, CycleNest+, getCycleNest+, getRedHeaders+) where+import Data.List+import Control.Monad+import Control.Monad.State+import Data.Graph.Libgraph.Core+import Data.Graph.Libgraph.DepthFirst+import Data.Graph.Libgraph.UnionFind(UF)+import Data.Graph.Libgraph.Dot+import qualified  Data.Graph.Libgraph.UnionFind as UF+import Data.Array++data CycleTree vertex = CycleTree vertex [CycleTree vertex]+                      | Reducible vertex [CycleTree vertex]+                      | Irreducible      [CycleTree vertex]+                      deriving Show++getCycles :: Ord vertex => CycleNest vertex -> CycleTree vertex+getCycles nest = {-# SCC "getCycles" #-} cycleTree nest (children nest) 1++cycleTree :: CycleNest vertex -> Array Int [Int] -> Int -> CycleTree vertex+cycleTree nest cs x+  = case (vertexType nest) ! x of+    NonHead   -> CycleTree v cts+    SelfHead  -> Reducible v []+    RedHead   -> Reducible v cts+    IrredHead -> Irreducible ((CycleTree v []) : simplify cts)+    +    where cts  = map ct (cs ! x)+          ct c = cycleTree nest cs c+          v    = getVertex nest x++-- Flattens irreducible loops.+simplify :: [CycleTree vertex] -> [CycleTree vertex]+simplify vs = foldl simplify' [] vs+  where simplify' acc v = case v of+          (Irreducible ws) -> ws ++ acc+          _                -> v : acc++children :: CycleNest vertex -> Array Int [Int]+children nest+  = foldl add cs0 ps+  where cs0 = listArray (1,n nest) (cycle [[]])+        ps  = assocs (header nest)+        add cs (p,c) = if p == c then cs else cs // [(c,p : cs ! c)]+++-- | Entry vertices of reducible cycles.+getRedHeaders :: CycleNest vertex -> [vertex]+getRedHeaders nest+  = map i2v (filter (isRedHead . snd) vtyps)+  where vtyps = assocs . vertexType $ nest +        i2v   = (getVertex nest) . fst++isRedHead RedHead  = True+isRedHead SelfHead = True+isRedHead _        = False++-- Implementation of Havlaks algorithm.++type S vertex a = State (CycleNest vertex) a++data VertexType = NonHead | SelfHead | RedHead | IrredHead+  deriving Show++data CycleNest vertex = CycleNest+  { graph        :: Graph Int ()+  , getVertex    :: Int -> vertex+  , n            :: Int+  , dfs          :: Dfs Int ()+  , backPreds    :: [[Int]]+  , nonBackPreds :: Array Int [Int]+  , vertexType   :: Array Int VertexType+  , header       :: Array Int Int+  , body         :: [Int]              -- P in Havlak's algorithm+  , worklist     :: [Int]+  , uf           :: UF+  }+++-- Part a and b of Havlak's algorithm+state0 :: Ord vertex => Graph vertex arc -> CycleNest vertex+state0 g = s0+  where ps   = map (\w -> partition (isAncestor (dfs s0) w) (preds (graph s0) w)) [1..n s0]+        bps  = map fst ps+        nbps = map snd ps+        dfsg = dfsGraph g+        s0   = CycleNest+          { graph        = fst dfsg+          , getVertex    = snd dfsg+          , n            = length (vertices g)+          , dfs          = getDfs (graph s0)+          , backPreds    = bps+          , nonBackPreds = listArray (1,n s0) nbps+          , vertexType   = listArray (1,n s0) $ cycle [NonHead]+          , header       = listArray (1,n s0) $ cycle [root . graph $ s0]+          , body         = []+          , worklist     = []+          , uf           = UF.fromList [1..n s0]+          }++getCycleNest :: Ord vertex => Graph vertex arc -> CycleNest vertex+getCycleNest g = execState (analyse . reverse $ [1..n s0]) s0+  where s0 = state0 g++-- Part c of Havlak's algorithm+analyse :: Eq vertex => [Int] -> S vertex ()+analyse ws = mapM_ analyse' ws+  where analyse' w = do modify $ \s -> s { body = [] }+                        analyseBackPreds w+                        modify $ \s -> s { worklist = body s }+                        labelReducible w+                        work w+                        merge w+++labelReducible :: Eq vertex => Int -> S vertex ()+labelReducible w = do p <- gets $ body+                      case p of [] -> return ()+                                _  -> modifyVertexType (w,RedHead)+work :: Int -> S vertex ()+work w = do+  wl <- gets worklist+  case wl of+    []      -> return ()+    (x:wl') -> do modify $ \s -> s { worklist = wl' }+                  chase w x+                  work w++merge :: Int -> S vertex ()+merge w = do+  p <- gets body+  mapM_ (merge' w) p++merge' w x = do+  modify $ \s -> s { header = (header s) // [(x,w)] }+  uf_union x w++-- Part d of Havlak's algorithm+analyseBackPreds :: Eq vertex => Int -> S vertex ()+analyseBackPreds w = do bps <- gets backPreds+                        mapM_ f (bps !!! w)+  where f v = if v /= w then do x <- uf_find v+                                addToBody x+                        else modifyVertexType (w,SelfHead)++(!!!) :: [a] -> Int -> a+xs !!! i = xs !! (i-1)++-- Part e of Havlak's algorithm++chase :: Int -> Int -> S vertex ()+chase w x = do+  nbps <- gets nonBackPreds+  mapM_ (chase' w) (nbps ! x)++chase' :: Int -> Int -> S vertex ()+chase' w y = do+  y' <- uf_find y+  d  <- gets dfs+  p  <- gets body+  if not $ isAncestor d w y' then do+    modifyVertexType (w,IrredHead)+    y' `addToNonBackPredsOf` w+  else if not (y' `elem` p) && y' /= w then do+    addToBody y'+    addWork y'+  else+    return ()++-- Some helper functions++dfsGraph :: Ord vertex => Graph vertex arc -> (Graph Int (), Int -> vertex)+dfsGraph g = (mapGraph v2i g', i2v)+  where preorder = getPreorder (getDfs g)+        i2v i = lookup' i (zip [1..] preorder) "Libraph.dfsGraph: lookup failed"+        v2i v = lookup' v (zip preorder [1..]) "Libraph.dfsGraph: lookup failed"+        g' = unitGraph g++modifyVertexType :: (Int,VertexType) -> S vertex ()+modifyVertexType vtyp = do+  modify $ \s -> s { vertexType = (vertexType s) // [vtyp]}++addToNonBackPredsOf :: Int -> Int -> S vertex ()+addToNonBackPredsOf y w =+  modify $ \s -> s { nonBackPreds = (nonBackPreds s) // [(w,y : (nonBackPreds s) ! w)] }++addToBody :: Int -> S vertex ()+addToBody v = modify $ \s -> s { body = v : body s }++addWork :: Int -> S vertex ()+addWork v = modify $ \s -> s { worklist = v : worklist s }++uf_find :: Int -> S vertex Int+uf_find v = do +  uf' <- gets uf+  let r =  UF.find uf' v+  -- MF TODO update uf?+  return r++uf_union :: Int -> Int -> S vertex ()+uf_union v w = modify $ \s -> s { uf = UF.union (uf s) v w }++-- Show++instance Show vertex => Show (CycleNest vertex) where+  show cycleNest+    =  "diGraph G {\n"+    ++ "rankdir=BT\n"+    ++ foldl (\s -> (s++) . showVType i2v)  "" (assocs . vertexType $ cycleNest)+    ++ foldl (\s -> (s++) . showHeader)     "" (assocs . header     $ cycleNest)+    ++ "}\n"+      where i2v = getVertex cycleNest++showVType :: Show vertex => (Int -> vertex) -> (Int,VertexType) -> String+showVType i2v (i,vtyp) +  = "v" ++ show i ++ " [label=\"" ++ s (i2v i) ++ " (" ++ show i ++ " | " ++ show vtyp ++ ")\"]\n"+  where s = escape . show++showHeader :: (Int,Int) -> String+showHeader (i,j) = v i ++ " -> " ++ v j ++ "\n"+  where v x = "v" ++ show x
+ Data/Graph/Libgraph/Dagify.hs view
@@ -0,0 +1,37 @@+module Data.Graph.Libgraph.Dagify where+import Data.Graph.Libgraph.Core+import Data.Graph.Libgraph.Cycles+import Data.Graph.Libgraph.DepthFirst+import Data.List(nub)++dagify :: (Ord v, Eq a, Show v)  => ([v]->v) -> Graph v a -> Graph v a+dagify merge = {-# SCC "dagify" #-} (collapse merge) . remove++remove :: (Ord v, Show v) => Graph v a -> Graph v a+remove g = filterArc (\a -> not $ isBackEdge a && hasRedHead a) g+  where isBackEdge a = getEdgetype (getDfs g) a == BackEdge+        hasRedHead (Arc _ h _) = h `elem` getRedHeaders (getCycleNest g)++collapse :: (Ord v,Eq a) => ([v]->v) -> Graph v a -> Graph v a+collapse merge g = foldl collapseCycle g ics+  where (CycleTree _ ts) = getCycles (getCycleNest g)+        ics              = filter (\c -> case c of +                                Irreducible _ -> True+                                _             -> False) ts+        collapseCycle g (Irreducible cts)+          = let ws = (verticesInCycle cts)+                v  = (merge ws)+            in rewire g ws v+        verticesInCycle = map (\(CycleTree v []) -> v)++rewire :: (Eq v, Eq a) => Graph v a -> [v] -> v -> Graph v a+rewire (Graph r vs as) ws c +  = Graph r +          (c : filter (not . (`elem` ws)) vs)+          (nub $ map fromTo $ filter (not . isInternalArc) as)+  where isInternalArc (Arc src tgt _) = src `elem` ws && tgt `elem` ws+        -- MF TODO: Should we keep arc-type 't' when rewiring?+        fromTo (Arc src tgt t)+          | tgt `elem` ws = Arc src c t +          | src `elem` ws = Arc c   tgt t+          | otherwise     = Arc src tgt t
+ Data/Graph/Libgraph/DepthFirst.hs view
@@ -0,0 +1,125 @@+module Data.Graph.Libgraph.DepthFirst+( Dfs+, EdgeType(..)+, getDfs+, getEdgetype+, getPreorder+, getPostorder+, isAncestor+) where+import Data.Graph.Libgraph.Core+import Data.Graph.Libgraph.Dot+import Control.Monad.State+import Data.List++data Dfs vertex arc+  = Dfs { num       :: [(vertex,Int)]+        , lastVisit :: [(vertex,Int)] +        , spanning  :: [SimpleArc vertex]+        , graph     :: Graph vertex arc+        }++data EdgeType = TreeEdge | BackEdge | FwdEdge | CrossEdge+  deriving Eq++-- | Is first vertex a (recursive) parent of second vertex?+isAncestor :: (Eq vertex, Show vertex)+           => Dfs vertex arc -> vertex -> vertex -> Bool+isAncestor d w v = (n_w <= n_v && n_v <= l_w)+  where n_v    = lookup' v (num d) $ "LibGraph.isAncestor: lookup dfs number failed " ++ show v+        n_w    = lookup' w (num d) $ "LibGraph.isAncestor: lookup dfs number failed"+        l_w    = lookup' w (lastVisit d) $ "LibGraph.isAncestor: lookup dfs lasVisit-number failed"++-- | The 'EdgeType' of an 'Arc'.+getEdgetype :: (Eq vertex, Show vertex) => Dfs vertex arc -> Arc vertex arc -> EdgeType+getEdgetype d (Arc v w _)+  | (v-->w) `elem` (spanning d) = TreeEdge+  | w `isAnc` v                 = BackEdge+  | v `isAnc` w                 = FwdEdge+  | otherwise                   = CrossEdge+  where isAnc = isAncestor d++-- | Get list of vertices in the order they were visited by the depth-first search.+getPreorder :: Dfs vertex arc -> [vertex]+getPreorder d = map fst (reverse . num $ d)++-- | Get list of vertices in the order they were last visited by the depth-first search.+getPostorder :: Dfs vertex arc -> [vertex]+getPostorder d = map fst (reverse . lastVisit $ d)++data Succs vertex = Succs vertex [vertex]++data DfsState vertex arc+  = DfsState { graph'     :: Graph vertex arc+             , spanning'  :: [SimpleArc vertex]+             , stack      :: [Succs vertex]+             , seen       :: [vertex]+             , time       :: Int+             , num'       :: [(vertex,Int)]+             , lastVisit' :: [(vertex,Int)]+             }++-- | Walk graph in depth-first order and number the vertices.+getDfs :: Eq vertex => Graph vertex arc -> Dfs vertex arc+getDfs g = Dfs (num' finalState) (lastVisit' finalState) (spanning' finalState) g+  where state0 = DfsState { graph'     = g+                          , spanning'  = []+                          , stack      = []+                          , seen       = []+                          , time       = 0+                          , num'       = []+                          , lastVisit' = []+                          }+        finalState = execState (visit $ root g) state0++visit :: Eq vertex => vertex -> State (DfsState vertex arc) ()+visit v = do see v+             pushSuccs v+             s <- gets stack+             mvw <- pop+             case mvw of Just (v,w) -> do addToSpanning v w+                                          visit w+                         Nothing    -> return ()++addToSpanning :: vertex -> vertex -> State (DfsState vertex arc) ()+addToSpanning v w +  = modify $ \s -> s { spanning' = v --> w : (spanning' s) }++pushSuccs :: Eq vertex => vertex -> State (DfsState vertex arc) ()+pushSuccs v = do g  <- gets graph'+                 vs <- gets seen+                 modify $ \s -> s { stack = Succs v (succs g v) : (stack s) }++pop :: Eq vertex => State (DfsState vertex arc) (Maybe (vertex,vertex))+pop = do s <- gets stack+         case s of []                  -> return Nothing+                   (Succs v []:ss)     -> do modify $ \s -> s { stack = ss }+                                             visitedAllChildren v+                                             pop+                   (Succs v (c:cs):ss) +                     -> do visited <- gets seen+                           modify $ \s -> s { stack = Succs v cs : ss }+                           if c `elem` visited +                             then pop +                             else do return $ Just (v,c)++visitedAllChildren :: Eq vertex => vertex -> State (DfsState vertex arc) ()+visitedAllChildren v = modify $ \s -> s { lastVisit' = (v, time s) : lastVisit' s }++see :: vertex -> State (DfsState vertex arc) ()+see v = modify $ \s -> s { seen = v : seen s+                         , num' = (v, time s + 1) : num' s+                         , time = time s + 1+                         }++instance (Eq vertex,Show vertex) => Show (Dfs vertex arc) where+  show d = showWith (graph d) showVertex showArc+    where showVertex v = show v ++ show (lkup v (num d), lkup v (lastVisit d))+          showArc      = show . (getEdgetype d)+          lkup v ds    = lookup' v ds "Libgraph.show: lookup dfs number failed"++instance Show EdgeType where+  show TreeEdge  = "tree edge"+  show BackEdge  = "back edge"+  show FwdEdge   = "forward edge"+  show CrossEdge = "cross edge"
+ Data/Graph/Libgraph/Dominance.hs view
@@ -0,0 +1,38 @@+module Data.Graph.Libgraph.Dominance+( Domsets+, getDomsets+, getDominators+) where+import Data.Graph.Libgraph.Core+import Data.Graph.Libgraph.Dot+import Data.List++data Domsets vertex arc = Domsets { graph :: Graph vertex arc, sets :: [(vertex,[vertex])] }++-- | Vertices dominating the vertex given as argument.+getDominators :: Eq vertex => vertex -> Domsets vertex arc -> [vertex]+getDominators v = lkup . sets+  where lkup vs = lookup' v vs "Libgraph.getDomintors: lookup of dominator failed"++-- | Compute dominator sets.+-- N.B. currently a naive algorithm is implemented with time-complexity O(vertex^2).+getDomsets :: Eq vertex => Graph vertex arc -> Domsets vertex arc+getDomsets g = dom domset0+  where domset0 = Domsets g $ map (\v -> (v, if v == r then [r] else vs)) vs+        vs      = vertices g+        r       = root g++dom :: Eq vertex => Domsets vertex arc -> Domsets vertex arc+dom ds = if sets ds' == sets ds then ds else dom ds'+  where ds'          = ds { sets = map update (sets ds) }+        update (v,_) = if v == r then (v,[v]) else (v, sets' v)+        sets' v      = [v] `union` isets v+        isets v      = foldl (\s p -> (getDominators p ds) `intersect` s) vs (preds g v)+        vs           = vertices g+        r            = root g+        g            = graph ds++instance (Eq vertex,Show vertex) => Show (Domsets vertex arc) where+  show d = showWith (graph d) showVertex showArc+    where showVertex v = show v ++ show (getDominators v d)+          showArc _    = ""
+ Data/Graph/Libgraph/Dot.hs view
@@ -0,0 +1,45 @@+module Data.Graph.Libgraph.Dot+( showWith+, escape+, display+) where+import Data.Graph.Libgraph.Core+import System.Process(runCommand)++-- | Convert Graph to String with functions to show vertices and arcs.+showWith :: Eq vertex => Graph vertex arc -> (vertex->String) -> (Arc vertex arc->String) -> String+showWith g vLabel aLabel+  = "diGraph G {\n"+  ++ "root [style=invis label=\"\"]\n"+  ++ foldl (\s v -> (showVertex vLabel v) ++ s) "" vs+  ++ "root -> " ++ vName r ++ "\n"+  ++ foldl (\s a -> (showArc vs aLabel a) ++ s) "" (arcs g)+  ++ "}\n"+  where vs = zip (vertices g) [0..]+        r  = lookup' (root g) vs "LibGraph.showWith: lookup root in vs failed"++showVertex :: (vertex->String) -> (vertex,Int) -> String+showVertex vLabel (v,i) +  = vName i ++ " [label=\"" ++ (escape . vLabel) v ++ "\"]\n"++showArc :: Eq vertex => [(vertex,Int)] -> (Arc vertex arc->String) -> (Arc vertex arc) -> String+showArc vs aLabel a+  = vName i ++ " -> " ++ vName j ++ " [label=\"" ++ (escape . aLabel) a ++ "\"]\n"+  where i = lookup' (source a) vs $ "LibGraph.showArc: lookup source failed" +        j = lookup' (target a) vs $ "LibGraph.showArc: lookup target failed"+        +vName :: Int -> String+vName i = "v" ++ show i++escape :: String -> String+escape []          = []+escape ('"' : ss)  = '\\' : '"'   : escape ss+escape ('\\' : ss)  = '\\' : '\\' : escape ss+escape (s   : ss)  = s : escape ss++-- | Invoke Graphviz and Imagemagick to display graph on screen.+display :: (Graph vertex arc -> String) -> Graph vertex arc -> IO ()+display sh g = do +  writeFile "/tmp/test.dot" (sh g)+  runCommand $ "cat /tmp/test.dot | dot -Tpng | display -"+  return ()
+ Data/Graph/Libgraph/UnionFind.hs view
@@ -0,0 +1,31 @@+module Data.Graph.Libgraph.UnionFind+( UF+, fromList+, find+, union+) where++import Data.UnionFind.IntMap( Point,PointSupply,newPointSupply+                            , fresh,repr,descriptor)+import qualified Data.UnionFind.IntMap as UF+import Data.IntMap.Lazy(IntMap,(!))+import qualified Data.IntMap.Lazy as IM++data UF = UF {ps :: PointSupply Int, im :: IntMap (Point Int)}++fromList :: [Int] -> UF+fromList xs = foldl singleton (UF newPointSupply IM.empty) xs++singleton :: UF -> Int -> UF+singleton uf x = UF ps' $ IM.insert x p (im uf)+  where (ps',p) = fresh (ps uf) x++point :: UF -> Int -> Point Int+point uf i = (im uf) ! i++-- MF TODO: isn't the find supposed to update uf?+find :: UF -> Int -> Int+find uf = (descriptor $ ps uf) . (repr $ ps uf) . (point uf)++union :: UF -> Int -> Int -> UF+union uf x y = uf { ps = UF.union (ps uf) (point uf x) (point uf y) }
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Maarten Faddegon++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Maarten Faddegon nor the names of other+      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,2 @@+import Distribution.Simple+main = defaultMain
+ libgraph.cabal view
@@ -0,0 +1,34 @@+Name:           libgraph
+Version:        1.3
+Homepage:      http://maartenfaddegon.nl
+Synopsis:       Store and manipulate data in a graph.
+Description:    A graph type, analysis of graphs and manipulation of graphs.
+License:        BSD3
+license-file:   LICENSE
+Author:         Maarten Faddegon
+Maintainer:     libgraph@maartenfaddegon.nl
+Copyright:      (c) 2014 Maarten Faddegon
+Category:       Algorithms, Data Structures
+Build-Type:     Simple
+Cabal-Version:  >= 1.10
+
+library
+  Build-Depends:     base >= 4 && < 5, monads-tf, union-find, 
+                     containers, array, process
+  exposed-modules:   Data.Graph.Libgraph  
+  other-modules:     Data.Graph.Libgraph.DepthFirst,
+                     Data.Graph.Libgraph.Dominance,
+                     Data.Graph.Libgraph.Cycles,
+                     Data.Graph.Libgraph.Core,
+                     Data.Graph.Libgraph.Dot
+                     Data.Graph.Libgraph.UnionFind
+                     Data.Graph.Libgraph.Dagify
+                     Data.Graph.Libgraph.AlgoDebug
+  default-language:  Haskell2010
+  ghc-prof-options:  -auto-all
+
+-- Executable Libgraph-test
+--   Build-Depends:     base >= 4 && < 5, monads-tf, process
+--   main-is:           Test.hs
+--   default-language:  Haskell2010
+--   ghc-prof-options:  -auto-all