Simplify MetaTrees

2022-06-13 10:25:06 +01:00
parent 768b86d393
commit 31e7f4290e
6 changed files with 97 additions and 84 deletions
@@ -4,11 +4,11 @@ module Dodge.Tree.Compose
    ( tToBTree
    , overwriteLabel
    , composeTree
-    , composeTree'
+--    , composeTree'
    , shiftChildren
    , attachTree
-    , composeTreeRand
-    , composeAndLog
+--    , composeTreeRand
+--    , composeAndLog
    , toOnward
    , attachOnward
 --    , cmpToMT
@@ -77,46 +77,46 @@ overwriteLabel i t ts = safeUpdateSingleNode
 --changeTo :: ComposingNode a -> ComposingNode a
 --changeTo x =  (_unCompose x)

-composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a)
-composeTreeRand (Node (_,t) ts) = attachListR t ts
+--composeTreeRand :: RandomGen g => Tree (a -> Maybe a, Tree a) -> State g (Tree a)
+--composeTreeRand (Node (_,t) ts) = attachListR t ts

-attachListR :: RandomGen g => Tree a -> [Tree (a -> Maybe a, Tree a)] -> State g (Tree a)
-attachListR t xs = shiftChildren <$> foldrM newfRand (fmap ([],) t) xs
+--attachListR :: RandomGen g => Tree a -> [Tree (a -> Maybe a, Tree a)] -> State g (Tree a)
+--attachListR t xs = shiftChildren <$> foldrM newfRand (fmap ([],) t) xs

-newfRand :: RandomGen g => Tree (a -> Maybe a,Tree a) -> Tree ([Tree a],a) 
-    -> State g (Tree ([Tree a],a))
-newfRand t = updateRandNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
-  where
-    upf = t ^?! root . _1
-    g x = fromMaybe x (upf x)
+--newfRand :: RandomGen g => Tree (a -> Maybe a,Tree a) -> Tree ([Tree a],a) 
+--    -> State g (Tree ([Tree a],a))
+--newfRand t = updateRandNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
+--  where
+--    upf = t ^?! root . _1
+--    g x = fromMaybe x (upf x)

-composeTree :: Tree (a -> Maybe a, Tree a) -> Tree a
-composeTree (Node (_,t) ts) = attachList t ts
+--composeTree :: Tree (a -> Maybe a, Tree a) -> Tree a
+--composeTree (Node (_,t) ts) = attachList t ts
+--
+--composeTree' :: Monoid b => Tree (a -> Maybe (b, a), Tree a) -> (b, Tree a)
+--composeTree' (Node (_,t) ts) = attachList' t ts

-composeTree' :: Monoid b => Tree (a -> Maybe (b, a), Tree a) -> (b, Tree a)
-composeTree' (Node (_,t) ts) = attachList' t ts
+--attachList' :: Monoid b => Tree a -> [Tree (a -> Maybe (b, a), Tree a)] -> (b,Tree a)
+--attachList' t xs = shiftChildren <$> foldrM newf' (fmap ([],) t) xs

-attachList' :: Monoid b => Tree a -> [Tree (a -> Maybe (b, a), Tree a)] -> (b,Tree a)
-attachList' t xs = shiftChildren <$> foldrM newf' (fmap ([],) t) xs
-
-newf' :: Monoid b => Tree (a -> Maybe (b, a),Tree a) -> Tree ([Tree a],a) -> (b , Tree ([Tree a],a))
-newf' t = first (s<>) . msafeUpdateSingleNode (isJust . upf . snd) upt
-  where
-    (s,t') = composeTree' t
-    upf = t ^?! root . _1
-    upt = (root . _2 %%~ g) . (root . _1 .:~ t')
-    g x = fromMaybe (mempty,x) (upf x)
+----newf' :: Monoid b => Tree (a -> Maybe (b, a),Tree a) -> Tree ([Tree a],a) -> (b , Tree ([Tree a],a))
+----newf' t = first (s<>) . msafeUpdateSingleNode (isJust . upf . snd) upt
+----  where
+----    (s,t') = composeTree' t
+----    upf = t ^?! root . _1
+----    upt = (root . _2 %%~ g) . (root . _1 .:~ t')
+----    g x = fromMaybe (mempty,x) (upf x)
 --    mtf = undefined
 --     ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )

-attachList :: Tree a -> [Tree (a -> Maybe a, Tree a)] -> Tree a
-attachList t xs = shiftChildren $ foldr newf (fmap ([],) t) xs
-
-newf :: Tree (a -> Maybe a,Tree a) -> Tree ([Tree a],a) -> Tree ([Tree a],a)
-newf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
-  where
-    upf = t ^?! root . _1
-    g x = fromMaybe x (upf x)
+--attachList :: Tree a -> [Tree (a -> Maybe a, Tree a)] -> Tree a
+--attachList t xs = shiftChildren $ foldr newf (fmap ([],) t) xs
+--
+--newf :: Tree (a -> Maybe a,Tree a) -> Tree ([Tree a],a) -> Tree ([Tree a],a)
+--newf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ composeTree t ) )
+--  where
+--    upf = t ^?! root . _1
+--    g x = fromMaybe x (upf x)

 attachTree :: (a -> Maybe a) -> Tree a -> Tree ([Tree a],a) -> Tree ([Tree a],a)
 attachTree upf t = safeUpdateSingleNode (isJust . upf . snd) ( (root . _2 %~ g) . (root . _1 .:~ t ) )
@@ -149,50 +149,66 @@ shiftChildren (Node (ts,x) ts') = Node x (ts ++ map shiftChildren ts')
 --  where
 --    t' = fmap (\(x,y) -> (x,y,[])) t

-logMB :: MetaBranch a -> Tree String
-logMB (MBranch str _ mt) = root ++.~ (str ++ ":") $ logMT mt
+--logMB :: MetaBranch a -> Tree String
+--logMB (MBranch str _ mt) = root ++.~ (str ++ ":") $ logMT mt
+--
+--logMT :: MetaTree a -> Tree String
+--logMT mt = case mt of
+--    MTree str (NodeMTree  brs -> Node ("M:"++str) $ map logMB brs
+--    BTree str _ brs -> Node str $ map logMT brs

-logMT :: MetaTree a -> Tree String
-logMT mt = case mt of
-    MTree str _ brs -> Node ("M:"++str) $ map logMB brs
-    BTree str _ brs -> Node str $ map logMT brs
+--composeAndSubLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a)
+--composeAndSubLog is dolog mt = case mt of
+--    MTree{} -> do
+--        dolog ("SUBTREE"++show is++mRootLabel mt++"\n")
+--        rt <- composeAndLog (0:is) dolog $ _mtTree mt
+--        brs <- mapM (\(_,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) 
+--            $ zip [(0::Int)..] $ _mtBranches mt
+--        return $ attachList rt $ map pure brs
+--    bt -> do
+--        dolog ("SUBTREE:"++show is++mRootLabel mt++"\n")
+--        dolog $ drawTree $ logMT mt
+--        brs <- mapM (composeAndSubLog is dolog) (_btBranches bt)
+--        return $ Node (_btValue bt) brs

-composeAndSubLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a)
-composeAndSubLog is dolog mt = case mt of
-    MTree{} -> do
-        dolog ("SUBTREE"++show is++mRootLabel mt++"\n")
-        rt <- composeAndLog (0:is) dolog $ _mtTree mt
-        brs <- mapM (\(i,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) 
-            $ zip [0..] $ _mtBranches mt
-        return $ attachList rt $ map pure brs
-    bt -> do
-        dolog ("SUBTREE:"++show is++mRootLabel mt++"\n")
-        dolog $ drawTree $ logMT mt
-        brs <- mapM (composeAndSubLog is dolog) (_btBranches bt)
-        return $ Node (_btValue bt) brs
+--composeAndLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a)
+--composeAndLog is dolog mt = case mt of
+--    MTree{} -> do
+--        dolog $ drawTree $ logMT mt
+--        dolog ("SUBTREE"++show is++mRootLabel mt++"\n")
+--        rt <- composeAndLog (0:is) dolog $ _mtTree mt
+--        brs <- mapM (\(_,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) 
+--            $ zip [(0::Int)..] $ _mtBranches mt
+--        return $ attachList rt $ map pure brs
+--    BTree{} -> do
+--        dolog ("SUBTREE:"++show is++mRootLabel mt++"\n")
+--        dolog $ drawTree $ logMT mt
+--        brs <- mapM (composeAndSubLog is dolog) $ _btBranches mt
+--        return $ Node (_btValue mt) brs
+
+composeTree :: MetaTree a -> Tree a
+composeTree mt = attachList' (composeNode $ _mtTree mt) (_mtBranches mt)
+
+composeNode :: MetaNode a -> Tree a
+composeNode (NodeTree t) = t
+composeNode (NodeMTree mt) = composeTree mt
+
+attachList' :: Tree a -> [MetaBranch a] -> Tree a
+attachList' t xs = shiftChildren $ foldr attachBranch (fmap ([],) t) xs
+
+attachBranch :: MetaBranch a -> Tree ([Tree a],a) -> Tree ([Tree a],a)
+attachBranch mb = safeUpdateSingleNode (isJust . upf . snd) 
+    ( (root . _2 %~ g) . (root ._1 .:~ composeTree (_mbTree mb)) )
+  where
+    upf = _mbAttach mb
+    g x = fromMaybe x (upf x)

-composeAndLog :: Monad m => [Int] -> (String -> m ()) -> MetaTree a -> m (Tree a)
-composeAndLog is dolog mt = case mt of
-    MTree{} -> do
-        dolog $ drawTree $ logMT mt
-        dolog ("SUBTREE"++show is++mRootLabel mt++"\n")
-        rt <- composeAndLog (0:is) dolog $ _mtTree mt
-        brs <- mapM (\(i,mb) -> (_mbAttach mb,) <$> composeAndSubLog (is & ix 0 +~ 1) dolog (_mbTree mb)) 
-            $ zip [0..] $ _mtBranches mt
-        return $ attachList rt $ map pure brs
-    BTree{} -> do
-        dolog ("SUBTREE:"++show is++mRootLabel mt++"\n")
-        dolog $ drawTree $ logMT mt
-        brs <- mapM (composeAndSubLog is dolog) $ _btBranches mt
-        return $ Node (_btValue mt) brs

 tToBTree :: Tree Room -> MetaTree Room
-tToBTree (Node r ts) = BTree (_rmName r) r $ map tToBTree ts
+tToBTree t = MTree "" (NodeTree t) []

 attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room
-attachOnward t1 t2 = case t1 of
-    MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward t2
-    BTree {} -> MTree (mRootLabel t1 ++ "-" ++ mRootLabel t2) t1 [MBranch "Onward" toOnward t2]
+attachOnward t1 t2 = t1 & mtBranches .:~ MBranch "Onward" toOnward t2

 toOnward :: Room -> Maybe Room
 toOnward rm