DAG tree view model builder, based on (V, E) and user choices
This commit is contained in:
parent
7d6ef47e05
commit
e7abd8eb9d
2 changed files with 160 additions and 0 deletions
159
src/Data/Graph/DirectedAcyclic/View/Tree.hs
Normal file
159
src/Data/Graph/DirectedAcyclic/View/Tree.hs
Normal file
|
@ -0,0 +1,159 @@
|
||||||
|
{- This file is part of Vervis.
|
||||||
|
-
|
||||||
|
- Written in 2016 by fr33domlover <fr33domlover@riseup.net>.
|
||||||
|
-
|
||||||
|
- ♡ 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
|
||||||
|
- <http://creativecommons.org/publicdomain/zero/1.0/>.
|
||||||
|
-}
|
||||||
|
|
||||||
|
-- | 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
|
|
@ -53,6 +53,7 @@ library
|
||||||
Data.EventTime.Local
|
Data.EventTime.Local
|
||||||
Data.Functor.Local
|
Data.Functor.Local
|
||||||
Data.Git.Local
|
Data.Git.Local
|
||||||
|
Data.Graph.DirectedAcyclic.View.Tree
|
||||||
Data.Graph.Inductive.Query.Cycle
|
Data.Graph.Inductive.Query.Cycle
|
||||||
Data.Graph.Inductive.Query.Layer
|
Data.Graph.Inductive.Query.Layer
|
||||||
Data.Graph.Inductive.Query.Path
|
Data.Graph.Inductive.Query.Path
|
||||||
|
|
Loading…
Reference in a new issue