Rework annotations

src/Dodge/Annotation.hs

@@ -10,70 +10,79 @@ import Dodge.Tree
 import Dodge.Room
 import Dodge.Data
 import Dodge.Annotation.Data
---import LensHelp
+import LensHelp
 
 --import Control.Lens
-import Data.Maybe
+--import Data.Maybe
 
-addLock :: Int -> Tree [Annotation] -> State StdGen (Tree [Annotation])
-addLock i t = do
-    (beforeLock, afterLock) <- splitTrunk t
-    newBefore <- applyToRandomNode (Key i :) beforeLock
-    return $ addToTrunk newBefore [Node [Lock i] afterLock]
 {- | Add one corridor between each parent-child link of a tree of annotations.  -}
-padWithCorridors :: Tree [Annotation] -> Tree [Annotation]
-padWithCorridors = padWithAno [Corridor]
+--padWithCorridors :: Annotation -> Annotation
+--padWithCorridors = padWithAno [Corridor]
+--
+--padWithAno :: [Annotation] -> Tree [Annotation] -> Tree [Annotation]
+--padWithAno ano (Node x xs) = Node ano [Node x (map (padWithAno ano) xs)]
+--
+--padSucWithCorridors :: Tree [Annotation] -> Tree [Annotation]
+--padSucWithCorridors (Node x xs) = Node x (map padWithCorridors xs)
+--
+--padSucWithDoors :: Tree [Annotation] -> Tree [Annotation]
+--padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs)
+--  where
+--    thetree = do
+--        thecor <- shuffleLinks corridor
+--        takeOne
+--            [ (toOnward "door",     return (cleatOnward door))
+--            , (toOnward "twoDoors" ,treePost [ door,  thecor, cleatOnward door])
+--            ]
+--
+--{- Add one to three corridors between each parent-child link of a tree of annotations.  -}
+--randomPadCorridors :: Tree [Annotation] -> State StdGen (Tree [Annotation])
+--randomPadCorridors  (Node x xs) = do
+--    n <- state $ randomR (1, 3)
+--    xs' <- mapM randomPadCorridors xs
+--    return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
 
-padWithAno :: [Annotation] -> Tree [Annotation] -> Tree [Annotation]
-padWithAno ano (Node x xs) = Node ano [Node x (map (padWithAno ano) xs)]
+annoToRoomTree :: Annotation -> State StdGen (MetaTree Room)
+annoToRoomTree an = case an of
+    OnwardList ans -> do
+        mts <- mapM annoToRoomTree ans
+        return $ foldr1 attachOnward mts
+    SpecificRoom r -> r
+    PadWith r an -> annoToRoomTree an
+    IntAnno i f -> annoToRoomTree $ f i
 
-padSucWithCorridors :: Tree [Annotation] -> Tree [Annotation]
-padSucWithCorridors (Node x xs) = Node x (map padWithCorridors xs)
-
-padSucWithDoors :: Tree [Annotation] -> Tree [Annotation]
-padSucWithDoors (Node x xs) = Node x (map (padWithAno [SpecificRoom thetree]) xs)
-  where
-    thetree = do
-        thecor <- shuffleLinks corridor
-        takeOne
-            [ (toOnward "door",     return (cleatOnward door))
-            , (toOnward "twoDoors" ,treePost [ door,  thecor, cleatOnward door])
-            ]
-
-{- Add one to three corridors between each parent-child link of a tree of annotations.  -}
-randomPadCorridors :: Tree [Annotation] -> State StdGen (Tree [Annotation])
-randomPadCorridors  (Node x xs) = do
-    n <- state $ randomR (1, 3)
-    xs' <- mapM randomPadCorridors xs
-    return $ treeFromTrunk (replicate n [Corridor]) (Node x xs')
+attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room
+attachOnward t1 t2 = case t1 of
+    MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward' t2
+    BTree {} -> t2 & btBranches .:~ t2
 
 {- | Create a random room tree structure from a list of annotations.  -}
-anoToRoomTree :: [Annotation] -> State StdGen (Room -> Maybe ([String],Room), Tree Room)
-anoToRoomTree anos = case anos of
-    [AnoApplyInt i f] -> f i
---    [AnoApplyInt' i f str] -> f i <&> (,TreeSubLabelling str Nothing)
-    (SpecificRoom rt:_) -> rt
-    [PassthroughLockKeyLists i ls ks] -> do
-        (functionlockroom,randomitemidentity) <- takeOne ls
-        lr' <- functionlockroom i
-        ii <- randomitemidentity
-        let lr = snd lr'
-        keyroom' <- fromJust $ lookup ii ks
-        let keyroom = snd keyroom'
-        rToOnward ("PassthroughLockKeyLists-"++show ii) $ overwriteLabel i lr [keyroom]
-    _ -> rToOnward "no label" =<< anoToRoomTree' anos
+--anoToRoomTree :: [Annotation] -> State StdGen (Room -> Maybe ([String],Room), Tree Room)
+--anoToRoomTree anos = case anos of
+--    [AnoApplyInt i f] -> f i
+----    [AnoApplyInt' i f str] -> f i <&> (,TreeSubLabelling str Nothing)
+--    (SpecificRoom rt:_) -> rt
+--    [PassthroughLockKeyLists i ls ks] -> do
+--        (functionlockroom,randomitemidentity) <- takeOne ls
+--        lr' <- functionlockroom i
+--        ii <- randomitemidentity
+--        let lr = snd lr'
+--        keyroom' <- fromJust $ lookup ii ks
+--        let keyroom = snd keyroom'
+--        rToOnward ("PassthroughLockKeyLists-"++show ii) $ overwriteLabel i lr [keyroom]
+--    _ -> rToOnward "no label" =<< anoToRoomTree' anos
 
 {- | Create a random room tree structure from a list of annotations.  -}
 anoToRoomTree' :: [Annotation] -> State StdGen (Tree Room)
 anoToRoomTree' anos = case anos of
-    [OrAno as] -> do
-        a <- takeOne as
-        anoToRoomTree' a
-    [Corridor] -> pure . cleatOnward <$> shuffleLinks corridor
-    (BossAno cr : _) -> do
-        br <- bossRoom cr
-        branchRectWith . pure $ treeFromPost [corridor,corridor] br
-    (TreasureAno crs loot : _) -> branchRectWith . fmap pure $ lootRoom crs loot
+--    [OrAno as] -> do
+--        a <- takeOne as
+--        anoToRoomTree' a
+--    [Corridor] -> pure . cleatOnward <$> shuffleLinks corridor
+--    (BossAno cr : _) -> do
+--        br <- bossRoom cr
+--        branchRectWith . pure $ treeFromPost [corridor,corridor] br
+--    (TreasureAno crs loot : _) -> branchRectWith . fmap pure $ lootRoom crs loot
     _ -> do
         w <- state $ randomR (100,400)
         h <- state $ randomR (200,400)