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

Improve pathing debugging, work on door pathing

Browse Source
This commit is contained in:
justin
2022-07-03 00:24:25 +01:00
parent 3efd89fa34
commit 67b612fe60
9 changed files with 59 additions and 43 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Data.hs
+2 -2
View File
@@ -1412,8 +1412,8 @@ data PSType = PutCrit {_unPutCrit :: Creature}
| PutLineBlock {_putWall :: Wall , _putWidth :: Float | PutLineBlock {_putWall :: Wall , _putWidth :: Float
, _putStartPoint :: Point2, _putEndPoint :: Point2} , _putStartPoint :: Point2, _putEndPoint :: Point2}
| PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall }
| PutSlideDr Door Wall Float Point2 Point2 | PutSlideDr Door Wall EdgeObstacle Float Point2 Point2
| PutDoor Color (World -> Bool) [(Point2,Point2)] | PutDoor Color EdgeObstacle (World -> Bool) [(Point2,Point2)]
| RandPS (State StdGen PSType) | RandPS (State StdGen PSType)
| PutForeground ForegroundShape | PutForeground ForegroundShape
| PutWorldUpdate (PlacementSpot -> World -> World) | PutWorldUpdate (PlacementSpot -> World -> World)
src/Dodge/Placement/Instance/Door.hs
+3 -3
View File
@@ -33,7 +33,7 @@ putDoubleDoorThen wl cond soff a b speed cont
doorBetween :: Wall -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float -> doorBetween :: Wall -> (World -> Bool) -> Float -> Point2 -> Point2 -> Float ->
(Placement -> Maybe Placement) -> Placement (Placement -> Maybe Placement) -> Placement
doorBetween wl cond soff pa pb speed g = case divideLine 40 pa pb of doorBetween wl cond soff pa pb speed g = case divideLine 40 pa pb of
[x,y] -> ptCont (PutSlideDr adoor wl soff x y) g [x,y] -> ptCont (PutSlideDr adoor wl DoorObstacle soff x y) g
(x:y:zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g (x:y:zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x:y:zs) (y:zs)) g
_ -> undefined _ -> undefined
where where
@@ -48,7 +48,7 @@ divideDoorPane mid wl cond soff speed ppairs g = case ppairs of
(p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g (p:ps) -> ptCont (adoor p) $ \pl -> Just $ divideDoorPane (_plMID pl) wl cond soff speed ps g
_ -> undefined _ -> undefined
where where
adoor (x,y) = PutSlideDr thedoor wl soff x y adoor (x,y) = PutSlideDr thedoor wl DoorObstacle soff x y
thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond thedoor = defaultDoor & drSpeed .~ speed & drTrigger .~ cond
& drPushedBy .~ maybe PushesItself PushedBy mid & drPushedBy .~ maybe PushesItself PushedBy mid
@@ -67,7 +67,7 @@ switchDoor btpos btrot dra drb col = pContID (PS btpos btrot) (PutButton $ makeS
$ \btid -> jsps0J (doorbetween btid dra drc) $ \btid -> jsps0J (doorbetween btid dra drc)
$ sps0 (doorbetween btid drb drc) $ sps0 (doorbetween btid drb drc)
where where
doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) 1 a b doorbetween btid a b = PutSlideDr thedoor (switchWallCol col) DoorObstacle 1 a b
where where
thedoor = defaultDoor thedoor = defaultDoor
& drTrigger .~ cond btid & drTrigger .~ cond btid
src/Dodge/Placement/PlaceSpot.hs
+3 -3
View File
@@ -95,10 +95,10 @@ placeSpotID ps pt w = case pt of
PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w PutLS ls -> plNewUpID lightSources lsID (mvLS p' rot ls) w
PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w PutPPlate pp -> plNewUpID pressPlates ppID (mvPP p rot pp) w
RandPS rgn -> evaluateRandPS rgn ps w RandPS rgn -> evaluateRandPS rgn ps w
PutDoor col f pss -> plDoor col f (map (bimap doShift doShift) pss) w PutDoor col eo f pss -> plDoor col eo f (map (bimap doShift doShift) pss) w
PutCoord cp -> plNewID coordinates (doShift cp) w PutCoord cp -> plNewID coordinates (doShift cp) w
PutSlideDr wl dr off a b PutSlideDr wl dr eo off a b
-> plSlideDoor wl dr off (doShift a) (doShift b) w -> plSlideDoor wl dr eo off (doShift a) (doShift b) w
PutBlock bl wl ps' -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot) PutBlock bl wl ps' -> plBlock (map doShift ps') (bl & blPos %~ doShift & blDir .~ rot)
wl w wl w
PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w PutLineBlock wl wdth a b -> plLineBlock wl wdth (doShift a) (doShift b) w
src/Dodge/Placement/PlaceSpot/TriggerDoor.hs
+11 -8
View File
@@ -23,12 +23,13 @@ import qualified Data.IntSet as IS
import qualified Data.Graph.Inductive as FGL import qualified Data.Graph.Inductive as FGL
import qualified Streaming.Prelude as S import qualified Streaming.Prelude as S
plDoor :: Color plDoor :: Color
-> EdgeObstacle
-> (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 -> World
-> (Int,World) -> (Int,World)
plDoor col cond pss gw = (drid, addWalls $ gw & doors %~ addDoor) -- carefull with the ordering of addWalls plDoor col eo cond pss gw = (drid, addWalls $ gw & doors %~ addDoor) -- carefull with the ordering of addWalls
where where
drid = IM.newKey $ _doors gw drid = IM.newKey $ _doors gw
addDoor = IM.insert drid $ defaultDoor addDoor = IM.insert drid $ defaultDoor
@@ -40,14 +41,15 @@ plDoor col cond pss gw = (drid, addWalls $ gw & doors %~ addDoor) -- carefull wi
, _drPos = head pss , _drPos = head pss
, _drOpenPos = head pss , _drOpenPos = head pss
, _drClosePos = last pss , _drClosePos = last pss
, _drObstacleType = eo
} }
nsteps = length pss - 1 nsteps = length pss - 1
wlids = take 4 [IM.newKey $ _walls gw ..] wlids = take 4 [IM.newKey $ _walls gw ..]
wlps' = uncurry (rectanglePairs 9) $ head pss wlps' = uncurry (rectanglePairs 9) $ head pss
addWalls w' = foldl' (addDoorWall drid $ switchWallCol col) w' $ zip wlids wlps' addWalls w' = foldl' (addDoorWall eo drid $ switchWallCol col) w' $ zip wlids wlps'
addDoorWall :: Int -> Wall -> World -> (Int,(Point2,Point2)) -> World addDoorWall :: EdgeObstacle -> Int -> Wall -> World -> (Int,(Point2,Point2)) -> World
addDoorWall drid wl w (wlid,wlps) = w' addDoorWall eo drid wl w (wlid,wlps) = w'
& walls %~ IM.insert wlid wl & walls %~ IM.insert wlid wl
{ _wlLine = wlps { _wlLine = wlps
, _wlID = wlid , _wlID = wlid
@@ -55,7 +57,7 @@ addDoorWall drid wl w (wlid,wlps) = w'
} }
& doors . ix drid . drObstructs .++~ es & doors . ix drid . drObstructs .++~ es
where where
(w',es) = uncurry (obstructPathsCrossing DoorObstacle) wlps w (w',es) = uncurry (obstructPathsCrossing eo) wlps w
-- TODO use vector instead of list, perhaps also memoisation of rectanglePairs -- TODO use vector instead of list, perhaps also memoisation of rectanglePairs
-- TODO update _drPos -- TODO update _drPos
-- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed -- perhaps also remove use of DoorInt in favour of DoorOpen/DoorClosed
@@ -121,12 +123,13 @@ maybeClearDoorPath eo w (x,y,pe)
plSlideDoor plSlideDoor
:: Door :: Door
-> Wall -> Wall
-> EdgeObstacle
-> Float -> Float
-> Point2 -> Point2
-> Point2 -> Point2
-> World -> World
-> (Int, World) -> (Int, World)
plSlideDoor dr wl shiftOffset a b gw plSlideDoor dr wl eo shiftOffset a b gw
= (drid, addDoorWalls $ gw & doors %~ addDoor) = (drid, addDoorWalls $ gw & doors %~ addDoor)
where where
drid = IM.newKey $ _doors gw drid = IM.newKey $ _doors gw
@@ -138,9 +141,9 @@ plSlideDoor dr wl shiftOffset a b gw
, _drPos = (a,b) , _drPos = (a,b)
, _drOpenPos = (shiftLeft a,shiftLeft b) , _drOpenPos = (shiftLeft a,shiftLeft b)
, _drClosePos = (a,b) , _drClosePos = (a,b)
, _drObstacleType = DoorObstacle , _drObstacleType = eo
} }
addDoorWalls w' = foldl' (addDoorWall drid wl) w' $ zip wlids pairs addDoorWalls w' = foldl' (addDoorWall eo drid wl) w' $ zip wlids pairs
pairs = rectanglePairs 9 a b pairs = rectanglePairs 9 a b
shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a))) shiftLeft = (+.+ (a -.- b +.+ shiftOffset *.* normalizeV (b -.- a)))
wlids = take 4 [IM.newKey $ _walls gw ..] wlids = take 4 [IM.newKey $ _walls gw ..]
src/Dodge/Render/ShapePicture.hs
+10 -16
View File
@@ -160,17 +160,18 @@ drawInspectWall w wl = setLayer DebugLayer $
drawDoorPaths :: World -> Int -> Picture drawDoorPaths :: World -> Int -> Picture
drawDoorPaths w drid = fromMaybe mempty $ do drawDoorPaths w drid = fromMaybe mempty $ do
paths <- w ^? doors . ix drid . drObstructs paths <- w ^? doors . ix drid . drObstructs
-- path <- listToMaybe paths
-- undefined
return $ foldMap (drawPathEdge . (^. _3)) paths return $ foldMap (drawPathEdge . (^. _3)) paths
-- return $ (drawPathEdge . (^. _3)) path
drawPathEdge :: PathEdge -> Picture drawPathEdge :: PathEdge -> Picture
drawPathEdge pe = setLayer DebugLayer $ color col $ arrow (_peStart pe) (_peEnd pe) drawPathEdge pe = setLayer DebugLayer
where $ multiArrow (_peStart pe) (_peEnd pe) green (Set.map obstacleColor (_peObstacles pe))
col = case _peObstacles pe of
pos | WallObstacle `Set.member` pos -> blue obstacleColor :: EdgeObstacle -> Color
| True -> red obstacleColor eo = case eo of
WallObstacle -> cyan
DoorObstacle -> red
AutoDoorObstacle -> yellow
BlockObstacle -> blue
drawWorldSelect :: World -> Picture drawWorldSelect :: World -> Picture
drawWorldSelect w = setLayer DebugLayer drawWorldSelect w = setLayer DebugLayer
@@ -293,15 +294,8 @@ drawWlIDs cfig w = setLayer FixedCoordLayer $ foldMap f (_walls w)
edgeToPic :: [Point2] -> PathEdge -> Picture edgeToPic :: [Point2] -> PathEdge -> Picture
edgeToPic poly pe edgeToPic poly pe
| not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty | not (pointInPolygon sp poly) && not (pointInPolygon ep poly) = mempty
| null $ _peObstacles pe | otherwise = drawPathEdge pe
= anarrow green
| hasobstacle BlockObstacle
= anarrow red
| hasobstacle AutoDoorObstacle = anarrow yellow
| otherwise = anarrow cyan
where where
hasobstacle = (`Set.member` _peObstacles pe)
anarrow col = color col $ arrow sp ep
sp = _peStart pe sp = _peStart pe
ep = _peEnd pe ep = _peEnd pe
src/Dodge/Room/Airlock.hs
+16 -6
View File
@@ -44,6 +44,14 @@ airlock0 = defaultRoom
cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn cond' btid w' = _btState (_buttons w' IM.! btid) == BtOn
col = dim $ dim $ bright red col = dim $ dim $ bright red
airlockDoor :: Color -> (World -> Bool) -> [(Point2,Point2)] -> PSType
airlockDoor col = PutDoor col DoorObstacle
airlockDoubleDoor :: Point2 -> Point2 -> Color -> (World -> Bool) -> [(Point2,Point2)]
-> [(Point2,Point2)] -> Maybe Placement
airlockDoubleDoor p1 p2 col cond outDoorps inDoorps = jspsJ p1 0 (airlockDoor col cond outDoorps)
$ sPS p2 0 (airlockDoor col cond inDoorps)
airlockSimple :: Room airlockSimple :: Room
airlockSimple = defaultRoom airlockSimple = defaultRoom
{ _rmPolys = { _rmPolys =
@@ -52,8 +60,9 @@ airlockSimple = defaultRoom
, _rmPath = foldMap (doublePairSet . (V2 90 30,) . fst) lnks , _rmPath = foldMap (doublePairSet . (V2 90 30,) . fst) lnks
, _rmPmnts = , _rmPmnts =
[pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 0) 0 (PutDoor col (cond btid) outDoorps) $ \btid -> airlockDoubleDoor 0 (V2 180 0) col (cond btid) outDoorps inDoorps
$ sPS (V2 180 0) 0 (PutDoor col (cond btid) inDoorps) -- jspsJ (V2 0 0) 0 (airlockDoor col (cond btid) outDoorps)
-- $ sPS (V2 180 0) 0 (airlockDoor col (cond btid) inDoorps)
] ]
, _rmBound = , _rmBound =
[ rectNSWE 120 0 0 180 ] [ rectNSWE 120 0 0 180 ]
@@ -78,8 +87,9 @@ airlockZ = defaultRoom
-- ] -- ]
, _rmPmnts = , _rmPmnts =
[pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id) [pContID (PS (V2 90 115) pi) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 60) 0 (PutDoor col (cond btid) outDoorps) $ \btid -> airlockDoubleDoor (V2 0 60) (V2 180 60) col (cond btid) outDoorps inDoorps
$ sPS (V2 180 60) 0 (PutDoor col (cond btid) inDoorps) -- jspsJ (V2 0 60) 0 (airlockDoor col (cond btid) outDoorps)
-- $ sPS (V2 180 60) 0 (airlockDoor col (cond btid) inDoorps)
, sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall , sps0 $ PutWall (reverse $ rectNSWE 70 50 60 120) defaultWall
, lighting , lighting
] ]
@@ -112,7 +122,7 @@ airlock90 = defaultRoom
, _rmPath = doublePairSet (V2 0 40,V2 40 0) , _rmPath = doublePairSet (V2 0 40,V2 40 0)
, _rmPmnts = , _rmPmnts =
[ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id) [ pContID (PS (V2 120 120) (3 * pi/4)) (PutButton $ makeSwitch col red id id)
$ \btid -> jsps (V2 5 5) 0 $ PutDoor col (cond btid) pss $ \btid -> jsps (V2 5 5) 0 $ airlockDoor col (cond btid) pss
, mntLS vShape (V2 35 35) (V3 70 70 50) , mntLS vShape (V2 35 35) (V3 70 70 50)
] ]
, _rmBound = , _rmBound =
@@ -137,7 +147,7 @@ airlockCrystal = defaultRoom
, _rmPath = mempty , _rmPath = mempty
, _rmPmnts = , _rmPmnts =
[pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id) [pContID (PS (V2 145 70) (pi/2)) ( PutButton $ makeSwitch col red id id)
$ \btid -> jsps0 $ PutDoor col (cond btid) pss $ \btid -> jsps0 $ airlockDoor col (cond btid) pss
, crystalLine (V2 0 70) (V2 40 70) , crystalLine (V2 0 70) (V2 40 70)
, mntLS vShape (V2 150 70) (V3 110 70 70) , mntLS vShape (V2 150 70) (V3 110 70 70)
] ]
src/Dodge/Room/LongDoor.hs
+2 -2
View File
@@ -46,8 +46,8 @@ twinSlowDoorRoom w h x = defaultRoom
, _rmPath = mempty , _rmPath = mempty
, _rmPmnts = , _rmPmnts =
[ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id) [ pContID (PS (V2 0 (h-5)) pi) ( PutButton $ makeButton col id)
$ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall 1 (V2 x 1) (V2 x h)) $ \btid -> jsps0J (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 x 1) (V2 x h))
$ ps0 (PutSlideDr (thedoor btid) thewall 1 (V2 (-x) 1) (V2 (-x) h)) $ ps0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-x) 1) (V2 (-x) h))
$ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampHeight))) $ \did -> jps0' (PutLS (lsColPos (V3 0.75 0 0) (V3 0 (h-1) lampHeight)))
$ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight $ \lspl -> jsps0 $ PutProp $ addColorChange (fromJust $ _plMID lspl) did $ lampCoverWhen (drmoving did) (V2 0 (h-1)) lampHeight
] ]
src/Dodge/Room/Procedural.hs
+2 -2
View File
@@ -267,8 +267,8 @@ centerVaultRoom w h d = return $ defaultRoom
col = dim $ dim $ bright red col = dim $ dim $ bright red
theDoor = theDoor =
[ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id) [ pContID (PS (V2 35 (d+4)) 0) (PutButton $ makeSwitch col red id id)
$ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall 1 (V2 (-21) 0) (V2 0 0)) $ \btid -> jspsJ (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 (-21) 0) (V2 0 0))
$ sPS (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall 1 (V2 21 0) (V2 0 0)) $ sPS (V2 0 (d-10)) 0 (PutSlideDr (thedoor btid) thewall DoorObstacle 1 (V2 21 0) (V2 0 0))
] ]
thewall = switchWallCol col thewall = switchWallCol col
thedoor btid = defaultDoor thedoor btid = defaultDoor
src/Picture/Composite.hs
+10 -1
View File
@@ -2,11 +2,20 @@ module Picture.Composite where
import Picture.Data import Picture.Data
import Picture.Base import Picture.Base
import Geometry import Geometry
--import Color
import Data.Foldable
arrowPath :: [Point2] -> Picture arrowPath :: [Point2] -> Picture
arrowPath xs = mconcat $ zipWith arrow xs $ tail xs arrowPath xs = mconcat $ zipWith arrow xs $ tail xs
multiArrow :: Foldable t => Point2 -> Point2 -> Color -> t Color -> Picture
multiArrow sp ep col' cols
| null cols = color col' (arrow sp ep)
| otherwise = foldl' f mempty cols
where
f pic col = uncurryV translate offset pic <> color col (arrow sp ep)
offset = normalizeV (vNormal (ep -.- sp))
arrow :: Point2 -> Point2 -> Picture arrow :: Point2 -> Point2 -> Picture
arrow a b = line [a,b] arrow a b = line [a,b]
<> line [b +.+ n -.- v,b] <> line [b +.+ n -.- v,b]