From 67e164c830dfb9e1796bbf82fe4de8164af39799 Mon Sep 17 00:00:00 2001 From: justin Date: Fri, 12 Nov 2021 14:16:16 +0000 Subject: [PATCH] Some cleanup, sidetracked from inter-room placements --- src/Dodge/Data.hs | 1 + src/Dodge/Default/Room.hs | 10 +-- src/Dodge/Default/World.hs | 3 +- src/Dodge/Floor.hs | 112 +++++++++++++----------------- src/Dodge/Layout.hs | 6 +- src/Dodge/Layout/Tree/Annotate.hs | 25 ++++--- src/Dodge/Layout/Tree/Shift.hs | 2 +- src/Dodge/LevelGen.hs | 49 +++++++++---- src/Dodge/LevelGen/Data.hs | 8 ++- src/Dodge/Placements/Spot.hs | 14 ++-- src/Dodge/Room/Data.hs | 9 ++- src/Dodge/Room/Door.hs | 29 ++++++-- src/Dodge/Room/Link.hs | 8 +-- 13 files changed, 160 insertions(+), 116 deletions(-) diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 5203582fb..64b76d14f 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -63,6 +63,7 @@ data World = World , _machines :: IM.IntMap Machine , _blocks :: IM.IntMap Block , _coordinates :: IM.IntMap Point2 + , _triggers :: IM.IntMap (World -> Bool) , _wallsZone :: Zone (IM.IntMap Wall) , _floorItems :: IM.IntMap FloorItem , _floorTiles :: [(Point3,Point3)] diff --git a/src/Dodge/Default/Room.hs b/src/Dodge/Default/Room.hs index 1b77c37f9..70b57df6d 100644 --- a/src/Dodge/Default/Room.hs +++ b/src/Dodge/Default/Room.hs @@ -8,15 +8,17 @@ defaultRoom :: Room defaultRoom = Room { _rmPolys = [] , _rmLinks = [] - , _rmUsedLinks = [] + , _rmPos = [] , _rmPath = [] - , _rmPmnts = [] - , _rmPartialPmnts = IM.empty - , _rmLabelledPmnts = IM.empty + , _rmPmnts = [] + , _rmTriggerPmnts = IM.empty + , _rmTriggers = IM.empty , _rmBound = [] , _rmFloor = [] , _rmName = "defaultRoom" , _rmShift = (V2 0 0 , 0) , _rmViewpoints = [] , _rmRandPSs = [] + , _rmLabel = Nothing + , _rmTakeFrom = Nothing } diff --git a/src/Dodge/Default/World.hs b/src/Dodge/Default/World.hs index f1ea835b9..9e896fae4 100644 --- a/src/Dodge/Default/World.hs +++ b/src/Dodge/Default/World.hs @@ -39,7 +39,8 @@ defaultWorld = World , _blocks = IM.empty , _machines = IM.empty , _doors = IM.empty - , _coordinates = IM.empty + , _coordinates = IM.empty + , _triggers = IM.empty , _wallsZone = Zone IM.empty , _floorItems = IM.empty , _floorTiles = [] diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 5ff654c70..2b6a50e23 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -1,6 +1,5 @@ {-# OPTIONS_GHC -Wno-unused-imports #-} -{- | -The tree of rooms that make up a level. -} +{- | The tree of rooms that make up a level. -} module Dodge.Floor ( layoutLevelFromSeed ) where @@ -34,72 +33,59 @@ import Data.Sequence hiding (zipWith) import Data.Maybe initialAnoTree :: RandomGen g => Tree [Annotation g] -initialAnoTree = - let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom] - t' = padWithCorridors struct - in treeFromTrunk - [[StartRoom] - ,[Corridor] - ,[SpecificRoom $ return $ connectRoom lasTunnel ] - ,[Corridor] - ,[SpecificRoom $ fmap connectRoom slowDoorRoom ] - ,[Corridor] - ,[Corridor] - ,[Corridor] - ,[SpecificRoom $ fmap connectRoom roomCCrits] - ,[Corridor] - ,[AirlockAno] - ,[Corridor] - ,[Corridor] ----- ,[SpecificRoom roomCCrits] ----- ,[Corridor] ----- ,[Corridor] ----- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 ----- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit ----- ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit ----- ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit ----- ]++) ----- ] ----- --,[Corridor] ----- --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 ----- -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) ----- -- ] ----- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 ----- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++) ----- ] ----- ,[Corridor] ----- ,[Corridor] --- --,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers] ---- ,[SpecificRoom $ pure $ (pure . Right) (twinSlowDoorRoom 80 200 40)] +initialAnoTree = padSucWithCorridors $ treeFromTrunk + [[StartRoom] + ,[SpecificRoom $ return $ connectRoom lasTunnel ] + ,[SpecificRoom $ fmap connectRoom slowDoorRoom ] + ,[Corridor] + ,[Corridor] + ,[SpecificRoom $ fmap connectRoom roomCCrits] + ,[AirlockAno] + ,[Corridor] +---- ,[SpecificRoom roomCCrits] +---- ,[Corridor] +---- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 +---- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit +---- ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit +---- ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit +---- ]++) +---- ] +---- --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 +---- -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) +---- -- ] +---- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 +---- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++) +---- ] +---- ,[Corridor] +-- --,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers] +--- ,[SpecificRoom $ pure $ (pure . Right) (twinSlowDoorRoom 80 200 40)] +--- ,[DoorAno] +--- ,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit] +--- ,[SpecificRoom blockedCorridor] +--- ,[OrAno [[DoorAno] --- ,[Corridor] ---- ,[DoorAno] ---- ,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit] ---- ,[SpecificRoom blockedCorridor] ---- ,[OrAno [[DoorAno] ---- ,[Corridor] ---- ,[DoorNumAno 0,AirlockAno]] ---- ] ---- ,[FirstWeapon] ---- ,[CorridorDebug] ---- ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom] - ,[Corridor] - ,[OrAno - [[SpecificRoom $ branchRectWith $ fmap (fmap Left) armouredChasers] - ,[BossAno $ addArmour launcherCrit & crHP +~ 800 - & crState . crDropsOnDeath .~ DropSpecific [0] ] - ] - ] - ,[Corridor] --- ,[SpecificRoom $ fmap (pure . Right) armouredCorridor] - ,[Corridor] - ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] - ] - t' +--- ,[DoorNumAno 0,AirlockAno]] +--- ] +--- ,[FirstWeapon] +--- ,[CorridorDebug] +--- ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom] + ,[OrAno + [[SpecificRoom $ branchRectWith $ fmap (fmap Left) armouredChasers] + ,[BossAno $ addArmour launcherCrit & crHP +~ 800 + & crState . crDropsOnDeath .~ DropSpecific [0] ] + ] + ] +-- ,[SpecificRoom $ fmap (pure . Right) armouredCorridor] + ,[Corridor] + ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]] + ] + $ treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] + [EndRoom] {- | A test level tree. -} initialRoomTree :: RandomGen g => State g (Tree Room) initialRoomTree = do - expandTreeBy id <$> mapM annoToRoomTree initialAnoTree + expandTreeBy id <$> mapM anoToRoomTree initialAnoTree layoutLevelFromSeed :: Int -> Int -> IO [Room] layoutLevelFromSeed i seed = do diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 4615cd75f..40b09c769 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -10,8 +10,6 @@ import Dodge.Wall.Zone import Dodge.Zone import Dodge.GameRoom import Dodge.Bounds ---import Dodge.RandomHelp ---import Dodge.Graph import Dodge.Layout.Tree.Polymorphic (applyToRoot) import Dodge.Room.Data import Dodge.Room.AddTile @@ -117,10 +115,10 @@ gameRoomsFromRooms = map f f rm = GameRoom { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm) ++ map fst (_rmLinks rm) - , _grViewpointsEx = mapMaybe unpos (_rmUsedLinks rm) + , _grViewpointsEx = mapMaybe unpos (_rmPos rm) , _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints . concat $ _rmBound rm ++ _rmPolys rm - , _grDir = getDir $ _rmUsedLinks rm + , _grDir = getDir $ _rmPos rm , _grName = _rmName rm } closePoints x y = roundPoint2 x == roundPoint2 y diff --git a/src/Dodge/Layout/Tree/Annotate.hs b/src/Dodge/Layout/Tree/Annotate.hs index d595e8681..604a26473 100644 --- a/src/Dodge/Layout/Tree/Annotate.hs +++ b/src/Dodge/Layout/Tree/Annotate.hs @@ -1,8 +1,5 @@ -{- | -Annotating tree structures with desired properties for rooms. --} -module Dodge.Layout.Tree.Annotate - where +{- | Annotating tree structures with desired properties for rooms. -} +module Dodge.Layout.Tree.Annotate where import Dodge.Data import Dodge.RandomHelp import Dodge.Layout.Tree.Polymorphic @@ -23,6 +20,7 @@ import Dodge.Room.Teleport import Data.Tree import Control.Monad.State import System.Random +import Control.Lens data Annotation g = Lock Int @@ -40,6 +38,8 @@ data Annotation g | SpecificRoom (State g (Tree (Either Room Room))) | BossAno Creature | TreasureAno [Creature] [Item] + | SetLabel Int (State g Room) + | UseLabel Int (State g Room) addLock :: RandomGen g => Int -> Tree [Annotation g] -> State g (Tree [Annotation g]) addLock i t = do @@ -49,6 +49,9 @@ addLock i t = do {- | Add one corridor between each parent-child link of a tree of annotations. -} padWithCorridors :: Tree [Annotation g] -> Tree [Annotation g] padWithCorridors (Node x xs) = Node [Corridor] [Node x (map padWithCorridors xs)] +padSucWithCorridors :: Tree [Annotation g] -> Tree [Annotation g] +padSucWithCorridors (Node x xs) = Node x (map padWithCorridors xs) + {- Add one to three corridors between each parent-child link of a tree of annotations. -} randomPadCorridors :: RandomGen g => Tree [Annotation g] -> State g (Tree [Annotation g]) randomPadCorridors (Node x xs) = do @@ -60,11 +63,17 @@ roomThenCorridor :: RandomGen g => Room -> State g (Tree (Either Room Room)) roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r]) (randomiseOutLinks corridor) {- | Create a random room tree structure from a list of annotations. -} -annoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room)) -annoToRoomTree anos = case anos of +anoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room)) +anoToRoomTree anos = case anos of + [SetLabel i randrm] -> do + rm <- randrm + return . connectRoom $ rm & rmLabel ?~ i + [UseLabel i randrm] -> do + rm <- randrm + return $ connectRoom $ rm & rmTakeFrom ?~ i [OrAno as] -> do a <- takeOne as - annoToRoomTree a + anoToRoomTree a [Corridor] -> pure . Right <$> randomiseOutLinks corridor [CorridorDebug] -> pure . Right <$> randomiseOutLinks corridorDebug [DoorAno] -> roomThenCorridor door diff --git a/src/Dodge/Layout/Tree/Shift.hs b/src/Dodge/Layout/Tree/Shift.hs index 0169b3a0a..2bcb154ac 100644 --- a/src/Dodge/Layout/Tree/Shift.hs +++ b/src/Dodge/Layout/Tree/Shift.hs @@ -47,6 +47,6 @@ posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do where convexBounds = map pointsToPoly $ _rmBound r' clipping = or (convexPolysOverlap <$> convexBounds <*> bounds) - useLink = (r & rmLinks %~ delete l & rmUsedLinks %~ (uncurry (OutLink (Prelude.length ts)) l :) + useLink = (r & rmLinks %~ delete l & rmPos %~ (uncurry (OutLink (Prelude.length ts)) l :) , i) shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index f6ee09c7b..719e9b2b3 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} -- | deals with placement of objects within the world -- after they have had their coordinates set by the layout module Dodge.LevelGen @@ -26,11 +27,16 @@ import Control.Monad.State import Control.Lens import qualified Data.IntSet as IS +placeSpotRoomRand :: Room -> Int -> Placement -> World -> (World,Room) +placeSpotRoomRand rm i plmnt w = + let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w + in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps) + placeSpot :: (World,Room) -> Placement -> (World,Room) placeSpot (w,rm) plmnt = case plmnt of - Placement{_plSpot = PSRoomRand i} - -> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w - in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps) + Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w +-- -> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w +-- in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps) Placement{_plSpot = PSLnk{}} -> case lnks of ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt) [] -> case fallback of @@ -77,8 +83,10 @@ shiftPSBy (pos,rot) ps = ps -- button ids, etc placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World) placeSpotID ps pt w = case pt of + PutTrigger cond -> placeNewInto triggers cond w PutProp prop -> placeProp prop p rot w - PutButton bt -> placeBt bt p rot w + --PutButton bt -> placeBt bt p rot w + PutButton bt -> placeNewUpdateID buttons btID (mvButton bt p rot) w PutFlIt itm -> placeFlIt itm p rot w PutCrit cr -> placeCr cr p rot w PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc p rot w @@ -88,7 +96,7 @@ placeSpotID ps pt w = case pt of where (evaluatedType, g) = runState rgen (_randGen w) PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) w - PutCoordinate coordp -> placeCoordinate (doShift coordp) w + PutCoordinate coordp -> placeNewInto coordinates (doShift coordp) w PutSlideDoor pathing col f a b spd -> placeSlideDoor pathing col f (doShift a) (doShift b) spd w PutBlock (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w PutBlock{} -> error "messed up block placement somehow" @@ -129,10 +137,25 @@ addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls where wlid = IM.newKey wls -placeCoordinate :: Point2 -> World -> (Int,World) -placeCoordinate p w = (i, w & coordinates %~ IM.insert i p) +-- | generalised way of putting a new item into a lensed intmap, returning the +-- new index as well +placeNewInto :: ALens' World (IM.IntMap a) + -> a + -> World + -> (Int,World) +placeNewInto l x w = (i,w & l #%~ IM.insert i x) where - i = IM.newKey $ _coordinates w + i = IM.newKey $ w ^# l + +-- | place an new object into an intmap and update its id +placeNewUpdateID :: ALens' World (IM.IntMap a) + -> ALens' a Int + -> a + -> World + -> (Int,World) +placeNewUpdateID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i)) + where + i = IM.newKey $ w ^# l placeProp :: Prop @@ -155,8 +178,11 @@ placeBt placeBt bt p a w = (i , over buttons addBT w) where i = IM.newKey $ _buttons w - addBT xs = IM.insert i (f bt) xs + addBT = IM.insert i (f bt) f = (btRot +~ a) . (btPos %~ ( (p +.+) . rotateV a )) . (btID .~ i) + +mvButton bt p a = bt & btRot +~ a & btPos %~ ( (p +.+) . rotateV a ) + {- Creates a floor item at a given point. Assigns an id correctly. -} placeFlIt @@ -165,9 +191,8 @@ placeFlIt -> Float -- ^ Rotation -> World -> (Int, World) -placeFlIt itm p rot w = (i, w & floorItems %~ \ fis -> IM.insert i - ( FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm } - ) fis +placeFlIt itm p rot w = (i + , w & floorItems %~ IM.insert i FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm } ) where i = IM.newKey $ _floorItems w diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 708935c39..782494146 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -19,6 +19,7 @@ data PSType = PutCrit {_unPutCrit :: Creature} | PutPressPlate PressPlate | PutBlock [Int] Color [Point2] | PutCoordinate Point2 + | PutTrigger (World -> Bool) | PutLineBlock Wall Float Float Point2 Point2 | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float @@ -72,9 +73,10 @@ ps0j :: PSType -> Placement -> Placement ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst (const $ Just plmnt) addPlmnt :: Placement -> Placement -> Placement -addPlmnt pl (PlacementUsingPos p f) = PlacementUsingPos p (fmap (addPlmnt pl) f) -addPlmnt pl (RandomPlacement rp) = RandomPlacement $ fmap (addPlmnt pl) rp -addPlmnt pl (Placement ps pt f) = Placement ps pt (fmap g f) +addPlmnt pl pl2 = case pl2 of + (PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f) + (RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp + (Placement ps pt f) -> Placement ps pt (fmap g f) where g Nothing = Just pl g (Just pl') = Just $ addPlmnt pl pl' diff --git a/src/Dodge/Placements/Spot.hs b/src/Dodge/Placements/Spot.hs index 51771505e..ebf3e3816 100644 --- a/src/Dodge/Placements/Spot.hs +++ b/src/Dodge/Placements/Spot.hs @@ -11,9 +11,10 @@ setPS = updatePS . const updatePSToLevel :: Int -> (PlacementSpot -> PlacementSpot) -> Placement -> Placement updatePSToLevel 0 _ plmnt = plmnt -updatePSToLevel i f (PlacementUsingPos p pl) = PlacementUsingPos p (fmap (updatePSToLevel i f) pl) -updatePSToLevel i f (Placement ps pt pl) = Placement (f ps) pt (fmap (fmap (updatePSToLevel (i-1) f)) pl) -updatePSToLevel i f (RandomPlacement rplmnt) = RandomPlacement $ fmap (updatePSToLevel i f) rplmnt +updatePSToLevel i f plmnt = case plmnt of + PlacementUsingPos p pl -> PlacementUsingPos p (fmap (updatePSToLevel i f) pl) + Placement ps pt pl -> Placement (f ps) pt (fmap (fmap (updatePSToLevel (i-1) f)) pl) + RandomPlacement rplmnt -> RandomPlacement $ fmap (updatePSToLevel i f) rplmnt setLocalPS :: PlacementSpot -> Placement -> Placement setLocalPS ps (Placement _ pt f) = Placement ps pt f @@ -21,6 +22,7 @@ setLocalPS ps (RandomPlacement rplmnt) = RandomPlacement (fmap (setLocalPS ps) r setLocalPS _ plmnt = plmnt updatePS :: (PlacementSpot -> PlacementSpot) -> Placement -> Placement -updatePS f (Placement ps pt iplmnt) = Placement (f ps) pt ((fmap . fmap $ updatePS f) iplmnt) -updatePS f (PlacementUsingPos p plmnt) = PlacementUsingPos p (fmap (updatePS f) plmnt) -updatePS f (RandomPlacement rplmnt) = RandomPlacement (fmap (updatePS f) rplmnt) +updatePS f pl' = case pl' of + Placement ps pt ipl -> Placement (f ps) pt $ (fmap . fmap $ updatePS f) ipl + PlacementUsingPos p pl -> PlacementUsingPos p (fmap (updatePS f) pl) + RandomPlacement rpl -> RandomPlacement (fmap (updatePS f) rpl) diff --git a/src/Dodge/Room/Data.hs b/src/Dodge/Room/Data.hs index b04a90b7b..063cc9fb7 100644 --- a/src/Dodge/Room/Data.hs +++ b/src/Dodge/Room/Data.hs @@ -5,6 +5,7 @@ module Dodge.Room.Data import Dodge.LevelGen.Data import Geometry.Data import Data.Tile +import Dodge.Data import Control.Monad.State import System.Random @@ -22,17 +23,19 @@ assigning no bounds will allow rooms to overlap. data Room = Room { _rmPolys :: [ [Point2] ] , _rmLinks :: [(Point2,Float)] - , _rmUsedLinks :: [RoomPos] + , _rmPos :: [RoomPos] , _rmPath :: [(Point2, Point2)] , _rmPmnts :: [Placement] - , _rmLabelledPmnts :: IM.IntMap Placement - , _rmPartialPmnts :: IM.IntMap (Int -> Placement) + , _rmTriggers :: IM.IntMap (World -> Bool) + , _rmTriggerPmnts :: IM.IntMap ((World -> Bool) -> Placement) , _rmBound :: [ [Point2] ] , _rmFloor :: [Tile] , _rmName :: String , _rmShift :: (Point2, Float) , _rmViewpoints :: [Point2] , _rmRandPSs :: [State StdGen (Point2,Float)] + , _rmLabel :: Maybe Int + , _rmTakeFrom :: Maybe Int } data RoomPos = OutLink Int Point2 Float diff --git a/src/Dodge/Room/Door.hs b/src/Dodge/Room/Door.hs index 1ae965f2a..a73c41320 100644 --- a/src/Dodge/Room/Door.hs +++ b/src/Dodge/Room/Door.hs @@ -1,12 +1,13 @@ -{- -Rooms that connect other rooms, blocking sight. --} +{- Rooms that connect other rooms, blocking sight. -} module Dodge.Room.Door where import Geometry import Dodge.Room.Data import Dodge.Default.Room import Dodge.Placements +import Color + +import qualified Data.IntMap.Strict as IM door :: Room door = defaultRoom @@ -17,8 +18,24 @@ door = defaultRoom , _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)] -- note no bounds } - where lnks = [(V2 20 35,0) - ,(V2 20 5,pi) - ] + where + lnks = [(V2 20 35,0) + ,(V2 20 5,pi) + ] +switchDoor :: Room +switchDoor = defaultRoom + { _rmPolys = [rectNSWE 40 0 0 40] + , _rmLinks = lnks + , _rmPath = [(V2 20 35,V2 20 5)] +-- door extends into side walls (for shadows as rendered 12/03) + , _rmTriggerPmnts = IM.fromList + [(0,\cond -> putDoubleDoor False red cond (V2 0 20) (V2 40 20) 2)] +-- note no bounds + } + where + lnks = [(V2 20 35,0) + ,(V2 20 5,pi) + ] + diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index e9eed36f6..409ad7463 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -1,10 +1,8 @@ -{- -Concerns link pairs of rooms. +{- Concerns link pairs of rooms. Link pairs determine where rooms can attach to each other; each pair consists of a position and a rotation. The last link in the list is considered the incoming link, the other links are -the outgoing links. --} +the outgoing links. -} module Dodge.Room.Link ( shiftRoomToLink , shiftRoomBy @@ -111,5 +109,5 @@ setLastLinkToUsed :: Room -> Room setLastLinkToUsed rm = case _rmLinks rm of (_:_) -> rm & rmLinks %~ init - & rmUsedLinks %~ (uncurry InLink (last (_rmLinks rm)) :) + & rmPos %~ (uncurry InLink (last (_rmLinks rm)) :) _ -> rm