135 lines
4.8 KiB
Haskell
135 lines
4.8 KiB
Haskell
{-# OPTIONS_GHC -Wno-unused-imports #-}
|
|
{- | The tree of rooms that make up a level. -}
|
|
module Dodge.Floor
|
|
( layoutLevelFromSeed
|
|
) where
|
|
import Geometry.Data
|
|
import Dodge.Data
|
|
import Dodge.Creature.State.Data
|
|
import Dodge.Room
|
|
import Dodge.Placement.Instance.Button
|
|
import Dodge.Layout.Tree.Polymorphic
|
|
import Dodge.Layout.Tree.Either
|
|
import Dodge.Annotation
|
|
import Dodge.Layout.Tree.Shift
|
|
import Dodge.Creature
|
|
import Dodge.LevelGen.Data
|
|
import Dodge.LevelGen.Switch
|
|
import Dodge.Item.Weapon.Launcher
|
|
import Dodge.PlacementSpot
|
|
import Dodge.RoomPos
|
|
import Dodge.Room.RunPast
|
|
import MonadHelp
|
|
import Data.Tree
|
|
import Color
|
|
import Dodge.Wire
|
|
|
|
import Control.Lens
|
|
import Control.Monad.State
|
|
import Control.Monad.Loops
|
|
import System.Random
|
|
import Data.Sequence hiding (zipWith)
|
|
import Data.Maybe
|
|
import qualified Data.IntMap.Strict as IM
|
|
|
|
|
|
initialAnoTree :: RandomGen g => Tree [Annotation g]
|
|
initialAnoTree = padSucWithCorridors $ treeFromTrunk
|
|
[[AnoApplyInt 0 startRoom]
|
|
, [AnoApplyInt 1 lasSensorTurretTest]
|
|
-- ,[ChainAnos
|
|
-- [[SetLabel 0 $ return $ roomRectAutoLinks 200 200
|
|
-- & rmExtPmnt ?~ triggerSwitchSPicLight (drawSwitchWire red red)
|
|
-- (anyLnkInPS 5 & psLnkRoomEff .~ (putWireStart 0 . extractRoomPos) )
|
|
-- & rmLinkEff .~ [putWireEnd 0]
|
|
-- ]
|
|
-- ,[UseLabel 0 $ return switchDoorRoom]
|
|
-- ]
|
|
-- ]
|
|
-- ,[SpecificRoom $ return $ connectRoom lasTunnel ]
|
|
-- ,[SpecificRoom $ fmap connectRoom slowDoorRoom ]
|
|
-- ,[Corridor]
|
|
-- ,[Corridor]
|
|
-- ,[SpecificRoom $ fmap connectRoom roomCCrits]
|
|
-- ,[AirlockAno]
|
|
-- ,[Corridor]
|
|
------ ,[SpecificRoom roomCCrits]
|
|
------ ,[Corridor]
|
|
------ ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
|
|
------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit armourChaseCrit
|
|
------ ,sPS (V2 50 25) 0 $ PutCrit armourChaseCrit
|
|
------ ,sPS (V2 50 0) 0 $ PutCrit armourChaseCrit
|
|
------ ]++)
|
|
------ ]
|
|
------ --,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
|
|
------ -- & rmPS %~ ([swarmPS 0 (x,y) 0 swarmCrit | x <- [-20,-19.5.. 20] , y <- [200,202] ]++)
|
|
------ -- ]
|
|
------ ,[SpecificRoom . pure . pure . Right $ roomGlassOctogon 400
|
|
------ & rmPS %~ ([sPS (V2 0 50) 0 $ PutCrit pistolCrit ]++)
|
|
------ ]
|
|
------ ,[Corridor]
|
|
---- --,[SpecificRoom $ pure . Right <$> twinSlowDoorChasers]
|
|
----- ,[SpecificRoom $ pure $ (pure . Right) (twinSlowDoorRoom 80 200 40)]
|
|
----- ,[DoorAno]
|
|
----- ,[SpecificRoom $ pure . Right <$> centerVaultExplosiveExit]
|
|
----- ,[SpecificRoom blockedCorridor]
|
|
----- ,[OrAno [[DoorAno]
|
|
----- ,[Corridor]
|
|
----- ,[DoorNumAno 0,AirlockAno]]
|
|
----- ]
|
|
----- ,[FirstWeapon]
|
|
----- ,[CorridorDebug]
|
|
----- ,[SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]
|
|
-- ,[OrAno
|
|
-- [[SpecificRoom $ branchRectWith $ fmap (fmap Left) armouredChasers]
|
|
-- ,[BossAno $ addArmour launcherCrit & crHP +~ 800
|
|
-- & crState . crDropsOnDeath .~ DropSpecific [0] ]
|
|
-- ]
|
|
-- ]
|
|
---- ,[SpecificRoom $ fmap (pure . Right) armouredCorridor]
|
|
-- ,[Corridor]
|
|
-- ,[TreasureAno [addArmour autoCrit,addArmour autoCrit] [launcher]]
|
|
]
|
|
$ treeFromPost [[Corridor,SpecificRoom $ fmap (pure . Right) randomFourCornerRoom]]
|
|
[EndRoom]
|
|
|
|
{- | A test level tree. -}
|
|
initialRoomTree :: RandomGen g => State g (Tree Room)
|
|
initialRoomTree = do
|
|
expandTreeBy id <$> mapM anoToRoomTree initialAnoTree
|
|
|
|
layoutLevelFromSeed :: Int -> Int -> IO [Room]
|
|
layoutLevelFromSeed i seed = do
|
|
let i' = i + 1
|
|
putStrLn $ "Generating level with seed " ++ show seed
|
|
let g = mkStdGen seed
|
|
let rmtree = inorderNumberTree $ evalState initialRoomTree g
|
|
putStrLn "Abstract layout: "
|
|
putStrLn $ compactDrawTree $ fmap (show . snd) rmtree
|
|
mrs <- positionRooms rmtree
|
|
case mrs of
|
|
Just rs -> do
|
|
putStrLn $ "After " ++ show i'
|
|
++ " attempt(s), Successful generation of level with seed "
|
|
++ show seed
|
|
--return (fmap setLastLinkToUsed rs)
|
|
return rs
|
|
Nothing -> do
|
|
putStr $ "Level generation with seed " ++ show seed ++ " failed: "
|
|
let (seed',_) = random g
|
|
layoutLevelFromSeed i' seed'
|
|
|
|
compactDrawTree :: Tree String -> String
|
|
compactDrawTree = unlines . compactDraw
|
|
|
|
compactDraw :: Tree String -> [String]
|
|
compactDraw (Node x [Node y ts]) = compactDraw (Node (x++","++y) ts)
|
|
compactDraw (Node x ts0) = lines x ++ drawSubTrees ts0
|
|
where
|
|
drawSubTrees [] = []
|
|
drawSubTrees [t] =
|
|
"|" : compactDraw t
|
|
drawSubTrees (t:ts) =
|
|
"|" : shift "+- " "| " (compactDraw t) ++ drawSubTrees ts
|
|
shift first other = zipWith (++) (first : repeat other)
|