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

Improve some door placement

Browse Source
This commit is contained in:
justin
2025-10-24 20:30:36 +01:00
parent 95b4105f52
commit b0d519c69d
9 changed files with 92 additions and 115 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Block/Draw.hs
-13
View File
@@ -1,13 +0,0 @@
--{-# LANGUAGE LambdaCase #-}
module Dodge.Block.Draw () where
--
--import Dodge.Data.Block
--import Shape
--import ShapePicture
--drawBlock :: BlockDraw -> SPic
--drawBlock = \case
-- BlockDrawMempty -> mempty
---- BlockDraws bds -> foldMap drawBlock bds
---- BlockDrawColHeightPoss col h ps -> noPic $ colorSH col (upperBox Medium Typical h ps)
-- BlockDrawBlSh x -> noPic x
src/Dodge/Data/Block.hs
+2 -16
View File
@@ -22,27 +22,13 @@ data Block = Block
, _blWallIDs :: IS.IntSet
, _blHP :: Int
, _blShadows :: [Int] -- a list of walls that are not shown when this block exists
, _blFootprint :: [Point2] -- TODO check whether this should be clockwise/anticlockwise
, _blFootprint :: [Point2] -- TODO check whether this should be clockwise/anticlockwise
, _blPos :: Point2
, _blDir :: Float
, _blHeight :: Float
-- , _blDraw :: BlockDraw
, _blDraw :: Shape
, _blDraw :: Shape -- should probably make a data type for instances of these...
}
deriving (Eq, Ord, Show, Read) --Generic, Flat)
--data BlockDraw
-- = BlockDrawMempty
-- | BlockDrawBlSh Shape
---- | BlockDraws [BlockDraw]
---- | BlockDrawColHeightPoss Color Float [Point2]
-- deriving (Eq, Ord, Show, Read) --Generic, Flat)
--
--data BlSh
-- = BlShConst Shape
-- deriving (Eq, Ord, Show, Read) --Generic, Flat)
makeLenses ''Block
--deriveJSON defaultOptions ''BlSh
--deriveJSON defaultOptions ''BlockDraw
deriveJSON defaultOptions ''Block
src/Dodge/Data/GenWorld.hs
+1 -1
View File
@@ -54,7 +54,7 @@ data PSType
| PutWall {_pwPoly :: [Point2], _pwWall :: Wall}
| PutSlideDr Bool Door Wall (S.Set EdgeObstacle) Float Point2 Point2
-- | PutDoor Color EdgeObstacle WdBl [(Point2, Point2)]
| PutDoor Bool (S.Set EdgeObstacle) WdBl Float Point2A Point2A -- [(Point2, Point2)]
| PutDoor Bool WdBl Float Point2A Point2A
| RandPS (State StdGen PSType)
| PutForeground ForegroundShape
| PutWorldUpdate (Int -> PlacementSpot -> GenWorld -> GenWorld)
src/Dodge/Placement/PlaceSpot.hs
+9 -14
View File
@@ -6,6 +6,7 @@
-}
module Dodge.Placement.PlaceSpot (placeSpot) where
import Dodge.Placement.PlaceSpot.Block
import Control.Monad.State
import Data.Bifunctor
import Data.Foldable
@@ -16,7 +17,6 @@ import Dodge.Base.NewID
import Dodge.Data.GenWorld
import Dodge.Default.Wall
import Dodge.Path
import Dodge.Placement.PlaceSpot.Block
import Dodge.Placement.PlaceSpot.TriggerDoor
import Dodge.Placement.Shift
import Dodge.ShiftPoint
@@ -134,7 +134,7 @@ placeSpotID rid ps pt w = case pt of
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 isauto eo f l p1 p2 -> plDoor isauto eo f l (pashift p1) (pashift p2) w
PutDoor isauto f l p1 p2 -> plDoor isauto f l (pashift p1) (pashift p2) w
PutCoord cp -> plNewID (gwWorld . coordinates) (doShift cp) w
PutSlideDr isauto wl dr eo off a b ->
plSlideDoor isauto wl dr eo off (doShift a) (doShift b) w
@@ -180,9 +180,9 @@ placeWallPoly qs wl w
| otherwise = error "tried to place wall poly with too few points"
addPane :: Wall -> World -> (Point2, Point2) -> World
addPane wl w l =
w & plNew (cWorld . lWorld . walls) wlID (wl & wlLine .~ l)
& uncurry (obstructPathsCrossing (S.fromList [WallObstacle WallNotAutoOpen])) l
addPane wl w l = insertWall (wl & wlLine .~ l & wlID .~ i) w
where
i = IM.newKey $ w ^. cWorld . lWorld . walls
mvProp :: Point2 -> Float -> Prop -> Prop
mvProp p a = (prRot +~ a) . (prPos %~ ((p +.+) . rotateV a))
@@ -211,7 +211,7 @@ plMachine ::
plMachine wallpoly mc mitm p rot gw =
( mcid
, gw & tolw . machines . at mcid ?~ themc
& tolw . walls %~ placeMachineWalls wallpoly mcid wlid
& gwWorld %~ placeMachineWalls wallpoly mcid wlid
& tolw %~ maybe id placeturretitm mitm
)
where
@@ -227,15 +227,10 @@ plMachine wallpoly mc mitm p rot gw =
itid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . items
itm' = itm & itID .~ NInt itid & itLocation .~ OnTurret mcid
-- TODO correctly remove/shift pathfinding lines (removePathsCrossing)
placeMachineWalls :: [Point2] -> Int -> Int -> IM.IntMap Wall -> IM.IntMap Wall
placeMachineWalls poly mcid wlid = flip (foldr f) $ zip [wlid ..] $ loopPairs poly
placeMachineWalls :: [Point2] -> Int -> Int -> World -> World
placeMachineWalls poly mcid = insertStructureWalls MachinePart baseWall poly mcid
where
f (wid, l) = IM.insert wid baseWall{_wlID = wid, _wlLine = l}
baseWall =
defaultMachineWall
& wlStructure . wsMachine .~ mcid
& wlTouchThrough .~ True
baseWall = defaultMachineWall & wlStructure . wsMachine .~ mcid
mvLS :: Point3 -> Float -> LightSource -> LightSource
mvLS (V3 x y z) rot ls = ls & lsParam . lsPos .~ V3 x y z +.+.+ startPos
src/Dodge/Placement/PlaceSpot/Block.hs
+21 -7
View File
@@ -2,16 +2,18 @@
module Dodge.Placement.PlaceSpot.Block (
plBlock,
plLineBlock,
insertWall,
insertStructureWalls,
) where
import Dodge.Wall.Pathing
import qualified Data.Set as S
import Control.Lens
import qualified Data.IntSet as IS
import Data.List
import qualified Data.Set as S
import Dodge.Base
import Dodge.Data.GenWorld
import Dodge.Path
import Dodge.Wall.Pathing
import Geometry
import qualified IntMapHelp as IM
@@ -26,15 +28,26 @@ plBlock ps bl wl w =
, _blShadows = []
, _blFootprint = ps
}
& gwWorld %~ insertWalls wls
& gwWorld %~ insertStructureWalls BlockPart wl ps blid i
where
blid = IM.newKey $ w ^. gwWorld . cWorld . lWorld . blocks
i = IM.newKey $ w ^. gwWorld . cWorld . lWorld . walls
is = take (length ps) [i .. ]
is = take (length ps) [i ..]
insertStructureWalls ::
(Int -> WallStructure) ->
Wall ->
[Point2] ->
Int ->
Int ->
World ->
World
insertStructureWalls f wl ps sid wid = insertWalls wls
where
wls =
zipWith
(\j ln -> wl & wlLine .~ ln & wlID .~ j & wlStructure .~ BlockPart blid)
is
(\i xy -> wl & wlLine .~ xy & wlID .~ i & wlStructure .~ f sid)
[wid ..]
(loopPairs ps)
-- | Splits a line into many four cornered blocks.
@@ -107,6 +120,7 @@ insertWalls wls w = foldl' (flip insertWall) w wls
insertWall :: Wall -> World -> World
insertWall wl =
uncurry (obstructPathsCrossing (S.map WallObstacle $ getWallPathing wl))
uncurry
(obstructPathsCrossing (S.map WallObstacle $ getWallPathing wl))
(_wlLine wl)
. (cWorld . lWorld . walls . at (_wlID wl) ?~ wl)
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+9 -7
View File
@@ -4,6 +4,7 @@ module Dodge.Placement.PlaceSpot.TriggerDoor (
updateDoorEdges,
) where
import Dodge.Placement.PlaceSpot.Block
import Data.List
import qualified Data.Set as S
import Dodge.Data.GenWorld
@@ -19,7 +20,6 @@ import Linear
plDoor ::
Bool ->
S.Set EdgeObstacle ->
-- | Opening condition
WdBl ->
-- | Door positions, closed to open.
@@ -29,7 +29,7 @@ plDoor ::
Point2A ->
GenWorld ->
(Int, GenWorld)
plDoor isauto eo cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) -- carefull with the ordering of addWalls
plDoor isauto cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld . cWorld . lWorld . doors %~ addDoor) -- carefull with the ordering of addWalls
where
drid = IM.newKey $ _doors (_lWorld (_cWorld $ _gwWorld gw))
addDoor =
@@ -43,13 +43,15 @@ plDoor isauto eo cond l p1 p2 gw = (drid, over gwWorld addWalls $ gw & gwWorld .
, _drLerp = 0
, _drFootPrint = IM.fromList . zip wlids $ wlps'
}
wlids = take 4 [IM.newKey $ _walls (_lWorld (_cWorld $ _gwWorld gw)) ..]
wlids = take 4 [wlid..]
wlid = IM.newKey $ gw ^. gwWorld . cWorld . lWorld . walls
wlps' = rectanglePairs 9 0 (V2 l 0)
addWalls = insertStructureWalls (`DoorPart` isauto) defaultDoorWall
(map fst wlps' & each %~ shiftPointBy p1) drid wlid
--addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids
addWalls w' =
foldl' (addDoorWall isauto eo drid defaultDoorWall) w' $
zip wlids $
wlps' & each . each %~ shiftPointBy p1
-- foldl' (addDoorWall isauto eo drid defaultDoorWall) w' $
-- zip wlids $
-- wlps' & each . each %~ shiftPointBy p1
addDoorWall ::
Bool ->
src/Dodge/Room/Airlock.hs
+1 -2
View File
@@ -96,9 +96,8 @@ airlock0 =
]
col = dim $ dim $ bright red
--airlockDoor :: Color -> WdBl -> [(Point2, Point2)] -> PSType
airlockDoor :: WdBl -> Float -> Point2A -> Point2A -> PSType
airlockDoor = PutDoor False switchWallObs
airlockDoor = PutDoor False
airlockDoubleDoor ::
Point2 ->
src/Dodge/Room/Tutorial.hs
+3 -2
View File
@@ -1,3 +1,4 @@
{-# OPTIONS_GHC -Wno-unused-imports #-}
module Dodge.Room.Tutorial where
import Dodge.Room.Tanks
@@ -44,10 +45,10 @@ tutAnoTree = do
foldMTRS
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, corDoor
, tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] []
-- , tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] []
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , tToBTree "lastun" . return . cleatOnward <$> cenLasTur
, tToBTree "lastun" . return . cleatOnward <$> cenLasTur
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor