-- |
-- 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
-}