mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-29 14:34:52 +09:00
Generelize DAG tree view node from Int to any Eq+Ord+Hashable
This commit is contained in:
parent
e7abd8eb9d
commit
3807a02daf
1 changed files with 25 additions and 16 deletions
|
@ -24,6 +24,7 @@ import Prelude
|
||||||
|
|
||||||
import Control.Arrow ((***))
|
import Control.Arrow ((***))
|
||||||
import Data.Function (on)
|
import Data.Function (on)
|
||||||
|
import Data.Hashable (Hashable)
|
||||||
import Data.HashMap.Lazy (HashMap)
|
import Data.HashMap.Lazy (HashMap)
|
||||||
import Data.HashSet (HashSet)
|
import Data.HashSet (HashSet)
|
||||||
import Data.List (groupBy, sortOn)
|
import Data.List (groupBy, sortOn)
|
||||||
|
@ -32,17 +33,18 @@ import Data.Monoid (Endo (..))
|
||||||
import qualified Data.HashMap.Lazy as M
|
import qualified Data.HashMap.Lazy as M
|
||||||
import qualified Data.HashSet as S
|
import qualified Data.HashSet as S
|
||||||
|
|
||||||
type Graph a b = HashMap Int (a, [(Int, b)])
|
type Graph n a b = HashMap n (a, [(n, b)])
|
||||||
|
|
||||||
data DagViewTree a b = FullNode a [DagViewTree a b] | LinkNode 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.
|
-- | Update the map according to a choice of a full parent for a given child.
|
||||||
-- Also specifies whether the choice was sucessfully applied.
|
-- Also specifies whether the choice was sucessfully applied.
|
||||||
chooseParent
|
chooseParent
|
||||||
:: Int
|
:: (Eq n, Hashable n)
|
||||||
-> Int
|
=> n
|
||||||
-> HashMap Int [(Int, Bool)]
|
-> n
|
||||||
-> Maybe (HashMap Int [(Int, Bool)])
|
-> HashMap n [(n, Bool)]
|
||||||
|
-> Maybe (HashMap n [(n, Bool)])
|
||||||
chooseParent c p h =
|
chooseParent c p h =
|
||||||
case M.lookup c h of
|
case M.lookup c h of
|
||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
|
@ -70,28 +72,30 @@ markFst :: [a] -> [(a, Bool)]
|
||||||
markFst [] = []
|
markFst [] = []
|
||||||
markFst (x:xs) = (x, True) : map (, False) xs
|
markFst (x:xs) = (x, True) : map (, False) xs
|
||||||
|
|
||||||
labeledDeps :: HashMap Int [(Int, b)] -> [(Int, Int, b)]
|
labeledDeps :: Hashable n => HashMap n [(n, b)] -> [(n, n, b)]
|
||||||
labeledDeps =
|
labeledDeps =
|
||||||
let mk c (p, full) = (c, p, full)
|
let mk c (p, full) = (c, p, full)
|
||||||
in concatMap (\ (c, ps) -> map (mk c) ps) . M.toList
|
in concatMap (\ (c, ps) -> map (mk c) ps) . M.toList
|
||||||
|
|
||||||
edgeView
|
edgeView
|
||||||
:: HashMap Int Int
|
:: (Eq n, Hashable n)
|
||||||
|
=> HashMap n n
|
||||||
-- ^ Full parent user choices
|
-- ^ Full parent user choices
|
||||||
-> (Int, Int, Bool)
|
-> (n, n, Bool)
|
||||||
-- ^ Child, parent, and whether the parent is full
|
-- ^ Child, parent, and whether the parent is full
|
||||||
-> Maybe (HashMap Int Int)
|
-> Maybe (HashMap n n)
|
||||||
-- ^ New edge label. For a full edge, 'Nothing'. For a link edge, 'Just' an
|
-- ^ 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
|
-- updated choice map that chooses this edge as the new full edge for the
|
||||||
-- child.
|
-- child.
|
||||||
edgeView _ (_, _, False) = Nothing
|
edgeView _ (_, _, False) = Nothing
|
||||||
edgeView choices (child, parent, True) = Just $ M.insert child parent choices
|
edgeView choices (child, parent, True) = Just $ M.insert child parent choices
|
||||||
|
|
||||||
reverseEdge :: (Int, Int, a) -> (Int, Int, a)
|
reverseEdge :: (n, n, a) -> (n, n, a)
|
||||||
reverseEdge (x, y, l) = (y, x, l)
|
reverseEdge (x, y, l) = (y, x, l)
|
||||||
|
|
||||||
-- | Given labeled nodes and labeled edges, prepare a hashmap.
|
-- | Given labeled nodes and labeled edges, prepare a hashmap.
|
||||||
mkGraph :: HashMap Int a -> [(Int, Int, b)] -> Graph a b
|
mkGraph
|
||||||
|
:: (Eq n, Ord n, Hashable n) => HashMap n a -> [(n, n, b)] -> Graph n a b
|
||||||
mkGraph nodeMap edges =
|
mkGraph nodeMap edges =
|
||||||
let pair23 (x, y, z) = (x, (y, z))
|
let pair23 (x, y, z) = (x, (y, z))
|
||||||
edgeMap = M.fromList $ groupSnd $ sortOn fst $ map pair23 edges
|
edgeMap = M.fromList $ groupSnd $ sortOn fst $ map pair23 edges
|
||||||
|
@ -102,7 +106,11 @@ mkGraph nodeMap edges =
|
||||||
keySet :: HashMap k v -> HashSet k
|
keySet :: HashMap k v -> HashSet k
|
||||||
keySet = S.fromMap . M.map (const ())
|
keySet = S.fromMap . M.map (const ())
|
||||||
|
|
||||||
buildTree :: [(Int, Maybe b)] -> Graph a (Maybe b) -> [DagViewTree a (a, b)]
|
buildTree
|
||||||
|
:: (Eq n, Hashable n)
|
||||||
|
=> [(n, Maybe b)]
|
||||||
|
-> Graph n a (Maybe b)
|
||||||
|
-> [DagViewTree a (a, b)]
|
||||||
buildTree nodes graph = go nodes
|
buildTree nodes graph = go nodes
|
||||||
where
|
where
|
||||||
go [] = []
|
go [] = []
|
||||||
|
@ -120,15 +128,16 @@ buildTree nodes graph = go nodes
|
||||||
in LinkNode (fst c, info) : ts
|
in LinkNode (fst c, info) : ts
|
||||||
|
|
||||||
dagViewTree
|
dagViewTree
|
||||||
:: [(Int, a)]
|
:: (Eq n, Ord n, Hashable n)
|
||||||
|
=> [(n, a)]
|
||||||
-- ^ Nodes: Numbers and details
|
-- ^ Nodes: Numbers and details
|
||||||
-> [(Int, Int)]
|
-> [(n, n)]
|
||||||
-- ^ Edges: Child-parent pairs
|
-- ^ Edges: Child-parent pairs
|
||||||
-> [(Int, Int)]
|
-> [(n, n)]
|
||||||
-- ^ Full parent choices as child-parent pairs. This is whatever user input
|
-- ^ Full parent choices as child-parent pairs. This is whatever user input
|
||||||
-- has been received, even if it includes duplicates or nonexistent node
|
-- has been received, even if it includes duplicates or nonexistent node
|
||||||
-- numbers. So just pass the user input directly here.
|
-- numbers. So just pass the user input directly here.
|
||||||
-> [DagViewTree a (a, HashMap Int Int)]
|
-> [DagViewTree a (a, HashMap n n)]
|
||||||
dagViewTree nodes deps choices =
|
dagViewTree nodes deps choices =
|
||||||
let choose ns@(c, p) acc@(h, l) =
|
let choose ns@(c, p) acc@(h, l) =
|
||||||
case chooseParent c p h of
|
case chooseParent c p h of
|
||||||
|
|
Loading…
Reference in a new issue