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

Commit before adding more debugging control

Browse Source
This commit is contained in:
justin
2025-10-26 16:55:22 +00:00
parent 0adf3f57b4
commit c641cbaa69
8 changed files with 171 additions and 128 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/DrWdWd.hs
+4 -1
View File
@@ -48,10 +48,13 @@ doorLerp speed dr w = fromMaybe (mempty,domounts (dr ^. drLerp) w) $ do
x <- newlerp
let ps = wlposs x
is = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) ps
ps' = wlposs (dr ^. drLerp)
is' = foldMap (S.fromList . uncurry (zoneOfSeg peZoneSize)) 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
-- old footprint. Seems unlikely, but a possible cause of pathfinding bugs
return
( is
( is''
, domounts x $ f x
& playSound x
& cWorld . lWorld . doors . ix drid . drLerp .~ x
src/Dodge/LevelGen/PlacementHelper.hs
+2 -1
View File
@@ -46,7 +46,8 @@ jspsJ :: Point2 -> Float -> PSType -> Placement -> Maybe Placement
jspsJ p a pst plm = Just $ Placement (PS p a) pst Nothing Nothing $ \_ _ -> Just plm
jsps0J :: PSType -> Placement -> Maybe Placement
jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing Nothing $ \_ _ -> Just plm
--jsps0J pst plm = Just $ Placement (PS (V2 0 0) 0) pst Nothing Nothing $ \_ _ -> Just plm
jsps0J = jspsJ 0 0
ps0 :: PSType -> (Int -> Maybe Placement) -> Placement
ps0 pst = Placement (PS (V2 0 0) 0) pst Nothing Nothing . contToIDCont
src/Dodge/Path.hs
+1
View File
@@ -118,6 +118,7 @@ pairsToIncGraph pairs =
inodes = UV.generate (length ps) (ps !!)
ps = Set.toList $ Set.map fst pairs <> Set.map snd pairs
-- consider updating all path edges at the end of world generation?
obstructPathsCrossing :: S.Set EdgeObstacle -> Point2 -> Point2 -> World -> World
obstructPathsCrossing obs s e w = w & cWorld . incGraph %~ updateincedges
where
src/Dodge/Placement/Instance/Door.hs
+21 -11
View File
@@ -4,12 +4,12 @@ module Dodge.Placement.Instance.Door (
putDoubleDoorThen,
) where
import Dodge.Door.PutSlideDoor
import Control.Lens
import Dodge.Data.CreatureEffect
import Dodge.Data.GenWorld
import Dodge.Default.Door
import Dodge.Default.Wall
import Dodge.Door.PutSlideDoor
import Dodge.LevelGen.PlacementHelper
import Geometry
import Linear
@@ -51,15 +51,22 @@ doorBetween ::
(Placement -> Maybe Placement) ->
Placement
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 : zs) -> divideDoorPane Nothing wl cond (soff - dist y pb) speed (zip (x : y : zs) (y : zs)) g
-- [x, y] -> ptCont (putSlideDr adoor wl soff x y) g
(x : y : zs) ->
divideDoorPane
Nothing
wl
cond
(soff - dist y pb)
speed
(zip (x : y : zs) (y : zs))
g
_ -> error "tried to create doorBetween with too few points"
where
adoor =
defaultDoor
& drTrigger .~ cond
& drUpdate .~ DoorLerp speed
-- where
-- adoor =
-- defaultDoor
-- & drTrigger .~ cond
-- & drUpdate .~ DoorLerp speed
divideDoorPane ::
Maybe Int ->
@@ -72,12 +79,15 @@ divideDoorPane ::
Placement
divideDoorPane mid wl cond soff speed ppairs g = case ppairs of
[p] -> ptCont (adoor p) g
(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
where
adoor (x, y) = putSlideDr thedoor wl soff x y
thedoor =
defaultDoor & drUpdate . drLerpSpeed .~ speed & drTrigger .~ cond
defaultDoor
& drUpdate . drLerpSpeed .~ speed
& drTrigger .~ cond
& drPushedBy .~ maybe PushesItself PushedBy mid
putAutoDoor :: Point2 -> Point2 -> Placement
src/Dodge/Placement/Instance/LightSource.hs
+12
View File
@@ -11,6 +11,7 @@ module Dodge.Placement.Instance.LightSource (
spanColLightBlackI,
moveLSThen,
spanLightI,
spanLightY,
mntLightLnkCond',
spanLS,
) where
@@ -27,6 +28,7 @@ import Geometry
import RandomHelp
import Shape
import ShapePicture
import Linear
propLSThen ::
PropUpdate ->
@@ -215,6 +217,16 @@ spanColLightBlackI col h a b =
spanLightI :: Point2 -> Point2 -> Placement
spanLightI = spanColLightI 0.75 50
spanLightY :: Point2 -> Point2 -> Point2 -> Point2 -> Placement
spanLightY l x y z =
ps0j (PutLS $ lsColPos 0.75 (addZ (h -5) l)) $
ps0j (f x) $
ps0j (f y) $
sps0 $ f z
where
f p = putShape $ thinHighBar h p (l + normalize (l-p))
h = 50
--extendAway :: Point2 -> Point2 -> Point2
--extendAway p x = p +.+ squashNormalizeV (p -.- x)
src/Dodge/Room/Airlock.hs
+31 -18
View File
@@ -3,8 +3,6 @@
{- Rooms that contain two doors and a switch alternating both. -}
module Dodge.Room.Airlock where
import Dodge.Room.Foreground
import ShapePicture
import Control.Lens
import Control.Monad
import qualified Data.IntMap.Strict as IM
@@ -18,11 +16,13 @@ import Dodge.LevelGen.PlacementHelper
import Dodge.LevelGen.Switch
import Dodge.Placement.Instance
import Dodge.Placement.Instance.Analyser
import Dodge.Room.Foreground
import Dodge.Room.Path
import Dodge.RoomLink
import Geometry
import Picture
import RandomHelp
import ShapePicture
-- | A passage with a switch that opens forward access while closing backwards access.
airlock :: RandomGen g => State g Room
@@ -107,26 +107,35 @@ airlockDoubleDoor ::
Point2A ->
Point2A ->
Maybe Placement
airlockDoubleDoor cond l x1 y1 x2 y2 =
jspsJ 0 0 (putDoor cond l x1 y1) $
sPS 0 0 (putDoor cond l x2 y2)
airlockDoubleDoor cond l x1 y1 x2 y2 = jsps0J (pd x1 y1) $ sps0 (pd x2 y2)
where
pd = putDoor cond l
putDoor :: WdBl -> Float -> Point2A -> Point2A -> PSType
putDoor cond l p1 p2 = PutDoor dr wl
putDoor cond l p1 p2 = PutDoor dr defaultDoorWall
where
wl = defaultDoorWall
dr =
defaultDoor
& drTrigger .~ cond
& drUpdate .~ DoorLerp 0.01
& drZeroPos .~ p1
& drOnePos .~ p2
& drFootPrint .~ IM.fromList (zip [0 ..] wlps')
wlps' = loopPairs $ mkRectangle 9 (V2 l 0)
& drFootPrint
.~ IM.fromDistinctAscList
(zip [0 ..] (loopPairs $ mkRectangle 9 (V2 l 0)))
airlockSimple :: RandomGen g => State g Room
airlockSimple = do
light1 <- mntLightLnkCond $ PS (V2 90 120) 0
light1 <-
join $
takeOne
[ mntLightLnkCond $ PS (V2 90 120) 0
, mntLightLnkCond $ PS (V2 90 0) pi
, return $ spanLightI (V2 90 0) (V2 90 120)
, return $ spanLightI (V2 0 60) (V2 180 60)
, takeOne [30, 60, 90] <&> \x ->
spanLightY (V2 90 (120 - x)) (V2 (90 - x) 120) (V2 (90 + x) 120) (V2 90 0)
]
return $
defaultRoom
{ _rmPolys = [rectNSWE 120 0 0 180]
@@ -208,9 +217,11 @@ airlock90 =
[ pContID
(PS (V2 120 120) (3 * pi / 4))
xSwitch
$ \btid -> jsps (V2 5 5) 0 $ putDoor (WdBlBtOn btid) l1 x1 y1
& putDoorDoor . drMounts .~ themounts
-- , mntLS vShape (V2 35 35) (V3 70 70 50)
$ \btid ->
jsps (V2 5 5) 0 $
putDoor (WdBlBtOn btid) l1 x1 y1
& putDoorDoor . drMounts .~ themounts
-- , mntLS vShape (V2 35 35) (V3 70 70 50)
]
, _rmBound =
pure
@@ -223,10 +234,10 @@ airlock90 =
, _rmName = "airlock90"
}
where
themounts =
themounts =
[ MountedLight (V3 hl hl 50) 150 0.5
, MountedLight (V3 hl (-hl) 50) 150 0.5
, MountedSPic . noPic $ thinHighBar 55 (V2 hl (-hl')) (V2 hl hl')
, MountedLight (V3 hl (- hl) 50) 150 0.5
, MountedSPic . noPic $ thinHighBar 55 (V2 hl (- hl')) (V2 hl hl')
]
lnks = muout [(V2 0 40, pi / 2)] ++ muin [(V2 40 0, pi)]
hl = 27.5
@@ -239,8 +250,9 @@ airlockCrystal :: Room
airlockCrystal =
defaultRoom
{ _rmPolys = [rectNSWE 140 0 0 40, switchcutout]
, _rmLinks = muout [(V2 20 130, 0)] ++ muin [(V2 20 0, pi)]
, _rmPath = mempty
, _rmLinks = lnks
, _rmPath = linksGridToPath' lnks
$ loopPairs [V2 20 40, V2 100 70, V2 20 110]
, _rmPmnts =
[ pContID
(PS (V2 145 70) (pi / 2))
@@ -252,6 +264,7 @@ airlockCrystal =
, _rmBound = [rectNSWE 120 20 0 40, switchcutout]
}
where
lnks = muout [(V2 20 130, 0)] ++ muin [(V2 20 0, pi)]
switchcutout = orderPolygon $ map toV2 [(39, 20), (150, 60), (150, 80), (39, 120)]
l1 = 55
x1 = (0, pi / 2)
src/Dodge/Room/Tutorial.hs
+3 -2
View File
@@ -51,10 +51,11 @@ tutAnoTree = do
-- , return $ tToBTree "cor" $ return $ cleatOnward (twinSlowDoorRoom 80 200 40)
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward airlock0
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward airlockCrystal
-- , tToBTree "x" . return . cleatOnward <$> airlockSimple
-- , tToBTree "lastun" . return . cleatOnward <$> tanksRoom [] []
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
, return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor
-- , tToBTree "lastun" . return . cleatOnward <$> cenLasTur
-- , return $ tToBTree "cor" $ return $ cleatOnward corridor