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

Further add information to room positions

Browse Source
This commit is contained in:
justin
2022-06-15 12:57:31 +01:00
parent 62dae5bebe
commit 29e1ee14a1
2 changed files with 23 additions and 12 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/Pillar.hs
+11 -9
View File
@@ -41,16 +41,18 @@ crossPillar w' h' = ps0jPushPS (aline (V2 (-w) 0) (V2 w 0))
aline = PutLineBlock baseBlockPane StoneBlock 9 9 aline = PutLineBlock baseBlockPane StoneBlock 9 9
roomPillarsSquare :: RandomGen g => State g Room roomPillarsSquare :: RandomGen g => State g Room
roomPillarsSquare = return $ roomRectAutoLinks 400 400 roomPillarsSquare = do
& rmPmnts .++~ [sps (rprBool $ \rp _ -> t rp) smallPillar h <- state $ randomR (300,300)
,sps (rprBool $ \rp _ -> t rp) smallPillar w <- state $ randomR (300,400)
,sps (rprBool $ \rp _ -> t rp) smallPillar let rm = roomRectAutoLinks w h
,sps (rprBool $ \rp _ -> t rp) smallPillar nlew = _numLinkEW (_rmType rm)
,sps (rprBool $ \rp _ -> t rp) smallPillar nlns = _numLinkNS (_rmType rm)
] return $ rm & rmPmnts .++~ concatMap (replicate nlew . makepill) [South,North]
++ concatMap (replicate nlns . makepill) [East,West]
where where
t rp = any f (_rpType rp) && _rpPlacementUse rp == 0 makepill edge = sps (rprBool $ \rp _ -> t edge rp) smallPillar
f rpt = maybe False (PathFromEdge West 1 `S.member`) (rpt ^? onPathEdges) t edge rp = any (f edge) (_rpType rp) && _rpPlacementUse rp == 0
f edge rpt = maybe False (PathFromEdge edge 0 `S.member`) (rpt ^? offPathEdges)
roomPillarsPassage :: RandomGen g => State g Room roomPillarsPassage :: RandomGen g => State g Room
roomPillarsPassage = do roomPillarsPassage = do
src/Dodge/Room/Procedural.hs
+12 -3
View File
@@ -50,8 +50,9 @@ roomRect x y xn yn = defaultRoom
, _rmName = "rect" , _rmName = "rect"
, _rmPath = concatMap doublePair pth , _rmPath = concatMap doublePair pth
--, _rmPos = map (roomposat (RoomPosOnPath S.empty)) posps --, _rmPos = map (roomposat (RoomPosOnPath S.empty)) posps
, _rmPos = map (makeonpos) posps' -- ++ map (roomposat (RoomPosOffPath S.empty)) interposps
++ map (roomposat (RoomPosOffPath S.empty)) interposps , _rmPos = map makeonpos posps'
++ map makeoffpos interposps'
, _rmPmnts = [] , _rmPmnts = []
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)] , _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = Tiled [Tile , _rmFloor = Tiled [Tile
@@ -90,12 +91,20 @@ roomRect x y xn yn = defaultRoom
makerpedges (a,b) = S.fromList makerpedges (a,b) = S.fromList
[PathFromEdge South b [PathFromEdge South b
,PathFromEdge North (yn-b) ,PathFromEdge North (yn-b)
,PathFromEdge East (yn-a) ,PathFromEdge East (xn-a)
,PathFromEdge West a ,PathFromEdge West a
] ]
posps' = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn+1) yd (xn+1) posps' = map (over _1 (+.+ V2 20 20)) $ gridPoints'' xd (xn+1) yd (xn+1)
interposps' = map (over _1 (+.+ V2 (20 + xd/2) (20 + yd/2))) $ gridPoints'' xd xn yd yn
posps = map (+.+ V2 20 20) $ gridPoints xd (xn+1) yd (yn+1) posps = map (+.+ V2 20 20) $ gridPoints xd (xn+1) yd (yn+1)
interposps = map (+.+ V2 (20 + xd/2) (20 + yd/2)) $ gridPoints xd xn yd yn interposps = map (+.+ V2 (20 + xd/2) (20 + yd/2)) $ gridPoints xd xn yd yn
makeoffpos (p,a) = RoomPos p 0 (S.singleton $ RoomPosOffPath $ makerpedges' a) NotLink 0
makerpedges' (a,b) = S.fromList
[PathFromEdge South b
,PathFromEdge North (yn-(b+1))
,PathFromEdge East (xn-(a+1))
,PathFromEdge West a
]
zipCountDown :: [a] -> [(Int,a)] zipCountDown :: [a] -> [(Int,a)]
zipCountDown xs = zip [length xs - 1, length xs - 2 ..] xs zipCountDown xs = zip [length xs - 1, length xs - 2 ..] xs