Polymorphise meta tree labels

src/Dodge/Tree/Compose.hs

@@ -22,25 +22,12 @@ import TreeHelp
 --import Dodge.Base
 import LensHelp
 
-import Data.Bifunctor
-import Control.Monad.State
-import Data.Foldable
-import System.Random
+--import Data.Bifunctor
+--import Control.Monad.State
+--import Data.Foldable
+--import System.Random
 import Data.Maybe
 
---expandTree :: CompTree a -> Tree a
---expandTree (Node rt extChildren) = case rt of
---    Node (useAll x)     _   -> Node x (map expandTree extChildren)
---    Node (UseSome is x) _   -> Node x (map (expandTree . \i -> extChildren !! i) is)
---    Node (UseNone _)    _   -> fmap _unCompose rt
---    Node (useLabel _ _) _   -> fmap _unCompose rt
---    Node ( x)   xs  -> Node x $ map (expandTree . (`Node` extChildren)) xs
---    Node (SplitDown x)  xs  -> Node x $ map expandTree $ zipWith Node xs 
---            $ map (:[]) extChildren ++ repeat []
-
---applyToCompRoot :: (a -> a) -> Tree a -> Tree a
---applyToCompRoot f = over root (unCompose %~ f)
-
 overwriteLabel :: Int -> Tree Room -> [Tree Room] -> Tree Room
 overwriteLabel i t ts = safeUpdateSingleNode 
     (\rm -> LabelCluster i `elem` (rm ^?! rmClusterStatus . csLinks))
@@ -186,17 +173,17 @@ shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')
 --        brs <- mapM (composeAndSubLog is dolog) $ _btBranches mt
 --        return $ Node (_btValue mt) brs
 
-composeTree :: MetaTree a -> Tree a
+composeTree :: MetaTree a b -> Tree a
 composeTree mt = attachList' (composeNode $ _mtTree mt) (_mtBranches mt)
 
-composeNode :: MetaNode a -> Tree a
+composeNode :: MetaNode a b -> Tree a
 composeNode (NodeTree t) = t
 composeNode (NodeMTree mt) = composeTree mt
 
-attachList' :: Tree a -> [MetaBranch a] -> Tree a
+attachList' :: Tree a -> [MetaBranch a b] -> Tree a
 attachList' t xs = shiftChildren $ foldr attachBranch (fmap ([],) t) xs
 
-attachBranch :: MetaBranch a -> Tree ([Tree a],a) -> Tree ([Tree a],a)
+attachBranch :: MetaBranch a b -> Tree ([Tree a],a) -> Tree ([Tree a],a)
 attachBranch mb = safeUpdateSingleNode (isJust . upf . snd) 
     ( (root . _2 %~ g) . (root ._1 .:~ composeTree (_mbTree mb)) )
   where
@@ -204,14 +191,15 @@ attachBranch mb = safeUpdateSingleNode (isJust . upf . snd)
     g x = fromMaybe x (upf x)
 
 
-tToBTree :: Tree Room -> MetaTree Room
-tToBTree t = MTree "" (NodeTree t) []
+tToBTree :: String -> Tree Room -> MetaTree Room String
+tToBTree str t = MTree str (NodeTree t) []
 
-attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room
-attachOnward t1 t2 = t1 & mtBranches .:~ MBranch "Onward" toOnward t2
+attachOnward :: MetaTree Room b -> MetaTree Room b -> MetaTree Room b
+attachOnward t1 t2 = t1 & mtBranches .:~ MBranch toOnward t2
 
 toOnward :: Room -> Maybe Room
 toOnward rm
     | OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks 
         = Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
     | otherwise = Nothing
+

src/Dodge/Tree/Compose/Data.hs

@@ -4,23 +4,12 @@ module Dodge.Tree.Compose.Data where
 import Data.Tree
 import Control.Lens
 
-data MetaBranch a 
-    = MBranch {_mbLabel :: String, _mbAttach :: a -> Maybe a, _mbTree :: MetaTree a}
 
-data MetaTree a
-    = MTree {_mtLabel :: String , _mtTree :: MetaNode a , _mtBranches :: [MetaBranch a] }
---    | BTree {_btLabel :: String , _btValue :: a ,         _btBranches :: [MetaTree a] }
-data MetaNode a = NodeTree {_nodeTree :: Tree a} | NodeMTree {_nodeMetaTree :: MetaTree a}
+--data MetaTree a = MTree {_mtLabel :: String , _mtTree :: MetaNode a , _mtBranches :: [MetaBranch a] }
+data MetaTree a b = MTree {_mtLabel :: b , _mtTree :: MetaNode a b, _mtBranches :: [MetaBranch a b] }
+data MetaNode a b = NodeTree {_nodeTree :: Tree a} | NodeMTree {_nodeMetaTree :: MetaTree a b}
+data MetaBranch a b = MBranch {_mbAttach :: a -> Maybe a, _mbTree :: MetaTree a b}
 
---type CompTree a = Tree (Tree a)
-type LabTree a = (a -> Maybe ([String],a),Tree a)
-type LabCompTree a = Tree (LabTree a)
-data TreeSubLabelling = TreeSubLabelling
-    { _topLabel :: String
-    , _subLabels :: Maybe (Tree TreeSubLabelling)
-    }
-makeLenses ''TreeSubLabelling
 makeLenses ''MetaTree
 makeLenses ''MetaBranch
 makeLenses ''MetaNode
-