Cleanup, fix menu lock on restarting level after game over

2021-12-06 23:44:10 +00:00
parent 19540bd19e
commit 763b771928
18 changed files with 88 additions and 119 deletions
@@ -23,8 +23,9 @@ import Data.Maybe
 import Data.List (scanl',sortOn)

 combinationsTrie :: Trie (Int,CombineType) Item
-combinationsTrie = foldr (uncurry insertInTrie) emptyTrie
-    $ map (first (sortOn snd)) itemCombinations
+combinationsTrie = foldr (uncurry insertInTrie . first (sortOn snd)) 
+    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
@@ -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
@@ -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 
@@ -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
@@ -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 = []
@@ -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)
@@ -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]
@@ -102,9 +102,9 @@ bangCaneX i = bangCane
            ,_muzPos    = 15
            }
        , _dimSPic = \it -> noPic $ 
-            (colorSH red $ foldMap 
-            (\y ->  upperPrismPoly 3 $ map (+.+ V2 0 y) $ rectXH 15 2)
-            $ map (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5)) [0..i-1]
+            colorSH red (foldMap 
+            ((\y ->  upperPrismPoly 3 $ map (+.+ V2 0 y) $ rectXH 15 2)
+             . (\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)
-            $ map (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5)) [0..la-1]
+            ( (\y -> translateSH (V3 5 0 3) . upperPrismPoly 1 $ map (+.+ V2 0 y) $ square 1.5)
+            . (\k -> fromIntegral k * 5 - ((fromIntegral i - 1) * 2.5))) 
+            [0..la-1]
    _ -> mempty
           

@@ -9,13 +9,13 @@ module Dodge.LightSource
    , lsPosCol
    , lsPosRad
    , lsColPosID
+    , makeTlsTimeRadColPos 
    )
    where
 import Dodge.Data
 import Geometry.Data
 import Dodge.Default
-
-import Control.Lens
+import LensHelp

 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
@@ -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
-slTitleOptions title ops = slTitleOptionsEff title ops (popScreen . writeConfig)
+pauseMenu :: ScreenLayer
+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]
@@ -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
@@ -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 
-    [ (,) (0.5::Float) $ chainUses <$> sequence [minigunFakeout,weaponRoom]
--    , (,) 1 rezBoxesWp
--    , (,) 1 rezBoxesThenWeaponRoom
--    , (,) 1 rezBoxThenWeaponRoom
--    , (,) 1 rezBoxesWpCrit
--    , (,) 1 $ runPastStart i
+startRoom i = join $ uncurry takeOneWeighted $ unzip 
+--    [ (,) (0.5::Float) $ chainUses <$> sequence [minigunFakeout,weaponRoom]
+    [ (,) (1::Float) rezBoxesWp
+    , (,) 1 rezBoxesThenWeaponRoom
+    , (,) 1 rezBoxThenWeaponRoom
+    , (,) 1 rezBoxesWpCrit
+    , (,) 1 $ runPastStart i
    ]

 runPastStart :: RandomGen g => Int -> State g (SubCompTree Room)
@@ -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
@@ -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
--    (TerminalScreen t xs:mls) -> w & menuLayers .~ (TerminalScreen (max (t-1) 0) xs:mls)
+updateUniverse u = case _menuLayers u of
    (WaitScreen s i : _) 
-        | i < 1     -> w & over uvWorld (dbArg _worldEvents)
-        | otherwise -> w & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
-    (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> 
-       -- updateParticles 
-       -- . updateProjectiles 
-       -- . updateLightSources
-       -- $ updateClouds
-        w
-    (_ : _) -> w
-    []  -> over uvWorld (functionalUpdate (_config w)) w 
+        | i < 1     -> u & over uvWorld (dbArg _worldEvents)
+        | otherwise -> u & menuLayers %~ ( (WaitScreen s (i-1) :) . tail )
+    (OptionScreen {_scOptionFlag = GameOverOptions} : _) -> u & uvWorld %~
+        ( updateParticles 
+        . updateProjectiles 
+        . updateLightSources
+        . updateClouds )
+    (_ : _) -> u
+    []  -> over uvWorld (functionalUpdate (_config u)) u 

-{- | The update step.
-For most menus the only way to change the world is using event handling.  -}
+{- | The update step. -}
 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
@@ -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
-    where
+module Dodge.World where
@@ -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
-import Dodge.Particle.Bullet.Draw
-import Dodge.Particle.Bullet.Update
+    ) where
 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
@@ -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
@@ -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