Start to migrate all old level generation to MetaTrees

src/Dodge/Annotation.hs

@@ -7,7 +7,8 @@ module Dodge.Annotation
 import Dodge.UseAll
 import RandomHelp
 import Dodge.Tree
-import Dodge.Room
+import Dodge.Tree.Compose
+--import Dodge.Room
 import Dodge.Data
 import Dodge.Annotation.Data
 import LensHelp
@@ -15,44 +16,17 @@ import LensHelp
 --import Control.Lens
 import Data.Maybe
 
-{- | Add one corridor between each parent-child link of a tree of annotations.  -}
+annoToRoomTree :: Annotation -> State (StdGen,Int) (MetaTree Room)
---padWithCorridors :: Annotation -> Annotation
+annoToRoomTree an = case an of
---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')
-
-annoToRoomTree' :: Annotation -> State (StdGen,Int) (MetaTree Room)
-annoToRoomTree' an = case an of
     SpecificRoom r -> zoom _1 r 
     OnwardList ans -> do
-        mts <- mapM annoToRoomTree' ans
+        mts <- mapM annoToRoomTree ans
         return $ foldr1 attachOnward mts
     IntAnno f -> do 
         (g,i) <- get
         put (g,i+1)
-        annoToRoomTree' (f i)
+        annoToRoomTree (f i)
-    PadWith r an -> annoToRoomTree' an
+    ModifyTree f a -> f <$> annoToRoomTree a
     PassthroughLockKeyLists ls ks i -> zoom _1 $ do
         (functionlockroom,randomitemidentity) <- takeOne ls
         lr <- functionlockroom i
@@ -62,7 +36,3 @@ annoToRoomTree' an = case an of
             (MTree "" lr [MBranch "" (toLabel' i) keyroom])
             []
 
-attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room
-attachOnward t1 t2 = case t1 of
-    MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward' t2
-    BTree {} -> MTree "ConstructedOnward" t1 [MBranch "Onward" toOnward' t2]

src/Dodge/Annotation/Data.hs

@@ -3,22 +3,17 @@
 module Dodge.Annotation.Data where
 import Dodge.Data
 --import Dodge.Room
-import TreeHelp
+--import TreeHelp
 import Dodge.Tree.Compose.Data
 
 import Control.Monad.State
 import Control.Lens
 import System.Random
 data Annotation
-    = -- Corridor
+    = ModifyTree (MetaTree Room -> MetaTree Room) Annotation
---    | AirlockAno
-    PadWith Room Annotation
     | OnwardList [Annotation]
---    | IntAnno Int (Int -> Annotation)
     | IntAnno (Int -> Annotation)
---    | OrAno [[Annotation]]
     | SpecificRoom (State StdGen (MetaTree Room))
-    | AnoApplyInt Int (Int -> State StdGen (LabTree Room))
     | PassthroughLockKeyLists
         [(Int -> State StdGen (MetaTree Room), State StdGen ItemBaseType)]
         [(ItemBaseType, State StdGen (MetaTree Room))]

src/Dodge/Floor.hs

@@ -38,7 +38,7 @@ import Data.List (intersperse)
 
 initialAnoTree :: Annotation
 initialAnoTree = OnwardList 
-        $ intersperse (SpecificRoom $ (tToBTree . pure) <$> shuffleLinks (cleatOnward corridor))
+        $ intersperse (SpecificRoom $ tToBTree . pure <$> shuffleLinks (cleatOnward corridor))
     [ IntAnno $ SpecificRoom . startRoom
 --     ,  (SpecificRoom . return . tToBTree $ treePost [corridor,corridor,cleatOnward corridor])
     , IntAnno $ PassthroughLockKeyLists
@@ -50,7 +50,7 @@ initialAnoTree = OnwardList
             [ spNoID anyUnusedSpot (PutCrit invisibleChaseCrit)
             , spNoID anyUnusedSpot (PutCrit armourChaseCrit)
             ]
---    , [AnoApplyInt 100 healthTest]
+    , IntAnno $ SpecificRoom . fmap tToBTree . healthTest
     , SpecificRoom (tanksRoom [] [] >>= rToOnward "empty tanksRoom" . pure . cleatOnward)
     , IntAnno $ PassthroughLockKeyLists lockRoomKeyItems itemRooms
     , SpecificRoom randomChallenges
@@ -101,4 +101,4 @@ initialAnoTree = OnwardList
 
 {- | A test level tree. -}
 initialRoomTree :: State (StdGen,Int) (MetaTree Room)
-initialRoomTree = annoToRoomTree' initialAnoTree
+initialRoomTree = annoToRoomTree initialAnoTree

src/Dodge/Room/GlassLesson.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
 module Dodge.Room.GlassLesson where
 import Dodge.UseAll
 import Dodge.RoomLink
@@ -54,6 +54,6 @@ glassLesson = do
             ]
         ]
 glassLessonRunPast :: RandomGen g => State g (MetaTree Room)
-glassLessonRunPast = (f <$> glassLesson) >>= rToOnward "glassLessonRunPast"
+glassLessonRunPast = glassLesson >>= rToOnward "glassLessonRunPast" . f
   where
     f (Node r rs) = Node r $ return (cleatLabel 0 $ door & rmConnectsTo .~ S.member (OnEdge West)) : rs

src/Dodge/Room/Room.hs

@@ -192,7 +192,7 @@ weaponEmptyRoom = do
         $ restrictRMInLinksPD f (roomRect w h 2 2 & rmPmnts .~ plmnts)
     return $ treeFromTrunk [ corridor] (pure $ cleatOnward rm )
      
-weaponUnderCrits :: RandomGen g => Int -> State g (LabTree Room)
+weaponUnderCrits :: RandomGen g => Int -> State g (MetaTree Room)
 weaponUnderCrits i = do
     let plmnts = 
             [--sPS (V2 20 0)   0 $ RandPS randFirstWeapon
@@ -211,19 +211,7 @@ weaponUnderCrits i = do
     junctionRoom <- takeOne [ tEast, tWest]
     let thetree = treeFromTrunk [ corridorN , corridorN] 
             $ Node junctionRoom [continuationRoom ,pure deadEndRoom' ]
-    return (toOnward "weaponUnderCrits" , thetree  )
+    rToOnward "weaponUnderCrits" thetree
--- TODO addSubmessages
-
---composingNodeName :: ComposingNode Room -> TreeSubLabelling
---composingNodeName cn = case cn of
---      rm -> f $ _rmName rm ++ "-"
---    SplitDown rm -> f $ _rmName rm ++ "-SplitDown"
---    useAll    rm -> f $ _rmName rm ++ "-useAll"
---    UseSome   is rm -> f $ _rmName rm ++ "-" ++ show is ++ "-UseSome"
---    UseNone   rm -> f $ _rmName rm ++ "-UseNone"
---    useLabel  i rm -> f $ _rmName rm ++ "-" ++ show i ++ "-useLabel"
---  where
---    f str = TreeSubLabelling str Nothing
 
 weaponBehindPillar :: RandomGen g => State g (Tree Room)
 weaponBehindPillar  = do
@@ -291,16 +279,14 @@ deadEndRoom = defaultRoom
   where 
     lnks = [(V2 0 30  ,0) ]
 {- A random Either tree with a weapon and melee monster challenge.  -}
-weaponRoom :: RandomGen g => Int -> State g (LabTree Room)
+weaponRoom :: RandomGen g => Int -> State g (MetaTree Room)
 weaponRoom i = join $ takeOne 
-    [ weaponEmptyRoom       <&>  f "weaponEmptyRoom"
+    [ weaponEmptyRoom       >>= rToOnward "weaponEmptyRoom"
     , weaponUnderCrits i
-    , weaponBehindPillar    <&>  f "weaponBehindPillar"
+    , weaponBehindPillar    >>= rToOnward "weaponBehindPillar"
-    , weaponBetweenPillars  <&>  f "weaponBetweenPillars"
+    , weaponBetweenPillars  >>= rToOnward "weaponBetweenPillars"
-    , weaponLongCorridor    <&>  f "weaponLongCorridor"
+    , weaponLongCorridor    >>= rToOnward "weaponLongCorridor"
     ]
-  where
-    f str = ( toOnward str ,)
 
 roomCCrits :: RandomGen g => State g Room
 roomCCrits = roomC 200 200

src/Dodge/Room/RunPast.hs

@@ -43,8 +43,8 @@ roomCritLS = do
 smallRoom :: Room
 smallRoom = corridorWallN & rmRandPSs .~ [psRandRanges (15,25) (30,45) (pi,2*pi)]
 
-runPastRoom :: RandomGen g => Int -> State g (Tree Room)
+lookedStart :: RandomGen g => Int -> State g (Tree Room)
-runPastRoom i = do
+lookedStart i = do
     h           <- state $ randomR (200,400::Float)
     thels       <- roomCritLS
     theweapon   <- randBlockBreakWeapon

src/Dodge/Room/Start.hs

@@ -71,10 +71,8 @@ randomChallenges = shootingRange
 runPastStart :: RandomGen g => Int -> State g (Tree Room)
 runPastStart i = do
     s <- rezBoxStart
-    rp <- runPastRoom i
+    rp <- lookedStart i
-    --return $ s `passUntiluseAll` [rp]
     return . shiftChildren $ attachTree toOnward' rp $ fmap ([],) s
---    return . shiftChildren $ attachTree toOnward' (pure $ useAll corridor) $ fmap ([],) s
     
 
 rezBoxStart :: RandomGen g => State g (Tree Room)
@@ -82,18 +80,17 @@ rezBoxStart = do
     ls <- rezColor
     return $ treePost [ rezBox ls, cleatOnward door ]
 
-rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (Tree Room,String)
+rezBoxesThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room)
 rezBoxesThenWeaponRoom i = do
     rboxes <- rezBoxes
-    wroom  <- snd <$> weaponRoom i
+    wroom  <- weaponRoom i
-    return (rboxes `passUntiluseAll` [wroom] , "rezBoxesThenWeaponRoom " ++ show i)
+    return $ MTree "rezBoxesThenWeaponRoom" (tToBTree rboxes) [MBranch "" toOnward' wroom]
 
 rezBoxThenWeaponRoom :: RandomGen g => Int -> State g (MetaTree Room)
 rezBoxThenWeaponRoom i = do
     rcol <- rezColor
-    (_,wroom) <- weaponRoom i
+    wroom <- weaponRoom i
-    rToOnward ("rezBoxThenWeaponRoom "++ show i)
+    return $ tToBTree (treePost [ rezBox rcol, cleatOnward door]) `attachOnward` wroom
-        $ treeFromTrunk [ rezBox rcol, door] wroom
 
 rezBoxThenRoom :: RandomGen g => Room -> State g (Tree Room)
 rezBoxThenRoom r = do

src/Dodge/Tree/Compose.hs

@@ -9,6 +9,7 @@ module Dodge.Tree.Compose
     --, changeTo
     --, applyToCompRoot
     passUntiluseAll  -- this should be moved, and the dependency on Dodge.Data removed
+    , tToBTree
     , overwriteLabel
     , composeTree
     , composeTree'
@@ -16,8 +17,11 @@ module Dodge.Tree.Compose
     , attachTree
     , composeTreeRand
     , composeAndLog
+    , toOnward'
+    , attachOnward
 --    , cmpToMT
 --    , compTree
+    , module Dodge.Tree.Compose.Data
     ) where
 import Dodge.Data
 import Dodge.Tree.Compose.Data
@@ -179,15 +183,23 @@ composeAndLog dolog mt = case mt of
     MTree{} -> do
         dolog $ drawTree $ logMT mt
         rt <- composeAndLog dolog $ _mtTree mt
-        brs <- mapM (\mb -> (_mbAttach mb,) <$> (composeAndSubLog dolog) (_mbTree mb)) $ _mtBranches mt
+        brs <- mapM (\mb -> (_mbAttach mb,) <$> composeAndSubLog dolog (_mbTree mb)) $ _mtBranches mt
         return $ attachList rt $ map pure brs
     BTree{} -> do
         dolog $ drawTree $ logMT mt
         brs <- mapM (composeAndSubLog dolog) $ _btBranches mt
         return $ Node (_btValue mt) brs
 
-cmpToMT :: Tree (a-> Maybe (b,a), Tree a) -> MetaTree a
+tToBTree :: Tree Room -> MetaTree Room
-cmpToMT (Node (_,t) ts) = MTree "A" (tToBT t) (map tToMB ts)
+tToBTree (Node r ts) = BTree (_rmName r) r $ map tToBTree ts
-  where
+
-    tToMB (Node (f,t') ts') = MBranch "C" (fmap snd . f) $ MTree "D" (tToBT t') (map tToMB ts')
+attachOnward :: MetaTree Room -> MetaTree Room -> MetaTree Room
-    tToBT (Node x xs) = BTree "B" x $ map tToBT xs
+attachOnward t1 t2 = case t1 of
+    MTree {} -> t1 & mtBranches .:~ MBranch "Onward" toOnward' t2
+    BTree {} -> MTree "ConstructedOnward" t1 [MBranch "Onward" toOnward' t2]
+
+toOnward' :: Room -> Maybe Room
+toOnward' rm
+    | OnwardCluster `elem` rm ^?! rmClusterStatus . csLinks 
+        = Just (rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
+    | otherwise = Nothing

src/Dodge/UseAll.hs

@@ -1,6 +1,14 @@
-{-# LANGUAGE TupleSections #-}
+--{-# LANGUAGE TupleSections #-}
-module Dodge.UseAll where
+module Dodge.UseAll 
+    ( toOnward'
+    , toLabel'
+    , cleatOnward
+    , cleatSide
+    , rToOnward
+    , cleatLabel
+    ) where
 import Dodge.Data
+import Dodge.Tree.Compose
 import Dodge.Tree.Compose.Data
 
 import Data.Tree
@@ -13,8 +21,6 @@ toOnward s rm
         = Just ([s],rm & rmClusterStatus . csLinks . at OnwardCluster .~ Nothing)
     | otherwise = Nothing
 
-toOnward' :: Room -> Maybe Room
-toOnward' = fmap snd . toOnward ""
 
 toLabel' :: Int -> Room -> Maybe Room
 toLabel' i rm
@@ -24,8 +30,6 @@ toLabel' i rm
 rToOnward :: Monad m => String -> Tree Room -> m (MetaTree Room)
 rToOnward s t = return $ MTree s (tToBTree t) []
 
-tToBTree :: Tree Room -> MetaTree Room
-tToBTree (Node r ts) = BTree (_rmName r) r $ map tToBTree ts
 
 toClusterLabel :: Int -> String ->  Room -> Maybe ([String],Room)
 toClusterLabel i s rm