Ready for replacement of Either with bespoke data type for compo trees

src/Dodge/Tree/Compose.hs

@@ -0,0 +1,97 @@
+{-| 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 []
+
+-- | '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'
+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"
+
+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"
+
+-- 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) [] 
+
+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) []
+
+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) []
+
+singleUseNone :: a -> SubCompTree a
+singleUseNone x = Node (UseNone x) []