From 6b937b115e3b2285fff942ad8bb1bdddbcdc6f20 Mon Sep 17 00:00:00 2001 From: justin Date: Tue, 28 Sep 2021 15:44:32 +0100 Subject: [PATCH] Continue placement refactor --- src/Dodge/Default/Room.hs | 2 ++ src/Dodge/Layout.hs | 23 +++-------------------- src/Dodge/LevelGen.hs | 25 ++++++++++--------------- src/Dodge/LevelGen/Data.hs | 14 +++++--------- src/Dodge/LevelGen/SwarmPlacement.hs | 22 +++++++++++----------- src/Dodge/Room/Data.hs | 12 ++---------- src/Dodge/Room/Link.hs | 4 ++-- src/Dodge/Room/LongDoor.hs | 4 ++-- src/Dodge/Room/Placement.hs | 16 ++++++++-------- src/Dodge/Room/Procedural.hs | 2 +- 10 files changed, 46 insertions(+), 78 deletions(-) diff --git a/src/Dodge/Default/Room.hs b/src/Dodge/Default/Room.hs index 39e0bf2b2..fc52f8439 100644 --- a/src/Dodge/Default/Room.hs +++ b/src/Dodge/Default/Room.hs @@ -1,5 +1,6 @@ module Dodge.Default.Room where +import Geometry.Data import Dodge.Room.Data defaultRoom :: Room @@ -11,4 +12,5 @@ defaultRoom = Room , _rmBound = [] , _rmFloor = [] , _rmName = "defaultRoom" + , _rmShift = (V2 0 0 , 0) } diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 40af99cff..c92fe7c5d 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -31,7 +31,7 @@ import System.Random --import Data.List --import Data.Maybe import Data.Tree -import Data.Graph.Inductive.Graph (labNodes) +--import Data.Graph.Inductive.Graph (labNodes) --import qualified Data.Map as M import Data.Foldable import qualified Control.Foldl as L @@ -43,7 +43,7 @@ generateLevelFromRoomList gr w . setupWorldBounds -- . initializeStaticWalls -- . setupForegroundEdgeVerxs - . placeSpots plmnts + . flip (foldr placeSpot') plmnts -- . addRoomPolyDecorations rs -- . addRoomLinkDecorations rs $ w { _walls = wallsFromRooms rs @@ -55,7 +55,7 @@ generateLevelFromRoomList gr w where path = pairsToGraph dist pairPath pairPath = concatMap _rmPath rs - plmnts = concatMap _rmPS rs + plmnts = concat $ map (\r -> map ((,) (_rmShift r)) (_rmPS r)) rs rs = zipWith addTile zs rs' zs = map fromIntegral $ randomRs (0,63::Int) $ _randGen w rs' = evalState gr $ _randGen w @@ -79,23 +79,6 @@ setupWorldBounds w = w polyhedrasToEdges :: [Polyhedra] -> [Point3] polyhedrasToEdges = concatMap tflat4 . concatMap polyToEdges --- | connects a collection (tree) of rooms together -generateFromTree :: State StdGen (Tree Room) -> World -> World -generateFromTree t w = updateWallZoning $ placeSpots plmnts - $ w {_walls = wallsFromTree tr - ,_pathGraph = path - ,_pathGraphP = pairGraph - ,_pathPoints = foldl' (flip insertPoint) IM.empty (labNodes path) - } - where - tr = evalState t $ _randGen w - plmnts = concatMap _rmPS $ flatten tr - path = pairsToGraph dist pairGraph - pairGraph = makePath tr - insertPoint pp@(_,V2 x y) = insertInZoneWith (floorHun x) (floorHun y) (++) [pp] - --pinc = M.fromList $ pairsToIncidence pairGraph - - updateWallZoning :: World -> World updateWallZoning w = set (wallsZone . znObjects) (foldl' (flip wallInZone) IM.empty (_walls w)) w where diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 44f2e663b..8ecdf0242 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -9,7 +9,6 @@ module Dodge.LevelGen , makeSwitch ) where import Dodge.Data ---import Dodge.Room.Data import Dodge.LevelGen.Block import Dodge.LevelGen.LineBlock import Dodge.LevelGen.Pathing @@ -21,26 +20,22 @@ import Dodge.LevelGen.Data import Geometry import Geometry.Vector3D import Shape ---import Geometry.Data import Picture import qualified IntMapHelp as IM ---import System.Random import Control.Monad.State ---import Control.Applicative import Control.Lens -import Data.List.Extra ---import Data.Function ---import Data.Maybe ---import qualified Data.Set as S ---import qualified Data.Map as M -placeSpots :: [Placement] -> World -> World -placeSpots pss w = foldr (placeSpot . _placementSpot) w simplePlacements - where - (simplePlacements, idPlacements ) = partition isSimple pss - isSimple SimplePlacement{} = True - isSimple _ = False +placeSpot' :: ((Point2,Float) , Placement) -> World -> World +placeSpot' (shift, plmnt) = placeSpot $ shiftPSBy' shift (_placementSpot plmnt) + +shiftPSBy' + :: (Point2,Float) + -> PlacementSpot + -> PlacementSpot +shiftPSBy' (pos,rot) ps = ps + & psPos %~ shiftPointBy (pos,rot) + & psRot %~ (+ rot) placeSpot :: PlacementSpot -> World -> World placeSpot ps w = case _psType ps of diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 025822b3a..c4d37b5b4 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -49,16 +49,12 @@ data PlacementSpot = PS , _psRot :: Float , _psType :: PSType } -data Placement - = SimplePlacement {_placementSpot :: PlacementSpot } - | IDPlacement {_placementSpot :: PlacementSpot, _idPlacement :: Int -> Placement } --- | GroupedPlacement --- {_groupPlacementID :: Int --- ,_groupUpdate :: World -> [Placement] -> World --- ,_placementSpot :: PlacementSpot --- } +data Placement = Placement + { _placementSpot :: PlacementSpot + , _idPlacement :: Int -> Maybe Placement + } sPS :: Point2 -> Float -> PSType -> Placement -sPS p a = SimplePlacement . PS p a +sPS p a pt = Placement (PS p a pt) (const Nothing) makeLenses ''PSType makeLenses ''PlacementSpot makeLenses ''Placement diff --git a/src/Dodge/LevelGen/SwarmPlacement.hs b/src/Dodge/LevelGen/SwarmPlacement.hs index 0c36b42ed..32991bd80 100644 --- a/src/Dodge/LevelGen/SwarmPlacement.hs +++ b/src/Dodge/LevelGen/SwarmPlacement.hs @@ -2,17 +2,17 @@ module Dodge.LevelGen.SwarmPlacement ( --swarmPS ) where -import Dodge.Data -import Dodge.LevelGen.Data -import Dodge.Creature.State.Data ---import Geometry -import Geometry.ConvexPoly -import Geometry.Data -import qualified IntMapHelp as IM - -import Data.List -import qualified Data.IntSet as IS -import Control.Lens +--import Dodge.Data +--import Dodge.LevelGen.Data +--import Dodge.Creature.State.Data +----import Geometry +--import Geometry.ConvexPoly +--import Geometry.Data +--import qualified IntMapHelp as IM +-- +--import Data.List +--import qualified Data.IntSet as IS +--import Control.Lens --swarmPS :: Int -> Point2 -> Float -> Creature -> Placement --swarmPS i p a cr = GroupedPlacement diff --git a/src/Dodge/Room/Data.hs b/src/Dodge/Room/Data.hs index 3047b8ded..432b26115 100644 --- a/src/Dodge/Room/Data.hs +++ b/src/Dodge/Room/Data.hs @@ -1,17 +1,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE StrictData #-} module Dodge.Room.Data - ( Room (..) - , rmPolys - , rmLinks - , rmPath - , rmPS - , rmBound - , rmFloor - , rmName - ) where + where import Dodge.LevelGen.Data ---import Geometry import Geometry.Data import Data.Tile @@ -33,5 +24,6 @@ data Room = Room , _rmBound :: [ [Point2] ] , _rmFloor :: [Tile] , _rmName :: String + , _rmShift :: (Point2, Float) } makeLenses ''Room diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index e77a4df40..6376300db 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -63,14 +63,14 @@ shiftRoomToLink l r r where (p,a) = last $ _rmLinks r - +-- NOTE placements are shifted by the room shift shiftRoomBy :: (Point2,Float) -> Room -> Room shiftRoomBy shift r = r & rmPolys %~ fmap (map (shiftPointBy shift)) & rmLinks %~ fmap (shiftLinkBy shift) & rmPath %~ map (shiftPathPointBy shift) - & rmPS %~ fmap (shiftPSBy shift) & rmBound %~ fmap (map (shiftPointBy shift)) + & rmShift %~ shiftLinkBy shift & rmFloor %~ map ( (tilePoly %~ map (shiftPointBy shift)) . (tileZero %~ shiftPointBy shift ) diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs index 5af3e333b..e9a22fe37 100644 --- a/src/Dodge/Room/LongDoor.hs +++ b/src/Dodge/Room/LongDoor.hs @@ -24,7 +24,7 @@ import Control.Lens import Control.Monad.State import Data.Tree import qualified Data.Map as M -import qualified Data.IntMap as IM +--import qualified Data.IntMap as IM twinSlowDoorRoom :: Int -- ^ Door id @@ -56,7 +56,7 @@ twinSlowDoorRoom drid w h x = defaultRoom , _rmName = "twinSlowDoorRoom" } where - drmoving w' = True -- DoorHalfway == _drStatus (_doors w' IM.! drid) + drmoving _ = True -- DoorHalfway == _drStatus (_doors w' IM.! drid) lampHeight = 41 ps = [rectNSWE h 0 (-w) w diff --git a/src/Dodge/Room/Placement.hs b/src/Dodge/Room/Placement.hs index 289971f5c..6230d7aa9 100644 --- a/src/Dodge/Room/Placement.hs +++ b/src/Dodge/Room/Placement.hs @@ -30,33 +30,33 @@ Places a line of blocks between two points. Width 9, also extends out from each point by 9. -} blockLine :: Point2 -> Point2 -> Placement -blockLine a b = SimplePlacement $ PS +blockLine a b = Placement PS { _psPos = V2 0 0 , _psRot = 0 , _psType = PutLineBlock baseBlockPane 9 9 a b - } + } (const Nothing) {- Places an breakable window between two points. Width 8, also extends out from each point by 8. -} windowLine :: Point2 -> Point2 -> Placement -windowLine a b = SimplePlacement $ PS +windowLine a b = Placement PS { _psPos = V2 0 0 , _psRot = 0 , _psType = PutLineBlock baseWindowPane 8 8 a b - } + } (const Nothing) {- Places an unbreakable window between two points. Width 7, also extends out from each point by 7. -} crystalLine :: Point2 -> Point2 -> Placement -crystalLine a b = SimplePlacement $ PS +crystalLine a b = Placement PS { _psPos = V2 0 0 , _psRot = 0 , _psType = PutWall ps defaultCrystalWall - } + } (const Nothing) where ps = [ a +.+ left +.+ up @@ -70,11 +70,11 @@ crystalLine a b = SimplePlacement $ PS Depth 15, does not extend wider than points. -} wallLine :: Point2 -> Point2 -> Placement -wallLine a b = SimplePlacement $ PS +wallLine a b = Placement PS { _psPos = V2 0 0 , _psRot = 0 , _psType = PutWall ps defaultWall - } + } (const Nothing) where ps = [ a +.+ up diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 29d486e9b..1db65f001 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -180,7 +180,7 @@ fillNothingPlacement :: PSType -> Room -> Room fillNothingPlacement pst r = r & rmPS %~ replaceNothingWith pst where - replaceNothingWith x (SimplePlacement (PS p rot PutNothing): pss) = sPS p rot x : pss + replaceNothingWith x (Placement (PS p rot PutNothing) _: pss) = sPS p rot x : pss replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss replaceNothingWith _ [] = [] {- | Successively fill 'PutNothing' placements with a list of given 'PSType's.