This commit is contained in:
2025-10-27 00:09:11 +00:00
parent aa82519e05
commit c676005219
4 changed files with 17 additions and 14 deletions
+10 -7
View File
@@ -7,7 +7,6 @@ import Dodge.WorldBool
import Dodge.Zoning.Pathing import Dodge.Zoning.Pathing
import Dodge.Door.DoorLerp import Dodge.Door.DoorLerp
import Dodge.ShiftPoint import Dodge.ShiftPoint
import Dodge.Path
import Dodge.Zoning.Base import Dodge.Zoning.Base
import Control.Lens import Control.Lens
import Control.Monad import Control.Monad
@@ -78,19 +77,21 @@ debugItem = \case
Debug_put -> debugPutItems Debug_put -> debugPutItems
debugGet :: Universe -> [String] debugGet :: Universe -> [String]
debugGet u = [maybe "DebugGetFail" show $ debugGet1 u debugGet u = [fromMaybe "DebugGetFail" $ debugGet1 u
, maybe "DebugGetFail" show $ debugGet2 u , fromMaybe "DebugGetFail" $ debugGet2 u
, maybe "DebugGetFail" show $ debugGet3 u , fromMaybe "DebugGetFail" $ debugGet3 u
] ]
--debugGet1 :: Show a => Universe -> Maybe a --debugGet1 :: Show a => Universe -> Maybe a
debugGet1 :: Universe -> Maybe String
debugGet1 u = do debugGet1 u = do
dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2 dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2
let wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x) let wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x)
ps = wlposs (dr ^. drLerp) ps = wlposs (dr ^. drLerp)
is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
return $ S.toList is return $ show $ S.toList is
debugGet2 :: Universe -> Maybe String
debugGet2 u = do debugGet2 u = do
let w = u ^. uvWorld let w = u ^. uvWorld
dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2 dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2
@@ -107,7 +108,7 @@ debugGet2 u = do
is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
return $ show is return $ show is
debugGet3 :: Universe -> Maybe String
debugGet3 u = do debugGet3 u = do
dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2 dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2
let wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x) let wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x)
@@ -129,18 +130,20 @@ doDebugPut i u
| u ^. uvWorld . input . mouseButtons . at SDL.ButtonLeft == Just 0 = u | u ^. uvWorld . input . mouseButtons . at SDL.ButtonLeft == Just 0 = u
& uvIOEffects %~ \ f u' -> do & uvIOEffects %~ \ f u' -> do
s <- getClipboard s <- getClipboard
f $ u & uvDebugPut . at i ?~ s f $ u' & uvDebugPut . at i ?~ s
| otherwise = u | otherwise = u
debugPutDraw :: IM.IntMap String -> Universe -> Picture debugPutDraw :: IM.IntMap String -> Universe -> Picture
debugPutDraw _ u = drawthedoor u <> drawthezones u debugPutDraw _ u = drawthedoor u <> drawthezones u
drawthezones :: Universe -> Picture
drawthezones u = fold $ do drawthezones u = fold $ do
is <- readMaybe =<< u ^? uvDebugPut . ix 0 is <- readMaybe =<< u ^? uvDebugPut . ix 0
let f :: [Int2] -> [Int2] let f :: [Int2] -> [Int2]
f = id f = id
return $ foldMap (drawZoneCol yellow peZoneSize) $ f is return $ foldMap (drawZoneCol yellow peZoneSize) $ f is
drawthedoor :: Universe -> Picture
drawthedoor u = fold $ do drawthedoor u = fold $ do
dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2 dr <- u ^? uvWorld . cWorld . lWorld . doors . ix 2
let wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x) let wlposs x = (dr ^. drFootPrint) & each . each %~ shiftPointBy (doDoorLerp dr x)
+4 -3
View File
@@ -314,13 +314,14 @@ drawDDATest w =
<> foldMap (drawZone f 50) qs <> foldMap (drawZone f 50) qs
<> foldMap (drawZone g 50) rs <> foldMap (drawZone g 50) rs
<> foldMap (drawCrossCol yellow) xs <> foldMap (drawCrossCol yellow) xs
-- <> foldMap (drawCrossCol cyan) xs'
<> setLayer DebugLayer (color yellow (line [x, y])) <> setLayer DebugLayer (color yellow (line [x, y]))
where where
x = w ^. wCam . camViewFrom x = w ^. wCam . camViewFrom
y = mouseWorldPos (w ^. input) (w ^. wCam) y = mouseWorldPos (w ^. input) (w ^. wCam)
f [a,b,c,d] = color red $ thickLine 2 [a,c] f [a,_,c,_] = color red $ thickLine 2 [a,c]
g [a,b,c,d] = color blue $ thickLine 2 [b,d] f _ = undefined
g [_,b,_,d] = color blue $ thickLine 2 [b,d]
g _ = undefined
ps = zoneOfSeg 50 x y ps = zoneOfSeg 50 x y
qs = map (zoneOfPoint 50) $ xIntercepts' 50 x y qs = map (zoneOfPoint 50) $ xIntercepts' 50 x y
rs = map (zoneOfPoint 50) $ yIntercepts' 50 x y rs = map (zoneOfPoint 50) $ yIntercepts' 50 x y
+2 -4
View File
@@ -47,14 +47,12 @@ doorLerp :: Float -> Door -> World -> (S.Set Int2, World)
doorLerp speed dr w = fromMaybe (mempty,domounts (dr ^. drLerp) w) $ do doorLerp speed dr w = fromMaybe (mempty,domounts (dr ^. drLerp) w) $ do
x <- newlerp x <- newlerp
let ps = wlposs x let ps = wlposs x
is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
ps' = wlposs (dr ^. drLerp) ps' = wlposs (dr ^. drLerp)
is' = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps' is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) (ps <> ps')
is'' = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) (ps <> ps')
-- it seems possible that this will miss some paths: we don't add zones for the -- it seems possible that this will miss some paths: we don't add zones for the
-- old footprint. Seems unlikely, but a possible cause of pathfinding bugs -- old footprint. Seems unlikely, but a possible cause of pathfinding bugs
return return
( is'' ( is
, domounts x $ f x , domounts x $ f x
& playSound x & playSound x
& cWorld . lWorld . doors . ix drid . drLerp .~ x & cWorld . lWorld . doors . ix drid . drLerp .~ x
+1
View File
@@ -77,6 +77,7 @@ walkableNodeNear w p = fmap fst . find (flip (isWalkable p) w . snd) $ nodesNear
-- where -- where
-- nodesNear = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p -- nodesNear = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p
nodesNear :: World -> Point2 -> [(Int, Point2)]
nodesNear w p = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p nodesNear w p = zonesExtract (w ^. incNodeZoning) . snailAround $ zoneOfPoint pnZoneSize p
snailAround :: Int2 -> [Int2] snailAround :: Int2 -> [Int2]