57 lines
1.7 KiB
Haskell
57 lines
1.7 KiB
Haskell
{-|
|
|
Combining and composing trees with 'Either' nodes.
|
|
-}
|
|
module Dodge.Layout.Tree.Either
|
|
( expandTreeBy
|
|
, appendEitherTree
|
|
, connectRoom
|
|
, connectTrunk
|
|
, deadRoom
|
|
) where
|
|
import Data.Tree
|
|
|
|
-- | 'Left' elements get new children as given by the node function,
|
|
-- 'Right' elements inherit the children from the base tree
|
|
expandTreeBy
|
|
:: (a -> Tree (Either b b)) -- ^ Node function
|
|
-> Tree a -- ^ Base tree
|
|
-> Tree b
|
|
expandTreeBy f (Node x []) = fmap removeEither (f x)
|
|
expandTreeBy f (Node x xs) = appendAndRemove $ f x
|
|
where
|
|
appendAndRemove (Node (Left y) ys) = Node y (map appendAndRemove ys)
|
|
appendAndRemove (Node (Right y) _ ) = Node y (map (expandTreeBy f) xs)
|
|
|
|
-- | Appends a second either forest at the 'Right' elements of a first either
|
|
-- tree.
|
|
-- Makes such 'Right' elements into 'Left's.
|
|
appendEitherTree
|
|
:: Tree (Either a a) -- ^ The first tree
|
|
-> [Tree (Either a a)] -- ^ The forest to append
|
|
-> Tree (Either a a)
|
|
appendEitherTree (Node (Left x) ts) ts' = Node (Left x) $ map (`appendEitherTree` ts') ts
|
|
appendEitherTree (Node (Right x) _) ts' = Node (Left x) ts'
|
|
|
|
removeEither :: Either p p -> p
|
|
removeEither (Left y) = y
|
|
removeEither (Right y) = y
|
|
|
|
{- |
|
|
Make a singleton connection of an Either Tree.
|
|
-}
|
|
connectRoom :: a -> Tree (Either a a)
|
|
connectRoom r = Node (Right r) []
|
|
|
|
{- |
|
|
Make a single Either connection at the end of a tree.
|
|
-}
|
|
connectTrunk :: Tree a -> Tree (Either a a)
|
|
connectTrunk (Node x (t:ts)) = Node (Left x) (connectTrunk t : map (fmap Left) ts)
|
|
connectTrunk (Node x []) = Node (Right x) []
|
|
|
|
{- |
|
|
Make a singleton dead end of an Either Tree.
|
|
-}
|
|
deadRoom :: a -> Tree (Either a a)
|
|
deadRoom r = Node (Left r) []
|