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

Simplify machine placement

Browse Source
This commit is contained in:
justin
2025-10-23 22:34:50 +01:00
parent 3c6d269d00
commit cba0f36ac5
8 changed files with 306 additions and 314 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Placement/PlaceSpot.hs
+16 -16
View File
@@ -6,6 +6,7 @@
-}
module Dodge.Placement.PlaceSpot (placeSpot) where
import Dodge.Default.Wall
import qualified Data.Set as S
import Control.Monad.State
import Data.Bifunctor
@@ -130,7 +131,8 @@ placeSpotID rid ps pt w = case pt of
fsID
(mvFS p rot fs)
w
PutMachine pps mc wl mitm -> plMachine (map doShift pps) mc wl mitm p rot w
--PutMachine pps mc wl mitm -> plMachine (map doShift pps) mc wl mitm p rot w
PutMachine pps mc mitm -> plMachine (map doShift pps) mc mitm p rot w
PutLS ls -> plNewUpID (gwWorld . cWorld . lWorld . lightSources) lsID (mvLS p' rot ls) w
RandPS _ -> error "RandPS should not be reachable here" --evaluateRandPS rid rgn ps w
--PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w
@@ -206,29 +208,29 @@ mvFS p a = (fsDir +~ a) . (fsPos %~ ((p +.+) . rotateV a))
plMachine ::
[Point2] ->
Machine ->
Wall ->
-- Wall ->
Maybe Item ->
Point2 ->
Float ->
GenWorld ->
(Int, GenWorld)
plMachine wallpoly mc wl = \case
Nothing -> plMachine' wallpoly mc wl
Just itm -> plTurret wallpoly mc wl itm
plMachine wallpoly mc = \case
Nothing -> plMachine' wallpoly mc
Just itm -> plTurret wallpoly mc itm
plTurret ::
[Point2] ->
Machine ->
Wall ->
-- Wall ->
Item ->
Point2 ->
Float ->
GenWorld ->
(Int, GenWorld)
plTurret wallpoly mc wl itm p rot gw =
plTurret wallpoly mc itm p rot gw =
( mcid
, gw & gwWorld . cWorld . lWorld . machines %~ addMc
& gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wl wallpoly mcid wlid
& gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wallpoly mcid wlid
& gwWorld . cWorld . lWorld . items . at itid ?~ itm'
)
where
@@ -246,11 +248,11 @@ plTurret wallpoly mc wl itm p rot gw =
& mcType . mctTurret . tuWeapon .~ itid
)
plMachine' :: [Point2] -> Machine -> Wall -> Point2 -> Float -> GenWorld -> (Int, GenWorld)
plMachine' wallpoly mc wl p rot gw =
plMachine' :: [Point2] -> Machine -> Point2 -> Float -> GenWorld -> (Int, GenWorld)
plMachine' wallpoly mc p rot gw =
( mcid
, gw & gwWorld . cWorld . lWorld . machines %~ addMc
& gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wl wallpoly mcid wlid
& gwWorld . cWorld . lWorld . walls %~ placeMachineWalls wallpoly mcid wlid
)
where
mcid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . machines
@@ -259,14 +261,12 @@ plMachine' wallpoly mc wl p rot gw =
addMc = IM.insert mcid (mc{_mcPos = p, _mcDir = rot, _mcID = mcid, _mcWallIDs = wlids})
-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
placeMachineWalls ::
Wall -> [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
placeMachineWalls wl poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly
placeMachineWalls :: [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
placeMachineWalls poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly
where
f (wid, l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
baseWall =
wl
-- & wlColor .~ col
defaultMachineWall
& wlStructure . wsMachine .~ mcid
& wlTouchThrough .~ True