Implement level portal

src/Dodge/Creature.hs

@@ -251,29 +251,32 @@ startCr = defaultCreature
     , _crMass = 10
     , _crHP = 10000
     , _crMaxHP = 1500
-    , _crInv = IM.fromList (zip [0..20] 
+    , _crInv = startInventory 
-        (
-        [pistol
-        ,blinkGun
-        ,spawnGun lamp
-        ,poisonSprayer
-        ,autoGun
-        ,launcher
-        ,lasGun
-        ,grenade
-        ,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
-        ,longGun
-        ,hvAutoGun
-        ,teslaGun
-        ,latchkey 0
-        ,miniGun
-        ,medkit 50
-        ,bezierGun
-        ] 
-          ++ repeat NoItem)) 
     , _crCorpse = onLayer CorpseLayer $ color (greyN 0.5) $ pictures [color (greyN 0.8) $ circleSolid 10, circLine 10]
     }
 
+startInventory = IM.fromList (zip [0..20] 
+    (
+    --[pistol
+    --,blinkGun
+    --,spawnGun lamp
+    --,poisonSprayer
+    --,autoGun
+    --,launcher
+    --,lasGun
+    --,grenade
+    --,ltAutoGun,flamer,multGun,spreadGun,remoteLauncher
+    --,longGun
+    --,hvAutoGun
+    --,teslaGun
+    --,latchkey 0
+    --,miniGun
+    --,medkit 50
+    --,bezierGun
+    --] 
+    --  ++ 
+    repeat NoItem))
+
 smokeGenGun = effectGun "smoke" $ \_ -> spawnSmokeAtCursor
 
 enemyPict :: Color -> Creature -> Picture

src/Dodge/Data.hs

@@ -70,6 +70,7 @@ data World = World
     , _storedLevel          :: Maybe World
     , _menuLayers           :: [MenuLayer]
     , _worldState           :: M.Map WorldState Bool
+    , _worldTriggers        :: S.Set WorldTrigger
     , _windowX              :: !Float
     , _windowY              :: !Float
     , _carteDisplay         :: !Bool
@@ -247,8 +248,13 @@ data Faction
     | NoFaction
   deriving (Eq,Show)
 
--- NOTE: walls must be drawn counterclockwise
+data WorldState 
-data WorldState = DoorNumOpen Int | CrNumAlive Int
+    = DoorNumOpen Int 
+    | CrNumAlive Int
+  deriving (Eq,Ord)
+
+data WorldTrigger
+    = ResetLevel Int
   deriving (Eq,Ord)
 
 data Button = Button 

src/Dodge/Default.hs

@@ -213,6 +213,7 @@ defaultWorld = World
     , _storedLevel = Nothing
     , _menuLayers = [LevelMenu 1]
     , _worldState = M.empty
+    , _worldTriggers = S.empty
     , _clickMousePos = (0,0)
     , _pathGraph = Data.Graph.Inductive.Graph.empty
     , _pathGraph' = []

src/Dodge/Floor.hs

@@ -1,9 +1,6 @@
 module Dodge.Floor
-    ( lev1 
+    ( levx
-    , levx
+    ) where
-    , generateLevel
-    )
-    where
 import Geometry
 import Picture
 import Dodge.Data
@@ -34,29 +31,14 @@ import System.Random
 roomTreex :: RandomGen g => State g (Maybe [Room])
 roomTreex = do
     struct' <- aTreeStrut
-    let struct = Node () []
+    let struct = Node [EndRoom] []
-    -- t <- randomPadCorridors $ fmap (const []) struct
+    let t' = padCorridors struct
-    let t' = padCorridors $ fmap (const []) struct
         t = treeTrunk [[StartRoom],[Corridor],[FirstWeapon],[Corridor]] t'
---    fmap shiftExpandTree $ mapM annoToRoom t
     fmap (shiftExpandTree . expandTreeBy id) $ mapM annoToRoomTree t
 
-roomTreex' :: RandomGen g => State g (Maybe [Room])
-roomTreex' = do
-    struct <- aTreeStrut
-    let t = padCorridors $ fmap (const []) struct
-    return . shiftExpandTree $ fmap annoToRoom' t
-
-
 levx :: RandomGen g => State g [Room]
 levx = untilJust roomTreex
 
-lev1 :: RandomGen g => State g (Tree Room)
-lev1 = do
-    struct <- aTreeStrut
-    let t = padCorridors $ fmap (const []) struct
-    fmap shiftRoomTree $ mapM annoToRoom t
-
 lev1' :: RandomGen g => State g (Tree Room)
 lev1' = do
     firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
@@ -105,34 +87,3 @@ lev1' = do
            ]
         )
         $ (fmap connectRoom . randomiseOutLinks) corridor
-
-roomToLevel2 :: RandomGen g => State g (Tree (Either Room Room))
-roomToLevel2 = join $ takeOne
-    [ portalRoom1
-    ]
-
-portalRoom1 :: RandomGen g => State g (Tree (Either Room Room))
-portalRoom1 = return $ connectRoom $ (roomRectAutoLinks 300 300) { _rmPS = plmnts}
-    where plmnts = [PS (0,0) (0-pi/2) $ PutPressPlate (levelPortalAt (200,120) 1)
-                   ,PS (60,100) pi $ PutCrit autoCrit
-                   ]
-
-generateLevel :: Int -> World -> World
-generateLevel i w = 
-    do haltSound $ ((generateFromTree $ levelTree i) w)
-
-levelTree :: Int -> State StdGen (Tree Room)
-levelTree 1 = lev1
-
-levelPortalAt :: Point2 -> Int -> PressPlate
-levelPortalAt p x 
-    = PressPlate
-        { _ppPict = onLayer PressPlateLayer $ color blue $ circle 10
-        , _ppPos = p
-        , _ppRot = 0
-        , _ppEvent = \pp w -> if dist (_crPos (you w)) (_ppPos pp) < 10
-                                then generateLevel x w
-                                else w
-        , _ppID = -1
-        , _ppText = "Portal to level "++ show x
-        }

src/Dodge/Layout/Tree/Annotate.hs

@@ -10,6 +10,8 @@ import Dodge.Room.Procedural
 import Dodge.Room.Link
 import Dodge.Room.Data
 import Dodge.Room
+import Dodge.Room.Teleport
+--import Dodge.Floor
 
 import Data.Tree
 import Control.Monad.State
@@ -21,6 +23,7 @@ data Annotation
     | Corridor
     | FirstWeapon
     | StartRoom
+    | EndRoom
 
 addLock :: RandomGen g => Int -> Tree [Annotation] -> State g (Tree [Annotation])
 addLock i t = do
@@ -40,24 +43,16 @@ randomPadCorridors  (Node x xs) = do
 annoToRoomTree :: RandomGen g => [Annotation] -> State g (Tree (Either Room Room))
 annoToRoomTree [Corridor] = fmap (pure . Right) $ randomiseOutLinks corridor
 annoToRoomTree [FirstWeapon] = do
-    --firstWeapon <- takeOne $ [[branchRectWith weaponRoom,blockedCorridor]] ++ replicate 5 [weaponRoom]
     branchWP <- branchRectWith weaponRoom
     blockedC <- blockedCorridor
     firstWeapon <- takeOne $ [return $ appendEitherTree branchWP [blockedC]] ++ replicate 5 weaponRoom
-    --firstWeapon <- takeOne $ replicate 5 weaponRoom
     firstWeapon
+annoToRoomTree [EndRoom] = fmap (pure . Right) (telRoomLev 1)
+annoToRoomTree [StartRoom] = do
+    w <- state $ randomR (100,400)
+    h <- state $ randomR (200,400)
+    fmap (pure . Right) $ return (shiftRoomBy ((-20,-20),0) $ roomRectAutoLinks w h) >>= randomiseOutLinks
 annoToRoomTree _ = do
     w <- state $ randomR (100,400)
     h <- state $ randomR (200,400)
     fmap (pure . Right) $ return (roomRectAutoLinks w h) >>= randomiseOutLinks
-
-annoToRoom :: RandomGen g => [Annotation] -> State g Room
-annoToRoom [Corridor] = randomiseOutLinks corridor
-annoToRoom _ = do
-    w <- state $ randomR (100,400)
-    h <- state $ randomR (200,400)
-    return (roomRectAutoLinks w h) >>= randomiseOutLinks
-
-annoToRoom' :: [Annotation] -> Room
-annoToRoom' [Corridor] = corridor
-annoToRoom' _          = roomRectAutoLinks 200 200

src/Dodge/Layout/Tree/Polymorphic.hs

@@ -108,4 +108,3 @@ splitTrunk :: RandomGen g => Tree a -> State g (Tree a, [Tree a])
 splitTrunk t = do
     i <- state $ randomR (0, trunkDepth t)
     return $ splitTrunkAt i t
-

src/Dodge/Render.hs

@@ -6,28 +6,23 @@ module Dodge.Render
   where
 import Dodge.Data
 import Dodge.Base
-
 import Dodge.Render.HUD
 import Dodge.Render.MenuScreen
 import Dodge.Render.Picture
 import Dodge.Render.PerspectiveMatrix
-
 import Geometry
 import Picture
-import Shader
-
 import Picture.Render
 import Picture.Preload
+import Shader
 
 import Data.Graph.Inductive.Query.DFS
 import Data.Graph.Inductive.Graph
-
 import Control.Monad.State
 import Data.List
 import Data.Bifunctor
-
-import Foreign (Word32)
 import Data.Function
+import Foreign (Word32)
 import Control.Applicative
 import Control.Lens
 import Data.Maybe
@@ -35,7 +30,6 @@ import qualified Data.IntMap.Strict as IM
 import qualified Data.Map as M
 import qualified Data.Set as S
 import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
-
 import qualified SDL
 
 doDrawing :: RenderData -> World -> IO (Word32)

src/Dodge/Render/Picture.hs

@@ -20,6 +20,7 @@ worldPictures w = pictures $ concat
     , map drawItem . IM.elems $ _floorItems w
     , map crDraw   . IM.elems $ _creatures w
     , map clDraw   . IM.elems $ _clouds w
+    , map ppDraw    . IM.elems $ _pressPlates w
     , map btDraw (IM.elems (_buttons w))
     , map (\pt -> _ptDraw pt pt) $ _particles' w
     , map drawWallFloor (wallFloorsToDraw w)

src/Dodge/Update.hs

@@ -13,6 +13,9 @@ import Dodge.Update.Camera
 import Dodge.Update.UsingInput
 import Dodge.SoundLogic
 import Dodge.Inventory
+import Dodge.Initialisation
+import Dodge.Layout
+import Dodge.Floor
 import Geometry
 
 import Data.List
@@ -38,23 +41,26 @@ update' :: World -> World
 update' w = case _menuLayers w of
     (ConfigSaveScreen : ls) -> w & menuLayers .~ ls
     (_ : _) -> w    
-    []  ->  let w1 = updateParticles' . updateProjectiles 
+    []  ->  let w1 = updateParticles' 
-                                      . updateLightSources
+                    . updateProjectiles 
-                                      . zoneClouds
+                    . updateLightSources
-                                      . updateClouds
+                    . zoneClouds
-                                      . updateCreatures 
+                    . updateClouds
-                                      . updateBlocks -- . zoning 
+                    . updateCreatures 
-                                      . updateSeenWalls 
+                    . updateBlocks -- . zoning 
-                                      . updateSoundQueue
+                    . updateSeenWalls 
-                                      $ updateCloseObjects w
+                    . updateSoundQueue
-            in  checkEndGame . ppEvents 
+                    $ updateCloseObjects w
-                             . updateCamera
+            in  checkEndGame 
-                             . colCrsWalls
+                    . triggerUpdate
-                             . simpleCrSprings 
+                    . ppEvents 
-                             . zoneCreatures 
+                    . updateCamera
-                             . wallEvents
+                    . colCrsWalls
-                             . set worldEvents id 
+                    . simpleCrSprings 
-                             $ _worldEvents w1 w1
+                    . zoneCreatures 
+                    . wallEvents
+                    . set worldEvents id 
+                    $ _worldEvents w1 w1
   where 
     zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
     creatureInZone cr = insertIMInZone x y cid cr
@@ -65,6 +71,18 @@ update' w = case _menuLayers w of
       where (x,y) = zoneOfPoint $ _clPos cr
             cid = _clID cr
 
+triggerUpdate :: World -> World
+triggerUpdate w 
+    | ResetLevel 1 `S.member` _worldTriggers w
+        = generateFromList levx
+            $ initialWorld 
+                & randGen .~ _randGen w
+                & windowX .~ _windowX w
+                & windowY .~ _windowY w
+                & menuLayers .~ []
+                & creatures . ix 0 .~ (_creatures w IM.! 0 & crPos .~ (0,0))
+    | otherwise = w
+
 updateSoundQueue = set soundQueue []
                     . set sounds M.empty
 
@@ -94,7 +112,7 @@ wallEvents w = IM.foldr (_doorMech) w ( IM.filter (\d -> case d of
                                                                 _       -> False) ( _walls w))
 
 ppEvents :: World -> World
-ppEvents w = IM.foldr' (\pp w -> _ppEvent pp pp w) w $ _pressPlates w
+ppEvents w = IM.foldr (\pp w -> _ppEvent pp pp w) w $ _pressPlates w
 
 updateSeenWalls :: World -> World
 updateSeenWalls w = foldr markSeen w wallsToUpdate