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

Add procedural room made up of four corners

Browse Source
This commit is contained in:
jgk
2021-04-24 15:40:10 +02:00
parent 108b66f3ad
commit aa08d66026
5 changed files with 136 additions and 27 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Creature/Inanimate.hs
+2 -1
View File
@@ -22,7 +22,8 @@ lamp :: Creature
lamp = defaultInanimate
{ _crUpdate = initialiseLamp
, _crHP = 500
, _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 10
, _crPict = \ _ -> onLayer CrLayer $ color white $ circleSolid 5
, _crRad = 5
}
initialiseLamp :: CRUpdate
src/Dodge/Floor.hs
+1 -1
View File
@@ -32,7 +32,7 @@ roomTreex :: RandomGen g => State g (Maybe [Room])
roomTreex = do
struct' <- aTreeStrut
-- let struct = treePost [[SpecificRoom $ fmap (pure . Right) pistolerRoom]] [EndRoom]
let struct = treePost [[SpecificRoom $ fmap (pure . Right) $ pure testRoom]] [EndRoom]
let struct = treePost [[SpecificRoom $ fmap (pure . Right) testRoom]] [EndRoom]
let t' = padCorridors struct
t = treeTrunk
[[StartRoom]
src/Dodge/RandomHelp.hs
+11 -6
View File
@@ -1,5 +1,7 @@
{-
Helpers for random generation.
-}
module Dodge.RandomHelp where
import Geometry
import Geometry.Data
@@ -9,8 +11,9 @@ import Data.List
randomRanges :: (Random a,RandomGen g) => [a] -> State g a
randomRanges xs = join $ takeOne $ f xs
where f (x:y:ys) = (state (randomR (x,y))) : (f ys)
f _ = []
where
f (x:y:ys) = (state (randomR (x,y))) : (f ys)
f _ = []
takeOne :: RandomGen g => [a] -> State g a
takeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (xs !! i))
@@ -18,9 +21,11 @@ takeOne xs = state (randomR (0,length xs - 1)) >>= (\i -> return (xs !! i))
takeOneWeighted :: (RandomGen g, Random b, Ord b, Num b) => [b] -> [a] -> State g a
takeOneWeighted ws xs = state (randomR (0, sum ws))
>>= (\w -> return (xs !! (i w ws)))
where i y (z:zs) | y <= z = 0
| otherwise = 1 + i (y-z) zs
i y _ = 0
where
i y (z:zs)
| y <= z = 0
| otherwise = 1 + i (y-z) zs
i y _ = 0
takeOneMore :: RandomGen g => ([a],[a]) -> State g ([a],[a])
takeOneMore (xs,[]) = error "trying to takeOneMore from empty list"
src/Dodge/Room.hs
+2 -2
View File
@@ -128,8 +128,8 @@ roomPillars :: Room
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
where
plmnts = PS (120,120) 0 putLamp
: PS (10,10) 0 putLamp
: PS (230,230) 0 putLamp
: PS (12,12) 0 putLamp
: PS (228,228) 0 putLamp
: g 180 150 90 60
f a x b y = putBlockRect a x b y
g a b c d = f a b a b ++ f a b c d ++ f c d a b ++ f c d c d
src/Dodge/Room/Procedural.hs
+120 -17
View File
@@ -9,14 +9,18 @@ module Dodge.Room.Procedural
import Dodge.Room.Data
import Dodge.Room.Placement
import Dodge.Room.Link
import Dodge.RandomHelp
import Dodge.LevelGen
import Dodge.LevelGen.Data
import Dodge.Creature
import Geometry
import Data.List (nub,nubBy,sortBy)
import Data.Function (on)
--import Control.Monad.State
--import System.Random
import Control.Lens
import Control.Monad
import Control.Monad.State
import System.Random
{-
A simple rectangular room with a light in the center.
Creates links and pathfinding graph.
@@ -82,21 +86,120 @@ combineRooms r r' = Room
, _rmBound = convexHull . nubBy (\a b -> dist a b < 5) $ _rmBound r ++ _rmBound r'
}
northSegment :: Room
northSegment = Room
{ _rmPolys = [ [(0,0),(200,200),(-200,200)] ]
, _rmLinks = [((0,200), 0)]
, _rmPath = [((0,200),(0,0)),((0,0),(0,200))]
, _rmPS = [PS (0,100) 0 putLamp]
, _rmBound = [(200,200),(-200,200)]
--, _rmBound = []
{-
The top fourth of a room of a given height.
-}
fourth
:: Float -- ^ Distance from center of room to top edge
-> Room
fourth w = Room
{ _rmPolys = [ [(0,0),(w,w),(-w,w)] ]
, _rmLinks = [((0,w), 0)]
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
, _rmPS =
[PS (0,w/2) 0 putLamp
]
, _rmBound = [(w,w),(-w,w)]
}
testRoom :: Room
testRoom = foldr1 combineRooms $ map (\a -> shiftRoomBy ((0,0),a) northSegment) [0,pi/2,pi,3*pi/2]
{-
Randomly generate a top fourth of a room possibly with a wall.
Add a light and a 'PutNothing' placement.
-}
fourthWall :: RandomGen g => Float -> State g Room
fourthWall w = do
b <- takeOne
--[ [ PS (20-w,w-40) 0 putLamp
-- , PS (w-20,w-40) pi PutNothing
-- ]
-- [ [ PS (20-w,w-40) 0 putLamp
-- , PS (0,40) 0 putLamp
-- , PS (w-20,w-40) pi PutNothing
-- , blockLine (w/2,w) (negate $ w/2,w/2)
-- ]
[ [ PS (20-w,w-40) 0 putLamp
, PS (0,40) 0 putLamp
, PS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (w/2,w)
]
, [ PS (20-w,w-40) 0 putLamp
, PS (0,40) 0 putLamp
, PS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (negate $ w/2,w/2)
]
, [ PS (20-w,w-40) 0 putLamp
, PS (0,20) 0 putLamp
, PS (w-20,w-20) pi PutNothing
, blockLine (w/2,w/2) (0,w/2)
, blockLine (-29,w) (0,w/2)
]
]
pure $ Room
{ _rmPolys = [ [(0,0),(w,w),(-w,w)] ]
, _rmLinks = [((0,w), 0)]
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
, _rmPS = b
, _rmBound = [(w,w),(-w,w)]
}
fourthCorner :: Float -> Room
fourthCorner w = Room
{ _rmPolys = [ [(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)
]
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
, _rmPS = [PS (0,w) 0 putLamp]
, _rmBound = [(w,w),(0,2*w),(-w,w)]
}
fourthCornerWall :: RandomGen g => Float -> State g Room
fourthCornerWall w = do
let l = w/2 - 30
b <- takeOne
[ [blockLine (5,5) (w-50,w-50)
,PS (0,w) 0 putLamp
,PS (0,w-30) 0 PutNothing
]
, [blockLine (0,5) (0,2*w-60)
,PS (-50,w) 0 putLamp
,PS (50,w) 0 PutNothing
]
, [blockLine (50,50) (w,w)
,PS (0,w) 0 putLamp
,PS (w-40,w) (pi/4) PutNothing
]
, [blockLine (40-l,l+40) (w-l,l+w)
,PS (0,w) 0 putLamp
,PS (w-40,0) (pi/8) PutNothing
]
]
pure $ Room
{ _rmPolys = [ [(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)
]
, _rmPath = [((0,w),(0,0)),((0,0),(0,w))]
, _rmPS = b
, _rmBound = [(w,w),(0,2*w),(-w,w)]
}
fillNothingPlacement :: PSType -> Room -> Room
fillNothingPlacement pst r =
r & rmPS %~ replaceNothingWith pst
where
replaceNothingWith x (PS p rot PutNothing: pss) = PS p rot x : pss
replaceNothingWith x (ps:pss) = ps : replaceNothingWith x pss
replaceNothingWith _ [] = []
testRoom :: RandomGen g => State g Room
testRoom = do
corners <- replicateM 4 . join $ takeOne [fourthWall 100] --, fourthCornerWall 100]
-- corners <- replicateM 4 (fourthCornerWall 100)
randomiseAllLinks
. fillNothingPlacement (PutCrit chaseCrit)
. foldr1 combineRooms
$ zipWith (\r a -> shiftRoomBy ((0,0),a) r) corners [0,pi/2,pi,3*pi/2]
---- -- -{- Combines multiple rooms into one room.
---- -- -Combines into one big poly and one big bound, and concatenates the rest.
---- -- --}
---- -- -combineRooms :: [Room] -> Room
---- -- -combineRooms rs = foldr f