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

Work on chasm rooms

Browse Source
This commit is contained in:
justin
2025-10-02 16:58:38 +01:00
parent 013f50f0bc
commit 7e3614c9c8
15 changed files with 301 additions and 152 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base/CardinalPoint.hs
+8
View File
@@ -1,3 +1,4 @@
{-# LANGUAGE LambdaCase #-}
module Dodge.Base.CardinalPoint where
import Dodge.Data.Room
@@ -23,3 +24,10 @@ cardEightVec cp = case cp of
SouthWest8 -> V2 (-1) (-1)
West8 -> V2 (-1) 0
NorthWest8 -> V2 (-1) 1
cardinalBetweenAdj :: CardinalPointBetween -> (CardinalPoint,CardinalPoint)
cardinalBetweenAdj = \case
NorthEast -> (North,East)
SouthEast -> (South,East)
SouthWest -> (South,West)
NorthWest -> (North,West)
src/Dodge/Data/CardinalPoint.hs
+7
View File
@@ -9,6 +9,13 @@ data CardinalPoint
| West
deriving (Eq, Ord, Show, Bounded, Enum)
data CardinalPointBetween
= NorthEast
| SouthEast
| SouthWest
| NorthWest
deriving (Eq, Ord, Show, Bounded, Enum)
data CardinalEightPoint
= North8
| NorthEast8
src/Dodge/Humanoid.hs
+1 -1
View File
@@ -261,7 +261,7 @@ retreatActionsPistol tcr cr =
-0.7
| otherwise = 0.7
in fromMaybe tpos $
intersectLineLine'
intersectLineLine
cpos
(cpos +.+ rotateV a (tpos -.- cpos))
tpos
src/Dodge/Room/Foreground.hs
+1 -1
View File
@@ -68,7 +68,7 @@ diagonalLinesRect pa pb w d ang = zip lhsPoints $ map findDiPoint lhsPoints
findDiPoint p =
head . sortOn (dist p) $
catMaybes
[ intersectLineLine' p (p +.+ diVec) pax pbx
[ intersectLineLine p (p +.+ diVec) pax pbx
, intersectSegLine pa pax p (p +.+ diVec)
, intersectSegLine pb pbx p (p +.+ diVec)
]
src/Dodge/Room/Ngon.hs
+7 -7
View File
@@ -2,7 +2,7 @@ module Dodge.Room.Ngon where
import RandomHelp
import Data.List
import Data.Maybe
--import Data.Maybe
import Data.Tile
import Dodge.Data.GenWorld
import Dodge.Default.Room
@@ -27,10 +27,10 @@ roomNgon n x = do
where
rot = 2 * pi / fromIntegral n
rots = map ((rot *) . fromIntegral) [0 .. n -1]
poly =
mapMaybe
(\(ra, rb) -> intersectLineLine' (rotateV ra bl) (rotateV ra br) (rotateV rb bl) (rotateV rb br))
$ loopPairs rots
bl = V2 x x
br = V2 (- x) x
poly = polyOrthDist n x
-- mapMaybe
-- (\(ra, rb) -> intersectLineLine (rotateV ra bl) (rotateV ra br) (rotateV rb bl) (rotateV rb br))
-- $ loopPairs rots
-- bl = V2 x x
-- br = V2 (- x) x
lnks = sortOn ((\(V2 a b) -> (negate b, a)) . fst) $ map (\r -> (rotateV r (V2 0 x), r)) rots
src/Dodge/Room/Room.hs
+21 -23
View File
@@ -36,7 +36,6 @@ import Geometry
import LensHelp
import MonadHelp
import RandomHelp
import Linear
roomC :: RandomGen g => Float -> Float -> State g Room
roomC w h = do
@@ -75,9 +74,11 @@ glassSwitchBack = do
wth <- state $ randomR (200, 400)
hgt <- state $ randomR (400, 600)
wllen <- state $ randomR (60, wth / 2 -40)
l1 <- mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
--l2 <- mntLightLnkCond (rprBool $ \rp _ -> (rp ^. rpPos . _x) > wth -1 && null (rp ^. rpPlacementUse))
l2 <- mntLightLnkCond (rprBool $ \rp _ -> rp ^. rpLinkStatus . rplsType . at (OnEdge West) == Just ()&& null (rp ^. rpPlacementUse))
l2 <-
mntLightLnkCond $
rprBool $ \rp _ ->
rp ^. rpLinkStatus . rplsType . at (OnEdge West) == Just ()
&& null (rp ^. rpPlacementUse)
let hf = hgt / 5
awindow h xl xr = windowLine (V2 xl h) (V2 xr h)
plmnts =
@@ -89,14 +90,8 @@ glassSwitchBack = do
, blockLine (V2 (wth - wllen) (2 * hf)) (V2 wth (2 * hf))
, blockLine (V2 0 (3 * hf)) (V2 wllen (3 * hf))
, blockLine (V2 (wth - wllen) (4 * hf)) (V2 wth (4 * hf))
, l1
, l2
, l2
, l2
, l2
, l2
-- , sPS (V2 (wth / 2) (10 + hgt / 2)) 0 putLamp
]
<> replicate 5 l2
let northPSs = do
cry <- randomRanges [3 * hf + 10, 4 * hf -10, 4 * hf + 10, 5 * hf -10]
crx <- state $ randomR (wllen, wth - (wllen + 40))
@@ -108,16 +103,16 @@ glassSwitchBack = do
& rmRandPSs .~ [northPSs, midPS]
& rmName .~ "glassSwitchBack"
glassSwitchBackCrits :: RandomGen g => State g Room
glassSwitchBackCrits =
glassSwitchBack <&> rmPmnts
.++~ [ psPtPl (PSRoomRand 0 (uncurry PS)) (PutCrit miniGunCrit)
, psPtPl (PSRoomRand 1 (uncurry PS)) randC1
]
glassSwitchBackCrits :: RandomGen g => Int -> State g Room
glassSwitchBackCrits i = glassSwitchBack <&> rmPmnts <>~ fmap f [0 .. i -1]
where
f j = psPtPl (PSRoomRand j (uncurry PS)) randC1
-- note there used to be a creature with a minigun in glassSwitchBackCrits, has
-- been removed 25.10.01
miniTree2 :: RandomGen g => State g (Tree Room)
miniTree2 = do
rm <- glassSwitchBackCrits >>= shuffleLinks . restrictInLinks (\p -> (sndV2 . fst) p < 70)
rm <- glassSwitchBackCrits 2 >>= shuffleLinks . restrictInLinks (\p -> (sndV2 . fst) p < 70)
return $ branchWith rm (replicate 3 $ treePost [door, corridor, critInDeadEnd])
-- So, the idea is to attach outer children to the bottommost right nodes
@@ -131,8 +126,10 @@ roomMiniIntro = do
roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = do
l1 <- mntLightLnkCond (resetPLUse $ rprBool $ \rp _ -> isInLnk rp)
l2 <- mntLightLnkCond ((resetPLUse $ rprBool $ \rp _ -> isOutLnk rp)
& psFallback ?~ mntLightLnkCond' (resetPLUse useUnusedLnk))
l2 <-
mntLightLnkCond $
(resetPLUse $ rprBool $ \rp _ -> isOutLnk rp)
& psFallback ?~ mntLightLnkCond' (resetPLUse useUnusedLnk)
let plmnts =
[ blockLine (V2 115 115) (V2 115 125)
, blockLine (V2 125 115) (V2 125 125)
@@ -402,9 +399,10 @@ critsRoom :: Int -> State LayoutVars (Tree Room)
critsRoom i =
join $
takeOne
--[return <$> critsPillarRoom i]
--[return <$> roomC 200 200]
[return <$> glassSwitchBack]
[ return <$> roomCCrits i
, return <$> critsPillarRoom i
, return <$> glassSwitchBackCrits i
]
-- cor <- shuffleLinks corridor
-- return $ tToBTree "corDoor" $ treePost [door,cor,cleatOnward door]
src/Dodge/Room/Tutorial.hs
+71
View File
@@ -1,5 +1,6 @@
module Dodge.Room.Tutorial where
import Control.Monad
import qualified Data.Set as S
import ShortShow
import Dodge.Data.MTRS
@@ -46,6 +47,7 @@ tutAnoTree = do
[ tToBTree "TutStartRez" . return . cleatOnward <$> tutRezBox
, corDoor
, tutHub
, tutLight
, tutDrop
, return $ tToBTree "cor" $ return $ cleatOnward corridor
---- , AnTree $ pickupTut
@@ -103,6 +105,75 @@ tutDrop = do
, makeTermLine "-------------------------------------------"
]
cChasm :: State LayoutVars Room
cChasm = do
x <- state $ randomR (150,300)
y <- state $ randomR (150,300)
roomRectAutoLinks x y
<&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
<&> rmLinks %~ setInLinks (isCornerLink SouthWest)
<&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y-50) 50 0 (x-50))]
lChasm :: State LayoutVars Room
lChasm = do
x <- state $ randomR (150,300)
y <- state $ randomR (150,300)
roomRectAutoLinks x y
<&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
<&> rmLinks %~ setInLinks (isCornerLink SouthEast)
<&> rmPmnts <>~ [sps0 $ PutChasm (rectNSWE (y-50) 0 0 (x-50))]
zChasm :: Float -> State LayoutVars Room
zChasm z = do
x <- state $ randomR (150,300)
y <- state $ randomR (150,300)
roomRectAutoLinks x y
<&> rmLinks %~ setOutLinks (isCornerLink NorthWest)
<&> rmLinks %~ setInLinks (isCornerLink SouthEast)
<&> rmPmnts <>~
[sps0 $ PutChasm (rectNSWE (y/2-z) 0 0 (x-50))
,sps0 $ PutChasm (rectNSWE y (y/2+z) 50 x)
]
midChasm :: State LayoutVars Room
midChasm = do
x <- state $ randomR (200,300)
y <- state $ randomR (200,300)
r <- roomRectAutoLinks x y
cs <- join $ takeOne [cenoct x y,censquare x y]
shuffleLinks $ r
& rmLinks %~ setOutLinks (isMidEdgeLink r North)
& rmLinks %~ setInLinks (isMidEdgeLink r South)
& rmPmnts <>~ cs
where
censquare x y = do
z <- state $ randomR (40,60)
return [sps0 $ PutChasm (rectNSWE (y-z) z z (x-z))]
cenoct x y = return
[sps0 $ PutChasm $ (V2 (x/2) (y/2) +) <$> polyOrthDist 8 (min x y/2 - 25)]
-- dia x y = [sps0 $ PutChasm [V2 ]
polyChasm :: Int -> Float -> State LayoutVars Room
polyChasm n x = roomNgon n x
chasmSimpleMaze :: State LayoutVars Room
chasmSimpleMaze = join $ takeOne
[midChasm
,zChasm 25
,lChasm
,cChasm
]
tutLight :: State LayoutVars (MetaTree Room String)
tutLight = do
-- x <- roomRectAutoLinks 200 400
-- let y = x & rmLinks %~ setOutLinks (\rl -> OnEdge North `S.member` _rlType rl)
-- -- & rmLinks %~ setInLinks (\rl -> OnEdge South `S.member` _rlType rl)
-- -- & rmLinks %~ setLinkType InLink (isCornerLink SouthEast)
-- & rmLinks %~ setLinkType InLink (isMidEdgeLink x South)
x <- chasmSimpleMaze
return $ tToBTree "TutLight" $ treePost [x,cleatOnward corridor]
tutHub :: State LayoutVars (MetaTree Room String)
tutHub = do
(is,wbp) <- setTreeInts =<< critsRoom 2
src/Dodge/RoomLink.hs
+19
View File
@@ -21,8 +21,11 @@ module Dodge.RoomLink (
setLinkType,
getLinksOfType,
swapInOutLinks,
isCornerLink,
isMidEdgeLink,
) where
import Dodge.Base.CardinalPoint
import Control.Lens
import Data.List (partition)
import qualified Data.Set as S
@@ -51,6 +54,22 @@ setOutLinks = setLinkType OutLink
setInLinks :: (RoomLink -> Bool) -> [RoomLink] -> [RoomLink]
setInLinks = setLinkType InLink
isMidEdgeLink :: Room -> CardinalPoint -> RoomLink -> Bool
isMidEdgeLink r x rl
| x == North || x == South = g West (f $ r ^?! rmType . numLinkEW)
| otherwise = g South (f $ r ^?! rmType . numLinkNS)
where
f y | even y = [y `div` 2]
| otherwise = [y `div` 2, 1 + (y `div` 2)]
g a = any (\y -> FromEdge a y `S.member` (rl ^. rlType))
isCornerLink :: CardinalPointBetween -> RoomLink -> Bool
isCornerLink x rl = (OnEdge a `S.member` xs && FromEdge b 0 `S.member` xs)
|| (OnEdge b `S.member` xs && FromEdge a 0 `S.member` xs)
where
xs = rl ^. rlType
(a,b) = cardinalBetweenAdj x
setInLinksByType :: RoomLinkType -> [RoomLink] -> [RoomLink]
setInLinksByType lt = setInLinks (\rl -> lt `S.member` _rlType rl)
src/Geometry/Intersect.hs
+4 -4
View File
@@ -15,9 +15,9 @@ import Linear.Metric
import Control.Monad
-- | If two lines intersect, return 'Just' that point.
intersectLineLine' :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectLineLine' #-}
intersectLineLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
intersectLineLine :: Point2 -> Point2 -> Point2 -> Point2 -> Maybe Point2
{-# INLINE intersectLineLine #-}
intersectLineLine (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
| den == 0 = Nothing
| otherwise = Just $ V2 (x1 + (x2 - x1) * t' / den) (y1 + (y2 - y1) * t' / den)
where
@@ -28,7 +28,7 @@ intersectLineLine' (V2 x1 y1) (V2 x2 y2) (V2 x3 y3) (V2 x4 y4)
intersectLinePlane :: Point3 -> Point3 -> Point3 -> Point3 -> Maybe Point3
intersectLinePlane l v p n = case dot v n of
0 -> Nothing
x -> Just $ l + ((dot (p - l) n) / x) *.*.* v
x -> Just $ l + (dot (p - l) n / x) *.*.* v
-- this needs to be checked
intersectSegPlane :: Point3 -> Point3 -> Point3 -> Point3 -> Maybe Point3
src/Geometry/Polygon.hs
+18
View File
@@ -2,6 +2,7 @@
module Geometry.Polygon where
import Geometry.Intersect
import qualified Control.Foldl as L
import Data.Maybe
import Geometry.Data
@@ -46,6 +47,23 @@ rectVV (V2 x y) (V2 a b) = rectNSWE n s w e
square :: Float -> [Point2]
square n = rectWH n n
polyOrthDist :: Int -> Float -> [Point2]
polyOrthDist n x = mapMaybe
(\(ra, rb) -> intersectLineLine (rotateV ra bl) (rotateV ra br) (rotateV rb bl) (rotateV rb br))
$ loopPairs rots
where
rot = 2 * pi / fromIntegral n
rots = map ((rot *) . fromIntegral) [0 .. n -1]
bl = V2 x x
br = V2 (- x) x
polyCornerDist :: Int -> Float -> [Point2]
polyCornerDist n x = map f rots
where
rot = 2 * pi / fromIntegral n
rots = map ((rot *) . fromIntegral) [0 .. n -1]
f a = rotateV a (V2 x 0)
mirrorXAxis :: [Point2] -> [Point2]
mirrorXAxis ps = orderPolygon $ ps ++ mapMaybe f ps
where