From 108b66f3ad75330a8a9393dcf3bb195c45352f85 Mon Sep 17 00:00:00 2001 From: jgk Date: Fri, 23 Apr 2021 21:17:37 +0200 Subject: [PATCH] Tweak wall cutting, removes inverse walls --- src/Dodge/Floor.hs | 3 +- src/Dodge/Item/Weapon/TriggerType.hs | 292 ++++++++++++++++++--------- src/Dodge/Layout.hs | 5 +- src/Dodge/LevelGen/StaticWalls.hs | 24 ++- src/Dodge/Room.hs | 22 +- src/Dodge/Room/Procedural.hs | 51 ++++- src/Geometry.hs | 13 ++ 7 files changed, 289 insertions(+), 121 deletions(-) diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index ba98e9654..2cb78ca43 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -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] diff --git a/src/Dodge/Item/Weapon/TriggerType.hs b/src/Dodge/Item/Weapon/TriggerType.hs index 134c053b2..543a304cc 100644 --- a/src/Dodge/Item/Weapon/TriggerType.hs +++ b/src/Dodge/Item/Weapon/TriggerType.hs @@ -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 diff --git a/src/Dodge/Layout.hs b/src/Dodge/Layout.hs index 7a1dde1ac..336413de2 100644 --- a/src/Dodge/Layout.hs +++ b/src/Dodge/Layout.hs @@ -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} diff --git a/src/Dodge/LevelGen/StaticWalls.hs b/src/Dodge/LevelGen/StaticWalls.hs index 96282ef4c..899ce4ea1 100644 --- a/src/Dodge/LevelGen/StaticWalls.hs +++ b/src/Dodge/LevelGen/StaticWalls.hs @@ -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. diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index 8b8c12b96..50d19c5e9 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -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 diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 64833aa28..f23ce745c 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -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 diff --git a/src/Geometry.hs b/src/Geometry.hs index 985e1b2ba..2b4c5b64a 100644 --- a/src/Geometry.hs +++ b/src/Geometry.hs @@ -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 #-}