Cleanup, fix menu lock on restarting level after game over

src/Dodge/Combine.hs

@@ -23,8 +23,9 @@ import Data.Maybe
 import Data.List (scanl',sortOn)
 
 combinationsTrie :: Trie (Int,CombineType) Item
-combinationsTrie = foldr (uncurry insertInTrie) emptyTrie
+combinationsTrie = foldr (uncurry insertInTrie . first (sortOn snd)) 
-    $ map (first (sortOn snd)) itemCombinations
+    emptyTrie
+    itemCombinations
 
 -- this can probably be improved by going through accessing the combinations
 -- trie going through each combine type in your inventory in order, rather than
@@ -34,7 +35,7 @@ lookupItems' :: [(CombineType,Int,Int)] -> [ ([Int],Item) ]
 lookupItems' xs = lookupItems (sortOn (\(ct,_,_) -> ct) xs) combinationsTrie
 
 lookupItems :: [(CombineType,Int,Int)] -> Trie (Int,CombineType) Item -> [ ([Int],Item) ]
-lookupItems [] t = maybeToList $ fmap ([],) $ _trieMVal t
+lookupItems [] t = maybeToList $ ([],) <$> _trieMVal t
 lookupItems ((ct,i,n):xs) t = do
     n' <- [1..min n 4]
     let is = replicate n' i

src/Dodge/Creature/Inanimate.hs

@@ -13,6 +13,7 @@ import Dodge.WorldEvent.Explosion
 import Dodge.Creature.Picture
 --import Dodge.Creature.Stance.Data
 import Dodge.Picture.Layer
+import Dodge.Particle.Spark
 import Dodge.Default
 import Dodge.Creature.State
 import Dodge.LightSource
@@ -26,7 +27,6 @@ import Geometry
 --import Geometry.Vector3D
 import Polyhedra
 import Shape
-import Dodge.WorldEvent
 import Dodge.SoundLogic
 
 import System.Random

src/Dodge/Creature/YourControl.hs

@@ -34,7 +34,7 @@ wasdWithAiming
 wasdWithAiming w speed i cr
     | isAiming 
         = addAnyTwist $ set crDir mouseDir $ theMovement cr
-    | (isReloading && SDL.ButtonRight `S.member` _mouseButtons w)
+    | isReloading && SDL.ButtonRight `S.member` _mouseButtons w
         = addAnyTwist $ set crDir (mouseDir + anytwist) $ theMovement cr
     | otherwise = theMovement $ theTurn $ removeTwist cr
   where 

src/Dodge/Data.hs

@@ -105,7 +105,6 @@ data World = World
     , _pathGraph            :: ~(Gr Point2 Float)
     , _pathGraphP           :: ~[(Point2,Point2)]
     , _pathPoints           :: ~(IM.IntMap (IM.IntMap [(Int,Point2)]))
-    , _worldFlags           :: S.Set WorldFlag
     , _carteDisplay         :: !Bool
     , _carteCenter          :: !Point2
     , _carteZoom            :: !Float
@@ -273,10 +272,6 @@ data CrMvType
         , _mvTurnJit    :: Float
         , _mvAimSpeed   :: Float -> Float
         }
-data WorldFlag
-    = ResetLevel Int
-    | GameOver
-  deriving (Eq,Ord)
 data Button = Button 
     { _btPict :: Button -> SPic
     , _btPos :: Point2

src/Dodge/Default/World.hs

@@ -57,7 +57,6 @@ defaultWorld = World
     , _decorations = IM.empty
     --, _savedWorlds = M.empty
 --    , _menuLayers = []
-    , _worldFlags = S.empty
     , _clickMousePos = V2 0 0
     , _pathGraph = Data.Graph.Inductive.Graph.empty
     , _pathGraphP = []

src/Dodge/Event.hs

@@ -128,7 +128,7 @@ wheelEvent y w = case (_carteDisplay w, _inventoryMode w) of
     (_, TopInventory)
             -- functions that modify the inventory should be centralised so that
             -- this lock can be sensibly applied, perhaps
-        | _crInvLock (_creatures w IM.! (_yourID w)) -> w
+        | _crInvLock (_creatures w IM.! _yourID w) -> w
         | rbDown -> case yourItem w ^? _Just . itScroll of
             Nothing -> closeObjScrollDir y w
             Just f  -> w & creatures . ix 0 . crInv . ix (_crInvSel $ you w) %~ f y (you w)

src/Dodge/Item/Random.hs

@@ -7,4 +7,4 @@ import Control.Monad.State
 import System.Random
 
 randBlockBreakWeapon :: RandomGen g => State g Item
-randBlockBreakWeapon = takeOne [pistol,ltAutoGun,spreadGun,autoGun]
+randBlockBreakWeapon = takeOne [bangStick 1,bangCane]

src/Dodge/Item/Weapon/BulletGun/Cane.hs

@@ -102,9 +102,9 @@ bangCaneX i = bangCane
             ,_muzPos    = 15
             }
         , _dimSPic = \it -> noPic $ 
-            (colorSH red $ foldMap 
+            colorSH red (foldMap 
-            (\y ->  upperPrismPoly 3 $ map (+.+ V2 0 y) $ rectXH 15 2)
+            ((\y ->  upperPrismPoly 3 $ map (+.+ V2 0 y) $ rectXH 15 2)
-            $ map (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5)) [0..i-1]
+             . (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5))) [0..i-1]
             ) <> caneClipX i it
         }
     } & itUse . useAim . aimSpeed .~ 0.4
@@ -124,8 +124,9 @@ caneStickSoundChoice it
 caneClipX :: Int -> Item -> Shape
 caneClipX i it = case  it ^? itConsumption . ammoLoaded of
     Just la | la > 0 -> foldMap 
-            (\y -> translateSH (V3 5 0 3) . upperPrismPoly 1 $ map (+.+ V2 0 y) $ square 1.5)
+            ( (\y -> translateSH (V3 5 0 3) . upperPrismPoly 1 $ map (+.+ V2 0 y) $ square 1.5)
-            $ map (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5)) [0..la-1]
+            . (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5))) 
+            [0..la-1]
     _ -> mempty
            
 

src/Dodge/LightSource.hs

@@ -9,13 +9,13 @@ module Dodge.LightSource
     , lsPosCol
     , lsPosRad
     , lsColPosID
+    , makeTlsTimeRadColPos 
     )
     where
 import Dodge.Data
 import Geometry.Data
 import Dodge.Default
-
+import LensHelp
-import Control.Lens
 
 lsPosRad :: Point3 -> Float -> LightSource
 lsPosRad = lsColPosRad 0.75
@@ -83,3 +83,6 @@ tlsTimeRadColPos t rmax col (V3 x y z) = TLS
         | _tlsTime tls <= 0 = Nothing
         | otherwise         = Just $ tls    
             & tlsTime -~ 1
+
+makeTlsTimeRadColPos :: Int -> Float -> Point3 -> Point3 -> World -> World
+makeTlsTimeRadColPos i rad (V3 r g b) p = tempLightSources .:~ tlsTimeRadColPos i rad (V3 r g b) p

src/Dodge/Menu.hs

@@ -4,8 +4,7 @@ module Dodge.Menu
     , pushScreen
     , pauseMenu
     , gameOverMenu
-    )
+    ) where
-    where
 import LensHelp
 import Dodge.Menu.OptionType
 import Dodge.Menu.PushPop
@@ -22,8 +21,8 @@ import Dodge.LevelGen
 --import Control.Lens
 import System.Random
 
-slTitleOptions :: String -> [MenuOption] -> ScreenLayer
+pauseMenu :: ScreenLayer
-slTitleOptions title ops = slTitleOptionsEff title ops (popScreen . writeConfig)
+pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause)
 
 slTitleOptionsEff :: String -> [MenuOption] -> (Universe -> IO (Maybe Universe)) -> ScreenLayer
 slTitleOptionsEff title ops eff = OptionScreen
@@ -33,6 +32,18 @@ slTitleOptionsEff title ops eff = OptionScreen
     , _scOptionFlag = NormalOptions
     }
 
+pauseMenuOptions :: [MenuOption]
+pauseMenuOptions =
+    [ Toggle ScancodeN (return . startNewGame) (const "NEW LEVEL")
+    , Toggle ScancodeR (return . Just . loadSaveSlot LevelStartSlot) (const "RESTART")
+    , Toggle ScancodeO (pushScreen optionMenu ) (const "OPTIONS")
+    , Toggle ScancodeC (pushScreen displayControls) (const "CONTROLS")
+    , InvisibleToggle ScancodeEscape (return . const Nothing)
+    ]
+
+slTitleOptions :: String -> [MenuOption] -> ScreenLayer
+slTitleOptions title ops = slTitleOptionsEff title ops (popScreen . writeConfig)
+
 optionMenu :: ScreenLayer
 optionMenu = slTitleOptionsEff "OPTIONS" optionsOptions popScreen
 
@@ -69,7 +80,6 @@ gameplayMenuOptions =
     , makeBoolOption ScancodeS show_sound     "SHOW VISUAL SOUNDS"
     ]
 
-
 soundMenu :: ScreenLayer
 soundMenu = slTitleOptions
     "OPTIONS:VOLUME"
@@ -114,17 +124,6 @@ gameOverMenu = OptionScreen
     , _scOptionFlag = GameOverOptions
     }
 
-pauseMenu :: ScreenLayer
-pauseMenu = slTitleOptionsEff "PAUSED" pauseMenuOptions (return . unpause)
-
-pauseMenuOptions :: [MenuOption]
-pauseMenuOptions =
-    [ Toggle ScancodeN (return . startNewGame) (const "NEW LEVEL")
-    , Toggle ScancodeR (return . Just . loadSaveSlot LevelStartSlot) (const "RESTART")
-    , Toggle ScancodeO (pushScreen optionMenu ) (const "OPTIONS")
-    , Toggle ScancodeC (pushScreen displayControls) (const "CONTROLS")
-    , InvisibleToggle ScancodeEscape (return . const Nothing)
-    ]
 startNewGame :: Universe -> Maybe Universe
 startNewGame w = Just $ w
     & menuLayers .~ [WaitScreen (const "GENERATING...") 1]

src/Dodge/Particle/Spark.hs

@@ -1,6 +1,7 @@
 module Dodge.Particle.Spark
     ( colSpark
     , colSpark'
+    , createBarrelSpark
     )
     where
 import Dodge.Data
@@ -9,10 +10,31 @@ import Dodge.Particle.Bullet.Update
 import Dodge.WorldEvent.HitEffect
 import Color
 import Geometry
+import LensHelp
 
 import System.Random
-import Control.Lens
+--import Control.Lens
 
+createBarrelSpark :: Point2 -> Float -> Maybe Int -> Int -> Int -> World -> World
+createBarrelSpark pos dir maycid time colid w = w 
+    & instantParticles .:~ spark
+  where 
+    spark = BulletPt  
+        { _ptDraw = drawBul
+        , _ptUpdate = mvBullet
+        , _btVel' = rotateV dir (V2 5 0)
+        , _btDrag = 0.9
+        , _btColor' = numColor colid
+        , _btTrail' = [pos]
+        , _btPassThrough' = maycid
+        , _btWidth' = 1
+        , _btTimer' = time
+        , _btHitEffect' = destroyOnImpact sparkEff noEff
+        }
+    sparkEff bt p cr = creatures . ix (_crID cr) . crState . crDamage .:~ SparkDam 1 sp p ep
+      where 
+        sp = head (_btTrail' bt)
+        ep = sp +.+ _btVel' bt
 colSpark :: Int -> Color -> Point2 -> Float -> World -> World
 colSpark = colSpark' 0.7
 colSpark' :: Float -> Int -> Color -> Point2 -> Float -> World -> World

src/Dodge/Room/Start.hs

@@ -65,13 +65,13 @@ room2 :: RandomGen g => Int -> State g (SubCompTree Room)
 room2 = lasCenSensEdge    
 
 startRoom :: RandomGen g => Int -> State g (SubCompTree Room)
-startRoom _ = join $ uncurry takeOneWeighted $ unzip 
+startRoom i = join $ uncurry takeOneWeighted $ unzip 
-    [ (,) (0.5::Float) $ chainUses <$> sequence [minigunFakeout,weaponRoom]
+--    [ (,) (0.5::Float) $ chainUses <$> sequence [minigunFakeout,weaponRoom]
---    , (,) 1 rezBoxesWp
+    [ (,) (1::Float) rezBoxesWp
---    , (,) 1 rezBoxesThenWeaponRoom
+    , (,) 1 rezBoxesThenWeaponRoom
---    , (,) 1 rezBoxThenWeaponRoom
+    , (,) 1 rezBoxThenWeaponRoom
---    , (,) 1 rezBoxesWpCrit
+    , (,) 1 rezBoxesWpCrit
---    , (,) 1 $ runPastStart i
+    , (,) 1 $ runPastStart i
     ]
 
 runPastStart :: RandomGen g => Int -> State g (SubCompTree Room)

src/Dodge/Save.hs

@@ -2,8 +2,7 @@ module Dodge.Save
     ( saveWorldInEmptySlot
     , loadSaveSlot
     , doQuicksave
-    )
+    ) where
-  where
 import Dodge.Data
 
 import qualified Data.Map.Strict as M
@@ -20,7 +19,9 @@ saveWorldInSlot :: SaveSlot -> Universe -> Universe
 saveWorldInSlot slot w = w & savedWorlds %~ M.insert slot (clearKeys (_uvWorld w))
 
 loadSaveSlot :: SaveSlot -> Universe -> Universe
-loadSaveSlot slot u = maybe u (\w -> u & uvWorld .~ w) $ M.lookup slot (_savedWorlds u) 
+loadSaveSlot slot u = maybe u 
+    (\w -> u & menuLayers .~ [] & uvWorld .~ w) 
+    $ M.lookup slot (_savedWorlds u) 
 
 doQuicksave :: Universe -> Universe
 doQuicksave = saveWorldInSlot QuicksaveSlot

src/Dodge/Update.hs

@@ -6,6 +6,7 @@ module Dodge.Update
     ( updateUniverse
     ) where
 import Dodge.Data
+import Dodge.Menu
 import Dodge.Hammer
 import Dodge.Block
 import Dodge.Distortion
@@ -24,27 +25,26 @@ import Data.Maybe
 import Data.Function
 import qualified Data.IntMap.Strict as IM
 import qualified Data.Map.Strict as M
+--import qualified Data.Set as S
 import Control.Lens
 import Data.Monoid
 import System.Random
 
+{- For most menus the only way to change the world is using event handling.  -}
 updateUniverse :: Universe -> Universe
-updateUniverse w = case _menuLayers w of
+updateUniverse u = case _menuLayers u of
---    (TerminalScreen t xs:mls) -> w & menuLayers .~ (TerminalScreen (max (t-1) 0) xs:mls)
     (WaitScreen s i : _) 
-        | i < 1     -> w & over uvWorld (dbArg _worldEvents)
+        | i < 1     -> u & over uvWorld (dbArg _worldEvents)
-        | otherwise -> w & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
+        | otherwise -> u & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
-    (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> 
+    (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~
-       -- updateParticles 
+        ( updateParticles 
-       -- . updateProjectiles 
+        . updateProjectiles 
-       -- . updateLightSources
+        . updateLightSources
-       -- $ updateClouds
+        . updateClouds )
-        w
+    (_ : _) -> u
-    (_ : _) -> w
+    []  -> over uvWorld (functionalUpdate (_config u)) u 
-    []  -> over uvWorld (functionalUpdate (_config w)) w 
 
-{- | The update step.
+{- | The update step. -}
-For most menus the only way to change the world is using event handling.  -}
 functionalUpdate :: Configuration -> World -> World
 functionalUpdate cfig w = checkEndGame 
     . (worldClock +~ 1)
@@ -176,7 +176,7 @@ markWallSeen w wl = w { _walls = IM.adjust mw (_wlID wl) $ _walls w }
 
 checkEndGame :: World -> World
 checkEndGame w 
-    | _crHP (you w) < 1 = undefined -- haltSound $ w {_menuLayers = [gameOverMenu]}
+    | _crHP (you w) < 1 = w & sideEffects %~ ( . (menuLayers .~ [gameOverMenu]))
     | otherwise         = w
 
 updateClouds :: World -> World

src/Dodge/World.hs

@@ -2,5 +2,4 @@
 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
+module Dodge.World where
-    where

src/Dodge/WorldEvent.hs

@@ -1,61 +1,14 @@
 module Dodge.WorldEvent
-    ( module Dodge.WorldEvent
+    ( module Dodge.WorldEvent.Flash
-    , module Dodge.WorldEvent.Flash
     , module Dodge.WorldEvent.ThingsHit
     , module Dodge.WorldEvent.Cloud
     , module Dodge.WorldEvent.HitEffect
     , module Dodge.WorldEvent.Explosion
     , module Dodge.WorldEvent.SpawnParticle
-    )
+    ) where
-    where
-import Dodge.Particle.Bullet.Draw
-import Dodge.Particle.Bullet.Update
 import Dodge.WorldEvent.Flash
 import Dodge.WorldEvent.ThingsHit
 import Dodge.WorldEvent.Cloud
 import Dodge.WorldEvent.HitEffect
 import Dodge.WorldEvent.Explosion
 import Dodge.WorldEvent.SpawnParticle
-import Dodge.LightSource
-import Dodge.Creature.State.Data
-import Dodge.Data
-import Geometry
-import Color
-import LensHelp
-
---import Control.Lens
-import System.Random
-import qualified Data.IntMap.Strict as IM
-
-createBarrelSpark :: Point2 -> Float -> Maybe Int -> Int -> Int -> World -> World
-createBarrelSpark pos dir maycid time colid w = w 
-    & worldEvents %~ (( over particles (spark :) . sparkFlashAt pos') . )
-  where 
-    spark = BulletPt  
-        { _ptDraw = drawBul
-        , _ptUpdate = mvBullet
-        , _btVel' = rotateV dir (V2 5 0)
-        , _btDrag = 0.9
-        , _btColor' = numColor colid
-        , _btTrail' = [pos]
-        , _btPassThrough' = maycid
-        , _btWidth' = 1
-        , _btTimer' = time
-        , _btHitEffect' = destroyOnImpact sparkEff noEff
-        }
-    x = fst $ randomR (0,20) $ _randGen w
-    pos' = pos +.+ rotateV dir (V2 x 0)
-    sparkEff bt p cr = creatures . ix (_crID cr) . crState . crDamage .:~ SparkDam 1 sp p ep
-      where 
-        sp = head (_btTrail' bt)
-        ep = sp +.+ _btVel' bt
-
-damCrsOnLine :: Int -> Point2 -> Point2 -> World -> World
-damCrsOnLine dam p1 p2 = creatures %~ IM.map damIfOnLine
-  where 
-    damIfOnLine cr 
-        | circOnSeg p1 p2 (_crPos cr) (_crRad cr) = cr & crHP -~ dam
-        | otherwise                               = cr
-
-makeTlsTimeRadColPos :: Int -> Float -> Point3 -> Point3 -> World -> World
-makeTlsTimeRadColPos i rad (V3 r g b) p = tempLightSources .:~ tlsTimeRadColPos i rad (V3 r g b) p

src/Dodge/WorldEvent/Flash.hs

@@ -9,8 +9,7 @@ glow    : continuous, potentially long, fading, slow changes in alpha
 flicker : potentially long, moving, abrupt changes in alpha
 -}
 module Dodge.WorldEvent.Flash
-    ( sparkFlashAt
+    ( explosionFlashAt
-    , explosionFlashAt
     , laserGunFlashAt
     , teslaGunFlashAt
     , muzFlareAt
@@ -64,9 +63,6 @@ explosionFlashAt p = tempLightSources .:~ tlsTimeRadFunPos 20 150 intensityFunc
         | x < 10 = 1 / (10 - fromIntegral x)
         | otherwise = 1
 
-sparkFlashAt :: Point2 -> World -> World
-sparkFlashAt _ = id
-
 flameFlicker :: Particle -> World -> World
 flameFlicker pt 
     | _btTimer' pt `mod` 5 == 0 = tempLightSources .:~ theLight

src/SimpleTrie.hs

@@ -16,7 +16,7 @@ singletonTrie (k:ks) x = Trie Nothing $ singleton k $ singletonTrie ks x
 singletonTrie [] x = Trie (Just x) empty
 
 insertInTrie :: Ord a => [a] -> b -> Trie a b -> Trie a b
-insertInTrie [] x      = trieMVal .~ Just x
+insertInTrie [] x      = trieMVal ?~ x
 insertInTrie (k:ks) x  = trieChildren %~ insertWith f k (singletonTrie ks x)
   where
     f _ = insertInTrie ks x