Test of lock and key system

src/Dodge/Annotation.hs

@@ -11,7 +11,8 @@ import Dodge.Annotation.Data
 import Data.Tree
 import Control.Monad.State
 import System.Random
-import Control.Lens
+--import Control.Lens
+import Data.Maybe
 
 addLock :: RandomGen g => Int -> Tree [Annotation g] -> State g (Tree [Annotation g])
 addLock i t = do
@@ -43,15 +44,21 @@ roomThenCorridor theRoom = fmap (\r -> Node (PassDown theRoom) [(pure . UseAll)
 anoToRoomTree :: RandomGen g => [Annotation g] -> State g (SubCompTree Room)
 anoToRoomTree anos = case anos of
     [AnoApplyInt i f] -> f i
-    [SetLabel i randrm] -> do
-        rm <- randrm
-        return . singleUseAll $ rm & rmLabel ?~ i
-    [UseLabel i randrm] -> do
-        rm <- randrm
-        return $ singleUseAll $ rm & rmTakeFrom ?~ i
+--    [SetLabel i randrm] -> do
+--        rm <- randrm
+--        return . singleUseAll $ rm & rmLabel ?~ i
+--    [UseLabel i randrm] -> do
+--        rm <- randrm
+--        return $ singleUseAll $ rm & rmTakeFrom ?~ i
     [ChainAnos ass] -> do
         rms <- mapM anoToRoomTree ass
         return $ chainUses rms
+    [PassthroughLockKeyLists i ls ks] -> do
+        (functionlockroom,randomitemidentity) <- takeOne ls
+        lr <- functionlockroom i
+        ii <- randomitemidentity
+        keyroom <- fromJust $ lookup ii ks
+        return $ overwriteLabel 0 UseNone lr [keyroom]
     [OrAno as] -> do
         a <- takeOne as
         anoToRoomTree a

src/Dodge/Annotation/Data.hs

@@ -19,8 +19,11 @@ data Annotation g
     | BossAno Creature
     | TreasureAno [Creature] [Item]
     | AnoApplyInt Int (Int -> State g (SubCompTree Room))
-    | SetLabel Int (State g Room)
-    | UseLabel Int (State g Room)
+    | PassthroughLockKeyLists Int 
+        [(Int -> State g (SubCompTree Room), State g ItemIdentity)]
+        [(ItemIdentity, State g (SubCompTree Room))]
+--    | SetLabel Int (State g Room)
+--    | UseLabel Int (State g Room)
     | ChainAnos [[Annotation g]]
 
 makeLenses ''Annotation

src/Dodge/Floor.hs

@@ -5,6 +5,7 @@ module Dodge.Floor
     ) where
 import Geometry.Data
 import Dodge.Data
+import Dodge.LockAndKey
 import Dodge.Creature.State.Data
 import Dodge.Room
 import Dodge.Room
@@ -35,6 +36,7 @@ import qualified Data.IntMap.Strict as IM
 initialAnoTree :: RandomGen g => Tree [Annotation g]
 initialAnoTree = padSucWithCorridors $ treeFromTrunk 
     [[AnoApplyInt 0 startRoom]
+    , [PassthroughLockKeyLists 2 lockRoomKeyItems itemRooms]
     , [AnoApplyInt 2 room2]
     , [AnoApplyInt 1 lasSensorTurretTest]
 --    ,[ChainAnos 

src/Dodge/LockAndKey.hs

@@ -3,16 +3,28 @@ import Dodge.Data
 import Dodge.Tree
 import Dodge.LevelGen.Data
 import Dodge.Room
+import Dodge.RandomHelp
+import Dodge.Creature
 --import Dodge.Item.Equipment
 
 import System.Random
 import Control.Monad.State
 
-lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , [ItemIdentity] ) ]
+-- (const $ return $ chainUses $ map singleUseAll [door,lasTunnel,door] , return FlatShield )
+--    ,
+
+lockRoomKeyItems :: RandomGen g => [ (Int -> State g (SubCompTree Room) , State g ItemIdentity ) ]
 lockRoomKeyItems = 
-    [ (const $ return $ chainUses $ map singleUseAll [door,lasTunnel,door] , [FlatShield] )
-    , (lasCenSensEdge, [FlatShield,Launcher,TeslaGun] )
+    [ (lasCenSensEdge, takeOne [Launcher] )
     ]
 
-itemRooms :: [(ItemIdentity, Room)]
-itemRooms = []
+itemRooms :: RandomGen g => [(ItemIdentity, State g (SubCompTree Room))]
+itemRooms = 
+    [ (Launcher , corridorBoss launcherCrit ) ]
+
+corridorBoss :: RandomGen g => Creature -> State g (SubCompTree Room)
+corridorBoss cr = do
+    endroom <- bossRoom cr
+    return $ treeFromPost (replicate 5 $ PassDown corridor) 
+                            (PassDown endroom)
+

src/Dodge/Room/Boss.hs

@@ -45,6 +45,7 @@ roomGlassOctogon x = createPathGrid $ defaultRoom
         ,blockLine (V2 (-40) (50-x)) (V2 40 (50-x))
         ]
     , _rmBound = [rectNSWE x (-x) (-x) x]
+    , _rmName  = "glass8gon"
     }
   where
     fx = 4 * x / 5
@@ -101,6 +102,7 @@ roomCross x y = defaultRoom
         [rectNSWE y (-y) (-x) x
         ,rectNSWE x (-x) (-y) y
         ]
+    , _rmName = "cross"
     }
 {- | TODO: pathing -}
 roomShuriken 
@@ -121,7 +123,8 @@ roomShuriken x y =
             , _rmPmnts  = [mntLS iShape (V2 x x) (V3 (x-20) x 70)]
             , _rmBound  = ps
             }
-    in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]
+    in (foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2])
+            {_rmName = "shuriken"}
 {- | TODO: pathing 
 Precondition: first float is less than the second by at least 40. -}
 roomTwistCross 
@@ -145,4 +148,5 @@ roomTwistCross x y z =
             , _rmPmnts  = [mntLS iShape (V2 x x) (V3 (x-20) (x-20) 70)]
             , _rmBound  = ps
             }
-    in foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2]
+    in (foldr1 combineRooms $ map (\r -> shiftRoomBy (V2 0 0, r) corner) [0,pi/2,pi,3*pi/2])
+        {_rmName = "twistCross" }

src/Dodge/Room/LasTurret.hs

@@ -53,7 +53,7 @@ lightSensByDoor rm = rm
     & rmPmnts %~ ( 
         [ psPt atFstLnkOut $ PutForeground $ colorSH yellow 
             $ barPP 1.5 (V3 20 (-1) 0) (V3 20 (-1) 80)
-        , heightWallPS (atNthLnkOutShiftInward 1 50) 30 (rectNSEW (10) (-10) 20 (-20))
+        , heightWallPS (atNthLnkOutShiftInward 1 100) 30 (rectNSEW (10) (-10) 20 (-20))
         , heightWallPS (atFstLnkOutShiftInward 100) 30 (rectNSEW (10) (-10) 20 (-20))
         ] ++ )
     & rmExtPmnt ?~
@@ -76,6 +76,6 @@ lasCenSensEdge n = do
     cenroom <- randomiseOutLinks $ (lightSensByDoor cenLasTur) {_rmLabel = Just n}
     let doorroom = switchDoorRoom {_rmTakeFrom = Just n}
     return $ treeFromTrunk [PassDown door] (Node (PassDown cenroom) 
-        [treeFromPost [PassDown doorroom] (UseAll door), treeFromPost [UseNone door] (UseNone corridor)
+        [treeFromPost [PassDown doorroom] (UseAll door), treeFromPost [PassDown door] (UseLabel 0 corridor)
         ]
         )

src/Dodge/RoomComplex.hs

@@ -1 +1,3 @@
 module Dodge.RoomComplex where
+
+

src/Dodge/Tree/Compose.hs

@@ -7,19 +7,29 @@ module Dodge.Tree.Compose
     , chainUses
     , useAllAtEnd
     , changeToPassDown
+    , overwriteLabel
     ) where
 import Dodge.Tree.Compose.Data
+import Dodge.Tree.Polymorphic
 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 . \i -> extChildren !! i) is)
-    Node (UseNone _)    _   -> fmap _unCompose root
+    Node (UseNone _) _   -> fmap _unCompose root
+    Node (UseLabel _ _) _   -> fmap _unCompose root
     Node (PassDown x)   xs  -> Node x $ map (expandTree . (`Node` extChildren)) xs
     Node (SplitDown x)  xs  -> Node x $ map expandTree $ zipWith Node xs 
             $ map (:[]) extChildren ++ repeat []
 
+overwriteLabel :: Int -> (a -> ComposingNode a) -> SubCompTree a -> [SubCompTree a] -> SubCompTree a
+overwriteLabel i f t ts = head $ updateSingleNode islabel update t
+  where
+    islabel (UseLabel j _) | i == j = True
+    islabel _ = False
+    update (Node cr _) = Node (f $ _unCompose cr) 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

src/Dodge/Tree/Compose/Data.hs

@@ -9,6 +9,7 @@ data ComposingNode a
     | UseAll    {_unCompose :: a}
     | UseSome   {_composeIndices :: [Int], _unCompose :: a}
     | UseNone   {_unCompose :: a}
+    | UseLabel  {_composeIndex :: Int, _unCompose :: a} -- defaults to using no children
 type SubCompTree a = Tree (ComposingNode a)
 type CompTree a = Tree (Tree (ComposingNode a))
 makeLenses ''ComposingNode

src/Dodge/Tree/Polymorphic.hs

@@ -15,6 +15,7 @@ module Dodge.Tree.Polymorphic
     , applyToRandomNode
     , addToTrunk
     , inorderNumberTree
+    , updateSingleNode
     )
     where
 import Dodge.RandomHelp
@@ -22,6 +23,7 @@ import Dodge.RandomHelp
 import Data.Tree
 import Control.Monad.State
 import System.Random
+import Control.Lens
 
 {- |
 Creates a linear tree.
@@ -73,6 +75,22 @@ applyToNode (i:is) f (Node x xs) = Node x (ys ++ [applyToNode is f z] ++ zs)
 --    | otherwise = Node x (applyToSubTrunkBy cond f t : ts)
 --applyToSubTrunkBy _ _ t = t
 
+-- gives the list of all updates to a single node
+updateSingleNode :: (a -> Bool) -> (Tree a -> Tree a) -> Tree a -> [Tree a]
+updateSingleNode f update t@(Node x ts)
+    | f x       = update t : updateChildren
+    | otherwise = updateChildren
+  where
+    updateChildren = map (Node x) (subMap (updateSingleNode f update) ts)
+
+subMap :: (a -> [a]) -> [a] -> [[a]]
+subMap f (x:xs) = (f x <&> (: xs)) ++ ( (x :) <$> (subMap f xs) )
+subMap _ [] = []
+
+--subMap' :: Monad m => (a -> m a) -> [a] -> m [a]
+--subMap' f (x:xs) = (f x <&> (: xs)) ++ ( (x :) <$> (subMap f xs) )
+--subMap' f [] = 
+
 -- find use for?
 --zipTree :: Tree a -> Tree b -> Tree (a,b)
 --zipTree (Node x xs) (Node y ys) = Node (x,y) $ zipWith zipTree xs ys

src/Dodge/Tree/Shift.hs

@@ -48,7 +48,12 @@ posRms bounds parenti@(pr,i) numChild (t@(Node (cr,i') _):ts) tseq = do
             mayrs <- posRms (convexBounds ++ bounds) 
                 (first upr parenti) (numChild + 1) ts (tseq |> shiftedt)
             case mayrs of
-                Nothing -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
+                --Nothing -> putStr ("Backtracking to room " ++ show i' ++ ": ") >> tryLinks (j+1) ls
+                Nothing -> do
+                    putStr $ "Backtracking to " ++ (rpns 20 (_rmName cr ++ "-" ++ show i')) 
+                        ++ (rpns 9 (" child " ++ show numChild ))
+                        ++ (rpns 25 (" of " ++ _rmName pr ++ "-" ++ show i ))
+                    tryLinks (j+1) ls
                 Just rs -> return (Just rs)
       where
         convexBounds = map pointsToPoly $ _rmBound r'