Refactoring, add screen when generating level

This commit is contained in:
2021-05-03 14:44:27 +02:00
parent 2bf23db935
commit 6e6757499c
19 changed files with 342 additions and 118 deletions
+79 -9
View File
@@ -5,12 +5,17 @@ module Dodge.Room.Boss
where
import Dodge.Data
import Dodge.Room.Data
import Dodge.Room.Procedural
import Dodge.Room.Placement
import Dodge.Room.Link
import Dodge.Room.Corridor
import Dodge.LevelGen.Data
import Dodge.Creature
import Dodge.RandomHelp
import Dodge.Layout.Tree.Polymorphic
import Geometry
import Data.Tree
import Control.Monad.State
import Control.Lens
import System.Random
@@ -21,7 +26,10 @@ roomOctogon x = Room
{ _rmPolys = [rectNSWE x (-x) (-x) x
,rectNSWE 0 (-(x + 40)) (-20) 20
]
, _rmLinks = [((0,x),0),((0,-(x+40)),pi)]
, _rmLinks =
[((0,x),0)
,((0,-(x+40)),pi)
]
, _rmPath = [((0,x),(0,-(x+40)))
,((0,-(x+40)),(0,x))]
, _rmPS =
@@ -41,19 +49,26 @@ roomOctogon x = Room
fx = 4 * x / 5
bossRoom :: RandomGen g => Creature -> State g Room
--bossRoom cr = pure $ roomOctogon 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
bossRoom cr = pure $ roomCross 200 300 & rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
bossRoom cr = randomMediumRoom <&> rmPS %~ ( PS (0,100) (negate $ pi/2) (PutCrit cr) :)
armouredChasers :: RandomGen g => State g Room
armouredChasers :: RandomGen g => State g (Tree Room)
armouredChasers = do
ps <- takeN 5 [(x,y) | x <- [-200,-120 .. 200] ,y <- [-200,-120 .. 200] ]
ps <- takeN 5 [(x,y) | x <- [-100,-80 .. 100] ,y <- [-100,-80 .. 100] ]
as <- replicateM 5 . state $ randomR (0,2*pi)
let theCrits = zipWith3 (\p a c -> PS p a (PutCrit c)) ps as cs
pure $ roomOctogon 300 & rmPS %~ (++ theCrits)
treeFromPost [corridor,corridor] <$> (randomMediumRoom <&> rmPS %~ (++ theCrits))
where
cs = (armourChaseCrit & crState . crDropsOnDeath .~ DropSpecific [0])
: replicate 4 chaseCrit
randomMediumRoom :: RandomGen g => State g Room
randomMediumRoom = takeOne
[ roomOctogon 300
, roomCross 180 300
, roomShuriken 200 300
, roomTwistCross 230 300 (0)
]
roomCross
:: Float -- ^ First width/2
-> Float -- ^ Second width/2
@@ -62,7 +77,16 @@ roomCross x y = Room
{ _rmPolys = [rectNSWE y (-y) (-x) x
,rectNSWE (-x) x y (-y)
]
, _rmLinks = [((x,y-20),negate $ pi/2)]
, _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)
]
, _rmPath = []
, _rmPS =
[PS ( x, 0) 0 putLamp
@@ -70,6 +94,52 @@ roomCross x y = Room
,PS ( 0, x) 0 putLamp
,PS ( 0,-x) 0 putLamp
]
, _rmBound = [rectNSWE x (-x) (-x) x]
, _rmBound =
[rectNSWE y (-y) (-x) x
,rectNSWE x (-x) (-y) y
]
}
where
{- | TODO: pathing -}
roomShuriken
:: Float -- ^ First width/2
-> Float -- ^ Second width/2
-> Room
roomShuriken x y =
let ps = [
[ (0,-20)
, (x,-20)
, (x,y)
, (0,x)
] ]
corner = Room
{ _rmPolys = ps
, _rmLinks = [((x-1,y-20),negate $ pi/2)]
, _rmPath = []
, _rmPS = [PS (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]
{- | TODO: pathing
Precondition: first float is less than the second by at least 40. -}
roomTwistCross
:: Float -- ^ First width/2,
-> Float -- ^ Second width/2, should be biggest
-> Float -- ^ Third width, should be smallest, possibly negative
-> Room
roomTwistCross x y z =
let ps = [ [ (x,negate $ z+20)
, (x,x)
, (z,y)
, (z-20,x)
, (z,negate $ z+20)
]
, rectNSWE (x-5) 0 0 (x-5)
]
corner = Room
{ _rmPolys = ps
, _rmLinks = [((z,y-20), pi/2)]
, _rmPath = []
, _rmPS = [PS (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]