Unify option menu display and effects

2021-09-03 12:38:56 +01:00
parent 083000c103
commit 6a2df15d0d
5 changed files with 117 additions and 39 deletions
@@ -0,0 +1,66 @@
+module Dodge.Menu
+    where
+import Dodge.Data
+import Dodge.Data.Menu
+import Dodge.Config.Data
+import SDL
+import SDL.Internal.Numbered
+import Dodge.Layout
+import Dodge.Floor
+import Dodge.Initialisation
+import Preload.Update
+import Dodge.Base.Window
+
+import Control.Lens
+import Data.Maybe
+
+data MenuOption 
+    = Toggle
+        { _moKey    :: Scancode
+        , _moEffect :: World -> Maybe World
+        , _moString :: World -> String
+        }
+    | InvisibleToggle
+        { _moKey    :: Scancode
+        , _moEffect :: World -> Maybe World
+        }
+
+optionsOptions :: [MenuOption]
+optionsOptions =
+    [ Toggle ScancodeV (pushMenu SoundOptionMenu) (const "VOLUME")
+    , Toggle ScancodeG (pushMenu GraphicsOptionMenu) (const "GRAPHICS")
+    ]
+
+pushMenu ml w'   = Just $ w' & menuLayers %~ (ml :)
+
+pauseMenuOptions :: [MenuOption]
+pauseMenuOptions =
+    [ Toggle ScancodeN startNewGame (const "NEW LEVEL")
+    , Toggle ScancodeR (\w -> return $ fromMaybe w $ _storedLevel w) (const "RESTART")
+    , Toggle ScancodeO (pushMenu OptionMenu ) (const "OPTIONS")
+    , Toggle ScancodeC (pushMenu ControlList) (const "CONTROLS")
+    , InvisibleToggle ScancodeEscape (const Nothing)
+    ]
+
+startNewGame w = Just $ w
+        & menuLayers .~ [WaitMessage "GENERATING..." 1]
+        & worldEvents .~ const aNewGame
+  where
+    aNewGame :: World
+    aNewGame = updateFramebufferSize $ generateLevelFromRoomList levx $ initialWorld 
+        & randGen .~ _randGen w
+        & config .~ _config w
+
+-- | hacky
+scodeToChar :: Scancode -> Char
+scodeToChar = toEnum . (+ 61) . fromIntegral . toNumber
+
+charToScode :: Char -> Scancode
+charToScode = Scancode . fromIntegral . (\x -> x - 61) . fromEnum
+
+updateFramebufferSize :: World -> World
+updateFramebufferSize w = w & sideEffects 
+    %~ (pdataResizeUpdate (x `div` divRes) (y `div` divRes) x y : )
+  where 
+    (x,y) = (round $ getWindowX w, round $ getWindowY w)
+    divRes = w ^. config . resolution_factor