module Data.EdgeTree (
EdgeTree(..)
, TreeEdge(..)
, createEdgeTree
, filterEdgeTree
, filterEdgeTree'
, mapEdgeTree
, mapEdgeTree'
, mapTop
, truncateEdgeTree
, putEdgeForest
, hPutEdgeForest
, putEdgeTree
, putEdgeTree'
, hPutEdgeTree
, hPutEdgeTree'
, putTreeEdge'
, hPutTreeEdge'
) where
import System.IO (Handle, hPutStrLn, stdout)
data EdgeTree e v =
EdgeTree {
vertex :: v
, edges :: [TreeEdge e v]
}
deriving (Read, Show)
instance Functor (EdgeTree e) where
fmap f (EdgeTree v ee) = EdgeTree (f v) (map (fmap f) ee)
instance Foldable (EdgeTree e) where
foldMap f (EdgeTree v []) = f v
foldMap f (EdgeTree v ee) = mconcat (f v : map (foldMap f) ee)
instance Traversable (EdgeTree e) where
traverse f (EdgeTree v ee) =
EdgeTree
<$> f v
<*> sequenceA (map (traverse f) ee)
data TreeEdge e v =
TreeEdge {
edge :: e
, target :: EdgeTree e v
}
deriving (Read, Show)
instance Functor (TreeEdge e) where
fmap f (TreeEdge e t) = TreeEdge e (fmap f t)
instance Foldable (TreeEdge e) where
foldMap f (TreeEdge _ t) = foldMap f t
instance Traversable (TreeEdge e) where
traverse f (TreeEdge e t) =
TreeEdge e
<$> traverse f t
createEdgeTree ::
(a -> v)
-> (a -> e)
-> (a -> [a])
-> a
-> EdgeTree e v
createEdgeTree vertexLabeller edgeLabeller generator start =
EdgeTree {
vertex = vertexLabeller start
, edges = map (createTreeEdge vertexLabeller edgeLabeller generator) $ generator start
}
createTreeEdge ::
(a -> v)
-> (a -> e)
-> (a -> [a])
-> a
-> TreeEdge e v
createTreeEdge vertexLabeller edgeLabeller generator start =
TreeEdge {
edge = edgeLabeller start
, target = createEdgeTree vertexLabeller edgeLabeller generator start
}
filterEdgeTree ::
((v, e, v) -> Bool)
-> EdgeTree e v
-> EdgeTree e v
filterEdgeTree f edgeTree@(EdgeTree v ee) =
edgeTree {
edges = map filterTreeEdge $ filter filterVertex ee
}
where
filterVertex (TreeEdge e (EdgeTree v' _)) = f (v, e, v')
filterTreeEdge treeEdge@(TreeEdge _ t) = treeEdge {target = filterEdgeTree f t}
filterEdgeTree' ::
(v -> e -> Bool)
-> EdgeTree e v
-> EdgeTree e v
filterEdgeTree' = filterEdgeTree . uncurry2of3
mapEdgeTree ::
((v, e, v) -> w)
-> w
-> EdgeTree e v
-> EdgeTree e w
mapEdgeTree f start (EdgeTree v ee) =
EdgeTree {
vertex = start
, edges = map mapTreeEdge ee
}
where
mapTreeEdge treeEdge@(TreeEdge e t@(EdgeTree v' _)) =
treeEdge {
target = mapEdgeTree f (f (v, e, v')) t
}
mapEdgeTree' ::
(v -> e -> w)
-> w
-> EdgeTree e v
-> EdgeTree e w
mapEdgeTree' = mapEdgeTree . uncurry2of3
uncurry2of3 :: (a -> b -> d) -> (a, b, c) -> d
uncurry2of3 f (x, y, _) = f x y
mapTop :: (EdgeTree e v -> a) -> EdgeTree e v -> [(e, a)]
mapTop f (EdgeTree _ edges') = map (\(TreeEdge edge' target') -> (edge', f target')) edges'
truncateEdgeTree :: Int -> EdgeTree e v -> EdgeTree e v
truncateEdgeTree 0 (EdgeTree vertex' _) = EdgeTree vertex' []
truncateEdgeTree n (EdgeTree vertex' edges') = EdgeTree vertex' $ map (truncateTreeEdge (n 1)) edges'
truncateTreeEdge :: Int -> TreeEdge e v -> TreeEdge e v
truncateTreeEdge n (TreeEdge edge' target') = TreeEdge edge' $ truncateEdgeTree n target'
putEdgeForest ::
Int
-> (a -> String)
-> (v -> String)
-> (e -> String)
-> [(a, EdgeTree e v)]
-> IO ()
putEdgeForest = hPutEdgeForest stdout
hPutEdgeForest ::
Handle
-> Int
-> (a -> String)
-> (v -> String)
-> (e -> String)
-> [(a, EdgeTree e v)]
-> IO ()
hPutEdgeForest handle depth showGroup showVertex showEdge =
do
let
putGroup (group, edgeTree) =
do
hPutStrLn handle $ showGroup group
hPutEdgeTree' handle depth ". " showVertex showEdge edgeTree
mapM_ putGroup
putEdgeTree ::
Int
-> (v -> String)
-> (e -> String)
-> EdgeTree e v
-> IO ()
putEdgeTree = hPutEdgeTree stdout
putEdgeTree' ::
Int
-> String
-> (v -> String)
-> (e -> String)
-> EdgeTree e v
-> IO ()
putEdgeTree' = hPutEdgeTree' stdout
hPutEdgeTree ::
Handle
-> Int
-> (v -> String)
-> (e -> String)
-> EdgeTree e v
-> IO ()
hPutEdgeTree = flip flip "" . hPutEdgeTree'
hPutEdgeTree' ::
Handle
-> Int
-> String
-> (v -> String)
-> (e -> String)
-> EdgeTree e v
-> IO ()
hPutEdgeTree' handle depth indent showVertex showEdge (EdgeTree v ee) =
do
hPutStrLn handle $ indent ++ showVertex v
mapM_ (hPutTreeEdge' handle depth (indent ++ ". ") showVertex showEdge) ee
putTreeEdge' ::
Int
-> String
-> (v -> String)
-> (e -> String)
-> TreeEdge e v
-> IO ()
putTreeEdge' = hPutTreeEdge' stdout
hPutTreeEdge' ::
Handle
-> Int
-> String
-> (v -> String)
-> (e -> String)
-> TreeEdge e v
-> IO ()
hPutTreeEdge' handle depth indent showVertex showEdge (TreeEdge e t) =
do
hPutStrLn handle $ indent ++ showEdge e
if depth > 0
then hPutEdgeTree' handle (depth 1) (indent ++ ". ") showVertex showEdge t
else hPutStrLn handle $ indent ++ ". <<TRUNCATED>>"