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

Thread a more complex structure through the placement process

Browse Source
This commit is contained in:
justin
2021-11-25 01:32:25 +00:00
parent 0e87f340b4
commit aad79bdf25
5 changed files with 63 additions and 50 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Layout.hs
+10 -8
View File
@@ -8,6 +8,7 @@ import Dodge.ShiftPoint
import Dodge.Placement.PlaceSpot import Dodge.Placement.PlaceSpot
import Dodge.LevelGen.Data import Dodge.LevelGen.Data
import Dodge.LevelGen.StaticWalls import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.LevelStructure
import Dodge.Room.Foreground import Dodge.Room.Foreground
import Dodge.Wall.Zone import Dodge.Wall.Zone
import Dodge.GameRoom import Dodge.GameRoom
@@ -42,6 +43,7 @@ generateLevelFromRoomList gr' w
. doPartialPlacements . doPartialPlacements
. doExtendedPlacements . doExtendedPlacements
. flip (mapAccumR doRoomPlacements) rs' . flip (mapAccumR doRoomPlacements) rs'
. worldToGenWorld
$ w { _walls = wallsFromRooms rs $ w { _walls = wallsFromRooms rs
, _floorTiles = floorsFromRooms rs , _floorTiles = floorsFromRooms rs
, _gameRooms = gameRoomsFromRooms rs' , _gameRooms = gameRoomsFromRooms rs'
@@ -60,8 +62,8 @@ shuffleRoomPos rm = do
newPos <- shuffle $ _rmPos rm newPos <- shuffle $ _rmPos rm
return $ rm & rmPos .~ newPos return $ rm & rmPos .~ newPos
placeWires :: (World,[Room])-> World placeWires :: (GenWorld,[Room])-> World
placeWires (w,rms) = foldr placeRoomWires w rms placeWires (w,rms) = foldr placeRoomWires (_gWorld w) rms
placeRoomWires :: Room -> World -> World placeRoomWires :: Room -> World -> World
placeRoomWires rm w = IM.foldr ($) w placeRoomWires rm w = IM.foldr ($) w
@@ -89,21 +91,21 @@ placeWire rm (WallWire p _ h1) (WallWire q _ h2) = foregroundShape
rightpleftq x = isRHS rmcen p x && isLHS rmcen q x rightpleftq x = isRHS rmcen p x && isLHS rmcen q x
rs = _rmShift rm rs = _rmShift rm
doPartialPlacements :: ( (IM.IntMap [Placement],World) , [Room] ) -> (World,[Room]) doPartialPlacements :: ( (IM.IntMap [Placement],GenWorld) , [Room] ) -> (GenWorld,[Room])
doPartialPlacements ((im,w),rms) = mapAccumR (doPartialPlacement im) w rms doPartialPlacements ((im,w),rms) = mapAccumR (doPartialPlacement im) w rms
doPartialPlacement :: IM.IntMap [Placement] -> World -> Room -> (World, Room) doPartialPlacement :: IM.IntMap [Placement] -> GenWorld -> Room -> (GenWorld, Room)
doPartialPlacement im w rm = case _rmPartPmnt rm of doPartialPlacement im w rm = case _rmPartPmnt rm of
Nothing -> (w, rm) Nothing -> (w, rm)
Just fi -> case _rmTakeFrom rm of Just fi -> case _rmTakeFrom rm of
Nothing -> (w, rm) Nothing -> (w, rm)
Just i -> fst $ placeSpot (w,rm) (fi (im IM.! i)) Just i -> fst $ placeSpot (w,rm) (fi (im IM.! i))
doExtendedPlacements :: (World,[Room]) -> ( (IM.IntMap [Placement], World) , [Room] ) doExtendedPlacements :: (GenWorld,[Room]) -> ( (IM.IntMap [Placement], GenWorld) , [Room] )
doExtendedPlacements (w,rms) = mapAccumR doExtendedPlacement (IM.empty,w) rms doExtendedPlacements (w,rms) = mapAccumR doExtendedPlacement (IM.empty,w) rms
doExtendedPlacement :: (IM.IntMap [Placement], World) -> Room doExtendedPlacement :: (IM.IntMap [Placement], GenWorld) -> Room
-> ( (IM.IntMap [Placement], World) , Room ) -> ( (IM.IntMap [Placement], GenWorld) , Room )
doExtendedPlacement (im,w) rm = case _rmExtPmnt rm of doExtendedPlacement (im,w) rm = case _rmExtPmnt rm of
Nothing -> ( (im,w) , rm ) Nothing -> ( (im,w) , rm )
Just plmnt -> case _rmLabel rm of Just plmnt -> case _rmLabel rm of
@@ -111,7 +113,7 @@ doExtendedPlacement (im,w) rm = case _rmExtPmnt rm of
Just i -> let ((neww,newrm),plmnts) = placeSpot (w,rm) plmnt Just i -> let ((neww,newrm),plmnts) = placeSpot (w,rm) plmnt
in ( (IM.insert i plmnts im, neww) , newrm ) in ( (IM.insert i plmnts im, neww) , newrm )
doRoomPlacements :: World -> Room -> (World, Room) doRoomPlacements :: GenWorld -> Room -> (GenWorld, Room)
doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm doRoomPlacements w rm = foldl' (\wr -> fst . placeSpot wr) (w,rm) $ _rmPmnts rm
setupWorldBounds :: World -> World setupWorldBounds :: World -> World
src/Dodge/LevelGen/LevelStructure.hs
+3
View File
@@ -7,9 +7,12 @@ import Dodge.Data
--import Data.Tree --import Data.Tree
import qualified Data.IntMap.Strict as IM import qualified Data.IntMap.Strict as IM
import Control.Lens
--import System.Random --import System.Random
data GenWorld = GenWorld data GenWorld = GenWorld
{ _gWorld :: World { _gWorld :: World
, _gPlacements :: IM.IntMap [Placement] , _gPlacements :: IM.IntMap [Placement]
} }
worldToGenWorld w = GenWorld w IM.empty
makeLenses ''GenWorld
src/Dodge/Placement/PlaceSpot.hs
+30 -29
View File
@@ -30,7 +30,7 @@ import Data.Bifunctor
-- when placing a placement, we update the world and the room and assign an id -- when placing a placement, we update the world and the room and assign an id
-- to the placement -- to the placement
placeSpot :: (World,Room) -> Placement -> ( (World,Room), [Placement] ) placeSpot :: (GenWorld,Room) -> Placement -> ( (GenWorld,Room), [Placement] )
placeSpot (w,rm) plmnt = case plmnt of placeSpot (w,rm) plmnt = case plmnt of
Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w Placement{_plSpot = PSRoomRand i f} -> placeSpotRoomRand rm i f plmnt w
Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback Placement{_plSpot = PSPos extract eff fallback} -> placeSpotUsingLink w rm plmnt extract eff fallback
@@ -43,18 +43,18 @@ placeSpot (w,rm) plmnt = case plmnt of
in (wr,newplmnt:newplmnts) in (wr,newplmnt:newplmnts)
-- (placeSpot (w',rm)) (_plIDCont plmnt i) -- (placeSpot (w',rm)) (_plIDCont plmnt i)
PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p)) PlacementUsingPos p subpl -> placeSpot (w,rm) (subpl (shiftPoint3By shift p))
RandomPlacement rplmnt -> placeSpot (w & randGen .~ g,rm) plmnt' RandomPlacement rplmnt -> placeSpot (w & gWorld . randGen .~ g,rm) plmnt'
where where
(plmnt', g) = runState rplmnt (_randGen w) (plmnt', g) = runState rplmnt (_randGen $ _gWorld w)
where where
shift = _rmShift rm shift = _rmShift rm
-- this should be tidied up -- this should be tidied up
placeSpotUsingLink :: World -> Room -> Placement placeSpotUsingLink :: GenWorld -> Room -> Placement
-> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos)) -> (RoomPos -> Room -> Maybe (PlacementSpot,RoomPos))
-> (RoomPos -> Room -> Room) -> (RoomPos -> Room -> Room)
-> Maybe Placement -> Maybe Placement
-> ((World, Room), [Placement]) -> ((GenWorld, Room), [Placement])
placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos rm) of
Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps) Just (ps,rmposs) -> placeSpot (w, eff (head rmposs) $ rm & rmPos .~ rmposs) (plmnt & plSpot .~ ps)
Nothing -> case fallback of Nothing -> case fallback of
@@ -67,15 +67,15 @@ placeSpotUsingLink w rm plmnt extract eff fallback = case searchedPoss (_rmPos r
Just (ps,rmpos) -> Just ( ps,rmpos:poss) Just (ps,rmpos) -> Just ( ps,rmpos:poss)
placeSpotRoomRand :: Room -> Int -> ((Point2,Float) -> PlacementSpot) placeSpotRoomRand :: Room -> Int -> ((Point2,Float) -> PlacementSpot)
-> Placement -> World -> ((World,Room),[Placement]) -> Placement -> GenWorld -> ((GenWorld,Room),[Placement])
placeSpotRoomRand rm i f plmnt w = placeSpotRoomRand rm i f plmnt w =
let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen w let (ps,g) = runState (_rmRandPSs rm !! i) $_randGen (_gWorld w)
in placeSpot (w & randGen .~ g,rm) (plmnt & plSpot .~ f ps) in placeSpot (w & gWorld . randGen .~ g,rm) (plmnt & plSpot .~ f ps)
-- the Int here is some id that is assigned when the placement is placed -- the Int here is some id that is assigned when the placement is placed
placeSpotID :: PlacementSpot -> PSType -> World -> (Int, World) placeSpotID :: PlacementSpot -> PSType -> GenWorld -> (Int, GenWorld)
placeSpotID ps pt w = case pt of placeSpotID ps pt w = case pt of
PutTrigger cond -> placeNewInto triggers cond w PutTrigger cond -> placeNewInto triggers cond w
PutMod modi -> plNewUpID modifications mdID modi w PutMod modi -> plNewUpID modifications mdID modi w
@@ -94,23 +94,23 @@ placeSpotID ps pt w = case pt of
PutBlock{} -> error "messed up block placement somehow" PutBlock{} -> error "messed up block placement somehow"
PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w PutLineBlock wl bm wdth dpth a b -> placeLineBlock wl bm wdth dpth (doShift a) (doShift b) w
PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w) PutWall { _pwPoly = ps', _pwWall = wl } -> (0,placeWallPoly (map doShift ps') wl w)
PutForeground sh -> (0,w & foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>)) PutForeground sh -> (0,w & gWorld . foregroundShape %~ ((uncurryV translateSHf p . rotateSH rot) sh <>))
PutNothing -> (0,w) PutNothing -> (0,w)
PutID i -> (i, w) PutID i -> (i, w)
PutWorldUpdate f -> (0,f ps w) PutWorldUpdate f -> (0,w & gWorld %~ f ps)
where where
p@(V2 px py) = _psPos ps p@(V2 px py) = _psPos ps
p' = V3 px py 0 p' = V3 px py 0
rot = _psRot ps rot = _psRot ps
doShift = shiftPointBy (p,rot) doShift = shiftPointBy (p,rot)
evaluateRandPS :: State StdGen PSType -> PlacementSpot -> World -> (Int,World) evaluateRandPS :: State StdGen PSType -> PlacementSpot -> GenWorld -> (Int,GenWorld)
evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set randGen g w) evaluateRandPS rgen ps w = placeSpotID ps evaluatedType (set (gWorld . randGen) g w)
where where
(evaluatedType, g) = runState rgen (_randGen w) (evaluatedType, g) = runState rgen (_randGen $ _gWorld w)
placeWallPoly :: [Point2] -> Wall -> World -> World placeWallPoly :: [Point2] -> Wall -> GenWorld -> GenWorld
placeWallPoly ps wl = rmCrossPaths . over walls (addWalls ps wl) placeWallPoly ps wl = gWorld %~ (rmCrossPaths . over walls (addWalls ps wl))
where where
rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ loopPairs ps
@@ -130,21 +130,21 @@ addPane wl l wls = IM.insert wlid (wl { _wlLine = l, _wlID = wlid }) wls
-- new index as well -- new index as well
placeNewInto :: ALens' World (IM.IntMap a) placeNewInto :: ALens' World (IM.IntMap a)
-> a -> a
-> World -> GenWorld
-> (Int,World) -> (Int,GenWorld)
placeNewInto l x w = (i,w & l #%~ IM.insert i x) placeNewInto l x w = (i,w & gWorld . l #%~ IM.insert i x)
where where
i = IM.newKey $ w ^# l i = IM.newKey $ (_gWorld w) ^# l
-- | place an new object into an intmap and update its id -- | place an new object into an intmap and update its id
plNewUpID :: ALens' World (IM.IntMap a) plNewUpID :: ALens' World (IM.IntMap a)
-> ALens' a Int -> ALens' a Int
-> a -> a
-> World -> GenWorld
-> (Int,World) -> (Int,GenWorld)
plNewUpID l li x w = (i,w & l #%~ IM.insert i (x & li #~ i)) plNewUpID l li x w = (i,w & gWorld . l #%~ IM.insert i (x & li #~ i))
where where
i = IM.newKey $ w ^# l i = IM.newKey $ (_gWorld w) ^# l
mvProp :: Point2 -> Float -> Prop -> Prop mvProp :: Point2 -> Float -> Prop -> Prop
mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a )) mvProp p a = (pjRot +~ a) . (pjPos %~ ( (p +.+) . rotateV a ))
@@ -162,14 +162,15 @@ mvPP p rot pp = pp {_ppPos = p,_ppRot = rot}
mvCr :: Point2 -> Float -> Creature -> Creature mvCr :: Point2 -> Float -> Creature -> Creature
mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot} mvCr p rot cr = cr {_crPos = p,_crOldPos = p,_crDir = rot}
placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> World -> (Int,World) placeMachine :: Color -> [Point2] -> Machine -> Point2 -> Float -> GenWorld -> (Int,GenWorld)
placeMachine color wallpoly mc p rot w = (mcid placeMachine color wallpoly mc p rot w = (mcid
, w & machines %~ addMc , w & gWorld . machines %~ addMc
& walls %~ placeMachineWalls color wallpoly mcid wlid & gWorld . walls %~ placeMachineWalls color wallpoly mcid wlid
) )
where where
mcid = IM.newKey $ _machines w w' = _gWorld w
wlid = IM.newKey $ _walls w mcid = IM.newKey $ _machines w'
wlid = IM.newKey $ _walls w'
wlids = IS.fromList [wlid .. wlid + length wallpoly - 1] wlids = IS.fromList [wlid .. wlid + length wallpoly - 1]
addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs addMc mcs = IM.insert mcid (mc {_mcPos = p,_mcDir = rot,_mcID = mcid, _mcWallIDs = wlids}) mcs
src/Dodge/Placement/PlaceSpot/Block.hs
+11 -7
View File
@@ -6,6 +6,7 @@ module Dodge.Placement.PlaceSpot.Block
where where
import Dodge.Data import Dodge.Data
import Dodge.Path import Dodge.Path
import Dodge.LevelGen.LevelStructure
import Dodge.Base import Dodge.Base
import Dodge.Zone import Dodge.Zone
import Geometry import Geometry
@@ -53,10 +54,11 @@ addBlock (p:ps) wl hp hps bm w
ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl) ips = map zoneOfPoint $ uncurry (divideLine (2*zoneSize)) (_wlLine wl)
addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon" addBlock _ _ _ _ _ _ = error "Trying to add a block with incomplete polygon"
placeBlock :: [Point2] -> Int -> Wall -> [Int] -> BlockMaterial -> World -> (Int,World) placeBlock :: [Point2] -> Int -> Wall -> [Int] -> BlockMaterial -> GenWorld -> (Int,GenWorld)
placeBlock poly i wl is bm w placeBlock poly i wl is bm gw
= (0, foldr (uncurry removePathsCrossing) wWithBlock pairs) = (0, gw & gWorld .~ foldr (uncurry removePathsCrossing) wWithBlock pairs)
where where
w = _gWorld gw
pairs = loopPairs poly pairs = loopPairs poly
wWithBlock = addBlock poly wl i is bm w wWithBlock = addBlock poly wl i is bm w
@@ -68,11 +70,13 @@ placeLineBlock
-> Float -- ^ Block depth -> Float -- ^ Block depth
-> Point2 -- ^ Start point (symmetric) -> Point2 -- ^ Start point (symmetric)
-> Point2 -- ^ End point (symmetric) -> Point2 -- ^ End point (symmetric)
-> World -> GenWorld
-> (Int, World) -> (Int, GenWorld)
placeLineBlock basePane bm blockWidth depth a b w = (,) 0 placeLineBlock basePane bm blockWidth depth a b gw = ( 0
$ removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls , gw & gWorld .~ (removePathsCrossing a b $ foldr insertWall (insertBlocks w) listWalls)
)
where where
w = _gWorld gw
psOnLine = divideLineOddNumPoints blockWidth a b psOnLine = divideLineOddNumPoints blockWidth a b
halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1) halfBlockWidth = dist a b / fromIntegral (length psOnLine - 1)
blockCenPs = snd $ evenOddSplit psOnLine blockCenPs = snd $ evenOddSplit psOnLine
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+9 -6
View File
@@ -11,6 +11,7 @@ import Picture
import Geometry import Geometry
import qualified IntMapHelp as IM import qualified IntMapHelp as IM
import Dodge.SoundLogic import Dodge.SoundLogic
import Dodge.LevelGen.LevelStructure
import Data.List import Data.List
import Control.Lens import Control.Lens
@@ -21,10 +22,11 @@ placeDoor
-> (World -> Bool) -- ^ Opening condition -> (World -> Bool) -- ^ Opening condition
-> [(Point2,Point2)] -- ^ Door positions, closed to open. -> [(Point2,Point2)] -- ^ Door positions, closed to open.
-- Bumped out up and down by 9, not widened -- Bumped out up and down by 9, not widened
-> World -> GenWorld
-> (Int,World) -> (Int,GenWorld)
placeDoor col cond pss w = (drid, addWalls w & doors %~ addDoor) placeDoor col cond pss gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
where where
w = _gWorld gw
drid = IM.newKey $ _doors w drid = IM.newKey $ _doors w
addDoor = IM.insert drid $ Door addDoor = IM.insert drid $ Door
{ _drID = drid { _drID = drid
@@ -86,10 +88,11 @@ doorMechanism drid speed wlidOpCps dr w
doClose w' (wlid,_ ,clp) = moveWallIDToward wlid speed clp w' doClose w' (wlid,_ ,clp) = moveWallIDToward wlid speed clp w'
-- TODO cut pathing if not pathable, reset when opened -- TODO cut pathing if not pathable, reset when opened
placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> World placeSlideDoor :: Bool -> Color -> (World -> Bool) -> Point2 -> Point2 -> Float -> GenWorld
-> (Int, World) -> (Int, GenWorld)
placeSlideDoor isPathable col cond a b speed w = (drid, addWalls w & doors %~ addDoor) placeSlideDoor isPathable col cond a b speed gw = (drid, gw & gWorld .~ (addWalls w & doors %~ addDoor))
where where
w = _gWorld gw
drid = IM.newKey $ _doors w drid = IM.newKey $ _doors w
addDoor = IM.insert drid $ Door addDoor = IM.insert drid $ Door
{ _drID = drid { _drID = drid