From 5ab5be3087253d94a63b526736e0da510fc70c89 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 22 Nov 2021 23:54:58 +0000 Subject: [PATCH] Test of lock and key system --- src/Dodge/Annotation.hs | 21 ++++++++++++++------- src/Dodge/Annotation/Data.hs | 7 +++++-- src/Dodge/Floor.hs | 2 ++ src/Dodge/LockAndKey.hs | 22 +++++++++++++++++----- src/Dodge/Room/Boss.hs | 8 ++++++-- src/Dodge/Room/LasTurret.hs | 4 ++-- src/Dodge/RoomComplex.hs | 2 ++ src/Dodge/Tree/Compose.hs | 12 +++++++++++- src/Dodge/Tree/Compose/Data.hs | 1 + src/Dodge/Tree/Polymorphic.hs | 18 ++++++++++++++++++ src/Dodge/Tree/Shift.hs | 7 ++++++- 11 files changed, 84 insertions(+), 20 deletions(-) diff --git a/src/Dodge/Annotation.hs b/src/Dodge/Annotation.hs index 2aea8ea09..8d7d0d511 100644 --- a/src/Dodge/Annotation.hs +++ b/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 diff --git a/src/Dodge/Annotation/Data.hs b/src/Dodge/Annotation/Data.hs index 2d12884da..7efbf35ad 100644 --- a/src/Dodge/Annotation/Data.hs +++ b/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 diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 60d74d718..c785a6f49 100644 --- a/src/Dodge/Floor.hs +++ b/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 diff --git a/src/Dodge/LockAndKey.hs b/src/Dodge/LockAndKey.hs index 9ff36904b..932823762 100644 --- a/src/Dodge/LockAndKey.hs +++ b/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) + diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs index 47da6e9d0..c687d3ff7 100644 --- a/src/Dodge/Room/Boss.hs +++ b/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" } diff --git a/src/Dodge/Room/LasTurret.hs b/src/Dodge/Room/LasTurret.hs index 58d98c906..524aa8b35 100644 --- a/src/Dodge/Room/LasTurret.hs +++ b/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) ] ) diff --git a/src/Dodge/RoomComplex.hs b/src/Dodge/RoomComplex.hs index 8e0a76296..5c6f499c4 100644 --- a/src/Dodge/RoomComplex.hs +++ b/src/Dodge/RoomComplex.hs @@ -1 +1,3 @@ module Dodge.RoomComplex where + + diff --git a/src/Dodge/Tree/Compose.hs b/src/Dodge/Tree/Compose.hs index e675dc3d5..73836b134 100644 --- a/src/Dodge/Tree/Compose.hs +++ b/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 diff --git a/src/Dodge/Tree/Compose/Data.hs b/src/Dodge/Tree/Compose/Data.hs index e17bee55a..988b58226 100644 --- a/src/Dodge/Tree/Compose/Data.hs +++ b/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 diff --git a/src/Dodge/Tree/Polymorphic.hs b/src/Dodge/Tree/Polymorphic.hs index b7870d4f1..2ca2640eb 100644 --- a/src/Dodge/Tree/Polymorphic.hs +++ b/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 diff --git a/src/Dodge/Tree/Shift.hs b/src/Dodge/Tree/Shift.hs index 4f2eeaa8b..8a8ead5cb 100644 --- a/src/Dodge/Tree/Shift.hs +++ b/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'