```-- |
-- Copyright   : (c) 2010,2012 Simon Meier
--
-- 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           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
-}
```