Cleanup creature picture

src/Dodge/Menu.hs

@@ -1,7 +1,6 @@
 module Dodge.Menu
     where
 import Dodge.Data
-import Dodge.Data.Menu
 import Dodge.Config.Data
 import Dodge.Config.Update
 import SDL
@@ -11,38 +10,37 @@ import Dodge.Floor
 import Dodge.Initialisation
 import Preload.Update
 import Dodge.Base.Window
+import Dodge.SoundLogic
+import Picture
+import Geometry
 
 import Control.Lens
 import Data.Maybe
-
-data MenuOption 
-    = Toggle
-        { _moKey    :: Scancode
-        , _moEff    :: World -> Maybe World
-        , _moString :: World -> String
-        }
-    | Toggle2
-        { _moKey1   :: Scancode
-        , _moEff1   :: World -> Maybe World
-        , _moKey2   :: Scancode
-        , _moEff2   :: World -> Maybe World
-        , _moString :: World -> String
-        }
-    | InvisibleToggle
-        { _moKey    :: Scancode
-        , _moEff    :: World -> Maybe World
-        }
+optionMenu :: ScreenLayer
+optionMenu = OptionScreen
+    { _scTitle = const "OPTIONS"
+    , _scOptions = optionsOptions
+    , _scDefaultEff = popScreen
+    , _scOptionFlag = NormalOptions
+    }
 optionsOptions :: [MenuOption]
 optionsOptions =
-    [ Toggle ScancodeV (pushMenu SoundOptionMenu) (const "VOLUME")
-    , Toggle ScancodeG (pushMenu GraphicsOptionMenu) (const "GRAPHICS")
+    [ Toggle ScancodeV (pushScreen soundMenu) (const "VOLUME")
+    , Toggle ScancodeG (pushScreen graphicsMenu) (const "GRAPHICS")
     ]
 levelMenuOptions :: [MenuOption]
 levelMenuOptions =
     [  InvisibleToggle ScancodeEscape (const Nothing)
-    ,  InvisibleToggle ScancodeO        (pushMenu OptionMenu)
-    ,  InvisibleToggle ScancodeC        (pushMenu ControlList)
+    ,  InvisibleToggle ScancodeO      (pushScreen optionMenu)
+    ,  InvisibleToggle ScancodeC      (pushScreen displayControls)
     ]
+soundMenu :: ScreenLayer
+soundMenu = OptionScreen
+    { _scTitle = const "OPTIONS:VOLUME"
+    , _scOptions = soundMenuOptions
+    , _scDefaultEff = popScreen . writeConfig
+    , _scOptionFlag = NormalOptions
+    }
 soundMenuOptions :: [MenuOption]
 soundMenuOptions =
     [ Toggle2 ScancodeY (master dec . sw)
@@ -65,9 +63,22 @@ soundMenuOptions =
     muvol w = f $ _volume_music  $ cfig w
     f x = show (round $ 10 * x :: Int)
 
-pushMenu :: MenuLayer -> World -> Maybe World
-pushMenu ml w'   = Just $ w' & menuLayers %~ (ml :)
+pushScreen :: ScreenLayer -> World -> Maybe World
+pushScreen ml w = Just $ w & menuLayers %~ (ml :)
 
+popScreen :: World -> Maybe World
+popScreen = Just . (menuLayers %~ tail)
+
+writeConfig :: World -> World
+writeConfig w = w & sideEffects %~ (saveConfig (_config w) :)
+
+graphicsMenu :: ScreenLayer
+graphicsMenu = OptionScreen
+    { _scTitle = const "OPTIONS:GRAPHICS"
+    , _scOptions = graphicsMenuOptions
+    , _scDefaultEff = popScreen . writeConfig
+    , _scOptionFlag = NormalOptions
+    }
 graphicsMenuOptions :: [MenuOption]
 graphicsMenuOptions =
     [ Toggle ScancodeW (Just . (config . wall_textured %~ not))  wtextstring
@@ -86,18 +97,32 @@ cycleResolution 2 = 4
 cycleResolution 4 = 1
 cycleResolution _ = 1
 
+gameOverMenu :: ScreenLayer
+gameOverMenu = OptionScreen
+    { _scTitle = const "GAME OVER"
+    , _scOptions = pauseMenuOptions
+    , _scDefaultEff = Just
+    , _scOptionFlag = GameOverOptions
+    }
+
+pauseMenu :: ScreenLayer
+pauseMenu = OptionScreen
+    { _scTitle = const "PAUSED"
+    , _scOptions = pauseMenuOptions
+    , _scDefaultEff = unpause
+    , _scOptionFlag = NormalOptions
+    }
 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")
+    , Toggle ScancodeO (pushScreen optionMenu ) (const "OPTIONS")
+    , Toggle ScancodeC (pushScreen displayControls) (const "CONTROLS")
     , InvisibleToggle ScancodeEscape (const Nothing)
     ]
-
 startNewGame :: World -> Maybe World
 startNewGame w = Just $ w
-    & menuLayers .~ [WaitMessage "GENERATING..." 1]
+    & menuLayers .~ [WaitScreen (const "GENERATING...") 1]
     & worldEvents .~ const aNewGame
   where
     aNewGame :: World
@@ -118,3 +143,56 @@ updateFramebufferSize w = w & sideEffects
   where 
     (x,y) = (round $ getWindowX w, round $ getWindowY w)
     divRes = w ^. config . resolution_factor
+
+levelMenu :: Int -> ScreenLayer
+levelMenu x = OptionScreen
+    { _scTitle = const $ "LEVEL "++ show x 
+    , _scOptions = levelMenuOptions
+    , _scDefaultEff = unpause . storeLevel
+    , _scOptionFlag = NormalOptions
+    }
+unpause :: World -> Maybe World
+unpause w = Just . resumeSound $ w {_menuLayers = []}
+
+storeLevel :: World -> World
+storeLevel w = case _storedLevel w of
+    Nothing -> w & storedLevel ?~ w
+    _       -> w
+
+displayControls :: ScreenLayer
+displayControls = DisplayScreen
+    {_scDisplay = \w -> pictures 
+        [color (withAlpha 0.5 black) $ polygon $ screenBox w
+        ,tst (-100) 100 0.4 "CONTROLS"
+        ,controlsList
+        ]
+    }
+  where
+    tst x y sc t = translate x y $ scale sc sc $ color white $ text t
+
+controlsList :: Picture
+controlsList = pictures $ concat $ zipWith butAndEff
+    [("wasd",           "movement")
+    ,("[rmb]",          "aim")
+    ,("[rmb+lmb]",      "shoot or use item")
+    ,("[wheelscroll]" , "select item"  )
+    ,("[space]" ,       "pickup item"  )
+    ,("m" ,             "display map"    )
+    ,("f" ,             "drop item"    )
+    ,("c[esc]" ,        "pause"        )
+    ,("qe" ,       "rotate camera")
+    ]
+    [60,30..]
+  where
+    butAndEff (btext,etext) y = 
+        [translate (-250) y $ scale 0.15 0.15 $ color white $ text btext
+        ,translate     0  y $ scale 0.15 0.15 $ color white $ text etext
+        ]
+
+screenBox 
+    :: World
+    -> [Point2]
+screenBox w = rectNSEW hh (-hh) hw (-hw)
+  where
+    hw = halfWidth w
+    hh = halfHeight w