justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Some cleanup, sidetracked from inter-room placements

Browse Source
This commit is contained in:
justin
2021-11-12 14:16:16 +00:00
parent 1d5b2ea765
commit 67e164c830
13 changed files with 160 additions and 116 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+1
View File
@@ -63,6 +63,7 @@ data World = World
, _machines :: IM.IntMap Machine , _machines :: IM.IntMap Machine
, _blocks :: IM.IntMap Block , _blocks :: IM.IntMap Block
, _coordinates :: IM.IntMap Point2 , _coordinates :: IM.IntMap Point2
, _triggers :: IM.IntMap (World -> Bool)
, _wallsZone :: Zone (IM.IntMap Wall) , _wallsZone :: Zone (IM.IntMap Wall)
, _floorItems :: IM.IntMap FloorItem , _floorItems :: IM.IntMap FloorItem
, _floorTiles :: [(Point3,Point3)] , _floorTiles :: [(Point3,Point3)]
src/Dodge/Default/Room.hs
+6 -4
View File
@@ -8,15 +8,17 @@ defaultRoom :: Room
defaultRoom = Room defaultRoom = Room
{ _rmPolys = [] { _rmPolys = []
, _rmLinks = [] , _rmLinks = []
, _rmUsedLinks = [] , _rmPos = []
, _rmPath = [] , _rmPath = []
, _rmPmnts = [] , _rmPmnts = []
, _rmPartialPmnts = IM.empty , _rmTriggerPmnts = IM.empty
, _rmLabelledPmnts = IM.empty , _rmTriggers = IM.empty
, _rmBound = [] , _rmBound = []
, _rmFloor = [] , _rmFloor = []
, _rmName = "defaultRoom" , _rmName = "defaultRoom"
, _rmShift = (V2 0 0 , 0) , _rmShift = (V2 0 0 , 0)
, _rmViewpoints = [] , _rmViewpoints = []
, _rmRandPSs = [] , _rmRandPSs = []
, _rmLabel = Nothing
, _rmTakeFrom = Nothing
} }
src/Dodge/Default/World.hs
+2 -1
View File
@@ -39,7 +39,8 @@ defaultWorld = World
, _blocks = IM.empty , _blocks = IM.empty
, _machines = IM.empty , _machines = IM.empty
, _doors = IM.empty , _doors = IM.empty
, _coordinates = IM.empty , _coordinates = IM.empty
, _triggers = IM.empty
, _wallsZone = Zone IM.empty , _wallsZone = Zone IM.empty
, _floorItems = IM.empty , _floorItems = IM.empty
, _floorTiles = [] , _floorTiles = []
src/Dodge/Floor.hs
+49 -63
View File
@@ -1,6 +1,5 @@
{-# OPTIONS_GHC -Wno-unused-imports #-} {-# 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 module Dodge.Floor
( layoutLevelFromSeed ( layoutLevelFromSeed
) where ) where
@@ -34,72 +33,59 @@ import Data.Sequence hiding (zipWith)
import Data.Maybe import Data.Maybe
initialAnoTree :: RandomGen g => Tree [Annotation g] initialAnoTree :: RandomGen g => Tree [Annotation g]
initialAnoTree = initialAnoTree = padSucWithCorridors $ treeFromTrunk
let struct = treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]] [EndRoom] [[StartRoom]
t' = padWithCorridors struct ,[SpecificRoom $ return $ connectRoom lasTunnel ]
in treeFromTrunk ,[SpecificRoom $ fmap connectRoom slowDoorRoom ]
[[StartRoom] ,[Corridor]
,[Corridor] ,[Corridor]
,[SpecificRoom $ return $ connectRoom lasTunnel ] ,[SpecificRoom $ fmap connectRoom roomCCrits]
,[Corridor] ,[AirlockAno]
,[SpecificRoom $ fmap connectRoom slowDoorRoom ] ,[Corridor]
,[Corridor] ---- ,[SpecificRoom roomCCrits]
,[Corridor] ---- ,[Corridor]
,[Corridor] ---- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
,[SpecificRoom $ fmap connectRoom roomCCrits] ---- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit
,[Corridor] ---- ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit
,[AirlockAno] ---- ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit
,[Corridor] ---- ]++)
,[Corridor] ---- ]
---- ,[SpecificRoom roomCCrits] ---- --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
---- ,[Corridor] ---- -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
---- ,[Corridor] ---- -- ]
---- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 ---- ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
---- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit ---- & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
---- ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit ---- ]
---- ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit ---- ,[Corridor]
---- ]++) -- --,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers]
---- ] --- ,[SpecificRoom $ pure $ (pure . Right) (twinSlowDoorRoom 80 200 40)]
---- --,[Corridor] --- ,[DoorAno]
---- --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400 --- ,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit]
---- -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++) --- ,[SpecificRoom blockedCorridor]
---- -- ] --- ,[OrAno [[DoorAno]
---- ,[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)]
--- ,[Corridor] --- ,[Corridor]
--- ,[DoorAno] --- ,[DoorNumAno 0,AirlockAno]]
--- ,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit] --- ]
--- ,[SpecificRoom blockedCorridor] --- ,[FirstWeapon]
--- ,[OrAno [[DoorAno] --- ,[CorridorDebug]
--- ,[Corridor] --- ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]
--- ,[DoorNumAno 0,AirlockAno]] ,[OrAno
--- ] [[SpecificRoom $ branchRectWith $ fmap (fmap Left) armouredChasers]
--- ,[FirstWeapon] ,[BossAno $ addArmour launcherCrit & crHP +~ 800
--- ,[CorridorDebug] & crState . crDropsOnDeath .~ DropSpecific [0] ]
--- ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom] ]
,[Corridor] ]
,[OrAno -- ,[SpecificRoom $ fmap (pure . Right) armouredCorridor]
[[SpecificRoom $ branchRectWith $ fmap (fmap Left) armouredChasers] ,[Corridor]
,[BossAno $ addArmour launcherCrit & crHP +~ 800 ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
& crState . crDropsOnDeath .~ DropSpecific [0] ] ]
] $ treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]]
] [EndRoom]
,[Corridor]
-- ,[SpecificRoom $ fmap (pure . Right) armouredCorridor]
,[Corridor]
,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
]
t'
{- | A test level tree. -} {- | A test level tree. -}
initialRoomTree :: RandomGen g => State g (Tree Room) initialRoomTree :: RandomGen g => State g (Tree Room)
initialRoomTree = do initialRoomTree = do
expandTreeBy id <$> mapM annoToRoomTree initialAnoTree expandTreeBy id <$> mapM anoToRoomTree initialAnoTree
layoutLevelFromSeed :: Int -> Int -> IO [Room] layoutLevelFromSeed :: Int -> Int -> IO [Room]
layoutLevelFromSeed i seed = do layoutLevelFromSeed i seed = do
src/Dodge/Layout.hs
+2 -4
View File
@@ -10,8 +10,6 @@ import Dodge.Wall.Zone
import Dodge.Zone import Dodge.Zone
import Dodge.GameRoom import Dodge.GameRoom
import Dodge.Bounds import Dodge.Bounds
--import Dodge.RandomHelp
--import Dodge.Graph
import Dodge.Layout.Tree.Polymorphic (applyToRoot) import Dodge.Layout.Tree.Polymorphic (applyToRoot)
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Room.AddTile import Dodge.Room.AddTile
@@ -117,10 +115,10 @@ gameRoomsFromRooms = map f
f rm = GameRoom f rm = GameRoom
{ _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm) { _grViewpoints = _rmViewpoints rm ++ (map fst . foldl' (flip cutWalls) [] $ _rmPolys rm)
++ map fst (_rmLinks rm) ++ map fst (_rmLinks rm)
, _grViewpointsEx = mapMaybe unpos (_rmUsedLinks rm) , _grViewpointsEx = mapMaybe unpos (_rmPos rm)
, _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints , _grBound = expandPolyByFixed 100 . convexHullSafe . nubBy closePoints
. concat $ _rmBound rm ++ _rmPolys rm . concat $ _rmBound rm ++ _rmPolys rm
, _grDir = getDir $ _rmUsedLinks rm , _grDir = getDir $ _rmPos rm
, _grName = _rmName rm , _grName = _rmName rm
} }
closePoints x y = roundPoint2 x == roundPoint2 y closePoints x y = roundPoint2 x == roundPoint2 y
src/Dodge/Layout/Tree/Annotate.hs
+17 -8
View File
@@ -1,8 +1,5 @@
{- | {- | Annotating tree structures with desired properties for rooms. -}
Annotating tree structures with desired properties for rooms. module Dodge.Layout.Tree.Annotate where
-}
module Dodge.Layout.Tree.Annotate
where
import Dodge.Data import Dodge.Data
import Dodge.RandomHelp import Dodge.RandomHelp
import Dodge.Layout.Tree.Polymorphic import Dodge.Layout.Tree.Polymorphic
@@ -23,6 +20,7 @@ import Dodge.Room.Teleport
import Data.Tree import Data.Tree
import Control.Monad.State import Control.Monad.State
import System.Random import System.Random
import Control.Lens
data Annotation g data Annotation g
= Lock Int = Lock Int
@@ -40,6 +38,8 @@ data Annotation g
| SpecificRoom (State g (Tree (Either Room Room))) | SpecificRoom (State g (Tree (Either Room Room)))
| BossAno Creature | BossAno Creature
| TreasureAno [Creature] [Item] | 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 :: RandomGen g => Int -> Tree [Annotation g] -> State g (Tree [Annotation g])
addLock i t = do 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. -} {- | Add one corridor between each parent-child link of a tree of annotations. -}
padWithCorridors :: Tree [Annotation g] -> Tree [Annotation g] padWithCorridors :: Tree [Annotation g] -> Tree [Annotation g]
padWithCorridors (Node x xs) = Node [Corridor] [Node x (map padWithCorridors xs)] 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. -} {- 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 :: RandomGen g => Tree [Annotation g] -> State g (Tree [Annotation g])
randomPadCorridors (Node x xs) = do 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]) roomThenCorridor theRoom = fmap (\r -> Node (Left theRoom) [(pure . Right) r])
(randomiseOutLinks corridor) (randomiseOutLinks corridor)
{- | Create a random room tree structure from a list of annotations. -} {- | Create a random room tree structure from a list of annotations. -}
annoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room)) anoToRoomTree :: RandomGen g => [Annotation g] -> State g (Tree (Either Room Room))
annoToRoomTree anos = case anos of 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 [OrAno as] -> do
a <- takeOne as a <- takeOne as
annoToRoomTree a anoToRoomTree a
[Corridor] -> pure . Right <$> randomiseOutLinks corridor [Corridor] -> pure . Right <$> randomiseOutLinks corridor
[CorridorDebug] -> pure . Right <$> randomiseOutLinks corridorDebug [CorridorDebug] -> pure . Right <$> randomiseOutLinks corridorDebug
[DoorAno] -> roomThenCorridor door [DoorAno] -> roomThenCorridor door
src/Dodge/Layout/Tree/Shift.hs
+1 -1
View File
@@ -47,6 +47,6 @@ posRms bounds (r,i) (t@(Node (_,i') _):ts) tseq = do
where where
convexBounds = map pointsToPoly $ _rmBound r' convexBounds = map pointsToPoly $ _rmBound r'
clipping = or (convexPolysOverlap <$> convexBounds <*> bounds) 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) , i)
shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t shiftedt@(Node (r',_) _) = applyToRoot (first $ shiftRoomToLink l) t
src/Dodge/LevelGen.hs
+37 -12
View File
@@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RankNTypes #-}
-- | deals with placement of objects within the world -- | deals with placement of objects within the world
-- after they have had their coordinates set by the layout -- after they have had their coordinates set by the layout
module Dodge.LevelGen module Dodge.LevelGen
@@ -26,11 +27,16 @@ import Control.Monad.State
import Control.Lens import Control.Lens
import qualified Data.IntSet as IS 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 :: (World,Room) -> Placement -> (World,Room)
placeSpot (w,rm) plmnt = case plmnt of placeSpot (w,rm) plmnt = case plmnt of
Placement{_plSpot = PSRoomRand i} Placement{_plSpot = PSRoomRand i} -> placeSpotRoomRand rm i plmnt w
-> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w -- -> let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps) -- in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ uncurry PS ps)
Placement{_plSpot = PSLnk{}} -> case lnks of Placement{_plSpot = PSLnk{}} -> case lnks of
((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt) ((lnki,lnk):_) -> placeSpot (w & randGen .~ g,uselnk lnki) (updatePS (f lnk) plmnt)
[] -> case fallback of [] -> case fallback of
@@ -77,8 +83,10 @@ shiftPSBy (pos,rot) ps = ps
-- button ids, etc -- button ids, etc
placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World) placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World)
placeSpotID ps pt w = case pt of placeSpotID ps pt w = case pt of
PutTrigger cond -> placeNewInto triggers cond w
PutProp prop -> placeProp prop p rot 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 PutFlIt itm -> placeFlIt itm p rot w
PutCrit cr -> placeCr cr p rot w PutCrit cr -> placeCr cr p rot w
PutMachine col wallpoly mc -> placeMachine col (map doShift wallpoly) mc 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 where
(evaluatedType, g) = runState rgen (_randGen w) (evaluatedType, g) = runState rgen (_randGen w)
PutDoor col f pss -> placeDoor col f (map (bimap doShift doShift) pss) 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 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 (hp:hps) col ps' -> placeBlock (map doShift ps') hp col Opaque hps w
PutBlock{} -> error "messed up block placement somehow" 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 where
wlid = IM.newKey wls wlid = IM.newKey wls
placeCoordinate :: Point2 -> World -> (Int,World) -- | generalised way of putting a new item into a lensed intmap, returning the
placeCoordinate p w = (i, w & coordinates %~ IM.insert i p) -- 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 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 placeProp
:: Prop :: Prop
@@ -155,8 +178,11 @@ placeBt
placeBt bt p a w = (i , over buttons addBT w) placeBt bt p a w = (i , over buttons addBT w)
where where
i = IM.newKey $ _buttons w 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) 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. {- Creates a floor item at a given point.
Assigns an id correctly. -} Assigns an id correctly. -}
placeFlIt placeFlIt
@@ -165,9 +191,8 @@ placeFlIt
-> Float -- ^ Rotation -> Float -- ^ Rotation
-> World -> World
-> (Int, World) -> (Int, World)
placeFlIt itm p rot w = (i, w & floorItems %~ \ fis -> IM.insert i placeFlIt itm p rot w = (i
( FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm } , w & floorItems %~ IM.insert i FlIt { _flItPos = p , _flItRot = rot , _flItID = i , _flIt = itm }
) fis
) )
where where
i = IM.newKey $ _floorItems w i = IM.newKey $ _floorItems w
src/Dodge/LevelGen/Data.hs
+5 -3
View File
@@ -19,6 +19,7 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutPressPlate PressPlate | PutPressPlate PressPlate
| PutBlock [Int] Color [Point2] | PutBlock [Int] Color [Point2]
| PutCoordinate Point2 | PutCoordinate Point2
| PutTrigger (World -> Bool)
| PutLineBlock Wall Float Float Point2 Point2 | PutLineBlock Wall Float Float Point2 Point2
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
| PutSlideDoor Bool Color (World -> Bool) Point2 Point2 Float | 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) ps0j pst plmnt = Placement (PS (V2 0 0) 0) pst (const $ Just plmnt)
addPlmnt :: Placement -> Placement -> Placement addPlmnt :: Placement -> Placement -> Placement
addPlmnt pl (PlacementUsingPos p f) = PlacementUsingPos p (fmap (addPlmnt pl) f) addPlmnt pl pl2 = case pl2 of
addPlmnt pl (RandomPlacement rp) = RandomPlacement $ fmap (addPlmnt pl) rp (PlacementUsingPos p f) -> PlacementUsingPos p (fmap (addPlmnt pl) f)
addPlmnt pl (Placement ps pt f) = Placement ps pt (fmap g f) (RandomPlacement rp) -> RandomPlacement $ fmap (addPlmnt pl) rp
(Placement ps pt f) -> Placement ps pt (fmap g f)
where where
g Nothing = Just pl g Nothing = Just pl
g (Just pl') = Just $ addPlmnt pl pl' g (Just pl') = Just $ addPlmnt pl pl'
src/Dodge/Placements/Spot.hs
+8 -6
View File
@@ -11,9 +11,10 @@ setPS = updatePS . const
updatePSToLevel :: Int -> (PlacementSpot -> PlacementSpot) -> Placement -> Placement updatePSToLevel :: Int -> (PlacementSpot -> PlacementSpot) -> Placement -> Placement
updatePSToLevel 0 _ plmnt = plmnt updatePSToLevel 0 _ plmnt = plmnt
updatePSToLevel i f (PlacementUsingPos p pl) = PlacementUsingPos p (fmap (updatePSToLevel i f) pl) updatePSToLevel i f plmnt = case plmnt of
updatePSToLevel i f (Placement ps pt pl) = Placement (f ps) pt (fmap (fmap (updatePSToLevel (i-1) f)) pl) PlacementUsingPos p pl -> PlacementUsingPos p (fmap (updatePSToLevel i f) pl)
updatePSToLevel i f (RandomPlacement rplmnt) = RandomPlacement $ fmap (updatePSToLevel i f) rplmnt 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 :: PlacementSpot -> Placement -> Placement
setLocalPS ps (Placement _ pt f) = Placement ps pt f 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 setLocalPS _ plmnt = plmnt
updatePS :: (PlacementSpot -> PlacementSpot) -> Placement -> Placement updatePS :: (PlacementSpot -> PlacementSpot) -> Placement -> Placement
updatePS f (Placement ps pt iplmnt) = Placement (f ps) pt ((fmap . fmap $ updatePS f) iplmnt) updatePS f pl' = case pl' of
updatePS f (PlacementUsingPos p plmnt) = PlacementUsingPos p (fmap (updatePS f) plmnt) Placement ps pt ipl -> Placement (f ps) pt $ (fmap . fmap $ updatePS f) ipl
updatePS f (RandomPlacement rplmnt) = RandomPlacement (fmap (updatePS f) rplmnt) PlacementUsingPos p pl -> PlacementUsingPos p (fmap (updatePS f) pl)
RandomPlacement rpl -> RandomPlacement (fmap (updatePS f) rpl)
src/Dodge/Room/Data.hs
+6 -3
View File
@@ -5,6 +5,7 @@ module Dodge.Room.Data
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Geometry.Data import Geometry.Data
import Data.Tile import Data.Tile
import Dodge.Data
import Control.Monad.State import Control.Monad.State
import System.Random import System.Random
@@ -22,17 +23,19 @@ assigning no bounds will allow rooms to overlap.
data Room = Room data Room = Room
{ _rmPolys :: [ [Point2] ] { _rmPolys :: [ [Point2] ]
, _rmLinks :: [(Point2,Float)] , _rmLinks :: [(Point2,Float)]
, _rmUsedLinks :: [RoomPos] , _rmPos :: [RoomPos]
, _rmPath :: [(Point2, Point2)] , _rmPath :: [(Point2, Point2)]
, _rmPmnts :: [Placement] , _rmPmnts :: [Placement]
, _rmLabelledPmnts :: IM.IntMap Placement , _rmTriggers :: IM.IntMap (World -> Bool)
, _rmPartialPmnts :: IM.IntMap (Int -> Placement) , _rmTriggerPmnts :: IM.IntMap ((World -> Bool) -> Placement)
, _rmBound :: [ [Point2] ] , _rmBound :: [ [Point2] ]
, _rmFloor :: [Tile] , _rmFloor :: [Tile]
, _rmName :: String , _rmName :: String
, _rmShift :: (Point2, Float) , _rmShift :: (Point2, Float)
, _rmViewpoints :: [Point2] , _rmViewpoints :: [Point2]
, _rmRandPSs :: [State StdGen (Point2,Float)] , _rmRandPSs :: [State StdGen (Point2,Float)]
, _rmLabel :: Maybe Int
, _rmTakeFrom :: Maybe Int
} }
data RoomPos data RoomPos
= OutLink Int Point2 Float = OutLink Int Point2 Float
src/Dodge/Room/Door.hs
+23 -6
View File
@@ -1,12 +1,13 @@
{- {- Rooms that connect other rooms, blocking sight. -}
Rooms that connect other rooms, blocking sight.
-}
module Dodge.Room.Door module Dodge.Room.Door
where where
import Geometry import Geometry
import Dodge.Room.Data import Dodge.Room.Data
import Dodge.Default.Room import Dodge.Default.Room
import Dodge.Placements import Dodge.Placements
import Color
import qualified Data.IntMap.Strict as IM
door :: Room door :: Room
door = defaultRoom door = defaultRoom
@@ -17,8 +18,24 @@ door = defaultRoom
, _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)] , _rmPmnts = [putAutoDoor (V2 0 20) (V2 40 20)]
-- note no bounds -- note no bounds
} }
where lnks = [(V2 20 35,0) where
,(V2 20 5,pi) 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)
]
src/Dodge/Room/Link.hs
+3 -5
View File
@@ -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 Link pairs determine where rooms can attach to each other; each pair consists
of a position and a rotation. of a position and a rotation.
The last link in the list is considered the incoming link, the other links are 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 module Dodge.Room.Link
( shiftRoomToLink ( shiftRoomToLink
, shiftRoomBy , shiftRoomBy
@@ -111,5 +109,5 @@ setLastLinkToUsed :: Room -> Room
setLastLinkToUsed rm = case _rmLinks rm of setLastLinkToUsed rm = case _rmLinks rm of
(_:_) -> rm (_:_) -> rm
& rmLinks %~ init & rmLinks %~ init
& rmUsedLinks %~ (uncurry InLink (last (_rmLinks rm)) :) & rmPos %~ (uncurry InLink (last (_rmLinks rm)) :)
_ -> rm _ -> rm