vervis/src/Data/Graph/DirectedAcyclic/View/Tree.hs

{- 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.Hashable (Hashable)
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 n a b = HashMap n (a, [(n, 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
    :: (Eq n, Hashable n)
    => n
    -> n
    -> HashMap n [(n, Bool)]
    -> Maybe (HashMap n [(n, 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 :: Hashable n => HashMap n [(n, b)] -> [(n, n, b)]
labeledDeps =
    let mk c (p, full) = (c, p, full)
    in  concatMap (\ (c, ps) -> map (mk c) ps) . M.toList

edgeView
    :: (Eq n, Hashable n)
    => HashMap n n
    -- ^ Full parent user choices
    -> (n, n, Bool)
    -- ^ Child, parent, and whether the parent is full
    -> Maybe (HashMap n n)
    -- ^ 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 _       (_,     _,      True)  = Nothing
edgeView choices (child, parent, False) = Just $ M.insert child parent choices

reverseEdge :: (n, n, a) -> (n, n, a)
reverseEdge (x, y, l) = (y, x, l)

-- | Given labeled nodes and labeled edges, prepare a hashmap.
mkGraph
    :: (Eq n, Ord n, Hashable n) => HashMap n a -> [(n, n, b)] -> Graph n 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 ())

-- | Traverse a graph DFS-style and build a tree recording the traversal.
--
-- The code looks like a simple fold, because the edge labels are the ones
-- responsible for limiting the recursion into a tree structure.
--
-- The graph should have at most one full out-edge per node, and\/or have no
-- cycles, otherwise this function isn't guaranteed to stop.
buildTree
    :: (Eq n, Hashable n)
    => [(n, Maybe b)]
    -> Graph n 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
    -}

    let f (n, full) ts =
            case M.lookup n graph of
                Nothing -> ts
                Just c  ->
                    let t = case full of
                                Nothing   -> FullNode (fst c) (go $ snd c)
                                Just info -> LinkNode (fst c, info)
                    in  t : ts
        go = foldr f []
    in  go nodes

dagViewTree
    :: (Eq n, Ord n, Hashable n)
    => [(n, a)]
    -- ^ Nodes: Numbers and details
    -> [(n, n)]
    -- ^ Edges: Child-parent pairs
    -> [(n, n)]
    -- ^ 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 n n)]
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