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

More strictifiiiying

Browse Source
This commit is contained in:
justin
2021-07-30 01:25:11 +02:00
parent 2d8b27746c
commit 7b7fd302d8
37 changed files with 459 additions and 448 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Room/Procedural.hs
+65 -65
View File
@@ -46,25 +46,25 @@ roomRect x y xn yn = defaultRoom
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
, _rmPS = [sPS (x/2,y/2) 0 putLamp]
, _rmPS = [sPS (V2 (x/2) (y/2)) 0 putLamp]
, _rmBound = [rectNSWE (y+5) (-5) (-5) (x+5)]
, _rmFloor = [Tile
{ _tilePoly = rectNSWE y 0 0 x
, _tileCenter = (0,0)
, _tileX = (50,0)
, _tileY = (0,50)
, _tileCenter = (V2 0 0)
, _tileX = (V2 50 0)
, _tileY = (V2 0 50)
, _tileZ = 16
} ]
}
where
yd = (y - 40) / fromIntegral yn
xd = (x - 40) / fromIntegral xn
elnks = zip (translateS (0,20) $ gridPoints 0 1 yd (yn+1)) (repeat ( pi/2))
wlnks = zip (translateS (x,20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2))
nlnks = zip (translateS (20,y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 )
slnks = zip (translateS (20,0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi )
elnks = zip (translateS (V2 0 20) $ gridPoints 0 1 yd (yn+1)) (repeat ( pi/2))
wlnks = zip (translateS (V2 x 20) $ gridPoints 0 1 yd (yn+1)) (repeat (-pi/2))
nlnks = zip (translateS (V2 20 y) $ gridPoints xd (xn+1) 0 1 ) (repeat 0 )
slnks = zip (translateS (V2 20 0) $ gridPoints xd (xn+1) 0 1 ) (repeat pi )
lnks = nlnks ++ elnks ++ wlnks ++ slnks
pth = linksAndPath lnks $ translateS (20,20) (makeGrid xd xn yd yn)
pth = linksAndPath lnks $ translateS (V2 20 20) (makeGrid xd xn yd yn)
{-
Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size.
-}
@@ -79,12 +79,12 @@ makeGrid x nx y ny
$ gridPoints x nx y ny
gridPoints :: Float -> Int -> Float -> Int -> [Point2]
gridPoints x nx y ny = [(a,b) | a <- take nx $ scanl (+) 0 $ repeat x
gridPoints x nx y ny = [(V2 a b) | a <- take nx $ scanl (+) 0 $ repeat x
, b <- take ny $ scanl (+) 0 $ repeat y
]
makeRect :: Float -> Float -> [(Point2,Point2)]
makeRect x y = [((0,0),(x,0))
makeRect x y = map (bimap toV2 toV2) [((0,0),(x,0))
,((0,0),(0,y))
,((x,y),(x,0))
,((x,y),(0,y))
@@ -123,29 +123,29 @@ Add a light and a 'PutNothing' placement. -}
fourthWall :: RandomGen g => Float -> State g Room
fourthWall w = do
b <- takeOne
[ [ sPS (20-w,w-40) 0 putLamp
, sPS (0,40) 0 putLamp
, sPS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (w/2,w)
[ [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 (0) (40)) 0 putLamp
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (w/2) (w))
]
, [ sPS (20-w,w-40) 0 putLamp
, sPS (0,40) 0 putLamp
, sPS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (negate $ w/2,w/2)
, [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 0 40) 0 putLamp
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (negate $ w/2) (w/2))
]
, [ sPS (20-w,w-40) 0 putLamp
, sPS (0,20) 0 putLamp
, sPS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (0,w/2)
, blockLine (-29,w) (0,w/2)
, [ sPS (V2 (20-w) (w-40)) 0 putLamp
, sPS (V2 0 20) 0 putLamp
, sPS (V2 (w-20) (w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 (0) (w/2))
, blockLine (V2 (-29) (w)) (V2 (0) (w/2))
]
]
pure $ defaultRoom
{ _rmPolys = [ [(0,0),(w,w),(-w,w)] ]
, _rmLinks = [((0,w), 0)]
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
{ _rmPolys = [ map toV2 [(0,0),(w,w),(-w,w)] ]
, _rmLinks = [((V2 0 w), 0)]
, _rmPath = [((V2 0 w),(V2 0 0)),((V2 0 0),(V2 0 w))]
, _rmPS = b
, _rmBound = [[(0,0),(w,w),(-w,w)]]
, _rmBound = [[(V2 0 0),(V2 w w),(V2 (-w) (w))]]
}
--fourthCorner :: Float -> Room
--fourthCorner w = Room
@@ -162,38 +162,38 @@ fourthWall w = do
fourthCornerWall :: RandomGen g => Float -> State g Room
fourthCornerWall w = do
b <- takeOne
[ [ sPS (10-w,w) 0 putLamp
, sPS (w-10,w) 0 putLamp
, sPS (0,10) 0 putLamp
, sPS (0,2*w-20) pi PutNothing
, blockLine (w/2,w/2) (0,w)
, blockLine (negate $ w/2,w/2) (0,w)
[ [ sPS (V2 (10-w) (w)) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp
, sPS (V2 0 10) 0 putLamp
, sPS (V2 (0) (2*w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate $ w/2) (w/2)) (V2 0 w)
]
, [ sPS (0,3*w/2) 0 putLamp
, sPS (w-10,w) 0 putLamp
, sPS (10-w,w-20) 0 putLamp
, sPS (0,10) 0 putLamp
, sPS (0,2*w-20) pi PutNothing
, blockLine (w/2,w/2) (0,w)
, blockLine (negate w,w) (0,w)
, [ sPS (V2 (0) (3*w/2)) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp
, sPS (V2 (10-w) (w-20)) 0 putLamp
, sPS (V2 0 10) 0 putLamp
, sPS (V2 (0) (2*w-20)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 (negate w) (w)) (V2 0 w)
]
, [ sPS (10-w,w) 0 putLamp
, sPS (w-10,w) 0 putLamp
, sPS (0,10) 0 putLamp
, sPS (20,2*w-40) pi PutNothing
, blockLine (w/2,w/2) (0,w)
, blockLine (0,w) (0,w*2)
, [ sPS (V2 (10-w) (w)) 0 putLamp
, sPS (V2 (w-10) (w)) 0 putLamp
, sPS (V2 0 10) 0 putLamp
, sPS (V2 (20) (2*w-40)) pi PutNothing
, blockLine (V2 (w/2) (w/2)) (V2 0 w)
, blockLine (V2 0 w) (V2 (0) (w*2))
]
]
pure $ defaultRoom
{ _rmPolys = [ [(0,0),(w,w),(0,2*w),(-w,w)] ]
{ _rmPolys = [ map toV2 [(0,0),(w,w),(0,2*w),(-w,w)] ]
, _rmLinks =
[((w/2,3*w/2), negate $ pi/4)
,((negate $ w/2,3*w/2), pi/4)
[((V2 (w/2) (3*w/2)), negate $ pi/4)
,((V2 (negate $ w/2) (3*w/2)), pi/4)
]
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
, _rmPath = [((V2 0 w),(V2 0 0)),((V2 0 0),(V2 0 w))]
, _rmPS = b
, _rmBound = [[(w,w),(0,2*w),(-w,w)]]
, _rmBound = [map toV2 [(w,w),(0,2*w),(-w,w)]]
}
{- | Replace the first 'PutNothing' with a given 'PSType'. -}
fillNothingPlacement :: PSType -> Room -> Room
@@ -226,7 +226,7 @@ randomFourCornerRoom = do
randomiseAllLinks . fillNothingPlacements (crits ++ itms) =<<
( shufflePlacements
. foldr1 combineRooms
$ zipWith (\r a -> shiftRoomBy ((0,0),a) r) corners [0,pi/2,pi,3*pi/2]
$ zipWith (\r a -> shiftRoomBy ((V2 0 0),a) r) corners [0,pi/2,pi,3*pi/2]
)
{- | Creates room with a central vault with doors around it.
-}
@@ -246,28 +246,28 @@ centerVaultRoom n w h d = do
return $ defaultRoom
{ _rmPolys = polys
, _rmLinks =
[((0,h),0)
,((w,0),-pi/2)
,((-w,0),pi/2)
,((0,-h),pi)
[((V2 0 h),0)
,((V2 w 0),-pi/2)
,((V2 (-w) (0)),pi/2)
,((V2 (0) (-h)),pi)
]
, _rmPath = []
, _rmPS =
[sPS (d-25,d-25) 0 putLamp
,sPS (w-5,h-5) 0 putLamp
,sPS (w-5,5-h) 0 putLamp
,sPS (5-w,h-5) 0 putLamp
,sPS (5-w,5-h) 0 putLamp
[sPS (V2 (d-25) (d-25)) 0 putLamp
,sPS (V2 (w-5) (h-5)) 0 putLamp
,sPS (V2 (w-5) (5-h)) 0 putLamp
,sPS (V2 (5-w) (h-5)) 0 putLamp
,sPS (V2 (5-w) (5-h)) 0 putLamp
]
++ concat (zipWith (\i r -> map (shiftPSBy ((0,0),r)) $ theDoor i)
++ concat (zipWith (\i r -> map (shiftPSBy ((V2 0 0),r)) $ theDoor i)
[n, n+1, n+2, n+3] [0,pi/2,pi,3*pi/2])
, _rmBound = [rectNSWE h (-h) (-w) w]
}
where
col = dim $ dim $ bright red
theDoor i =
[ sPS (0,d-10) 0 $ PutDoubleDoor col (cond i) (-19,0) (19,0)
, sPS (35,d+4) 0 $ PutButton $ makeSwitch col
[ sPS (V2 (0) (d-10)) 0 $ PutDoubleDoor col (cond i) (V2 (-19) (0)) (V2 19 0)
, sPS (V2 (35) (d+4)) 0 $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen i) True))
(over worldState (M.insert (DoorNumOpen i) False))
]