{-# LANGUAGE RecordWildCards #-}
module Data.Named.DAG
(
DAG (..)
, mkDAG
, unDAG
, vertex
, node
, edges
, maybeNode
, maybeEdges
, nodeV
, keyV
, edgesV
, toForest
, toForestBy
, roots
, leaves
) where
import Control.Applicative ((<$>))
import Data.List (sortBy, minimumBy)
import qualified Data.Set as S
import qualified Data.Tree as T
import qualified Data.Graph as G
data DAG k v = DAG {
graph :: G.Graph,
nodeDesc :: G.Vertex -> (v, k, [k]),
maybeVertex :: k -> Maybe G.Vertex }
maybeNode :: DAG k v -> k -> Maybe v
maybeNode DAG{..} k = _1 . nodeDesc <$> maybeVertex k
{-# INLINE maybeNode #-}
maybeEdges :: DAG k v -> k -> Maybe [k]
maybeEdges DAG{..} k = _3 . nodeDesc <$> maybeVertex k
{-# INLINE maybeEdges #-}
vertex :: Show k => DAG k v -> k -> G.Vertex
vertex dag k = case maybeVertex dag k of
Nothing -> error $ "vertex: key " ++ show k ++ " not in the graph"
Just x -> x
node :: Show k => DAG k v -> k -> v
node dag k = case maybeNode dag k of
Nothing -> error $ "node: key " ++ show k ++ " not in the graph"
Just x -> x
edges :: Show k => DAG k v -> k -> [k]
edges dag k = case maybeEdges dag k of
Nothing -> error $ "edges: key " ++ show k ++ " not in the graph"
Just x -> x
nodeV :: DAG k v -> G.Vertex -> v
nodeV DAG{..} = _1 . nodeDesc
{-# INLINE nodeV #-}
keyV :: DAG k v -> G.Vertex -> k
keyV DAG{..} = _2 . nodeDesc
{-# INLINE keyV #-}
edgesV :: DAG k v -> G.Vertex -> [k]
edgesV DAG{..} = _3 . nodeDesc
{-# INLINE edgesV #-}
leaves :: DAG k v -> [k]
leaves dag = [k | (_, k, []) <- unDAG dag]
roots :: Ord k => DAG k v -> [k]
roots dag =
let desc = S.fromList . concat . map _3 $ unDAG dag
in [k | (_, k, _) <- unDAG dag, not (k `S.member` desc)]
mkDAG :: (Show k, Ord k) => [(v, k, [k])] -> Maybe (DAG k v)
mkDAG xs
| any ((>1) . length . T.flatten) (G.scc _graph) = Nothing
| otherwise = Just $ DAG
{ graph = _graph
, nodeDesc = _nodeDesc
, maybeVertex = _maybeVertex }
where
(_graph, _nodeDesc, _maybeVertex) = G.graphFromEdges xs
unDAG :: DAG k v -> [(v, k, [k])]
unDAG DAG{..} = map nodeDesc (G.vertices graph)
toForestBy :: (Show k, Ord k) => (k -> k -> Ordering) -> DAG k v -> T.Forest k
toForestBy cmp dag@DAG{..} =
let proxy = minimumBy cmp . map (keyV dag)
. G.reachable graph . vertex dag
cmpRoots r r' = cmp (proxy r) (proxy r')
xs = map (vertex dag) . sortBy cmpRoots $ roots dag
in map (fmap (_2 . nodeDesc)) (G.dfs graph xs)
toForest :: (Show k, Ord k) => DAG k v -> T.Forest k
toForest = toForestBy compare
_1 :: (a, b, c) -> a
_1 (x, _, _) = x
{-# INLINE _1 #-}
_2 :: (a, b, c) -> b
_2 (_, x, _) = x
{-# INLINE _2 #-}
_3 :: (a, b, c) -> c
_3 (_, _, x) = x
{-# INLINE _3 #-}