Add airlocks

package.yaml

@@ -46,7 +46,6 @@ dependencies:
 - aeson
 - directory
 - QuickCheck
-- utility-ht
 
 library:
   source-dirs: src

src/Dodge/Base.hs

@@ -735,7 +735,7 @@ nearestCrInFront p dir x w
 {- | Test whether a creature is in a polygon.
  -}
 crInPolygon :: Creature -> [Point2] -> Bool
-crInPolygon cr xs = errorPointInPolygon 3 (_crPos cr) xs
+crInPolygon cr = errorPointInPolygon 3 (_crPos cr)
 
 {- | Transform coordinates from world position to normalised screen coordinates.
  -}

src/Dodge/Creature/Inanimate.hs

@@ -67,10 +67,12 @@ explosiveBarrel :: Creature
 explosiveBarrel = defaultInanimate
     { _crUpdate = updateExpBarrel
     , _crHP = 400
-    , _crPict = \ _ -> onLayer CrLayer $ pictures [ color orange $ circleSolid 10
+    , _crPict = \ _ -> onLayer CrLayer $ pictures 
-                                , color red $ circleSolid 8
+        [ color red $ circleSolid 8
+        , color orange $ circleSolid 10
         ]
-    , _crState = defaultState {_goals = [[Wait]]
+    , _crState = defaultState 
+        {_goals = [[Wait]]
         ,_faction = ChaseCritters
         ,_crSpState = Barrel []
         }

src/Dodge/Creature/State.hs

@@ -46,9 +46,11 @@ stateUpdate u w (f,g) cr =
                                       $ crOrCorpse =<< maybeCr
                                )
   where   
-    crOrCorpse cr | cr ^. crHP > 0 = Just cr
+    crOrCorpse cr 
+        | cr ^. crHP > 0 = Just cr
         | otherwise      = Nothing
-    deathEff | cr ^.crHP > 0 = id
+    deathEff 
+        | cr ^.crHP > 0 = id
         | otherwise = stopSoundFrom (CrWeaponSound (_crID cr)) 
             . over decorations addCorpse 
             . dropByState cr
@@ -57,7 +59,7 @@ stateUpdate u w (f,g) cr =
                              $ rotate (_crDir cr)
                              (_crCorpse cr)
 
--- | Drop items accoring to the creature state.
+-- | Drop items according to the creature state.
 dropByState :: Creature -> World -> World
 dropByState cr w = foldr (copyItemToFloor cr) w is
   where
@@ -81,7 +83,8 @@ crFriction cr vel = (0,0)
 doDamage :: Creature -> Creature
 doDamage cr = set (crState . crDamage) [] $ over (crState . crPastDamage) (+ hpLost) 
                                             damagedCr
-    where dams = _crDamage $ _crState cr
+  where 
+    dams = _crDamage $ _crState cr
     startHP = _crHP cr
     damagedCr = snd $ (_crApplyDamage cr) dams cr
     afterHP = _crHP damagedCr

src/Dodge/Creature/YourControl.hs

@@ -16,8 +16,6 @@ import qualified Data.Set as S
 import qualified Data.IntMap.Strict as IM
 import System.Random
 
-
-
 yourControl :: World -> (World -> World,StdGen) -> Creature -> ((World -> World,StdGen), Maybe Creature)
 yourControl w (f,g) cr = ( (updateUsingInput . f, g)
                          , Just . crAutoReload . mouseActionsCr (_mouseButtons w) $ wasdWithAiming w speed strafeSpeed 0 cr

src/Dodge/Data.hs

@@ -26,10 +26,12 @@ import Dodge.Data.DamageType
 import Dodge.Config.Data
 import Dodge.Config.KeyConfig
 import Dodge.Item.Attachment.Data
+import Dodge.World.Trigger.Data
 import Preload.Data
 import Picture.Data
 import Geometry.Data
 import Sound.Data
+import qualified DoubleStack as DS
 
 import Control.Lens
 import Control.Monad.State
@@ -162,10 +164,6 @@ data WorldState
     | CrNumAlive Int
   deriving (Eq,Ord)
 
-data WorldTrigger
-    = ResetLevel Int
-  deriving (Eq,Ord)
-
 data Button = Button 
     { _btPict :: Picture
     , _btPos :: Point2
@@ -434,12 +432,14 @@ data Wall
         , _wlIsSeeThrough :: Bool
         }
     | Door 
-        { _wlLine :: [Point2] , _wlID :: Int 
+        { _wlLine :: [Point2] 
+        , _wlID :: Int 
         , _doorMech :: World -> World
         , _wlColor :: Color
         , _wlSeen :: Bool
         , _wlIsSeeThrough :: Bool
         , _doorPathable :: Bool
+        , _drPositions :: DS.DS [Point2]
         }
     | Block 
         { _wlLine :: [Point2]

src/Dodge/Data.hs.orig

@@ -616,7 +616,7 @@ data PSType = PutCrit Creature
     | PutAutoDoor Point2 Point2
     | PutBlock [Int] Color [Point2]
     | PutLineBlock Wall Float Float Point2 Point2
-    | PutTriggerDoor Color (World -> Bool) Point2 Point2
+    | PutDoubleDoor Color (World -> Bool) Point2 Point2
     | PutBtDoor Color Point2 Float Point2 Point2
     | PutSwitchDoor Color Point2 Float Point2 Point2
     | RandPS (State StdGen PSType)

src/Dodge/Default.hs

@@ -16,6 +16,7 @@ import Dodge.Config.Data
 import Dodge.Config.KeyConfig
 import Geometry
 import Picture
+import qualified DoubleStack as DS
 
 import Control.Lens
 import System.Random
@@ -44,6 +45,7 @@ defaultAutoDoor = Door
     , _wlSeen = False
     , _wlIsSeeThrough = False
     , _doorPathable = True
+    , _drPositions = DS.singleton [(0,0),(50,0)]
     }
 {-
 Non-pathable door.
@@ -56,6 +58,7 @@ defaultDoor = Door
     , _wlSeen = False
     , _wlIsSeeThrough = False
     , _doorPathable = False
+    , _drPositions = DS.singleton [(0,0),(50,0)]
     }
 defaultCreature :: Creature
 defaultCreature = Creature

src/Dodge/Floor.hs

@@ -12,6 +12,7 @@ import Dodge.Room.Link
 import Dodge.Room.Door
 import Dodge.Room.Branch
 import Dodge.Room.Boss
+import Dodge.Room.Airlock
 import Dodge.Base
 import Dodge.Layout
 import Dodge.Layout.Tree.Polymorphic
@@ -41,8 +42,12 @@ roomTreex = do
     let t' = padCorridors struct
         t = treeFromTrunk 
             [[StartRoom]
+            ,[Corridor]
+            ,[SpecificRoom $ (pure . pure . Right) $ airlockCrystal 20]
+            ,[Corridor]
             ,[DoorAno]
-                ,[SpecificRoom $ fmap (pure . Right) $ randomiseAllLinks =<< centerVaultRoom 1 200 200 50]
+            ,[SpecificRoom $ fmap (pure . Right) 
+                $ randomiseLinksBy shuffleTail =<< centerVaultRoom 1 200 200 50]
             ,[SpecificRoom blockedCorridor]
             ,[OrAno [[DoorAno]
                     ,[Corridor]
@@ -52,7 +57,8 @@ roomTreex = do
             ,[Corridor]
             ,[SpecificRoom $ fmap (pure . Right) testRoom]
             ,[Corridor]
-                ,[OrAno [[SpecificRoom $ branchRectWith $ fmap (pure . Left) armouredChasers]
+            ,[OrAno 
+                [[SpecificRoom $ branchRectWith $ fmap (pure . Left) armouredChasers]
                 ,[BossAno $ addArmour launcherCrit & crHP +~ 800
                     & crState . crDropsOnDeath .~ DropSpecific [0] ]
                 ]

src/Dodge/Layout/Tree/Annotate.hs

@@ -15,6 +15,7 @@ import Dodge.Room.Boss
 import Dodge.Room.Treasure
 import Dodge.Room.Link
 import Dodge.Room.Data
+import Dodge.Room.Airlock
 import Dodge.Room
 import Dodge.Room.Teleport
 
@@ -71,7 +72,7 @@ annoToRoomTree [OrAno as] = do
     annoToRoomTree a
 annoToRoomTree [Corridor] = pure . Right <$> randomiseOutLinks corridor
 annoToRoomTree [DoorAno] = roomThenCorridor door
-annoToRoomTree [DoorNumAno i,AirlockAno] = roomThenCorridor (airlock i)
+annoToRoomTree [DoorNumAno i,AirlockAno] = airlock i >>=  roomThenCorridor
 annoToRoomTree [FirstWeapon] = do
     branchWP <- branchRectWith weaponRoom
     blockedC <- longBlockedCorridor

src/Dodge/LevelGen.hs

@@ -61,10 +61,16 @@ placeSpot ps w = case ps of
         -> placePressPlate pp p rot w
     PS {_psType = RandPS rgen} 
         -> placeSpot (set psType evaluatedType ps) (set randGen g w)
-        where (evaluatedType, g) = runState rgen (_randGen w)
+      where 
+            (evaluatedType, g) = runState rgen (_randGen w)
 
-    PS {_psPos = p, _psRot = rot, _psType = PutTriggerDoor col f a b} 
+    PS {_psPos = p, _psRot = rot, _psType = PutDoor col f pss} 
-        -> addTriggerDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
+        -> putDoor col f (map (mapBoth $ shiftPointBy (p,rot)) pss) w
+      where 
+        mapBoth fn (x,y) = (fn x, fn y) 
+
+    PS {_psPos = p, _psRot = rot, _psType = PutDoubleDoor col f a b} 
+        -> putDoubleDoor col f (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w
 
     PS {_psPos = p, _psRot = rot, _psType = PutAutoDoor a b} 
         -> addAutoDoor (shiftPointBy (p,rot) a) (shiftPointBy (p,rot) b) w

src/Dodge/LevelGen/AutoDoor.hs

@@ -10,6 +10,7 @@ import Dodge.SoundLogic
 import Dodge.Creature.Property
 import Geometry
 import Picture
+import qualified DoubleStack as DS
 
 import Data.List
 import Data.Maybe
@@ -85,6 +86,7 @@ autoDoorPane (trigx,trigy) n closedPos openPos = Door
     , _wlSeen = False
     , _wlIsSeeThrough = False
     , _doorPathable = True
+    , _drPositions = DS.singleton closedPos
     }
   where 
     a = closedPos !! 0

src/Dodge/LevelGen/Data.hs

@@ -17,7 +17,8 @@ data PSType = PutCrit Creature
     | PutAutoDoor Point2 Point2
     | PutBlock [Int] Color [Point2]
     | PutLineBlock Wall Float Float Point2 Point2
-    | PutTriggerDoor Color (World -> Bool) Point2 Point2
+    | PutDoubleDoor Color (World -> Bool) Point2 Point2
+    | PutDoor Color (World -> Bool) [(Point2,Point2)]
     | PutBtDoor Color Point2 Float Point2 Point2
     | PutSwitchDoor Color Point2 Float Point2 Point2
     | RandPS (State StdGen PSType)

src/Dodge/LevelGen/TriggerDoor.hs

@@ -6,17 +6,15 @@ import Dodge.Base
 import Dodge.SoundLogic
 import Dodge.LevelGen.Switch
 import Dodge.LevelGen.Pathing
-
 import Picture
 import Geometry
+import qualified DoubleStack as DS
 
 import Data.List
 import Data.Maybe
 import qualified Data.IntMap.Strict as IM
-
 import Control.Lens
 import Control.DeepSeq (deepseq)
-
 import Data.Graph.Inductive hiding ((&))
 import Data.Graph.Inductive.NodeMap
 
@@ -26,7 +24,7 @@ addButtonDoor c btp btr a b w = over buttons (IM.insert bid bt)
     $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
     $ set pathGraph newGraph
     $ set pathGraph' newGraphPairs
-    $ addTriggerDoor c cond a b w
+    $ putDoubleDoor c cond a b w
   where 
     bid = newKey $ _buttons w
     cond w = BtNoLabel == _btState (_buttons w IM.! bid)
@@ -44,7 +42,7 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
     $ set pathPoints (foldr insertPoint IM.empty (labNodes newGraph))
     $ set pathGraph newGraph
     $ set pathGraph' newGraphPairs
-    $ addTriggerDoor c cond a b w
+    $ putDoubleDoor c cond a b w
   where 
     bid = newKey $ _buttons w
     cond w = BtOn == _btState (_buttons w IM.! bid)
@@ -59,17 +57,48 @@ addSwitchDoor c btp btr a b w = over buttons (IM.insert bid bt)
     closeDoor w' = over pathGraph' (\\ removedPairs)
                   . over pathGraph (flip run_ $ delMapEdgesM removedPairs) $ w'
 
-addTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
-addTriggerDoor c cond a b = over walls (triggerDoor c cond a b)
 
-triggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> IM.IntMap Wall -> IM.IntMap Wall
+putDoor 
-triggerDoor c cond a b wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond a b is
+    :: Color 
+    -> (World -> Bool) 
+    -> [(Point2,Point2)]   -- ^ Door positions, closed to open.
+                    -- Bumped out up and down by 9, not widened
+    -> World 
+    -> World
+putDoor c cond pss = over walls triggerDoor
   where
-    i = newKey wls
+    triggerDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoor c cond pss is
-    is = [i..]
+      where
+        is = [newKey wls..]
 
-mkTriggerDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
+putDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> World -> World
-mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
+putDoubleDoor c cond a b = over walls triggerDoubleDoor
+  where
+    triggerDoubleDoor wls = IM.union wls $ IM.fromList $ zip is $ mkTriggerDoubleDoor c cond a b is
+      where
+        is = [newKey wls..]
+
+mkTriggerDoor 
+    :: Color 
+    -> (World -> Bool)      -- ^ Opening condition
+    -> [(Point2,Point2)]    -- ^ List of wall position pairs, closed to open
+    -> [Int]                -- ^ Wall ids
+    -> [Wall]
+mkTriggerDoor c cond ppairs is = zipWith (triggerDoorPane c cond) is $
+    transpose $ map toPanePoints ppairs
+
+toPanePoints :: (Point2,Point2) -> [[Point2]]
+toPanePoints (x,y) = 
+    [ [y +.+ perp, y -.- perp]
+    , [y -.- perp, x -.- perp]
+    , [x -.- perp, x +.+ perp]
+    , [x +.+ perp, y +.+ perp]
+    ]
+  where
+    perp = 9 *.* errorNormalizeV 49 ( vNormal (x -.- y))
+
+mkTriggerDoubleDoor :: Color -> (World -> Bool) -> Point2 -> Point2 -> [Int] -> [Wall]
+mkTriggerDoubleDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPaneLinear c cond)
     xs
     (leftDoor ++ rightDoor)
     (map shiftLeft leftDoor ++ map shiftRight rightDoor)
@@ -106,8 +135,14 @@ mkTriggerDoor c cond pl pr xs = addSound $ zipWith3 (triggerDoorPane c cond)
       where 
         wp = _wlLine (_walls w IM.! head xs) !! 1
 
-triggerDoorPane :: Color -> (World -> Bool) -> Int -> [Point2] -> [Point2] -> Wall
+triggerDoorPaneLinear
-triggerDoorPane c cond n closedPos openPos = Door
+    :: Color 
+    -> (World -> Bool)  -- ^ Opening condition
+    -> Int              -- ^ Wall id
+    -> [Point2]         -- ^ Closed position
+    -> [Point2]         -- ^ Open position
+    -> Wall
+triggerDoorPaneLinear c cond n closedPos openPos = Door
     { _wlLine = closedPos
     , _wlID = n
     , _doorMech = dm
@@ -115,6 +150,7 @@ triggerDoorPane c cond n closedPos openPos = Door
     , _wlSeen = False
     , _wlIsSeeThrough = False
     , _doorPathable = False
+    , _drPositions = DS.singleton closedPos
     }
   where 
     a = closedPos !! 0
@@ -135,3 +171,40 @@ triggerDoorPane c cond n closedPos openPos = Door
           = over wallsZone $ adjustIMZone openDoor x y n
     changeZonedWall' (!x,!y) 
           = over wallsZone $ adjustIMZone closeDoor x y n
+
+{- |
+Zoning might be an issue here.
+It is necessary in the current version, but I am not sure of its behaviour. -}
+triggerDoorPane
+    :: Color 
+    -> (World -> Bool)  -- ^ Opening condition
+    -> Int              -- ^ Wall id
+    -> [[Point2]]       -- ^ List of positions: closed to open
+    -> Wall
+triggerDoorPane c cond n poss = Door
+    { _wlLine = head poss
+    , _wlID = n
+    , _doorMech = dm
+    , _wlColor = c
+    , _wlSeen = False
+    , _wlIsSeeThrough = False
+    , _doorPathable = False
+    , _drPositions = DS.fromListL poss
+    }
+  where 
+    dm w | cond w    = flip (foldr changeZonedWall) allZoneps
+                       $ over walls (IM.adjust openDoor n) w -- . wlLine . ix 0) (mvPointToward a')
+         | otherwise = flip (foldr changeZonedWall') allZoneps
+                       $ over walls (IM.adjust closeDoor n) w -- . wlLine . ix 0) (mvPointToward a)
+    openDoor  = updatePos . (drPositions %~ DS.pushL)
+    closeDoor = updatePos . (drPositions %~ DS.pushR)
+    updatePos :: Wall -> Wall
+    updatePos d = d & wlLine %~ maybe id const (DS.head <$> (d ^? drPositions))
+    changeZonedWall (!x,!y) 
+          = over wallsZone $ adjustIMZone openDoor x y n
+    changeZonedWall' (!x,!y) 
+          = over wallsZone $ adjustIMZone closeDoor x y n
+    allZoneps = nub $ concatMap zoneps poss
+    zoneps [a,b]
+        | dist a b <= 2 * zoneSize = [zoneOfPoint $ pHalf a b]
+        | otherwise = map zoneOfPoint $ divideLine (2*zoneSize) a b

src/Dodge/RandomHelp.hs

@@ -41,7 +41,7 @@ takeN :: RandomGen g => Int -> [a] -> State g [a]
 takeN 0 xs = return []
 takeN i xs = fmap fst $ takeNMore i ([],xs)
 
--- to randomly shuffle a list
+-- | Randomly shuffle a list.
 shuffle :: RandomGen g => [a] -> State g [a]
 shuffle xs = do 
     let l = length xs
@@ -51,6 +51,10 @@ shuffle xs = do
     let (_,zs) = mapAccumR f xs rands
     return zs
 
+-- | Randomly shuffle the tail of a list, not safe.
+shuffleTail :: RandomGen g => [a] -> State g [a]
+shuffleTail (x:xs) = (x :) <$> shuffle xs
+
 randomSelectionFromList :: RandomGen g => Float -> [a] -> State g [a]
 randomSelectionFromList p = filterM $ const $ randProb p
 

src/Dodge/Render.hs

@@ -51,53 +51,43 @@ doDrawing pdata w = do
         viewFroms@(viewFromx,viewFromy) = _cameraViewFrom w
         pic = worldPictures w
         wallPoints = map fst wallPointsCol
-
     -- set the coordinate uniforms ready for drawing elements with using world coordinates
     setCommonUniforms pdata rot zoom trans wins
     depthFunc $= Just Less
     pmat <- (newMatrix RowMajor $ perspectiveMatrix rot zoom trans wins viewFroms) 
         :: IO (GLmatrix GLfloat)
-
     -- draw the lightmap. Probably changes the bound framebufferObject
     createLightMap pdata (w ^. config . shadow_resolution) wallPoints lightPoints viewFroms pmat
-
     -- draw the background. Assumes that depth testing is not enabled or that
     -- the depth buffer is ready to be drawn on
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
     renderBackground pdata rot zoom trans wins
-
     -- draw the walls
     depthFunc $= Just Less
     if w ^. config . wall_textured
         then renderTextureWalls pdata wallPointsCol pmat
         else renderBlankWalls pdata wallPointsCol pmat
-
     -- I believe a more apt name would be setCeilingDepth: stops drawing of objects
     -- at points that are behind the extension of walls to the screen edge
     setWallDepth pdata wallPoints (viewFromx,viewFromy) pmat
-
     -- draw the first layer of pictures
     -- these will probably all be opaque
     renderFoldable pdata $ picToLTree (Just 0) pic
-
     -- reset blend so that light map doesn't apply
     -- useful for drawing vivid projectiles
     blendFuncSeparate $= ((SrcAlpha,OneMinusSrcAlpha) , (Zero,One))
     depthFunc $= Just Lequal
     renderFoldable pdata $ picToLTree (Just 1) pic
-
     -- reset blend so that light map applies again
     -- allows us to be certain these elements are drawn on top of those before,
     -- in case we want transparency effects
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
     renderFoldable pdata $ picToLTree (Just 2) pic
     depthMask $= Disabled
-
     -- render transparent walls
     -- the ordering between these and transparent clouds perhaps presents a challenge
     renderBlankWalls pdata windowPoints pmat
     depthMask $= Enabled
-
     -- draw the fbo to the screen
     -- allows for post-processing
     -- first, bind the screen fbo
@@ -108,20 +98,23 @@ doDrawing pdata w = do
     textureBinding Texture2D $= Just (snd $ _fbo2 pdata)
 --    textureFilter Texture2D $= ((Linear',Just Linear') , Linear')
 --    generateMipmap' Texture2D
+    if _crHP (you w) > 0 
+        then do
             bindShaderBuffers [_fullscreenShader pdata] [4]
             drawShader (_fullscreenShader pdata) 4
+        else do
+            bindShaderBuffers [_grayscaleShader pdata] [4]
+            drawShader (_grayscaleShader pdata) 4
     blend $= Enabled
-
     -- reset the coordinate uniforms for pictures that are drawn wrt to window
     -- coordinates
     resetShaderUniforms (map extractProgAndUnis $ _pictureShaders pdata)
-
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
     renderFoldable pdata (picToLTree Nothing $ fixedCoordPictures w)
     eTicks <- SDL.ticks
     return (eTicks - sTicks)
 
-----------------------
+--------------------------------------------------------------------------------
 
 renderBlankWalls 
     :: RenderData 

src/Dodge/Room.hs

@@ -27,6 +27,7 @@ import Dodge.Room.Corridor
 import Dodge.Room.Link
 import Dodge.Room.Branch
 import Dodge.Room.Door
+import Dodge.Room.Airlock
 import Geometry
 import Picture
 
@@ -47,53 +48,6 @@ import Data.Graph.Inductive.NodeMap
 import qualified Data.Map as M
 import qualified Data.IntMap.Strict as IM
 
-airlockOneWay :: Int -> Room
-airlockOneWay n = Room
-    { _rmPolys = [rectNSWE 90 0 0 40]
-    , _rmLinks = lnks
-    , _rmPath  = []
-    , _rmPS    = [PS (0,15) 0 $ PutTriggerDoor col (not . cond) (0,0) (0,40)
-                 ,PS (0,75) 0 $ PutTriggerDoor col (cond)       (0,0) (0,40)
-                 ,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState 
-                                                                 (M.insert (DoorNumOpen n) True))
-                 ]
-    --, _rmBound = rectNSWE 90 30 (-30) 30
-    , _rmBound = rectNSWE 75 15 0 40
-    }
-    where lnks = [((0,85),0)
-                 ,((0, 5),pi)
-                 ]
-          cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
-          col = dim $ dim $ bright red
-
-airlock 
-    :: Int  -- ^ Door id
-    -> Room
-airlock n = Room
-    { _rmPolys =
-        [ rectNSWE 100 0 0 40
-        , rectNSWE 65 35 (-40) 20
-        ]
-    , _rmLinks = lnks
-    , _rmPath  = [((20,85),(20,45))
-                 ,((20,45),(20, 5))
-                 ]
-    , _rmPS    = 
-        [PS (0,20) 0 $ PutTriggerDoor col (not . cond) (1,0) (39,0)
-        ,PS (0,80) 0 $ PutTriggerDoor col (cond)       (1,0) (39,0)
-        ,PS (35,50) (pi/2) $ PutButton $ makeSwitch col 
-                           (over worldState (M.insert (DoorNumOpen n) True))
-                           (over worldState (M.insert (DoorNumOpen n) False))
-        ,PS (-25, 50) 0 putLamp
-        ]
-    , _rmBound = rectNSWE 75 15 0 40
-    }
-  where 
-    lnks = [((20,85),0)
-           ,((20, 5),pi)
-           ]
-    cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
-    col = dim $ dim $ bright red
 
 roomC :: Float -> Float -> Room
 roomC x y = Room
@@ -633,4 +587,5 @@ spawnerRoom = do
                  ]
     let f ((lx,_),_) = lx < x/2-5 
     roomWithSpawner <- (fmap connectRoom . randomiseOutLinks) =<< filterLinks f (set rmPS plmnts $ roomRect x y 2 2) 
-    return $ treeFromTrunk [Left (airlock 0)] roomWithSpawner
+    aRoom <- airlock 0
+    return $ treeFromTrunk [Left aRoom] roomWithSpawner

src/Dodge/Room/Airlock.hs

@@ -0,0 +1,157 @@
+{-# LANGUAGE TupleSections #-}
+{-
+Rooms that contain two doors and a switch alternating both.  -}
+module Dodge.Room.Airlock
+    where
+import Dodge.Room.Data
+import Dodge.Room.Placement
+import Dodge.Data
+import Dodge.LevelGen.Data
+import Dodge.LevelGen.Switch
+import Dodge.RandomHelp
+import Geometry
+import Picture
+
+import qualified Data.Map as M
+import System.Random
+import Control.Monad.State
+import Control.Lens
+
+airlockOneWay :: Int -> Room
+airlockOneWay n = Room
+    { _rmPolys = [rectNSWE 90 0 0 40]
+    , _rmLinks = lnks
+    , _rmPath  = []
+    , _rmPS    = [PS (0,15) 0 $ PutDoubleDoor col (not . cond) (0,0) (0,40)
+                 ,PS (0,75) 0 $ PutDoubleDoor col (cond)       (0,0) (0,40)
+                 ,PS (35,45) (pi/2) $ PutButton $ makeButton col (over worldState 
+                                                                 (M.insert (DoorNumOpen n) True))
+                 ]
+    --, _rmBound = rectNSWE 90 30 (-30) 30
+    , _rmBound = rectNSWE 75 15 0 40
+    }
+    where lnks = [((0,85),0)
+                 ,((0, 5),pi)
+                 ]
+          cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
+          col = dim $ dim $ bright red
+
+{- |
+A passage with a switch that opens forward access while closing backwards access. -}
+airlock 
+    :: RandomGen g
+    => Int  -- ^ Door id
+    -> State g Room
+airlock n = takeOne [airlock0 n,airlock90 n,airlockCrystal n]
+
+{- |
+Straight airlock -}
+airlock0 
+    :: Int -- ^ Door id
+    -> Room
+airlock0 n = Room
+    { _rmPolys =
+        [ rectNSWE 100 0 0 40
+        , rectNSWE 65 35 (-40) 20
+        ]
+    , _rmLinks = lnks
+    , _rmPath  = [((20,95),(20,45))
+                 ,((20,45),(20, 5))
+                 ]
+    , _rmPS    = 
+        [PS (0,20) 0 $ PutDoubleDoor col (not . cond) (1,0) (39,0)
+        ,PS (0,80) 0 $ PutDoubleDoor col (cond)       (1,0) (39,0)
+        ,PS (35,50) (pi/2) $ PutButton $ makeSwitch col 
+                           (over worldState (M.insert (DoorNumOpen n) True))
+                           (over worldState (M.insert (DoorNumOpen n) False))
+        ,PS (-25, 50) 0 putLamp
+        ]
+    , _rmBound = rectNSWE 75 15 0 40
+    }
+  where 
+    lnks = [((20,95),0)
+           ,((20, 5),pi)
+           ]
+    cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
+    col = dim $ dim $ bright red
+
+airlock90 
+    :: Int -- ^ Door id
+    -> Room
+airlock90 n = Room
+    { _rmPolys =
+        [ rectNSWE 100 10 10 100
+        , rectNSWE 20  0  20 60
+        , rectNSWE 20  60 20 0
+        ,   [ (10,100)
+            , (100,150)
+            , (150,100)
+            , (100,10)
+            ]
+        ]
+    , _rmLinks =
+         [((0,40),pi/2)
+         ,((40, 0),pi)
+         ]
+    , _rmPath  = 
+         [((0,40),(40,0))
+         ,((40,0),(0,40))
+         ]
+    , _rmPS    = 
+        [PS (5,5) 0 $ PutDoor col (not . cond) pss
+        ,PS (120,120) (3* pi/4) $ PutButton $ makeSwitch col 
+            (over worldState (M.insert (DoorNumOpen n) True))
+            (over worldState (M.insert (DoorNumOpen n) False))
+        ,PS (60, 60) 0 putLamp
+        ]
+    , _rmBound = 
+        [ (10,10)
+        , (10,100)
+        , (100,150)
+        , (150,100)
+        , (100,10)
+        ]
+    }
+  where 
+    cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
+    col = dim $ dim $ bright red
+    pss = ((0,0) ,) <$> arcStepwise 3 (negate $ pi/2) (0,0) (0,55)
+
+airlockCrystal
+    :: Int -- ^ Door id
+    -> Room
+airlockCrystal n = Room
+    { _rmPolys =
+        [ rectNSWE 140 0 0 40
+        , orderPolygon
+            [(39,20)
+            ,(150,60)
+            ,(150,80)
+            ,(39,120)
+            ]
+        ]
+    , _rmLinks =
+         [((20,130),0)
+         ,((20, 0),pi)
+         ]
+    , _rmPath  = 
+         [
+         ]
+    , _rmPS    = 
+        [PS (0,0) 0 $ PutDoor col (not . cond) pss
+        ,PS (145,70) (pi/2) $ PutButton $ makeSwitch col 
+            (over worldState (M.insert (DoorNumOpen n) True))
+            (over worldState (M.insert (DoorNumOpen n) False))
+        ,crystalLine (0,70) (40,70)
+        ,PS (20, 40) 0 putLamp
+        ,PS (20, 100) 0 putLamp
+        ]
+    , _rmBound = 
+        [         ]
+    }
+  where 
+    cond w = or $ M.lookup (DoorNumOpen n) (_worldState w)
+    col = dim $ dim $ bright red
+    pss :: [(Point2,Point2)]
+    pss = reverse $ fmap ( (\x -> ((50,x),(50,x+50)) ) . fromIntegral)
+            [20,22..70]

src/Dodge/Room/Door.hs

@@ -22,3 +22,5 @@ door = Room
     where lnks = [((20,35),0)
                  ,((20, 5),pi)
                  ]
+
+

src/Dodge/Room/Link.hs

@@ -30,6 +30,15 @@ randomiseAllLinks r = do
     newLinks <- shuffle $ _rmLinks r
     return $ r {_rmLinks = newLinks}
 
+randomiseLinksBy 
+    :: RandomGen g 
+    => ( [(Point2,Float)] -> State g [(Point2,Float)] )
+    -> Room
+    -> State g Room
+randomiseLinksBy f r = do
+    newLinks <- f $ _rmLinks r
+    return $ r {_rmLinks = newLinks}
+
 filterLinks :: RandomGen g => ((Point2,Float) -> Bool) -> Room -> State g Room
 filterLinks cond r = do
     newLinks <- shuffle $ filter cond $ init $ _rmLinks r

src/Dodge/Room/Procedural.hs

@@ -260,6 +260,10 @@ 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) 
@@ -269,7 +273,7 @@ centerVaultRoom n w h d = do
   where
     col = dim $ dim $ bright red
     theDoor i = 
-        [ PS (0,d-10) 0 $ PutTriggerDoor col (cond i) (-19,0) (19,0)
+        [ PS (0,d-10) 0 $ PutDoubleDoor col (cond i) (-19,0) (19,0)
         , PS (35,d+4) 0 $ PutButton $ makeSwitch col 
                            (over worldState (M.insert (DoorNumOpen i) True))
                            (over worldState (M.insert (DoorNumOpen i) False))

src/Dodge/Room/Teleport.hs

@@ -4,6 +4,7 @@ Specification of rooms that teleport (between levels).
 module Dodge.Room.Teleport
     where
 import Dodge.Data
+import Dodge.World.Trigger.Data
 import Dodge.Base
 import Dodge.Room.Data
 import Dodge.Room.Procedural

src/Dodge/Update.hs

@@ -7,6 +7,7 @@ module Dodge.Update
     ) where
 import Dodge.Data
 import Dodge.Data.Menu
+import Dodge.World.Trigger.Data
 import Dodge.Config.Data
 import Dodge.Data.Menu
 import Dodge.Base
@@ -35,26 +36,19 @@ pushSideEffects :: World -> World
 pushSideEffects w = w 
     & sideEffects .~ []
     & doneSideEffects .~ _sideEffects w
-
+{- | 
-{- | The update step.
+ The update step.
-If '_menuLayers' is not empty, or the saving screen, this is the identity.
+For most menus the only way to change the world is using event handling.  -}
-In such 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
-    (_ : _) -> w    
+    (GameOverMenu : _) -> updateParticles 
-    []  ->  let w1 = updateParticles 
         . updateProjectiles 
         . updateLightSources
-                    . zoneClouds
+        $ updateClouds
-                    . updateClouds
+        w
-                    . updateCreatures 
+    (_ : _) -> w
-                    . updateBlocks -- . zoning 
+    []  -> checkEndGame 
-                    . updateSeenWalls 
-                    . updateSoundQueue
-                    $ updateCloseObjects w
-            in  checkEndGame 
         . updateTriggers
         . ppEvents 
         . updateCamera
@@ -63,7 +57,17 @@ update' w = case _menuLayers w of
         . zoneCreatures 
         . updateWalls
         . set worldEvents id 
-                    $ _worldEvents w1 w1
+        . doubleArgumentFor _worldEvents
+        . updateParticles 
+        . updateProjectiles 
+        . updateLightSources
+        . zoneClouds
+        . updateClouds
+        . updateCreatures 
+        . updateBlocks
+        . updateSeenWalls 
+        . updateSoundQueue
+        $ updateCloseObjects w
   where 
     zoneCreatures = set creaturesZone (IM.foldr creatureInZone IM.empty (_creatures w))
     creatureInZone cr = insertIMInZone x y cid cr
@@ -73,17 +77,18 @@ update' w = case _menuLayers w of
     cloudInZone cr = insertIMInZone x y cid cr
       where (x,y) = zoneOfPoint $ _clPos cr
             cid = _clID cr
+    doubleArgumentFor f x = f x x
 
 updateTriggers :: World -> World
 updateTriggers w 
-    | ResetLevel 1 `S.member` _worldTriggers w
+    | ResetLevel 1 `S.member` _worldTriggers w = generateFromList levx $ initialWorld 
-        = generateFromList levx
-            $ initialWorld 
         & randGen       .~ _randGen w
         & config        .~ _config w
         & menuLayers    .~ []
-                & creatures . ix 0 . crPos .~ (0,0)
+        & creatures . ix 0 .~ cr
     | otherwise = w
+  where
+    cr = _creatures w IM.! 0 & crPos .~ (0,0)
 
 updateSoundQueue = set soundQueue [] . set sounds M.empty
 
@@ -93,10 +98,8 @@ updateLightSources w = set tempLightSources (catMaybes tlss) w'
     (w',tlss) = mapAccumR (\a b -> _tlsUpdate b a b) w $ _tempLightSources w
 
 updateProjectiles w = IM.foldr' _pjUpdate w $ _projectiles w
-
 {-
-Apply internal particle updates, delete 'Nothing's.
+Apply internal particle updates, delete 'Nothing's.  -}
- -}
 updateParticles :: World -> World
 updateParticles w = set particles (catMaybes ps) w'
   where 
@@ -105,12 +108,11 @@ updateParticles w = set particles (catMaybes ps) w'
 updateCreatures :: World -> World
 updateCreatures w = f $ set randGen newG $ set creatures (IM.mapMaybe id crs) w
   where 
-    ((f,newG),crs) = IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) 
+    ((f,newG),crs) = 
-                        $ _creatures w
+        IM.mapAccum (\g' cr -> _crUpdate cr w g' cr) (id,_randGen w) $ _creatures w
 
 {- |
-Apply door mechanisms.
+Apply door mechanisms.  -}
- -}
 updateWalls :: World -> World
 updateWalls w = IM.foldr (maybe id id . (^? doorMech)) w (_walls w)
 
@@ -127,29 +129,34 @@ updateSeenWalls w = foldr markSeen w wallsToUpdate
 
 setTestStringIO :: IO World -> IO World
 setTestStringIO = fmap (\ w -> set testString (show $ s w) w)
-    where s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
+  where 
+    s w = (-.-) <$> (w ^? creatures . ix 0 . crPos) <*> (w ^? creatures . ix 0 . crOldPos)
 
 checkEndGame :: World -> World
-checkEndGame w | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]}
+checkEndGame w 
+    | _crHP (you w) < 1 = haltSound $ w {_menuLayers = [GameOverMenu]}
     | otherwise         = w
 
 updateClouds :: World -> World
 updateClouds w = IM.foldr' updateCloud w $ _clouds w 
 
 updateCloud :: Cloud -> World -> World
-updateCloud c w | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c)
+updateCloud c w 
+    | _clTimer c < 1 = w & clouds %~ IM.delete (_clID c)
     | otherwise = moveCloud c w
 
 moveCloud :: Cloud -> World -> World
 moveCloud c w = _clEffect c c . theUpdate $ w
-    where newVel = 0.95 *.* springVels
+  where 
+    newVel = 0.95 *.* springVels
     springVels = IM.foldr' (clClSpringVel c w) (_clVel c) (cloudsNearPoint oldPos w)
     oldPos = _clPos c
     newPos = oldPos +.+ newVel
     hitWl = collideCircWalls' oldPos newPos 5 $ wallsNearPoint newPos w
     finalPos = fromMaybe newPos (fmap fst hitWl)
     finalVel = fromMaybe newVel (fmap snd hitWl)
-          theUpdate w' = w' & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1)
+    theUpdate w' = w' 
+        & clouds . ix (_clID c) . clTimer %~ (\t -> t - 1)
         & clouds . ix (_clID c) . clVel .~ finalVel
         & clouds . ix (_clID c) . clPos .~ finalPos
 
@@ -158,7 +165,8 @@ clClSpringVel a w b v
     | ida == idb = v
     | dist pa pb < radDist = v +.+ 0.1 *.* (safeNormalizeV (pa -.- pb))
     | otherwise = v
-    where ida = _clID a
+  where 
+    ida = _clID a
     idb = _clID b
     pa = _clPos a
     pb = _clPos b
@@ -169,7 +177,8 @@ simpleCrSprings w = IM.foldr' crSpring w $ _creatures w
 
 crSpring :: Creature -> World -> World
 crSpring c w = IM.foldr' (crCrSpring c) w $ cs
-    where cs = creaturesNearPoint (_crPos c) w
+  where 
+    cs = creaturesNearPoint (_crPos c) w
 
 crCrSpring :: Creature -> Creature -> World -> World
 crCrSpring c1 c2 w 
@@ -178,7 +187,8 @@ crCrSpring c1 c2 w
     | diff < comRad = over (creatures . ix id1 . crPos) (+.+ overlap1)
                         $ over (creatures . ix id2 . crPos) (-.- overlap2) w
     | otherwise = w
-         where id1  = _crID c1
+  where 
+    id1  = _crID c1
     id2  = _crID c2
     vec  = _crPos c1 -.- _crPos c2
     diff = magV $ vec
@@ -186,10 +196,8 @@ crCrSpring c1 c2 w
     overlap1 = ((comRad - diff) * _crMass c2 * 0.5 / massT) *.* errorNormalizeV 55 vec
     overlap2 = ((comRad - diff) * _crMass c1 * 0.5 / massT) *.* errorNormalizeV 56 vec
     massT    = _crMass c1 + _crMass c2
-
 {-
-Finds the IDs of visible walls from a point to another point.
+Finds the IDs of visible walls from a point to another point.  -}
--}
 visibleWalls :: Point2 -> Point2 -> IM.IntMap Wall -> [Int]
 visibleWalls p1 p2 ws 
     = map fst 
@@ -201,8 +209,10 @@ visibleWalls p1 p2 ws
     $ IM.toList ws
   where 
     f (i,wl) = (intersectSegSeg' (_wlLine wl !! 0) (_wlLine wl !! 1) p1 p2, (i,wl))
-    takeUntil h xs = let (ys,zs) = span h xs
+    takeUntil h xs = 
+        let (ys,zs) = span h xs
         in ys ++ tf zs
-      where tf (x:_) = [x]
+      where 
+        tf (x:_) = [x]
         tf _ = []
 

src/Dodge/World.hs

@@ -0,0 +1,6 @@
+{- |
+Placeholder... not sure of its purpose, but might deal with pure world change functions.
+The world datatype itself is very intertwined with the creature, weapon, etc datatypes.
+ -}
+module Dodge.World
+    where

src/Dodge/World/Trigger/Data.hs

@@ -0,0 +1,12 @@
+{- |
+World triggers are intended to help me handle global events, 
+such as new levels, game overs, etc, that disrupt the typical flow of the game.
+They should probably be used sparingly.
+ -}
+module Dodge.World.Trigger.Data
+    where
+
+data WorldTrigger
+    = ResetLevel Int
+    | GameOver
+  deriving (Eq,Ord)

src/DoubleStack.hs

@@ -0,0 +1,33 @@
+module DoubleStack
+    where
+
+newtype DS a = DS (a,[a],[a])
+    deriving (Eq, Ord, Read, Show)
+
+{- |
+Unsafe. -}
+fromListL :: [a] -> DS a
+fromListL (x:xs) = DS (x,xs,[])
+
+singleton :: a -> DS a
+singleton x = DS (x,[],[])
+
+head (DS (x,_,_)) = x
+left (DS (_,l,_)) = l
+right (DS (_,_,r)) = r
+
+pushL :: DS a -> DS a
+pushL (DS (x,xs,(y:ys))) = DS (y,(x:xs),ys)
+pushL ds = ds
+
+pushR :: DS a -> DS a
+pushR (DS (y,(x:xs),ys)) = DS (x,xs,(y:ys))
+pushR ds = ds
+
+cycleL :: DS a -> Maybe (DS a)
+cycleL (DS (x,xs,(y:ys))) = Just $ DS (y,(x:xs),ys)
+cycleL _ = Nothing
+
+cycleR :: DS a -> Maybe (DS a)
+cycleR (DS (y,(x:xs),ys)) = Just $ DS (x,xs,(y:ys))
+cycleR _ = Nothing

src/Geometry.hs

@@ -461,6 +461,29 @@ divideCircle x cen rad = map (cen +.+) $ nRaysRad n rad
   where 
     n = ceiling $ rad * 2 * pi / x
 
+arcStepwise
+    :: Float    -- ^ Maximum distance between points
+    -> Float    -- ^ Angle to travel
+    -> Point2   -- ^ Center
+    -> Point2   -- ^ Start vector from center
+    -> [Point2]
+arcStepwise ssize a c v
+    | a < 0 = reverse $ arcStepwisePositive ssize (negate a) c (rotateV a v)
+    | otherwise = arcStepwisePositive ssize a c v
+
+arcStepwisePositive
+    :: Float    -- ^ Maximum distance between points
+    -> Float    -- ^ Angle to travel, assumed to be positive
+    -> Point2   -- ^ Center
+    -> Point2   -- ^ Start vector from center
+    -> [Point2]
+arcStepwisePositive ssize a cen v = ((cen +.+) . (\rot -> rotateV rot v) ) <$> rots
+  where
+    rots :: [Float]
+    rots = map ((a*) . (/ fromIntegral n ) . fromIntegral) [0 .. n]
+    n :: Int
+    n = ceiling (a * magV v / ssize)
+
 --nPointsOnCirc :: Int -> Float -> [Point2]
 --nPointsOnCirc n rad = take n $ iterate (rotateV (2*pi/fromIntegral n)) (rad,0)