-- |
-- Copyright : (c) 2010,2012 Simon Meier
-- License : GPL v3 (see LICENSE)
--
-- Maintainer : Simon Meier <iridcode@gmail.com>
--
-- Simple vertice list based representation of DAGs and some common operations on it.
module Data.DAG.Simple (
-- * Computing with binary relations
Relation
, inverse
, image
, reachableSet
, restrict
-- ** Cycles
, dfsLoopBreakers
, cyclic
, toposort
) where
import Control.Basics
import Control.Monad.Writer
import Control.Monad.RWS
import Data.List
import qualified Data.DList as D
import qualified Data.Set as S
-- import Test.QuickCheck.Property (label)
-- import Test.QuickCheck (quickCheck)
-- | Produce a topological sorting of the given relation. If the relation is
-- cyclic, then the result is at least some permutation of all elements of
-- the given relation.
toposort :: Ord a => [(a, a)] -> [a]
toposort dag =
execWriter . foldM visit S.empty $ map fst dag ++ map snd dag
where
visit visited x
| x `S.member` visited = return visited
| otherwise =
foldM visit (S.insert x visited) preds <* tell (pure x)
where
preds = x `image` inverse dag
-- | Compute the set of nodes reachable from the given set of nodes.
reachableSet :: Ord a => [a] -> [(a,a)] -> S.Set a
reachableSet start dag =
foldl' visit S.empty start
where
visit visited x
| x `S.member` visited = visited
| otherwise =
foldl' visit (S.insert x visited) (x `image` dag)
-- | Is the relation cyclic.
cyclic :: Ord a => [(a,a)] -> Bool
cyclic rel =
maybe True (const False) $ foldM visitForest S.empty $ map fst rel
where
visitForest visited x
| x `S.member` visited = return visited
| otherwise = findLoop S.empty visited x
findLoop parents visited x
| x `S.member` parents = mzero
| x `S.member` visited = return visited
| otherwise =
S.insert x <$> foldM (findLoop parents') visited next
where
next = [ e' | (e,e') <- rel, e == x ]
parents' = S.insert x parents
-- TODO: Consider implementing something along the lines of Ann Becker, Dan
-- Geiger, Optimization of Pearl's method of conditioning and greedy-like
-- approximation algorithms for the vertex feedback set problem, Artificial
-- Intelligence, Volume 83, Issue 1, May 1996, Pages 167-188, ISSN 0004-3702,
-- 10.1016/0004-3702(95)00004-6.
-- <http://www.sciencedirect.com/science/article/pii/0004370295000046>.
-- | Compute a minimal set of loop-breakers using a greedy DFS strategy. A set
-- of loop-breakers is a set of nodes such that removing them ensures the
-- acyclicity of the relation. It is minimal, if no node can be removed from
-- the set.
dfsLoopBreakers :: Ord a => [(a,a)] -> [a]
dfsLoopBreakers rel =
D.toList $ snd $ execRWS (mapM_ (visit . fst) rel) () S.empty
where
visit x = do
visited <- gets (S.member x)
unless visited $ findLoopBreakers S.empty x
-- PRE: x0 is not yet visited
findLoopBreakers parents0 x = do
modify (S.insert x)
let parents = S.insert x parents0
ys = x `image` rel
if any (`S.member` parents) ys
then tell (return x)
else forM_ ys $ \y -> do
visited <- gets (S.member y)
unless visited $ findLoopBreakers parents y
-- | A relation represented as a list of tuples.
type Relation a = [(a,a)]
-- | Restrict a relation to elements satisfying a predicate.
restrict :: Eq a => (a -> Bool) -> Relation a -> Relation a
restrict p = filter (\(x,y) -> p x && p y)
-- | The image of an element under a 'Relation'.
image :: Eq a => a -> Relation a -> [a]
image x rel = [ y' | (x', y') <- rel, x == x' ]
-- | The inverse of a 'Relation'.
inverse :: Relation a -> Relation a
inverse rel = [ (y,x) | (x, y) <- rel ]
{-
prop_dfsLoopBreakers noSelfLoops rel0
| cyclic rel = label cycleLabel (minimal && not (cyclic (rel' breakers)))
| otherwise = label "acyclic" (null breakers)
where
-- remove (x,x) entries in half of the cases
removeSelfLoops | noSelfLoops = filter (not . (uncurry (==)))
| otherwise = id
-- restrict the relation to get more cyclic cases
rel = removeSelfLoops $ map ((`mod` (20 :: Int)) *** (`mod` 20)) rel0
rel' bs = restrict (not . (`elem` bs)) rel
breakers = dfsLoopBreakers rel
cycleLabel | any (uncurry (==)) rel = "cyclic (with self-loop)"
| otherwise = "cyclic (no self-loop)"
-- true if loop breakers are minimal
minimal = all (\b -> cyclic (rel' (filter (/= b) breakers))) breakers
-}