From 6e6757499cf500f5ef558d29f818e832c166849e Mon Sep 17 00:00:00 2001 From: jgk Date: Mon, 3 May 2021 14:44:27 +0200 Subject: [PATCH] Refactoring, add screen when generating level --- src/Dodge/Creature.hs | 4 +- src/Dodge/Data/Menu.hs | 2 +- src/Dodge/Default.hs | 12 +++- src/Dodge/Event/Menu.hs | 11 +-- src/Dodge/Floor.hs | 9 +-- src/Dodge/Layout/Tree/Either.hs | 8 +++ src/Dodge/LevelGen.hs | 27 ++++---- src/Dodge/LevelGen/Data.hs | 2 +- src/Dodge/LevelGen/LineBlock.hs | 9 ++- src/Dodge/Render/MenuScreen.hs | 2 +- src/Dodge/Room.hs | 65 ++---------------- src/Dodge/Room/Boss.hs | 88 +++++++++++++++++++++--- src/Dodge/Room/Link.hs | 4 +- src/Dodge/Room/LockAndKeyList.hs | 2 +- src/Dodge/Room/LongDoor.hs | 112 +++++++++++++++++++++++++++++++ src/Dodge/Room/NoNeedWeapon.hs | 38 +++++++++++ src/Dodge/Room/Placement.hs | 50 +++++++++++--- src/Dodge/Room/Procedural.hs | 8 +-- src/Dodge/Update.hs | 7 +- 19 files changed, 342 insertions(+), 118 deletions(-) create mode 100644 src/Dodge/Room/LongDoor.hs create mode 100644 src/Dodge/Room/NoNeedWeapon.hs diff --git a/src/Dodge/Creature.hs b/src/Dodge/Creature.hs index 9970ca130..4399c8846 100644 --- a/src/Dodge/Creature.hs +++ b/src/Dodge/Creature.hs @@ -265,11 +265,11 @@ Items you start with. startInventory = IM.fromList (zip [0..20] ( [bezierGun + ,autoGun ,remoteLauncher ,grenade - --,spawnGun lamp + ,spawnGun lamp --,poisonSprayer - --,autoGun --,launcher --,lasGun --,grenade diff --git a/src/Dodge/Data/Menu.hs b/src/Dodge/Data/Menu.hs index ad61a69d5..e415f9e89 100644 --- a/src/Dodge/Data/Menu.hs +++ b/src/Dodge/Data/Menu.hs @@ -9,5 +9,5 @@ data MenuLayer | SoundOptionMenu | GraphicsOptionMenu | ControlList - | WaitMessage String + | WaitMessage String Int deriving (Eq,Ord) diff --git a/src/Dodge/Default.hs b/src/Dodge/Default.hs index e78afdb64..0b56760b8 100644 --- a/src/Dodge/Default.hs +++ b/src/Dodge/Default.hs @@ -25,8 +25,7 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Graph.Inductive.Graph hiding ((&)) import Data.List -{- -Indestructible wall. -} +{- Indestructible wall. -} defaultWall = Wall { _wlLine = [(0,0),(50,0)] , _wlID = 0 @@ -34,6 +33,15 @@ defaultWall = Wall , _wlSeen = False , _wlIsSeeThrough = False } +{- Indestructible see-through wall. -} +defaultCrystalWall = Wall + { _wlLine = [(0,0),(50,0)] + , _wlID = 0 + , _wlColor = withAlpha 0.5 aquamarine + , _wlSeen = False + , _wlIsSeeThrough = True + } + {- Door that opens on approach. Pathable. -} diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index 7b5015acb..feaaa14d7 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -65,10 +65,13 @@ handlePressedKeyInMenu mState scode w = case mState of pushMenu ml w = Just $ w & menuLayers %~ (ml :) popMenu w = Just $ w & menuLayers %~ tail sw = w & sideEffects %~ (setVol (_config w) : ) - startNewGame = Just $ updateFramebufferSize $ generateFromList levx - $ initialWorld - & randGen .~ _randGen w - & config .~ _config w + startNewGame = Just $ w + & menuLayers .~ [WaitMessage "GENERATING..." 1] + & worldEvents .~ const aNewGame + aNewGame :: World + aNewGame = updateFramebufferSize $ generateFromList levx $ initialWorld + & randGen .~ _randGen w + & config .~ _config w updateFramebufferSize :: World -> World updateFramebufferSize w = w & sideEffects diff --git a/src/Dodge/Floor.hs b/src/Dodge/Floor.hs index 185588b16..92e7a3d9d 100644 --- a/src/Dodge/Floor.hs +++ b/src/Dodge/Floor.hs @@ -15,6 +15,8 @@ import Dodge.Room.Door import Dodge.Room.Branch import Dodge.Room.Boss import Dodge.Room.Airlock +import Dodge.Room.LongDoor +import Dodge.Room.NoNeedWeapon import Dodge.Base import Dodge.Layout import Dodge.Layout.Tree.Polymorphic @@ -46,12 +48,11 @@ roomTreex = do t = treeFromTrunk [[StartRoom] ,[Corridor] - ,[BossAno $ addArmour launcherCrit & crHP +~ 800 - & crState . crDropsOnDeath .~ DropSpecific [0] ] + ,[SpecificRoom . fmap (pure . Right) $ twinSlowDoorChasers 30] ,[Corridor] ,[DoorAno] ,[SpecificRoom $ fmap (pure . Right) - $ randomiseLinksBy shuffleTail =<< centerVaultRoom 1 200 200 50] + $ centerVaultExplosiveExit 50] ,[SpecificRoom blockedCorridor] ,[OrAno [[DoorAno] ,[Corridor] @@ -62,7 +63,7 @@ roomTreex = do ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom] ,[Corridor] ,[OrAno - [[SpecificRoom $ branchRectWith $ fmap (pure . Left) armouredChasers] + [[SpecificRoom $ branchRectWith $ fmap (fmap Left) armouredChasers] ,[BossAno $ addArmour launcherCrit & crHP +~ 800 & crState . crDropsOnDeath .~ DropSpecific [0] ] ] diff --git a/src/Dodge/Layout/Tree/Either.hs b/src/Dodge/Layout/Tree/Either.hs index 0bf2b2545..05bd73ebf 100644 --- a/src/Dodge/Layout/Tree/Either.hs +++ b/src/Dodge/Layout/Tree/Either.hs @@ -5,6 +5,7 @@ module Dodge.Layout.Tree.Either ( expandTreeBy , appendEitherTree , connectRoom + , connectTrunk , deadRoom ) where import Data.Tree @@ -40,6 +41,13 @@ Make a singleton connection of an Either Tree. connectRoom :: a -> Tree (Either a a) connectRoom r = Node (Right r) [] +{- | +Make a single Either connection at the end of a tree. +-} +connectTrunk :: Tree a -> Tree (Either a a) +connectTrunk (Node x (t:ts)) = Node (Left x) (connectTrunk t : map (fmap Left) ts) +connectTrunk (Node x []) = Node (Right x) [] + {- | Make a singleton dead end of an Either Tree. -} diff --git a/src/Dodge/LevelGen.hs b/src/Dodge/LevelGen.hs index 3665e95a8..fd7f97867 100644 --- a/src/Dodge/LevelGen.hs +++ b/src/Dodge/LevelGen.hs @@ -88,8 +88,8 @@ placeSpot ps w = case ps of PS {_psPos = p, _psRot = rot, _psType = PutLineBlock wl width depth a b} -> putLineBlock wl width depth (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w - PS {_psPos = p, _psRot = rot, _psType = PutWindow { _pwPoly = ps, _pwColor = c }} - -> rmCrossPaths $ over walls (addWindow (q:qs) c) w + PS {_psPos = p, _psRot = rot, _psType = PutWall { _pwPoly = ps, _pwWall = wl }} + -> rmCrossPaths $ over walls (addWalls (q:qs) wl) w where (q:qs) = map (shiftPointBy (p,rot)) ps rmCrossPaths w = foldr (uncurry removePathsCrossing) w $ zip (q:qs) (qs++[q]) @@ -119,18 +119,17 @@ instance Shiftable PlacementSpot where shiftPointBy (pos,rot) p = pos +.+ rotateV rot p -addWindow :: [Point2] -> Color -> IM.IntMap Wall -> IM.IntMap Wall -addWindow qs c wls = foldr (addPane c) wls pairs - where (p:ps) = orderPolygon qs - pairs = zip (ps ++ [p]) (p:ps) -addPane :: Color -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall -addPane c (p0,p1) wls = IM.insert (newKey wls) (Wall { _wlLine = [p0,p1] - , _wlID = newKey wls - , _wlColor = c - , _wlSeen = False - , _wlIsSeeThrough = True - } - ) wls +addWalls :: [Point2] -> Wall -> IM.IntMap Wall -> IM.IntMap Wall +addWalls qs wl wls = foldr (addPane wl) wls pairs + where + (p:ps) = orderPolygon qs + pairs = zip (ps ++ [p]) (p:ps) +addPane :: Wall -> (Point2,Point2) -> IM.IntMap Wall -> IM.IntMap Wall +addPane wl (p0,p1) wls = IM.insert (newKey wls) (wl + { _wlLine = [p0,p1] + , _wlID = newKey wls + }) + wls placeBt bt p rot w = over buttons addBT w diff --git a/src/Dodge/LevelGen/Data.hs b/src/Dodge/LevelGen/Data.hs index 1c618234d..66e2ae2d6 100644 --- a/src/Dodge/LevelGen/Data.hs +++ b/src/Dodge/LevelGen/Data.hs @@ -17,6 +17,7 @@ data PSType = PutCrit Creature | PutAutoDoor Point2 Point2 | PutBlock [Int] Color [Point2] | PutLineBlock Wall Float Float Point2 Point2 + | PutWall { _pwPoly :: [Point2] , _pwWall :: Wall } | PutDoubleDoor Color (World -> Bool) Point2 Point2 | PutDoor Color (World -> Bool) [(Point2,Point2)] | PutBtDoor Color Point2 Float Point2 Point2 @@ -30,7 +31,6 @@ data PSType = PutCrit Creature , _collectiveFunction :: [Int] -> State StdGen [PSType] } | LabelPS { _psLabel :: Int, _ps :: PSType} - | PutWindow { _pwPoly :: [Point2] , _pwColor :: Color } data PlacementSpot = PS { _psPos :: Point2 , _psRot :: Float diff --git a/src/Dodge/LevelGen/LineBlock.hs b/src/Dodge/LevelGen/LineBlock.hs index 6daf1242e..43b9270c0 100644 --- a/src/Dodge/LevelGen/LineBlock.hs +++ b/src/Dodge/LevelGen/LineBlock.hs @@ -17,7 +17,14 @@ import qualified Data.IntMap as IM evenOddSplit = foldr f ([],[]) where f a (ls,rs) = (rs, a : ls) -putLineBlock :: Wall -> Float -> Float -> Point2 -> Point2 -> World -> World +putLineBlock + :: Wall -- Base pane + -> Float -- Block width + -> Float -- Block depth + -> Point2 -- Start point (symmetric) + -> Point2 -- End point (symmetric) + -> World + -> World putLineBlock basePane blockWidth depth a b w = removePathsCrossing a b $ foldr insertBlock w listBlocks where d = dist a b diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index b956c7c63..dde93c2d1 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -50,7 +50,7 @@ menuScreen cfig hw hh mLays = case mLays of ,tst (-100) 100 0.4 "CONTROLS" ,controlsList ] - (WaitMessage s : _) -> optionsList hw hh s [] + (WaitMessage s _ : _) -> optionsList hw hh s [] _ -> blank where tst x y sc t = translate x y $ scale sc sc $ color white $ text t diff --git a/src/Dodge/Room.hs b/src/Dodge/Room.hs index aa49a53a2..e55784984 100644 --- a/src/Dodge/Room.hs +++ b/src/Dodge/Room.hs @@ -28,6 +28,7 @@ import Dodge.Room.Link import Dodge.Room.Branch import Dodge.Room.Door import Dodge.Room.Airlock +import Dodge.Room.LongDoor import Geometry import Picture @@ -84,22 +85,6 @@ roomPillars = over rmLinks init $ set rmPS plmnts $ roomRect 240 240 2 2 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 -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) - ] -putBlockV a x b y = [ blockLine (a,b) (a,y) - , blockLine (x,b) (a,b) - ] -putBlockC a x b y = [ blockLine (a,b) (a,y) - , blockLine (x,b) (a,b) - , blockLine (a,y) (x,y) - ] -putBlockN a x b y = [ blockLine (a,b) (a,y) - , blockLine (x,b) (a,b) - , blockLine (x,y) (x,b) - ] branchWith :: Room -> [Tree Room] -> Tree (Either Room Room) branchWith r ts = Node (Left r) $ [return $ Right door] ++ fmap (fmap Left) ts @@ -134,8 +119,8 @@ glassLesson = do $ roomRect 200 200 1 1 topRoom = set rmPS topplmnts $ roomRect 200 200 1 1 - botplmnts = [PS (0,0) 0 $ PutWindow (rectNSWE (200) 0 (90) (110)) - $ withAlpha 0.5 aquamarine + botplmnts = [PS (0,0) 0 $ PutWall (rectNSWE (200) 0 (90) (110)) + $ defaultCrystalWall ,PS (50,100) 0 $ PutCrit miniGunCrit ,PS (50,50) 0 putLamp ] @@ -275,7 +260,6 @@ randFirstWeapon = do -- ++ [flamer] --randC1 :: State StdGen PSType -randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit) randC = randC1 @@ -396,53 +380,18 @@ roomCCrits = do return $ connectRoom $ over rmPS ((lamps ++) . (plmnts ++)) $ roomC 200 200 -slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room)) -slowDoorRoom = do - x <- state $ randomR (400,800) - 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) - ] - let n = 25 - xs <- sequence $ replicate n $ state $ randomR (10,x-10) - ys <- sequence $ replicate n $ state $ randomR (h+20,y) - rs <- sequence $ replicate n $ state $ randomR (0,2*pi) - let ps = zip xs ys - xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10) - ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y) - let crits = zipWith (\p r -> PS p r randC1) ps rs - lsources = [PS (x/2,30) 0 putLamp, PS (x/2,y-30) 0 putLamp] - let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys' - let pillarsa = [] - let 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) - ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20) - ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20) - let 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 - let cond2 x = (snd . fst) x < h - 40 - but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h) - -- ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h) - ] - fmap connectRoom (filterLinks cond =<< (changeLinkTo cond2 - $ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources) - $ roomRectAutoLinks x y - )) longRoom :: RandomGen g => State g Room longRoom = do h <- state $ randomR (1500,1500) let w = 75 let cond x = (snd . fst) x < h - 40 - let ws = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine) + let ws = map (\ps -> PS (0,0) 0 $ PutWall ps defaultCrystalWall) [rectNSWE (h-35) (h-135) (-10) 10 ,rectNSWE (h-35) (h-135) 15 35 ,rectNSWE (h-35) (h-135) 40 60 ,rectNSWE (h-35) (h-135) 65 85 ] - let wsDefense = map (\ps -> PS (0,0) 0 $ PutWindow ps $ withAlpha 0.5 aquamarine) + let wsDefense = map (\ps -> PS (0,0) 0 $ PutWall ps defaultCrystalWall) [rectNSWE (95) (70) 0 25 ,rectNSWE (95) (70) 50 75 ] @@ -577,8 +526,8 @@ spawnerRoom :: RandomGen g => State g (Tree (Either Room Room)) spawnerRoom = do x <- state $ randomR (250,300) y <- state $ randomR (300,400) - wl <- takeOne [PS (0,0) 0 $ PutWindow (rectNSWE (y-60) 0 (x/2-10) (x/2+10)) - $ withAlpha 0.5 aquamarine + wl <- takeOne [PS (0,0) 0 $ PutWall (rectNSWE (y-60) 0 (x/2-10) (x/2+10)) + defaultCrystalWall ,windowLine (x/2,0) (x/2,y-60) ] let plmnts = [PS (x/4, y/4) (pi/2) $ PutCrit spawnerCrit diff --git a/src/Dodge/Room/Boss.hs b/src/Dodge/Room/Boss.hs index c3087cad5..410bb0507 100644 --- a/src/Dodge/Room/Boss.hs +++ b/src/Dodge/Room/Boss.hs @@ -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] diff --git a/src/Dodge/Room/Link.hs b/src/Dodge/Room/Link.hs index ce2aecdf6..f7ee5b26b 100644 --- a/src/Dodge/Room/Link.hs +++ b/src/Dodge/Room/Link.hs @@ -43,13 +43,13 @@ filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room filterLinks cond r = do newLinks <- shuffle $ filter cond $ init $ _rmLinks r return $ r {_rmLinks = newLinks ++ [last $ _rmLinks r]} - +{- | Swaps the last link in the list with one that satisfies a given + - property (it might swap with itself). Unsafe. -} changeLinkTo :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room changeLinkTo cond r = do l <- takeOne $ filter cond $ _rmLinks r let newLinks = delete l (_rmLinks r) ++ [l] return $ r {_rmLinks = newLinks} - {- | Move a room so that the last link in '_rmLinks' lines up to an external point and direction. This is intended to work when the external point is an outgoing link from another room. diff --git a/src/Dodge/Room/LockAndKeyList.hs b/src/Dodge/Room/LockAndKeyList.hs index 60b4e3702..8c06426fe 100644 --- a/src/Dodge/Room/LockAndKeyList.hs +++ b/src/Dodge/Room/LockAndKeyList.hs @@ -14,6 +14,6 @@ lockAndKeyRoomList :: RandomGen g => ) ] lockAndKeyRoomList = [ ( fmap (pure . Right) armouredCorridor - , fmap (pure . Left) armouredChasers + , fmap (fmap Left) armouredChasers ) ] diff --git a/src/Dodge/Room/LongDoor.hs b/src/Dodge/Room/LongDoor.hs new file mode 100644 index 000000000..874556bbf --- /dev/null +++ b/src/Dodge/Room/LongDoor.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE TupleSections #-} +{- | Rooms containing long doors, probably with a big reveal behind them. + -} +module Dodge.Room.LongDoor + where +import Dodge.Data +import Dodge.Room.Data +import Dodge.Room.Placement +import Dodge.Room.Link +import Dodge.Room.Procedural +import Dodge.Layout.Tree.Either +import Dodge.LevelGen.Data +import Dodge.LevelGen.Switch +import Dodge.RandomHelp +import Dodge.Creature.Inanimate +import Dodge.Creature +import Picture +import Geometry + +import System.Random +import Control.Lens +import Control.Monad.State +import Data.Tree +import qualified Data.Map as M + +twinSlowDoorRoom + :: Int -- ^ Door id + -> Float -- ^ Half width + -> Float -- ^ Half height + -> Float -- ^ Inner width + -> Room +twinSlowDoorRoom drID w h x = Room + { _rmPolys = ps + , _rmLinks = + [ ((w,h/2) , negate $ pi/2) + , ((-w,h/2) , pi/2) + , ((0,-h), pi) + ] + , _rmPath = [] + , _rmPS = + [ PS (0,h/2) 0 putLamp + , PS (25,5) 0 putLamp + , PS (negate $ 25,5) 0 putLamp + , PS (0,0) 0 $ PutDoor col (not . cond) drL + , PS (0,0) 0 $ PutDoor col (not . cond) drR + , PS (0,h-5) pi $ PutButton $ makeButton col + (over worldState (M.insert (DoorNumOpen drID) True)) + ] + , _rmBound = ps + } + where + ps = + [rectNSWE h (-2) (-w) w + ,rectNSWE 20 (-h) (negate x) x + ] + drL = fmap ((\h' -> ((x,-h'),(x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral) + [0..nDrp] + drR = fmap ((\h' -> ((-x,-h'),(-x,h-h'))) . (* h) . (/ fromIntegral nDrp) . fromIntegral) + [0..nDrp] + nDrp = ceiling $ h + cond w = or $ M.lookup (DoorNumOpen drID) (_worldState w) + col = dim $ dim $ bright red + +twinSlowDoorChasers + :: RandomGen g + => Int -- ^ Door id + -> State g Room +twinSlowDoorChasers drid = do + let lps = (-65 ,) <$> [20,40 .. 180] + rps = (65 ,) <$> [20,40 .. 180] + ps <- takeN 4 $ lps ++ rps + let plmnts = map (\p -> PS p 0 $ PutCrit chaseCrit) ps + return $ twinSlowDoorRoom drid 80 200 40 & rmPS %~ (plmnts ++) + +slowDoorRoom :: RandomGen g => State g (Tree (Either Room Room)) +slowDoorRoom = do + x <- state $ randomR (400,800) + 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) + ] + let n = 25 + xs <- sequence $ replicate n $ state $ randomR (10,x-10) + ys <- sequence $ replicate n $ state $ randomR (h+20,y) + rs <- sequence $ replicate n $ state $ randomR (0,2*pi) + let ps = zip xs ys + xs' <- sequence $ replicate 5 $ state $ randomR (10,x-10) + ys' <- sequence $ replicate 5 $ state $ randomR (h+20,y) + let crits = zipWith (\p r -> PS p r randC1) ps rs + lsources = [PS (x/2,30) 0 putLamp, PS (x/2,y-30) 0 putLamp] + let barrels = zipWith (\x y -> PS (x,y) 0 $ PutCrit explosiveBarrel) xs' ys' + let pillarsa = [] + let 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) + ++ putBlockRect (3*x/5-20) (3*x/5+20) (h/2-20) (h/2+20) + ++ putBlockRect (4*x/5-20) (4*x/5+20) (h/2-20) (h/2+20) + let 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 + let cond2 x = (snd . fst) x < h - 40 + but <- takeOne [PutBtDoor (dim $ light red) butPos butRot (0,h) (x,h) + -- ,PutSwitchDoor (dim $ light red) butPos butRot (0,h) (x,h) + ] + fmap connectRoom (filterLinks cond =<< (changeLinkTo cond2 + $ set rmPS ([PS (0,0) 0 but] ++ crits ++ pillars ++ barrels ++ lsources) + $ roomRectAutoLinks x y + )) + +randC1 = RandPS $ takeOne $ map PutCrit $ (armourChaseCrit : replicate 50 chaseCrit) diff --git a/src/Dodge/Room/NoNeedWeapon.hs b/src/Dodge/Room/NoNeedWeapon.hs new file mode 100644 index 000000000..a2a2a47c4 --- /dev/null +++ b/src/Dodge/Room/NoNeedWeapon.hs @@ -0,0 +1,38 @@ +{- | Rooms that can be successfully tackled without having any items. -} +module Dodge.Room.NoNeedWeapon + ( centerVaultExplosiveExit + ) where +import Dodge.Data +import Dodge.Creature +import Dodge.Creature.Inanimate +import Dodge.Room.Data +import Dodge.Room.Procedural +import Dodge.Room.Link +import Dodge.RandomHelp +import Dodge.LevelGen.Data + +import Control.Lens +import Control.Monad +import Control.Monad.State +import System.Random +{- | +A room designed to be /passable/ with no weapons. +Highlights an issue: when trying to place next door rooms, if the level generation fails it will try a different link. +So if there are multiple such, we cannot assume that a given link will be chosen. +To solve this, here we delete unwanted links. +-} +centerVaultExplosiveExit + :: RandomGen g + => Int -- ^ Door id + -> State g Room +centerVaultExplosiveExit drID = do + cr <- takeOne [miniGunCrit, autoCrit] + let extraPS = + [PS (0,175) 0 $ PutCrit explosiveBarrel + ,PS (5,195) 0 $ PutCrit explosiveBarrel + ,PS (0,200) 0 $ PutCrit explosiveBarrel + ,PS (-4,195) 0 $ PutCrit explosiveBarrel + ,PS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll) + ] + r <- centerVaultRoom drID 200 200 50 <&> rmPS %~ (extraPS ++) + randomiseLinksBy shuffleTail r <&> rmLinks %~ take 2 diff --git a/src/Dodge/Room/Placement.hs b/src/Dodge/Room/Placement.hs index 52df565f4..b5be46df4 100644 --- a/src/Dodge/Room/Placement.hs +++ b/src/Dodge/Room/Placement.hs @@ -2,6 +2,7 @@ module Dodge.Room.Placement where import Dodge.Data +import Dodge.Default import Dodge.LevelGen.Data import Dodge.Room.Data import Dodge.Creature.Inanimate @@ -47,7 +48,7 @@ crystalLine :: Point2 -> Point2 -> PlacementSpot crystalLine a b = PS { _psPos = (0,0) , _psRot = 0 - , _psType = PutWindow ps $ withAlpha 0.5 aquamarine + , _psType = PutWall ps defaultCrystalWall } where ps = @@ -58,6 +59,24 @@ crystalLine a b = PS ] left = 7 *.* normalizeV (a-.-b) up = vNormal left +{- Places an unbreakable wall between two points. +Depth 15, does not extend wider than points. + -} +wallLine :: Point2 -> Point2 -> PlacementSpot +wallLine a b = PS + { _psPos = (0,0) + , _psRot = 0 + , _psType = PutWall ps defaultWall + } + where + ps = + [ a +.+ up + , a -.- up + , b -.- up + , b +.+ up + ] + left = 15 *.* normalizeV (a-.-b) + up = vNormal left windowLineType :: Point2 -> Point2 -> PSType windowLineType = PutLineBlock baseWindowPane 8 8 @@ -88,10 +107,7 @@ baseWindowPane = Block , _blShadows = [] , _blDegrades = [5,5] } - -{- -Replaces instances of a given 'PutID' with 'PSType's drawn from a list. --} +{- Replaces instances of a given 'PutID' with 'PSType's drawn from a list. -} replacePutID :: Int -- ^ The id of 'PutID' to be replaced -> [PSType] -- ^ List of replacements @@ -99,12 +115,9 @@ replacePutID -> Room replacePutID i psts r = r & rmPS %~ flip (subZipWith (isPutID i) (\ps pt -> ps & psType .~ pt)) psts - -{- -Partition a list by a predicate, apply a zip to those elements +{- Partition a list by a predicate, apply a zip to those elements that satisfy the predicate, concatenate -the new zipped list and the other (unchanged) half. --} +the new zipped list and the other (unchanged) half. -} subZipWith :: (a -> Bool) -- ^ Filter: elements to apply zip to -> (a -> b -> a) -- ^ Combining function @@ -116,3 +129,20 @@ subZipWith f g xs ys = in zipWith g zs ys ++ ws isPutID i ps = Just i == ps ^? psType . putID + +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) + ] +putBlockV a x b y = [ blockLine (a,b) (a,y) + , blockLine (x,b) (a,b) + ] +putBlockC a x b y = [ blockLine (a,b) (a,y) + , blockLine (x,b) (a,b) + , blockLine (a,y) (x,y) + ] +putBlockN a x b y = [ blockLine (a,b) (a,y) + , blockLine (x,b) (a,b) + , blockLine (x,y) (x,b) + ] diff --git a/src/Dodge/Room/Procedural.hs b/src/Dodge/Room/Procedural.hs index 59e901bfc..e07c99437 100644 --- a/src/Dodge/Room/Procedural.hs +++ b/src/Dodge/Room/Procedural.hs @@ -6,6 +6,7 @@ module Dodge.Room.Procedural , roomRectAutoLinks , randomFourCornerRoom , centerVaultRoom + , combineRooms ) where import Dodge.Data import Dodge.Room.Data @@ -230,7 +231,6 @@ centerVaultRoom n w h d = do weDoors = rectNSWE 20 (-20) (d + 20) (negate (d +20)) centerPoly = rectWdthHght (d - 20) (d - 20) polys = centerPoly : nsDoors : weDoors : (take 4 $ iterate (map vNormal) northPoly) - cr <- takeOne [miniGunCrit, autoCrit] return $ Room { _rmPolys = polys , _rmLinks = @@ -246,11 +246,6 @@ centerVaultRoom n w h d = do ,PS (w-5,5-h) 0 putLamp ,PS (5-w,h-5) 0 putLamp ,PS (5-w,5-h) 0 putLamp - ,PS (0,h-5) 0 $ PutCrit explosiveBarrel - ,PS (5,h-5) 0 $ PutCrit explosiveBarrel - ,PS (0,h) 0 $ PutCrit explosiveBarrel - ,PS (-4,h-5) 0 $ PutCrit explosiveBarrel - ,PS (0,0) 0 $ PutCrit (cr & crState . crDropsOnDeath .~ DropAll) ] ++ concat (zipWith (\i r -> map (shiftPSBy ((0,0),r)) $ theDoor i) [n, n+1, n+2, n+3] [0,pi/2,pi,3*pi/2]) @@ -265,3 +260,4 @@ centerVaultRoom n w h d = do (over worldState (M.insert (DoorNumOpen i) False)) ] cond i w = or $ M.lookup (DoorNumOpen i) (_worldState w) + diff --git a/src/Dodge/Update.hs b/src/Dodge/Update.hs index 539ee50f9..76201bacb 100644 --- a/src/Dodge/Update.hs +++ b/src/Dodge/Update.hs @@ -41,11 +41,14 @@ pushSideEffects w = w For most menus the only way to change the world is using event handling. -} update' :: World -> World update' w = case _menuLayers w of - (WaitMessage _ : ls) -> w & menuLayers .~ ls + (WaitMessage s i: ls) + | i < 1 -> w & doubleArgumentFor _worldEvents + | otherwise -> w & menuLayers %~ ( (WaitMessage s (i-1) :) . tail ) (GameOverMenu : _) -> updateParticles . updateProjectiles . updateLightSources - $ updateClouds + . updateClouds + $ updateSoundQueue w (_ : _) -> w [] -> checkEndGame