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

Tweak wall cutting, removes inverse walls

Browse Source
This commit is contained in:
jgk
2021-04-23 21:17:37 +02:00
parent 4c611ba4aa
commit 108b66f3ad
7 changed files with 289 additions and 121 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Floor.hs
+2 -1
View File
@@ -31,7 +31,8 @@ import System.Random
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) pistolerRoom]] [EndRoom]
let struct = treePost [[SpecificRoom $ fmap (pure . Right) $ pure testRoom]] [EndRoom]
let t' = padCorridors struct
t = treeTrunk
[[StartRoom]
src/Dodge/Item/Weapon/TriggerType.hs
+194 -98
View File
@@ -1,3 +1,6 @@
{-
Weapon effects when pulling the trigger.
-}
module Dodge.Item.Weapon.TriggerType
where
import Dodge.Data
@@ -6,20 +9,20 @@ import Dodge.CreatureAction (reloadWeapon)
import Dodge.WorldEvent (muzzleFlashAt,tempLightForAt)
import Dodge.WorldEvent.Cloud
import Dodge.RandomHelp
import Dodge.Item.Weapon.Bullet
import Geometry
import System.Random
import Control.Lens
import Control.Monad.State
import Data.Maybe
import qualified Data.IntMap.Strict as IM
withThinSmoke :: (Int -> World -> World) -> Int -> World -> World
withThinSmoke
:: (Int -> World -> World) -- ^ Underlying effect
-> Int -- ^ Creature id
-> World
-> World
withThinSmoke eff cid w = eff cid . foldr makeThinSmokeAt w $ map (+.+ pos) ps
where
cr = _creatures w IM.! cid
@@ -27,7 +30,11 @@ withThinSmoke eff cid w = eff cid . foldr makeThinSmokeAt w $ map (+.+ pos) ps
pos = _crPos cr +.+ ((_crRad cr +0.5) *.* unitVectorAtAngle dir)
ps = (sequence . replicate 5 . randInCirc) 8 & evalState $ _randGen w
withThickSmoke :: (Int -> World -> World) -> Int -> World -> World
withThickSmoke
:: (Int -> World -> World) -- ^ Underlying effect
-> Int -- ^ Creature id
-> World
-> World
withThickSmoke eff cid w = eff cid . foldr makeThickSmokeAt w $ map (+.+ pos) ps
where
cr = _creatures w IM.! cid
@@ -35,27 +42,35 @@ withThickSmoke eff cid w = eff cid . foldr makeThickSmokeAt w $ map (+.+ pos) ps
pos = _crPos cr +.+ ((_crRad cr +15) *.* unitVectorAtAngle dir)
ps = (sequence . replicate 20 . randInCirc) 8 & evalState $ _randGen w
withWarmUp :: Int -> (Int -> World -> World) -> Int -> World -> World
{- Shoot a weapon rapidly after a warm up.
Applies ammo check as well.
-}
withWarmUp
:: Int -- ^ Warm up time (in frames)
-> (Int -> World -> World)
-- ^ Shoot effect
-> Int -- ^ Creature id
-> World
-> World
withWarmUp t f cid w
| reloadCondition = fromMaybe w $ reloadWeapon cid w
| _wpReloadState item /= 0 = w
| fState == 0 = set (pointerToItem . wpFire) (withWarmUp 100 f)
$ set (pointerToItem . wpFireState) 2
w
| t > 2 = set (pointerToItem . wpFire) (withWarmUp (t-1) f)
$ set (pointerToItem . wpFireState) 2
$ soundFrom (CrWeaponSound cid) 26 2 0
w
| t > 0 = set (pointerToItem . wpFire) (withWarmUp (t-1) f)
$ set (pointerToItem . wpFireState) 2
w
| otherwise = set (pointerToItem . wpFire) (withWarmUp 1 f)
$ over (pointerToItem . wpLoadedAmmo) (\ammo -> ammo-1)
$ set (pointerToItem . wpFireState) 2
$ f cid
$ soundFrom (CrWeaponSound cid) 28 2 0
w
| reloadCondition = fromMaybe w $ reloadWeapon cid w
| _wpReloadState item /= 0 = w
| fState == 0 = set (pointerToItem . wpFire) (withWarmUp 100 f)
$ set (pointerToItem . wpFireState) 2
w
| t > 2 = set (pointerToItem . wpFire) (withWarmUp (t-1) f)
$ set (pointerToItem . wpFireState) 2
$ soundFrom (CrWeaponSound cid) 26 2 0
w
| t > 0 = set (pointerToItem . wpFire) (withWarmUp (t-1) f)
$ set (pointerToItem . wpFireState) 2
w
| otherwise = set (pointerToItem . wpFire) (withWarmUp 1 f)
$ over (pointerToItem . wpLoadedAmmo) (\ammo -> ammo-1)
$ set (pointerToItem . wpFireState) 2
$ f cid
$ soundFrom (CrWeaponSound cid) 28 2 0
w
where
cr = _creatures w IM.! cid
itRef = _crInvSel cr
@@ -65,7 +80,13 @@ withWarmUp t f cid w
fRate = _wpFireRate item
reloadCondition = _wpLoadedAmmo item == 0
withSound :: Int -> (Int -> World -> World) -> Int -> World -> World
{- Adds a sound to a creature based world effect.
The sound is emitted from the creature's position. -}
withSound
:: Int -- ^ Sound id
-> (Int -> World -> World) -- ^ Underlying effect
-> Int -- ^ Creature id
-> World -> World
withSound soundid f cid w = (soundOncePos soundid p . f cid) w
where
p = _crPos (_creatures w IM.! cid)
@@ -79,6 +100,7 @@ withRecoil
withRecoil recoilAmount eff cid w = eff cid . over (creatures . ix cid) pushback $ w
where
pushback cr = over crPos (+.+ rotateV (_crDir cr) ((-recoilAmount) / _crMass cr ,0)) cr
withSidePush
:: Float -- ^ Maximal possible side push amount
-> (Int -> World -> World)
@@ -91,7 +113,7 @@ withSidePush maxSide eff cid w = eff cid . over (creatures . ix cid) push $ w
(pushAmount, _) = randomR (-maxSide,maxSide) $ _randGen w
{-
Applies an effect and sound with an ammo check.
Applies a world effect and sound effect after an ammo check.
-}
shootWithSound
:: Int -- ^ Sound identifier
@@ -115,21 +137,26 @@ shootWithSound soundid f cid w
&& _wpFireState item == 0
&& _wpLoadedAmmo item > 0
reloadCondition = _wpLoadedAmmo item == 0
shoot :: (Int -> World -> World) -> Int -> World -> World
{- Applies a world effect after an ammo check. -}
shoot
:: (Int -> World -> World)
-- ^ Underlying effect, takes creature id as input
-> Int -- ^ Creature id
-> World -> World
shoot f cid w | fireCondition = over (pointerToItem . wpLoadedAmmo) (\ammo -> ammo-1)
$ set (pointerToItem . wpFireState) (_wpFireRate item)
$ f cid w
| reloadCondition = fromMaybe w $ reloadWeapon cid w
| otherwise = w
where cr = (_creatures w IM.! cid)
itRef = _crInvSel cr
item = _crInv cr IM.! itRef
pointerToItem = creatures . ix cid . crInv . ix itRef
fireCondition = _wpReloadState item == 0
&& _wpFireState item == 0
&& _wpLoadedAmmo item > 0
reloadCondition = _wpLoadedAmmo item == 0
where
cr = (_creatures w IM.! cid)
itRef = _crInvSel cr
item = _crInv cr IM.! itRef
pointerToItem = creatures . ix cid . crInv . ix itRef
fireCondition = _wpReloadState item == 0
&& _wpFireState item == 0
&& _wpLoadedAmmo item > 0
reloadCondition = _wpLoadedAmmo item == 0
withMuzFlare :: (Int -> World -> World) -> Int -> World -> World
withMuzFlare f cid w = tempLightForAt 3 pos
@@ -139,87 +166,156 @@ withMuzFlare f cid w = tempLightForAt 3 pos
pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
withRandomDir :: Float -> (Int -> World -> World) -> Int -> World -> World
{-
Rotates the creature randomly, applies the effect, rotates the creature back.
-}
withRandomDir
:: Float -- ^ Max possible rotation
-> (Int -> World -> World)
-- ^ Underlying effect
-> Int -- ^ Creature id
-> World
-> World
withRandomDir acc f cid w = over (creatures . ix cid . crDir) (\d -> d - a)
. f cid
. over (creatures . ix cid . crDir) (+ a)
$ set randGen g
w
where (a, g) = randomR (-acc,acc) $ _randGen w
withVelWthHiteff :: Point2 -> Float -> HitEffect -> Int -> World -> World
{- Creates a bullet with a given velocity, width, and 'HitEffect'
-}
withVelWthHiteff
:: Point2 -- ^ Velocity, x direction is forward with respect to the creature
-> Float -- ^ Bullet width
-> HitEffect -- ^ Bullet effect when hitting creature, wall etc
-> Int -- ^ Creature id
-> World
-> World
withVelWthHiteff vel width hiteff cid w
= over particles' ((:) newbul)
= over particles' ((:) newbul) $ set randGen g w
where
cr = _creatures w IM.! cid
newbul = aGenBulAt' (Just cid) (numColor colid) pos (rotateV dir vel) hiteff width
(colid, g) = randomR (0,11) $ _randGen w
dir = _crDir cr
pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
{- Translate the creature sideways a random amount, apply the effect, translate back. -}
withRandomOffset
:: Float -- ^ Max possible translate
-> (Int -> World -> World)
-- ^ Underlying effect
-> Int -- ^ Creature id
-> World
-> World
withRandomOffset offsetAmount f cid w
= over (creatures . ix cid . crPos) (-.- offV)
. f cid
. over (creatures . ix cid . crPos) (+.+ offV)
$ set randGen g
w
where cr = _creatures w IM.! cid
newbul = aGenBulAt' (Just cid) (numColor colid) pos (rotateV dir vel) hiteff width
(colid, g) = randomR (0,11) $ _randGen w
dir = _crDir cr
pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr)
pos2 = _crPos cr +.+ (2 * _crRad cr) *.* unitVectorAtAngle (_crDir cr)
w
where
(offsetVal , g) = randomR (-offsetAmount,offsetAmount) $ _randGen w
cr = _creatures w IM.! cid
offV = rotateV (_crDir cr) (0,offsetVal)
withRandomOffset :: Float -> (Int -> World -> World) -> Int -> World -> World
withRandomOffset offsetAmount f cid w = over (creatures . ix cid . crPos) (-.- offV)
. f cid
. over (creatures . ix cid . crPos) (+.+ offV)
$ set randGen g
w
where (offsetVal , g) = randomR (-offsetAmount,offsetAmount) $ _randGen w
cr = _creatures w IM.! cid
offV = rotateV (_crDir cr) (0,offsetVal)
torqueBeforeForced :: Float -> (Int -> World -> World) -> Int -> World -> World
-- | Rotates a creature with minimum rotation at least 0.1.
-- Rotates the player creature before applying the effect, other creatures after.
torqueBeforeForced
:: Float -- ^ Max possible rotation (less the 0.1 forced rotation)
-> (Int -> World -> World)
-- ^ Underlying effect
-> Int -- ^ Creature id
-> World
-> World
torqueBeforeForced torque feff cid w
| cid == 0 = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot')
$ over cameraRot (+rot') w
| otherwise = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot') w
where (rot, g) = randomR (-torque,torque) $ _randGen w
rot' | rot < 0 = rot - 0.1
| otherwise = rot + 0.1
where
(rot, g) = randomR (-torque,torque) $ _randGen w
rot' | rot < 0 = rot - 0.1
| otherwise = rot + 0.1
torqueBefore :: Float -> (Int -> World -> World) -> Int -> World -> World
-- | Rotates the player creature before applying an effect, other creatures after.
torqueBefore
:: Float -- ^ Max possible rotation
-> (Int -> World -> World)
-- ^ Underlying effect
-> Int
-- ^ Creature id
-> World
-> World
torqueBefore torque feff cid w
| cid == 0 = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot)
$ over cameraRot (+rot) w
| otherwise = feff cid $ set randGen g $ over (creatures . ix cid . crDir) (+rot) w
where (rot, g) = randomR (-torque,torque) $ _randGen w
torqueAfter :: Float -> (Int -> World -> World) -> Int -> World -> World
where
(rot, g) = randomR (-torque,torque) $ _randGen w
-- | Rotate a randomly creature after applying an effect.
torqueAfter
:: Float -- ^ Max possible rotation
-> (Int -> World -> World)
-- ^ Underlying effect
-> Int
-- ^ Creature id
-> World
-> World
torqueAfter torque feff cid w
| cid == 0 = rotateScope $ set randGen g $ over cameraRot (+rot) $ feff cid w
| otherwise = set randGen g $ over (creatures . ix cid . crDir) (+rot) $ feff cid w
where (rot, g) = randomR (-torque,torque) $ _randGen w
rotateScope w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just . scopePos %~ rotateV rot
spreadNumVelWthHiteff :: Float -> Int -> Point2 -> Float -> HitEffect -> Int -> World -> World
where
(rot, g) = randomR (-torque,torque) $ _randGen w
rotateScope w = w & creatures . ix 0 . crInv . ix (_crInvSel (_creatures w IM.! 0))
. itAttachment . _Just . scopePos %~ rotateV rot
{- Create multiple bullets with a given spread, a given amount, given velocity,
given width and given 'HitEffect'.
-}
spreadNumVelWthHiteff
:: Float -- ^ Spread
-> Int -- ^ Number of bullets
-> Point2 -- ^ Velocity, x is direction of creature
-> Float -- ^ Bullet width
-> HitEffect -- ^ Effect when hitting creature, wall etc
-> Int -- ^ Creature id
-> World
-> World
spreadNumVelWthHiteff spread num vel wth eff cid w
= over particles' (newbuls ++)
w
where cr = _creatures w IM.! cid
newbuls = zipWith3 (\pos d colid -> aGenBulAt' (Just cid) (numColor colid)
pos (rotateV d vel) eff wth
) poss dirs colids
poss = map ((+.+) $ _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr))
$ evalState ((sequence . take num . repeat . randInCirc) 5) $ _randGen w
dirs = map ((+) (_crDir cr))
$ zipWith (+) [-spread,-spread+(2*spread/(fromIntegral num))..]
$ randomRs (0,spread/5) (_randGen w)
colids = take num $ randomRs (0,11) (_randGen w)
= over particles' (newbuls ++) w
where
cr = _creatures w IM.! cid
newbuls = zipWith3 (\pos d colid -> aGenBulAt' (Just cid) (numColor colid)
pos (rotateV d vel) eff wth
) poss dirs colids
poss = map ((+.+) $ _crPos cr +.+ _crRad cr *.* unitVectorAtAngle (_crDir cr))
$ evalState ((sequence . take num . repeat . randInCirc) 5) $ _randGen w
dirs = map ((+) (_crDir cr))
$ zipWith (+) [-spread,-spread+(2*spread/(fromIntegral num))..]
$ randomRs (0,spread/5) (_randGen w)
colids = take num $ randomRs (0,11) (_randGen w)
numVelWthHitEff :: Int -> Point2 -> Float -> HitEffect -> Int -> World -> World
{- Create a number of bullets side by side with a given velocity,
given width and given 'HitEffect'.
-}
numVelWthHitEff
:: Int -- ^ Amount of bullets
-> Point2 -- ^ Velocity, x axis is direction of creature
-> Float -- ^ Bullet width
-> HitEffect -- ^ Effect when hitting creature, wall etc
-> Int -- ^ Creature id
-> World
-> World
numVelWthHitEff num vel wth eff cid w
= over particles' (newbuls ++)
w
where cr = _creatures w IM.! cid
newbuls = zipWith (\pos colid -> aGenBulAt' (Just cid) (numColor colid)
pos (rotateV d vel) eff wth
)
poss colids
d = _crDir cr
poss = map (\o -> o +.+ pos) offsets
maxOffset = fromIntegral num * 2.5 - 2.5
offsets = map (\y -> rotateV d (0,y)) [-maxOffset,5-maxOffset..]
colids = take num $ randomRs (0,11) (_randGen w)
pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle d
= over particles' (newbuls ++) w
where
cr = _creatures w IM.! cid
newbuls = zipWith (\pos colid -> aGenBulAt' (Just cid) (numColor colid)
pos (rotateV d vel) eff wth
)
poss colids
d = _crDir cr
poss = map (\o -> o +.+ pos) offsets
maxOffset = fromIntegral num * 2.5 - 2.5
offsets = map (\y -> rotateV d (0,y)) [-maxOffset,5-maxOffset..]
colids = take num $ randomRs (0,11) (_randGen w)
pos = _crPos cr +.+ _crRad cr *.* unitVectorAtAngle d
src/Dodge/Layout.hs
+4 -1
View File
@@ -5,6 +5,7 @@ module Dodge.Layout
where
import Dodge.Data
import Dodge.LevelGen
import Dodge.LevelGen.StaticWalls
import Dodge.LevelGen.Data
import Dodge.Base
import Dodge.RandomHelp
@@ -77,6 +78,7 @@ wallsFromTree t =
-- createInnerWalls
divideWalls
. assignKeys
. removeInverseWalls
. foldr cutWalls [] -- map (map (g . roundPoint2))
-- . map (map roundPoint2)
$ (concatMap _rmPolys $ flatten t)
@@ -88,7 +90,8 @@ wallsFromTree t =
wallsFromRooms :: [Room] -> IM.IntMap Wall
wallsFromRooms =
-- divideWalls .
IM.fromList . zip [0..] . zipWith f [0..] . foldr cutWalls [] . concatMap _rmPolys
IM.fromList . zip [0..] . zipWith f [0..] . removeInverseWalls
. foldr cutWalls [] . concatMap _rmPolys
where
f i (x,y) = defaultWall {_wlLine = [x,y] , _wlID = i}
src/Dodge/LevelGen/StaticWalls.hs
+20 -4
View File
@@ -7,22 +7,38 @@ module Dodge.LevelGen.StaticWalls
import Dodge.Data
import Dodge.Base
import Dodge.Default
import Geometry
import Control.Lens
import Data.Function (on)
import Data.Graph
import Data.List
import Data.Maybe
import qualified Data.IntMap as IM
import qualified Data.Set as S
type WallP = (Point2,Point2)
-- | Test whether lines are near parallel.
-- Assumes non-zero length lines.
nearParallel :: WallP -> WallP -> Bool
nearParallel (a,b) (x,y)
= dotV (a -.- b) (vNormal (x -.- y)) < 0.01
-- | Test for near collinearity.
-- Assumes non-zero length lines.
nearCollinear :: WallP -> WallP -> Bool
nearCollinear (a,b) (x,y)
| a /= x = nearParallel (a,b) (x,y) && nearParallel (a,b) (a,x)
| otherwise = nearParallel (a,b) (x,y) && nearParallel (a,b) (a,y)
-- | Remove inverse walls.
removeInverseWalls :: [WallP] -> [WallP]
removeInverseWalls ((a,b):ps)
| elem (b,a) ps = removeInverseWalls $ delete (b,a) ps
| otherwise = (a,b) : (removeInverseWalls ps)
removeInverseWalls ps = ps
-- | Cut out a polygon from a set of walls, and check for errors in the
-- created walls.
-- If created walls are not consistent, expand poly and retry.
src/Dodge/Room.hs
+11 -11
View File
@@ -125,7 +125,7 @@ door = Room
,((20, 5),pi)
]
roomPillars :: Room
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect' 240 240 2 2
roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2
where
plmnts = PS (120,120) 0 putLamp
: PS (10,10) 0 putLamp
@@ -171,7 +171,7 @@ glassSwitchBack = do
,blockLine (wth-wllen, 4*hf) ( wth,4*hf)
, PS (wth/2,hgt/2) 0 $ putLamp
]
return $ set rmPS plmnts $ roomRect' wth hgt 2 6
return $ set rmPS plmnts $ roomRect wth hgt 2 6
manyDoors :: Int -> Tree (Either Room Room)
manyDoors i = treePost (replicate i (Left door)) $ Right door
@@ -182,9 +182,9 @@ glassLesson = do
return $ Node (Left $ botRoom) [deadRoom door,uppers, treePost (Left door : corridors) $ Right door]
where uppers = Node (Left door) [deadRoom topRoom]
botRoom = set rmPS botplmnts
$ roomRect' 200 200 1 1
$ roomRect 200 200 1 1
topRoom = set rmPS topplmnts
$ roomRect' 200 200 1 1
$ roomRect 200 200 1 1
botplmnts = [PS (0,0) 0 $ PutWindow (rectNSWE (200) 0 (90) (110))
$ withAlpha 0.5 aquamarine
,PS (50,100) 0 $ PutCrit miniGunCrit
@@ -218,7 +218,7 @@ miniRoom1 = do
,blockLine ( 0, 40+3*hf) (wllen,40+3*hf)
,blockLine (wth-wllen, 40+4*hf) ( wth,40+4*hf)
]
return $ set rmPS plmnts $ shiftRoomBy ((0,40),0) $ roomRect' wth hgt 2 4
return $ set rmPS plmnts $ shiftRoomBy ((0,40),0) $ roomRect wth hgt 2 4
miniTree2 :: RandomGen g => State g (Tree (Either Room Room))
miniTree2 = miniRoom1 >>= randomiseOutLinks >>= changeLinkTo (\p -> (snd . fst) p < 70)
@@ -277,7 +277,7 @@ roomMiniIntro = fmap (g . expandTreeBy f) $ sequence $ treePost
roomCenterPillar :: RandomGen g => State g Room
roomCenterPillar = changeLinkTo ((\p -> dist p (120,0) < 10) . fst)
$ set rmPS plmnts $ roomRect' 240 240 2 2
$ set rmPS plmnts $ roomRect 240 240 2 2
where plmnts = [ blockLine (115,115) (115,125)
, blockLine (125,115) (125,125)
, PS (40,120) 0 putLamp
@@ -342,7 +342,7 @@ weaponEmptyRoom = do
,PS (w/2,h/2) 0 $ putLamp
]
(fmap connectRoom . randomiseOutLinks) =<< (changeLinkTo ((\p -> dist p (w/2,0) < 10) . fst)
$ set rmPS plmnts $ roomRect' w h 2 2)
$ set rmPS plmnts $ roomRect w h 2 2)
weaponUnderCrits :: RandomGen g => State g (Tree (Either Room Room))
@@ -520,7 +520,7 @@ longRoom = do
]
brls <- fmap (map (\p -> PS (p +.+ (10,200)) 0 $ PutCrit explosiveBarrel) )
$ sequence $ replicate 5 $ randInRect (w-20) 900
let rm = roomRect' w (h+70) 1 1 & rmPolys %~ ( (++)
let rm = roomRect w (h+70) 1 1 & rmPolys %~ ( (++)
[rectNSWE h (h-165) (-45) (w+45)
]
)
@@ -548,7 +548,7 @@ shooterRoom = do
,PS ( 75,h-80) 0 putLamp
]
)
$ roomRect' 100 h 1 1
$ roomRect 100 h 1 1
shootersRoom1 :: RandomGen g => State g Room
@@ -628,7 +628,7 @@ pistolerRoom = do
++
concat [f x y | x<-xs,y<-ys]
return
$ set rmPS plmnts $ roomRect' w h (max i 2) (max i 2)
$ set rmPS plmnts $ roomRect w h (max i 2) (max i 2)
shootingRange :: RandomGen g => State g (Tree (Either Room Room))
shootingRange = do
@@ -658,5 +658,5 @@ spawnerRoom = do
,PS (x/2, y-10) 0 putLamp
]
let f ((lx,_),_) = lx < x/2-5
roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect' x y 2 2)
roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2)
return $ treeTrunk [Left (airlock 0)] roomWithSpawner
src/Dodge/Room/Procedural.hs
+45 -6
View File
@@ -1,12 +1,19 @@
{-
Procedural creation of rooms.
-}
module Dodge.Room.Procedural
where
( roomRect
, roomRectAutoLinks
, testRoom
) where
import Dodge.Room.Data
import Dodge.Room.Placement
import Dodge.Room.Link
import Dodge.LevelGen
import Dodge.LevelGen.Data
import Geometry
import Data.List (nub,sortBy)
import Data.List (nub,nubBy,sortBy)
import Data.Function (on)
--import Control.Monad.State
--import System.Random
@@ -14,13 +21,13 @@ import Data.Function (on)
A simple rectangular room with a light in the center.
Creates links and pathfinding graph.
-}
roomRect'
roomRect
:: Float -- ^ Width
-> Float -- ^ Height
-> Int -- ^ Number of links on vertical walls
-> Int -- ^ Number of links on horizontal walls
-> Room
roomRect' x y xn yn = Room
roomRect x y xn yn = Room
{ _rmPolys = [rectNSWE y 0 0 x ]
, _rmLinks = lnks
, _rmPath = concatMap doublePair pth
@@ -36,9 +43,11 @@ roomRect' x y xn yn = Room
slnks = flip zip (repeat ( pi)) $ translateS (20,0) $ gridPoints xd (xn+1) 0 1
lnks = nlnks ++ elnks ++ wlnks ++ slnks
pth = linksAndPath lnks $ translateS (20,20) (makeGrid xd xn yd yn)
{-
Creates a rectangular room, automatically creates links and pathfinding graph at a sensible size.
-}
roomRectAutoLinks :: Float -> Float -> Room
roomRectAutoLinks x y = roomRect' x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
roomRectAutoLinks x y = roomRect x y ((ceiling x - 40) `div` 60) ((ceiling y - 40) `div` 60)
makeGrid :: Float -> Int -> Float -> Int -> [(Point2,Point2)]
makeGrid x nx y ny = nub $ concatMap doublePair
@@ -61,3 +70,33 @@ linksAndPath :: [(Point2,Float)] -> [(Point2,Point2)] -> [(Point2,Point2)]
linksAndPath lnks subpth = subpth ++ concatMap linkClosest lnks
where linkClosest (p,_) = doublePair (p, head $ sortBy (compare `on` dist p) $ map fst subpth)
{- Combines two rooms into one room.
Combines into one big bound, concatenates the rest.
-}
combineRooms :: Room -> Room -> Room
combineRooms r r' = Room
{ _rmPolys = _rmPolys r ++ _rmPolys r'
, _rmLinks = _rmLinks r ++ _rmLinks r'
, _rmPath = _rmPath r ++ _rmPath r'
, _rmPS = _rmPS r ++ _rmPS r'
, _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 = []
}
testRoom :: Room
testRoom = foldr1 combineRooms $ map (\a -> shiftRoomBy ((0,0),a) northSegment) [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
src/Geometry.hs
+13
View File
@@ -164,6 +164,19 @@ orderPolygon ps = sortBy (compare `on` \p -> argV (p -.- cen)) ps
where
cen = 1/ fromIntegral (length ps) *.* foldr1 (+.+) ps
-- | Adds a point to a convex polygon.
-- If the point is inside, returns the original.
-- Points ordered anticlockwise, input not checked.
addPointPolygon :: Point2 -> [Point2] -> [Point2]
addPointPolygon p ps
| pointInOrOnPolygon p ps = ps
| otherwise = orderPolygon $ p : ps
-- | Creates the convex hull of a set of points.
convexHull :: [Point2] -> [Point2]
convexHull (x:y:z:xs) = foldr addPointPolygon (orderPolygon (x:y:z:[])) xs
convexHull _ = error "Tried to create the convex hull of two or less points"
-- | Return distance between two points.
dist :: Point2 -> Point2 -> Float
{-# INLINE dist #-}