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/Airlock.hs
+32 -32
View File
@@ -23,16 +23,16 @@ airlockOneWay n = defaultRoom
{ _rmPolys = [rectNSWE 90 0 0 40]
, _rmLinks = lnks
, _rmPath = []
, _rmPS = [sPS (0,15) 0 $ PutDoubleDoor col (not . cond) (0,0) (0,40)
,sPS (0,75) 0 $ PutDoubleDoor col cond (0,0) (0,40)
,sPS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState
, _rmPS = [sPS (V2 0 15) 0 $ PutDoubleDoor col (not . cond) (V2 0 0) (V2 0 40)
,sPS (V2 0 75) 0 $ PutDoubleDoor col cond (V2 0 0) (V2 0 40)
,sPS (V2 35 45) (pi/2) $ PutButton $ makeButton col (over worldState
(M.insert (DoorNumOpen n) True))
]
--, _rmBound = rectNSWE 90 30 (-30) 30
, _rmBound = [rectNSWE 75 15 0 40]
}
where lnks = [((0,85),0)
,((0, 5),pi)
where lnks = [((V2 0 85),0)
,((V2 0 5),pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
@@ -56,22 +56,22 @@ airlock0 n = defaultRoom
, rectNSWE 65 35 (-40) 20
]
, _rmLinks = lnks
, _rmPath = [((20,95),(20,45))
,((20,45),(20, 5))
, _rmPath = [((V2 20 95),(V2 20 45))
,((V2 20 45),(V2 20 5))
]
, _rmPS =
[sPS (0,20) 0 $ PutDoubleDoor col (not . cond) (1,0) (39,0)
,sPS (0,80) 0 $ PutDoubleDoor col cond (1,0) (39,0)
,sPS (35,50) (pi/2) $ PutButton $ makeSwitch col
[sPS (V2 0 20) 0 $ PutDoubleDoor col (not . cond) (V2 1 0) (V2 39 0)
,sPS (V2 0 80) 0 $ PutDoubleDoor col cond (V2 1 0) (V2 39 0)
,sPS (V2 35 50) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,sPS (-25, 50) 0 putLamp
,sPS (V2 (-25) ( 50)) 0 putLamp
]
, _rmBound = [rectNSWE 75 15 0 40]
}
where
lnks = [((20,95),0)
,((20, 5),pi)
lnks = [((V2 20 95),0)
,((V2 20 5),pi)
]
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
@@ -84,29 +84,29 @@ airlock90 n = defaultRoom
[ rectNSWE 100 10 10 100
, rectNSWE 20 0 20 60
, rectNSWE 20 60 20 0
, [ (10,100)
, map toV2 [ (10,100)
, (100,150)
, (150,100)
, (100,10)
]
]
, _rmLinks =
[((0,40),pi/2)
,((40, 0),pi)
[((V2 0 40),pi/2)
,((V2 40 0),pi)
]
, _rmPath =
[((0,40),(40,0))
,((40,0),(0,40))
[((V2 0 40),(V2 40 0))
,((V2 40 0),(V2 0 40))
]
, _rmPS =
[sPS (5,5) 0 $ PutDoor col (not . cond) pss
,sPS (120,120) (3* pi/4) $ PutButton $ makeSwitch col
[sPS (V2 5 5) 0 $ PutDoor col (not . cond) pss
,sPS (V2 120 120) (3* pi/4) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,sPS (60, 60) 0 putLamp
,sPS (V2 60 60) 0 putLamp
]
, _rmBound =
[[ (10,10)
[map toV2 [ (10,10)
, (10,100)
, (100,150)
, (150,100)
@@ -116,7 +116,7 @@ airlock90 n = defaultRoom
where
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
pss = ((0,0) ,) <$> arcStepwise 3 (negate $ pi/2) (0,0) (0,55)
pss = ((V2 0 0) ,) <$> arcStepwise 3 (negate $ pi/2) (V2 0 0) (V2 0 55)
airlockCrystal
:: Int -- ^ Door id
@@ -124,7 +124,7 @@ airlockCrystal
airlockCrystal n = defaultRoom
{ _rmPolys =
[ rectNSWE 140 0 0 40
, orderPolygon
, orderPolygon $ map toV2
[(39,20)
,(150,60)
,(150,80)
@@ -132,20 +132,20 @@ airlockCrystal n = defaultRoom
]
]
, _rmLinks =
[((20,130),0)
,((20, 0),pi)
[((V2 20 130),0)
,((V2 20 0),pi)
]
, _rmPath =
[
]
, _rmPS =
[sPS (0,0) 0 $ PutDoor col (not . cond) pss
,sPS (145,70) (pi/2) $ PutButton $ makeSwitch col
[sPS (V2 0 0) 0 $ PutDoor col (not . cond) pss
,sPS (V2 145 70) (pi/2) $ PutButton $ makeSwitch col
(over worldState (M.insert (DoorNumOpen n) True))
(over worldState (M.insert (DoorNumOpen n) False))
,crystalLine (0,70) (40,70)
,sPS (20, 40) 0 putLamp
,sPS (20, 100) 0 putLamp
,crystalLine (V2 0 70) (V2 40 70)
,sPS (V2 20 40) 0 putLamp
,sPS (V2 20 100) 0 putLamp
]
, _rmBound =
[ ]
@@ -154,5 +154,5 @@ airlockCrystal n = defaultRoom
cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
col = dim $ dim $ bright red
pss :: [(Point2,Point2)]
pss = reverse $ fmap ( (\x -> ((50,x),(50,x+50)) ) . fromIntegral)
pss = reverse $ fmap ( (\x -> ((V2 50 x),(V2 (50) (x+50))) ) . fromIntegral)
[20::Int,22..70]
src/Dodge/Room/Boss.hs
+35 -35
View File
@@ -29,21 +29,21 @@ roomGlassOctogon x = defaultRoom
,rectNSWE 0 (-(x + 40)) (-20) 20
]
, _rmLinks =
[((0,x),0)
,((0,-(x+40)),pi)
[((V2 0 x),0)
,((V2 (0) (-(x+40))),pi)
]
, _rmPath = [((0,x),(0,-(x+40)))
,((0,-(x+40)),(0,x))]
, _rmPath = [((V2 (0) (x)),(V2 (0) (-(x+40))))
,((V2 (0) (-(x+40))),(V2 (0) (x)))]
, _rmPS =
[sPS (fx,fx) 0 putLamp
,sPS (-fx,fx) 0 putLamp
,sPS (fx,-fx) 0 putLamp
,sPS (-fx,-fx) 0 putLamp
,crystalLine (-x,x/2) (negate (x/2), x)
,crystalLine (x,x/2) (x/2, x)
,crystalLine (x/2,-x) (x,negate (x/2))
,crystalLine (negate $ x/2,-x) (-x,negate (x/2))
,blockLine (-40,40-x) (40,40-x)
[sPS (V2 fx fx) 0 putLamp
,sPS (V2 (-fx) (fx)) 0 putLamp
,sPS (V2 (fx) (-fx)) 0 putLamp
,sPS (V2 (-fx) (-fx)) 0 putLamp
,crystalLine (V2 (-x) (x/2)) (V2 (negate (x/2)) ( x))
,crystalLine (V2 (x) (x/2)) (V2 (x/2) ( x))
,crystalLine (V2 (x/2) (-x)) (V2 (x) (negate (x/2)))
,crystalLine (V2 (negate $ x/2) (-x)) (V2 (-x) (negate (x/2)))
,blockLine (V2 (-40) (40-x)) (V2 (40) (40-x))
]
, _rmBound = [rectNSWE x (-x) (-x) x]
}
@@ -51,11 +51,11 @@ roomGlassOctogon x = defaultRoom
fx = 4 * x / 5
bossRoom :: RandomGen g => Creature -> State g Room
bossRoom cr = randomMediumRoom <&> rmPS %~ ( sPS (0,100) (negate $ pi/2) (PutCrit cr) :)
bossRoom cr = randomMediumRoom <&> rmPS %~ ( sPS (V2 0 100) (negate $ pi/2) (PutCrit cr) :)
armouredChasers :: RandomGen g => State g (Tree Room)
armouredChasers = do
ps <- takeN 5 [(x,y) | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
ps <- takeN 5 [(V2 x y) | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
as <- replicateM 5 . state $ randomR (0,2*pi)
let theCrits = zipWith3 (\p a c -> sPS p a (PutCrit c)) ps as cs
treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPS %~ (++ theCrits))
@@ -80,21 +80,21 @@ roomCross x y = defaultRoom
,rectNSWE (-x) x y (-y)
]
, _rmLinks =
[((x,y-20),negate $ pi/2)
,((x,20-y),negate $ pi/2)
,((20-y,x),0)
,((y-20,x),0)
,((-x,y-20),pi/2)
,((-x,20-y),pi/2)
,((20-y,-x),pi)
,((y-20,-x),pi)
[((V2 (x) (y-20)),negate $ pi/2)
,((V2 (x) (20-y)),negate $ pi/2)
,((V2 (20-y) (x)),0)
,((V2 (y-20) (x)),0)
,((V2 (-x) (y-20)),pi/2)
,((V2 (-x) (20-y)),pi/2)
,((V2 (20-y) (-x)),pi)
,((V2 (y-20) (-x)),pi)
]
, _rmPath = []
, _rmPS =
[sPS ( x, 0) 0 putLamp
,sPS (-x, 0) 0 putLamp
,sPS ( 0, x) 0 putLamp
,sPS ( 0,-x) 0 putLamp
[sPS (V2 ( x) ( 0)) 0 putLamp
,sPS (-V2 (x) ( 0)) 0 putLamp
,sPS (V2 ( 0) ( x)) 0 putLamp
,sPS (V2 ( 0) (-x)) 0 putLamp
]
, _rmBound =
[rectNSWE y (-y) (-x) x
@@ -107,7 +107,7 @@ roomShuriken
-> Float -- ^ Second width/2
-> Room
roomShuriken x y =
let ps = [
let ps = [ map toV2
[ (0,-20)
, (x,-20)
, (x,y)
@@ -115,12 +115,12 @@ roomShuriken x y =
] ]
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [((x-1,y-20),negate $ pi/2)]
, _rmLinks = [((V2 (x-1) (y-20)),negate $ pi/2)]
, _rmPath = []
, _rmPS = [sPS (x/2,x/2) 0 putLamp]
, _rmPS = [sPS (V2 (x/2) (x/2)) 0 putLamp]
, _rmBound = ps
}
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((0,0), r) corner) [0,pi/2,pi,3*pi/2]
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((V2 0 0), r) corner) [0,pi/2,pi,3*pi/2]
{- | TODO: pathing
Precondition: first float is less than the second by at least 40. -}
roomTwistCross
@@ -129,7 +129,7 @@ roomTwistCross
-> Float -- ^ Third width, should be smallest, possibly negative
-> Room
roomTwistCross x y z =
let ps = [ [ (x,negate $ z+20)
let ps = [ map toV2 [ (x,negate $ z+20)
, (x,x)
, (z,y)
, (z-20,x)
@@ -139,9 +139,9 @@ roomTwistCross x y z =
]
corner = defaultRoom
{ _rmPolys = ps
, _rmLinks = [((z,y-20), pi/2)]
, _rmLinks = [((V2 (z) (y-20)), pi/2)]
, _rmPath = []
, _rmPS = [sPS (x/2,x/2) 0 putLamp]
, _rmPS = [sPS (V2 (x/2) (x/2)) 0 putLamp]
, _rmBound = ps
}
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((0,0), r) corner) [0,pi/2,pi,3*pi/2]
in foldr1 combineRooms $ map (\r -> shiftRoomBy ((V2 0 0), r) corner) [0,pi/2,pi,3*pi/2]
src/Dodge/Room/LongDoor.hs
+22 -22
View File
@@ -33,18 +33,18 @@ twinSlowDoorRoom
twinSlowDoorRoom drID w h x = defaultRoom
{ _rmPolys = ps
, _rmLinks =
[ ((w,h/2) , negate $ pi/2)
, ((-w,h/2) , pi/2)
, ((0,-h), pi)
[ ((V2 (w) (h/2)) , negate $ pi/2)
, ((V2 (-w) (h/2)) , pi/2)
, ((V2 (0) (-h)), pi)
]
, _rmPath = []
, _rmPS =
[ sPS (0,h/2) 0 putLamp
, sPS (25,5) 0 putLamp
, sPS (negate 25,5) 0 putLamp
, sPS (0,0) 0 $ PutDoor col (not . cond) drL
, sPS (0,0) 0 $ PutDoor col (not . cond) drR
, sPS (0,h-5) pi $ PutButton $ makeButton col
[ sPS (V2 (0) (h/2)) 0 putLamp
, sPS (V2 (25) (5)) 0 putLamp
, sPS (V2 (negate 25) (5)) 0 putLamp
, sPS (V2 0 0) 0 $ PutDoor col (not . cond) drL
, sPS (V2 0 0) 0 $ PutDoor col (not . cond) drR
, sPS (V2 (0) (h-5)) pi $ PutButton $ makeButton col
(over worldState (M.insert (DoorNumOpen drID) True))
]
, _rmBound = ps
@@ -54,9 +54,9 @@ twinSlowDoorRoom drID w h x = defaultRoom
[rectNSWE h (-2) (-w) w
,rectNSWE 20 (-h) (negate x) x
]
drL = fmap ((\h' -> ((x,-h'),(x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
drL = fmap ((\h' -> ((V2 (x) (-h')),(V2 (x) (h-h')))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
[0..nDrp]
drR = fmap ((\h' -> ((-x,-h'),(-x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
drR = fmap ((\h' -> ((V2 (-x) (-h')),(V2 (-x) (h-h')))) . (* h) . (/ fromIntegral nDrp) . fromIntegral)
[0..nDrp]
nDrp = ceiling h :: Int
cond w' = or $ M.lookup (DoorNumOpen drID) (_worldState w')
@@ -67,8 +67,8 @@ twinSlowDoorChasers
=> Int -- ^ Door id
-> State g Room
twinSlowDoorChasers drid = do
let lps = (-65 ,) <$> [20,40 .. 180]
rps = (65 ,) <$> [20,40 .. 180]
let lps = (V2 (-65)) <$> [20,40 .. 180]
rps = (V2 65) <$> [20,40 .. 180]
ps <- takeN 4 $ lps ++ rps
let plmnts = map (\p -> sPS p 0 $ PutCrit chaseCrit) ps
return $ twinSlowDoorRoom drid 80 200 40 & rmPS %~ (plmnts ++)
@@ -79,19 +79,19 @@ slowDoorRoom = do
y <- state $ randomR (400,800)
h <- state $ randomR (200,min (y-100) 500)
(butPos,butRot) <- takeOne
[( (x/2-50,5),0)
,( (x/2+50,5),0)
[( (V2 (x/2-50) (5)),0)
,( (V2 (x/2+50) (5)),0)
]
let n = 25
xs <- replicateM n $ state $ randomR (10,x-10)
ys <- replicateM n $ state $ randomR (h+20,y)
rs <- replicateM n $ state $ randomR (0,2*pi)
let ps = zip xs ys
let ps = zipWith V2 xs ys
xs' <- replicateM 5 $ state $ randomR (10,x-10)
ys' <- replicateM 5 $ state $ randomR (h+20,y)
let crits = zipWith (\p r -> sPS p r randC1) ps rs
lsources = [sPS (x/2,30) 0 putLamp, sPS (x/2,y-30) 0 putLamp]
barrels = zipWith (\x' y' -> sPS (x',y') 0 $ PutCrit explosiveBarrel) xs' ys'
lsources = [sPS (V2 (x/2) (30)) 0 putLamp, sPS (V2 (x/2) (y-30)) 0 putLamp]
barrels = zipWith (\x' y' -> sPS (V2 x' y') 0 $ PutCrit explosiveBarrel) xs' ys'
pillarsa = []
pillarsb = putBlockRect (x/5-20) (x/5+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/5-20) (2*x/5+20) (h/2-20) (h/2+20)
@@ -100,15 +100,15 @@ slowDoorRoom = do
pillarsc = putBlockRect (x/3-20) (x/3+20) (h/2-20) (h/2+20)
++ putBlockRect (2*x/3-20) (2*x/3+20) (h/2-20) (h/2+20)
pillars <- takeOne [pillarsa, pillarsb, pillarsc]
let cond x' = (snd . fst) x' > h + 40
cond2 x' = (snd . fst) x' < h - 40
but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h)
let cond x' = (sndV2 . fst) x' > h + 40
cond2 x' = (sndV2 . fst) x' < h - 40
but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (V2 0 h) (V2 x h)
-- ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h)
]
fmap connectRoom
(filterLinks cond =<<
changeLinkTo cond2
(set rmPS ([sPS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
(set rmPS ([sPS (V2 0 0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources)
$ roomRectAutoLinks x y
)
)
src/Dodge/Room/NoNeedWeapon.hs
+6 -5
View File
@@ -11,6 +11,7 @@ import Dodge.Room.Procedural
import Dodge.Room.Link
import Dodge.RandomHelp
import Dodge.LevelGen.Data
import Geometry.Data
import Control.Lens
--import Control.Monad
@@ -29,11 +30,11 @@ centerVaultExplosiveExit
centerVaultExplosiveExit drID = do
cr <- takeOne [miniGunCrit, autoCrit]
let extraPS =
[sPS (0,175) 0 $ PutCrit explosiveBarrel
,sPS (5,195) 0 $ PutCrit explosiveBarrel
,sPS (0,200) 0 $ PutCrit explosiveBarrel
,sPS (-4,195) 0 $ PutCrit explosiveBarrel
,sPS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
[sPS (V2 0 175) 0 $ PutCrit explosiveBarrel
,sPS (V2 5 195) 0 $ PutCrit explosiveBarrel
,sPS (V2 0 200) 0 $ PutCrit explosiveBarrel
,sPS (V2 (-4) (195)) 0 $ PutCrit explosiveBarrel
,sPS (V2 0 0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll)
]
r <- centerVaultRoom drID 200 200 50 <&> rmPS %~ (extraPS ++)
randomiseLinksBy shuffleTail r <&> rmLinks %~ take 2
src/Dodge/Room/Placement.hs
+18 -18
View File
@@ -28,7 +28,7 @@ Width 9, also extends out from each point by 9.
-}
blockLine :: Point2 -> Point2 -> Placement
blockLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
{ _psPos = (V2 0 0)
, _psRot = 0
, _psType = PutLineBlock baseBlockPane 9 9 a b
}
@@ -39,7 +39,7 @@ Width 8, also extends out from each point by 8.
-}
windowLine :: Point2 -> Point2 -> Placement
windowLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
{ _psPos = (V2 0 0)
, _psRot = 0
, _psType = PutLineBlock baseWindowPane 8 8 a b
}
@@ -50,7 +50,7 @@ Width 7, also extends out from each point by 7.
-}
crystalLine :: Point2 -> Point2 -> Placement
crystalLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
{ _psPos = (V2 0 0)
, _psRot = 0
, _psType = PutWall ps defaultCrystalWall
}
@@ -68,7 +68,7 @@ Depth 15, does not extend wider than points.
-}
wallLine :: Point2 -> Point2 -> Placement
wallLine a b = SinglePlacement $ PS
{ _psPos = (0,0)
{ _psPos = (V2 0 0)
, _psRot = 0
, _psType = PutWall ps defaultWall
}
@@ -87,7 +87,7 @@ windowLineType = PutLineBlock baseWindowPane 8 8
baseBlockPane :: Wall
baseBlockPane = Block
{ _wlLine = ((0,0),(50,0))
{ _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0
, _wlColor = greyN 0.5
, _wlSeen = False
@@ -100,7 +100,7 @@ baseBlockPane = Block
}
baseWindowPane :: Wall
baseWindowPane = Block
{ _wlLine = ((0,0),(50,0))
{ _wlLine = ((V2 0 0),(V2 50 0))
, _wlID = 0
, _wlColor = withAlpha 0.2 cyan
, _wlSeen = False
@@ -141,10 +141,10 @@ putBlockRect
-> Float
-> Float
-> [Placement]
putBlockRect a x b y = [ blockLine (a,b) (a,y)
, blockLine (a,y) (x,y)
, blockLine (x,y) (x,b)
, blockLine (x,b) (a,b)
putBlockRect a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 a y) (V2 x y)
, blockLine (V2 x y) (V2 x b)
, blockLine (V2 x b) (V2 a b)
]
putBlockV
:: Float
@@ -152,8 +152,8 @@ putBlockV
-> Float
-> Float
-> [Placement]
putBlockV a x b y = [ blockLine (a,b) (a,y)
, blockLine (x,b) (a,b)
putBlockV a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
]
putBlockC
:: Float
@@ -161,9 +161,9 @@ putBlockC
-> Float
-> Float
-> [Placement]
putBlockC a x b y = [ blockLine (a,b) (a,y)
, blockLine (x,b) (a,b)
, blockLine (a,y) (x,y)
putBlockC a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
, blockLine (V2 a y) (V2 x y)
]
putBlockN
:: Float
@@ -171,7 +171,7 @@ putBlockN
-> Float
-> Float
-> [Placement]
putBlockN a x b y = [ blockLine (a,b) (a,y)
, blockLine (x,b) (a,b)
, blockLine (x,y) (x,b)
putBlockN a x b y = [ blockLine (V2 a b) (V2 a y)
, blockLine (V2 x b) (V2 a b)
, blockLine (V2 x y) (V2 x b)
]
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))
]
src/Dodge/Room/RoadBlock.hs
+15 -15
View File
@@ -32,21 +32,21 @@ litCorridor90 = do
poly2 = rectNSWE (h-60) (h-100) (-60) 5
pure $ defaultRoom
{ _rmPolys = [poly,poly2]
, _rmLinks = [ ((40,h - 80), -pi/2)
, ((20, 0), pi)
, _rmLinks = [ ((V2 (40) (h - 80)), -pi/2)
, ((V2 (20) ( 0)), pi)
]
, _rmPath = concatMap doublePair
[((20,0),(20,h-40))
,(( 0,h-40),(20,h-40))
,((40,h-40),(20,h-40))
[((V2 20 0),(V2 (20) (h-40)))
,((V2 ( 0) (h-40)),(V2 (20) (h-40)))
,((V2 (40) (h-40)),(V2 (20) (h-40)))
]
, _rmPS =
[ sPS (20,h-5) 0 putLamp
, windowLine (0,h-20) (40,h-20)
, sPS (-50,h-85) 0 putLamp
, windowLine (-40,h-60) (-40,h-100)
, sPS ( 20,h-40) 0 $ PutID 0
, sPS (-20,h-80) 0 $ PutID 2
[ sPS (V2 (20) (h-5)) 0 putLamp
, windowLine (V2 (0) (h-20)) (V2 (40) (h-20))
, sPS (V2 (-50) (h-85)) 0 putLamp
, windowLine (V2 (-40) (h-60)) (V2 (-40) (h-100))
, sPS (V2 ( 20) (h-40)) 0 $ PutID 0
, sPS (V2 (-20) (h-80)) 0 $ PutID 2
]
, _rmBound = [poly]
}
@@ -60,9 +60,9 @@ longBlockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
longBlockedCorridor = do
r <- state $ randomR (0,pi)
n <- state $ randomR (0,3)
let plmnts = [sPS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
let plmnts = [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) (75/256) (0) (250/256))
$ reverse $ rectNSWE 10 (-10) (-10) 10
,sPS (20,15) 0 putLamp
,sPS (V2 20 15) 0 putLamp
]
sequence $ treeFromPost (replicate n $ Left <$> randomiseOutLinks corridor)
$ return $ Right $ set rmPS plmnts corridor
@@ -71,8 +71,8 @@ longBlockedCorridor = do
blockedCorridor :: RandomGen g => State g (Tree (Either Room Room))
blockedCorridor = do
r <- state $ randomR (0,pi)
let plmnts = [sPS (20,40) r $ PutBlock [5,5,5] (150/256, 75/256, 0, 250/256)
let plmnts = [sPS (V2 20 40) r $ PutBlock [5,5,5] (V4 (150/256) ( 75/256) ( 0) ( 250/256))
$ reverse $ rectNSWE 10 (-10) (-10) 10
,sPS (20,15) 0 putLamp
,sPS (V2 20 15) 0 putLamp
]
sequence $ treeFromPost [] $ return $ Right $ set rmPS plmnts corridor
src/Dodge/Room/Start.hs
+7 -7
View File
@@ -8,7 +8,7 @@ import Dodge.Room.Foreground
import Dodge.Layout.Tree.Polymorphic
import Dodge.LevelGen.Data
--import Picture
--import Geometry
import Geometry.Data
import Data.Tree
import Control.Monad.State
@@ -16,20 +16,20 @@ import Control.Lens
import System.Random
rezBox :: Room
rezBox = shiftRoomBy ((-20,-10),0) $ roomRect 40 20 1 1 & rmPS .~ []
rezBox = shiftRoomBy ((V2 (-20) (-10)),0) $ roomRect 40 20 1 1 & rmPS .~ []
startRoom :: RandomGen g => State g (Tree (Either Room Room))
startRoom = do
w <- state $ randomR (100,400)
h <- state $ randomR (200,400)
let fground = sPS (0,0) 0 $ PutForeground $
highPipe 80 (0,h/3) (w, h/2)
++ highPipe 40 (0,h/2) (w, h/3)
++ highPipe 60 (w/3,0) (w/3, h)
let fground = sPS (V2 0 0) 0 $ PutForeground $
highPipe 80 (V2 (0) (h/3)) (V2 (w) ( h/2))
++ highPipe 40 (V2 (0) (h/2)) (V2 (w) ( h/3))
++ highPipe 60 (V2 (w/3) (0)) (V2 (w/3) ( h))
-- ++ highPipe 20 (0,2*h/3) (w, h/3)
-- , girderV cola 10 (0,3*h/4) (w, 3*h/4)
-- , girder colb 5 (0,5*h/8) (w, 5*h/8)
treeFromPost [Left rezBox, Left door] . Right <$> randomiseOutLinks (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h & rmPS %~ (fground :))
treeFromPost [Left rezBox, Left door] . Right <$> randomiseOutLinks (shiftRoomBy ((V2 (-20) (-20)),0) $ roomRectAutoLinks w h & rmPS %~ (fground :))
-- where
-- cola = dark . dark . light . light $ light red
-- colb = dark . dark . light . light $ light blue
src/Dodge/Room/Teleport.hs
+3 -3
View File
@@ -28,13 +28,13 @@ telRoomLev i = do
w <- state $ randomR (200,300)
h <- state $ randomR (200,300)
return $ roomRectAutoLinks w h & rmPS .~
[ sPS (w/2,h/2) 0 $ PutPressPlate telPP
, sPS (w/2,h/2+ 30) 0 putLamp
[ sPS (V2 (w/2) (h/2)) 0 $ PutPressPlate telPP
, sPS (V2 (w/2) (h/2+ 30)) 0 putLamp
]
where
telPP = PressPlate
{ _ppPict = setDepth 0.5 . color red $ polygon ppFootprint
, _ppPos = (0,0)
, _ppPos = (V2 0 0)
, _ppRot = 0
, _ppEvent = levelReset
, _ppID = 0
src/Dodge/Room/Treasure.hs
+10 -10
View File
@@ -26,21 +26,21 @@ triLootRoom w h = pure $ defaultRoom
{ _rmPolys = [ tri
, base
]
, _rmLinks = [((0,-80),pi)]
, _rmPath = doublePair ((0,-80),(0,h/2))
, _rmLinks = [((V2 (0) (-80)),pi)]
, _rmPath = doublePair ((V2 (0) (-80)),(V2 (0) (h/2)))
, _rmPS =
[sPS (15-w, 15) 0 $ PutID 0
,sPS (w-15, 15) pi $ PutID 0
,sPS ( 0,h-35) 0 $ PutID 2
,sPS ( -5,h-10) 0 putLamp
,sPS ( 5,h-10) 0 putLamp
,sPS ( 0,h-15) 0 putLamp
,sPS ( 0, -60) 0 putLamp
[sPS (V2 (15-w) ( 15)) 0 $ PutID 0
,sPS (V2 (w-15) ( 15)) pi $ PutID 0
,sPS (V2 ( 0) (h-35)) 0 $ PutID 2
,sPS (V2 ( -5) (h-10)) 0 putLamp
,sPS (V2 ( 5) (h-10)) 0 putLamp
,sPS (V2 ( 0) (h-15)) 0 putLamp
,sPS (V2 ( 0) ( -60)) 0 putLamp
]
, _rmBound = [tri , base]
}
where
tri =
tri = map toV2
[ ( -w,30)
, ( -w, 0)
, ( w, 0)