diff --git a/src/Data/Graph/DirectedAcyclic/View/Tree.hs b/src/Data/Graph/DirectedAcyclic/View/Tree.hs new file mode 100644 index 0000000..c7b6c70 --- /dev/null +++ b/src/Data/Graph/DirectedAcyclic/View/Tree.hs @@ -0,0 +1,159 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +-- | An interactive tree view model for acyclic directed graphs. +module Data.Graph.DirectedAcyclic.View.Tree + ( DagViewTree (..) + , dagViewTree + ) +where + +import Prelude + +import Control.Arrow ((***)) +import Data.Function (on) +import Data.HashMap.Lazy (HashMap) +import Data.HashSet (HashSet) +import Data.List (groupBy, sortOn) +import Data.Monoid (Endo (..)) + +import qualified Data.HashMap.Lazy as M +import qualified Data.HashSet as S + +type Graph a b = HashMap Int (a, [(Int, b)]) + +data DagViewTree a b = FullNode a [DagViewTree a b] | LinkNode b + +-- | Update the map according to a choice of a full parent for a given child. +-- Also specifies whether the choice was sucessfully applied. +chooseParent + :: Int + -> Int + -> HashMap Int [(Int, Bool)] + -> Maybe (HashMap Int [(Int, Bool)]) +chooseParent c p h = + case M.lookup c h of + Nothing -> Nothing + Just l -> + case break ((== p) . fst) l of + (_, []) -> Nothing + (before, (_ : after)) -> + let clear = map $ id *** const False + l' = clear before ++ (p, True) : clear after + in Just $ M.insert c l' h + +-- | Like 'group' but specific to pairs, and collects the 'snd' of items with +-- the same 'fst' into lists. +-- +-- >>> groupSnd [(1,1), (1,2), (3,3), (3,4), (3,5), (6,6)] +-- [(1, [1,2]), (3, [3,4,5]), (6, [6])] +groupSnd :: Eq a => [(a, b)] -> [(a, [b])] +groupSnd = + let collect [] = error "groupSnd: groupBy returned null element" + collect ((x, y) : l) = (x, y : map snd l) + in map collect . groupBy ((==) `on` fst) + +-- | Pair the first item with 'True' and the rest with 'False'. +markFst :: [a] -> [(a, Bool)] +markFst [] = [] +markFst (x:xs) = (x, True) : map (, False) xs + +labeledDeps :: HashMap Int [(Int, b)] -> [(Int, Int, b)] +labeledDeps = + let mk c (p, full) = (c, p, full) + in concatMap (\ (c, ps) -> map (mk c) ps) . M.toList + +edgeView + :: HashMap Int Int + -- ^ Full parent user choices + -> (Int, Int, Bool) + -- ^ Child, parent, and whether the parent is full + -> Maybe (HashMap Int Int) + -- ^ New edge label. For a full edge, 'Nothing'. For a link edge, 'Just' an + -- updated choice map that chooses this edge as the new full edge for the + -- child. +edgeView _ (_, _, False) = Nothing +edgeView choices (child, parent, True) = Just $ M.insert child parent choices + +reverseEdge :: (Int, Int, a) -> (Int, Int, a) +reverseEdge (x, y, l) = (y, x, l) + +-- | Given labeled nodes and labeled edges, prepare a hashmap. +mkGraph :: HashMap Int a -> [(Int, Int, b)] -> Graph a b +mkGraph nodeMap edges = + let pair23 (x, y, z) = (x, (y, z)) + edgeMap = M.fromList $ groupSnd $ sortOn fst $ map pair23 edges + addEdges n nl = (nl, M.lookupDefault [] n edgeMap) + in M.mapWithKey addEdges nodeMap + +-- | Turn 'HashMap' into a 'HashSet' of its keys. +keySet :: HashMap k v -> HashSet k +keySet = S.fromMap . M.map (const ()) + +buildTree :: [(Int, Maybe b)] -> Graph a (Maybe b) -> [DagViewTree a (a, b)] +buildTree nodes graph = go nodes + where + go [] = [] + go ((n, full) : ps) = + case M.lookup n graph of + Nothing -> go ps + Just c -> + case full of + Nothing -> + let ts = go $ snd c + ts' = go ps + in FullNode (fst c) ts : ts' + Just info -> + let ts = go ps + in LinkNode (fst c, info) : ts + +dagViewTree + :: [(Int, a)] + -- ^ Nodes: Numbers and details + -> [(Int, Int)] + -- ^ Edges: Child-parent pairs + -> [(Int, Int)] + -- ^ Full parent choices as child-parent pairs. This is whatever user input + -- has been received, even if it includes duplicates or nonexistent node + -- numbers. So just pass the user input directly here. + -> [DagViewTree a (a, HashMap Int Int)] +dagViewTree nodes deps choices = + let choose ns@(c, p) acc@(h, l) = + case chooseParent c p h of + Nothing -> acc + Just h' -> (h', ns : l) + -- Function that applies all user choices + updateChoices = mconcat $ map (Endo . choose) choices + -- Dependency map with default full parents + dmapDef = M.fromList $ map (id *** markFst) $ groupSnd deps + -- Dep map with user choices applied, and list of choices that were + -- actually valid and successfully applied + (dmapUpd, params) = appEndo updateChoices (dmapDef, []) + -- Turn dep map back into a list + depList = labeledDeps dmapUpd + -- Turn valid choice list into a map + choiceMap = M.fromList params + -- Attach info to each link dep required for turning a full dep, and + -- reverse the deps to get actual DAG edges in parent-child order + attachEdgeView m d@(c, p, _) = (c, p, edgeView m d) + edgeList = map (reverseEdge . attachEdgeView choiceMap) depList + -- Turn node list into a map + nodeMap = M.fromList nodes + -- Attach labeled children to each node using the edge list + graph = mkGraph nodeMap edgeList + -- The tree's top level contains the nodes which have no parents + orphanSet = keySet nodeMap `S.difference` keySet dmapDef + orphanList = map (, Nothing) $ S.toList orphanSet + in buildTree orphanList graph diff --git a/vervis.cabal b/vervis.cabal index 402a407..04389a5 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -53,6 +53,7 @@ library Data.EventTime.Local Data.Functor.Local Data.Git.Local + Data.Graph.DirectedAcyclic.View.Tree Data.Graph.Inductive.Query.Cycle Data.Graph.Inductive.Query.Layer Data.Graph.Inductive.Query.Path