120 lines
4.0 KiB
Haskell
120 lines
4.0 KiB
Haskell
{-| Combining and composing trees of trees. -}
|
|
module Dodge.Tree.Compose
|
|
( expandTreeBy
|
|
, appendEitherTree
|
|
, connectRoom
|
|
, connectTrunk
|
|
, deadRoom
|
|
, linkEitherTrees
|
|
, expandTree
|
|
, singleUseAll
|
|
, singleUseNone
|
|
, passUntilUseAll
|
|
, chainUses
|
|
, useAllAtEnd
|
|
) where
|
|
import Dodge.Tree.Compose.Data
|
|
import Data.Tree
|
|
|
|
expandTree :: CompTree a -> Tree a
|
|
expandTree (Node root extChildren) = case root of
|
|
Node (UseAll x) _ -> Node x (map expandTree extChildren)
|
|
Node (UseSome is x) _ -> Node x (map expandTree $ map (\i -> extChildren !! i) is)
|
|
Node (UseNone _) _ -> fmap _unCompose root
|
|
Node (PassDown x) xs -> Node x $ map (expandTree . (\ct -> Node ct extChildren)) xs
|
|
Node (SplitDown x) xs -> Node x $ map expandTree $ zipWith Node xs
|
|
$ map (:[]) extChildren ++ repeat []
|
|
|
|
expandTreeBy
|
|
:: (a -> SubCompTree b) -- ^ Node function
|
|
-> Tree a -- ^ Base tree
|
|
-> Tree b
|
|
expandTreeBy f (Node x []) = fmap _unCompose (f x)
|
|
expandTreeBy f (Node x xs) = appendAndRemove $ f x
|
|
where
|
|
appendAndRemove (Node (PassDown y) ys) = Node y (map appendAndRemove ys)
|
|
appendAndRemove (Node (UseAll y) _ ) = Node y (map (expandTreeBy f) xs)
|
|
|
|
|
|
---- | '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'
|
|
|
|
appendEitherTree = passUntilUseAll
|
|
|
|
passUntilUseAll :: SubCompTree a -> [SubCompTree a] -> SubCompTree a
|
|
passUntilUseAll (Node (UseAll x) _) ts' = Node (PassDown x) ts'
|
|
passUntilUseAll (Node cn ts) ts' = Node (PassDown (_unCompose cn)) $ map (`passUntilUseAll` ts') ts
|
|
|
|
--linkEitherTrees :: [Tree (Either a a)] -> Tree (Either a a)
|
|
--linkEitherTrees (t:s:ts) = linkEitherTrees (appendEitherTree t [s]:ts)
|
|
--linkEitherTrees [t] = t
|
|
--linkEitherTrees [] = error "tried to concatenate an empty list of either trees"
|
|
|
|
linkEitherTrees = chainUses
|
|
|
|
chainUses :: [SubCompTree a] -> SubCompTree a
|
|
chainUses (t:s:ts) = chainUses (passUntilUseAll t [s]:ts)
|
|
chainUses [t] = t
|
|
chainUses [] = error "tried to concatenate an empty list of SubCompTrees"
|
|
|
|
removeEither = _unCompose
|
|
|
|
-- this is _unCompose
|
|
--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) []
|
|
|
|
connectRoom = singleUseAll
|
|
|
|
singleUseAll :: a -> Tree (ComposingNode a)
|
|
singleUseAll x = Node (UseAll x) []
|
|
|
|
{- |
|
|
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) []
|
|
--
|
|
connectTrunk = useAllAtEnd
|
|
useAllAtEnd :: Tree a -> SubCompTree a
|
|
useAllAtEnd tree = case tree of
|
|
Node x (t:ts) -> Node (PassDown x) (useAllAtEnd t : map (fmap UseNone) ts)
|
|
Node x [] -> Node (UseAll x) []
|
|
|
|
{- |
|
|
Make a singleton dead end of an Either Tree.
|
|
-}
|
|
--deadRoom :: a -> Tree (Either a a)
|
|
--deadRoom r = Node (Left r) []
|
|
|
|
deadRoom = singleUseNone
|
|
|
|
singleUseNone :: a -> SubCompTree a
|
|
singleUseNone x = Node (UseNone x) []
|