From 3a605b81564bd666c001c653e3a4094729332189 Mon Sep 17 00:00:00 2001 From: justin Date: Mon, 29 Nov 2021 01:02:15 +0000 Subject: [PATCH] Allow for events to do io --- src/Dodge/Base.hs | 13 +++---- src/Dodge/Data.hs | 2 +- src/Dodge/Event.hs | 28 +++++++------- src/Dodge/Event/Keyboard.hs | 16 ++++---- src/Dodge/Event/Menu.hs | 25 +++++++------ src/Dodge/Menu.hs | 64 +++++++++++++------------------- src/Dodge/Render.hs | 5 +-- src/Dodge/Render/HUD.hs | 41 ++++++++++---------- src/Dodge/Render/List.hs | 9 ++--- src/Dodge/Render/MenuScreen.hs | 32 ++++++++-------- src/Dodge/Render/Picture.hs | 18 ++++----- src/Dodge/Render/ShapePicture.hs | 2 +- src/Loop.hs | 14 ++++--- 13 files changed, 127 insertions(+), 142 deletions(-) diff --git a/src/Dodge/Base.hs b/src/Dodge/Base.hs index e802da967..ce7cf467b 100644 --- a/src/Dodge/Base.hs +++ b/src/Dodge/Base.hs @@ -9,7 +9,7 @@ import Dodge.Data import Dodge.WinScale import Dodge.Zone --import Dodge.Zone.Data -import Dodge.Base.Window +--import Dodge.Base.Window import Geometry --import Picture import qualified IntMapHelp as IM @@ -453,14 +453,11 @@ crInPolygon cr = pointInPolygon (_crPos cr) {- | Transform coordinates from world position to screen coordinates. -} worldPosToScreenNorm :: Configuration -> World -> Point2 -> Point2 -worldPosToScreenNorm cfig w = doWindowScale . doRotate . doZoom . doTranslate +worldPosToScreenNorm cfig w = doWindowScale cfig . doRotate . doZoom . doTranslate where - doTranslate p = p -.- _cameraCenter w - doZoom p = _cameraZoom w *.* p - doRotate p = rotateV (negate $ _cameraRot w) p - doWindowScale (V2 x y) = V2 - ( x * 2 / _windowX cfig) - ( y * 2 / _windowY cfig) + doTranslate p = p -.- _cameraCenter w + doZoom p = _cameraZoom w *.* p + doRotate p = rotateV (negate $ _cameraRot w) p {- | Transform world coordinates to scaled screen coordinates. - These have to be according to the size of the window to get actual screen positions. - This allows for line thicknesses etc to correspond to pixel sizes.-} diff --git a/src/Dodge/Data.hs b/src/Dodge/Data.hs index 5f0cf7d8b..667288184 100644 --- a/src/Dodge/Data.hs +++ b/src/Dodge/Data.hs @@ -133,7 +133,7 @@ data ScreenLayer = OptionScreen { _scTitle :: Universe -> String , _scOptions :: [MenuOption] - , _scDefaultEff :: Universe -> Maybe Universe -- IO (Maybe Universe)? + , _scDefaultEff :: Universe -> IO (Maybe Universe) -- IO (Maybe Universe)? , _scOptionFlag :: OptionScreenFlag } | ColumnsScreen String [(String,String)] diff --git a/src/Dodge/Event.hs b/src/Dodge/Event.hs index dea99002e..649039d0a 100644 --- a/src/Dodge/Event.hs +++ b/src/Dodge/Event.hs @@ -16,7 +16,7 @@ import Dodge.Event.Keyboard --import Dodge.Event.Menu import Dodge.Data import Dodge.Base -import Dodge.Base.Window +--import Dodge.Base.Window import Dodge.PreloadData --import Dodge.Creature.Action import Dodge.SoundLogic @@ -39,15 +39,15 @@ import SDL -- Nothing -> Nothing -- Just w -> Just $ uv & uvWorld .~ w -handleEvent :: Event -> Universe -> Maybe Universe +handleEvent :: Event -> Universe -> IO (Maybe Universe) handleEvent e = case eventPayload e of KeyboardEvent kev -> handleKeyboardEvent kev - MouseMotionEvent mmev -> handleMouseMotionEvent mmev - MouseButtonEvent mbev -> handleMouseButtonEvent mbev - MouseWheelEvent mwev -> handleMouseWheelEvent mwev - WindowSizeChangedEvent sev -> handleResizeEvent sev - WindowMovedEvent mev -> handleWindowMoveEvent mev - _ -> Just + MouseMotionEvent mmev -> return . handleMouseMotionEvent mmev + MouseButtonEvent mbev -> return . handleMouseButtonEvent mbev + MouseWheelEvent mwev -> return . handleMouseWheelEvent mwev + WindowSizeChangedEvent sev -> return . handleResizeEvent sev + WindowMovedEvent mev -> return . handleWindowMoveEvent mev + _ -> return . Just handleMouseMotionEvent :: MouseMotionEventData -> Universe -> Maybe Universe handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2 @@ -55,16 +55,15 @@ handleMouseMotionEvent mmev u = Just $ u & uvWorld . mousePos .~ V2 (0.5*_windowY cfig - fromIntegral y) where cfig = _config u - w = _uvWorld u P (V2 x y) = mouseMotionEventPos mmev handleMouseButtonEvent :: MouseButtonEventData -> Universe -> Maybe Universe handleMouseButtonEvent mbev u = case mouseButtonEventMotion mbev of - Released -> Just $ u & uvWorld . mouseButtons %~ S.delete but - Pressed -> handlePressedMouseButton but - (u & uvWorld . mouseButtons %~ S.insert but) + Released -> Just $ u & updateButtons S.delete + Pressed -> handlePressedMouseButton thebutton $ u & updateButtons S.insert where - but = mouseButtonEventButton mbev + thebutton = mouseButtonEventButton mbev + updateButtons f = uvWorld . mouseButtons %~ f thebutton {- | Sets window position in config. -} handleWindowMoveEvent :: WindowMovedEventData -> Universe -> Maybe Universe @@ -81,14 +80,13 @@ handleResizeEvent sev u = Just $ u & config . windowY .~ fromIntegral y & uvWorld . sideEffects %~ sideEffectUpdatePreload divRes x y where - w = _uvWorld u x = fromIntegral x' y = fromIntegral y' V2 x' y' = windowSizeChangedEventSize sev divRes = u ^. config . resolution_factor handlePressedMouseButton :: MouseButton -> Universe -> Maybe Universe -handlePressedMouseButton but w +handlePressedMouseButton but w | but == ButtonMiddle || _carteDisplay (_uvWorld w) = Just $ w & uvWorld . clickMousePos .~ _mousePos (_uvWorld w) | otherwise = Just w diff --git a/src/Dodge/Event/Keyboard.hs b/src/Dodge/Event/Keyboard.hs index abdc94754..661a5ce3e 100644 --- a/src/Dodge/Event/Keyboard.hs +++ b/src/Dodge/Event/Keyboard.hs @@ -22,21 +22,21 @@ On release, remove scancode from the 'Set' of pressed keys. On press, adds the scancode, and perhaps applies a direct effect: see 'handlePressedKeyInGame'. -} -handleKeyboardEvent :: KeyboardEventData -> Universe -> Maybe Universe +handleKeyboardEvent :: KeyboardEventData -> Universe -> IO (Maybe Universe) handleKeyboardEvent kev u = case keyboardEventKeyMotion kev of - Released -> Just $ u & uvWorld . keys %~ S.delete kcode + Released -> return . Just $ u & uvWorld . keys %~ S.delete kcode Pressed -> handlePressedKey (keyboardEventRepeat kev) kcode (u & uvWorld . keys %~ S.insert kcode) where kcode = (keysymScancode . keyboardEventKeysym) kev -handlePressedKey :: Bool -> Scancode -> Universe -> Maybe Universe -handlePressedKey True _ w = Just w -handlePressedKey _ ScancodeF5 w = Just $ doQuicksave w -handlePressedKey _ ScancodeF9 w = Just $ loadSaveSlot QuicksaveSlot w -handlePressedKey _ ScancodeSemicolon w = Just $ gotoTerminal w +handlePressedKey :: Bool -> Scancode -> Universe -> IO (Maybe Universe) +handlePressedKey True _ w = return $ Just w +handlePressedKey _ ScancodeF5 w = return . Just $ doQuicksave w +handlePressedKey _ ScancodeF9 w = return . Just $ loadSaveSlot QuicksaveSlot w +handlePressedKey _ ScancodeSemicolon w = return . Just $ gotoTerminal w handlePressedKey _ scode w - | null (_menuLayers w) = uvWorld (handlePressedKeyInGame scode) w + | null (_menuLayers w) = return $ uvWorld (handlePressedKeyInGame scode) w | otherwise = handlePressedKeyInMenu (head $ _menuLayers w) scode w handlePressedKeyInGame :: Scancode -> World -> Maybe World diff --git a/src/Dodge/Event/Menu.hs b/src/Dodge/Event/Menu.hs index 38cca279b..7af0deac4 100644 --- a/src/Dodge/Event/Menu.hs +++ b/src/Dodge/Event/Menu.hs @@ -7,30 +7,31 @@ import Dodge.Debug.Terminal import Dodge.Menu import Control.Monad -import Control.Lens +--import Control.Lens import SDL -handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> Maybe Universe +handlePressedKeyInMenu :: ScreenLayer -> Scancode -> Universe -> IO (Maybe Universe) handlePressedKeyInMenu mState scode = case mState of OptionScreen { _scOptions = mos, _scDefaultEff = defeff} -> optionListToEffects mos defeff scode - DisplayScreen {} -> popScreen - ColumnsScreen {} -> popScreen - WaitScreen {} -> Just + DisplayScreen {} -> return . popScreen + ColumnsScreen {} -> return . popScreen + WaitScreen {} -> return . Just InputScreen s -> case scode of - ScancodeEscape -> popScreen - ScancodeReturn -> popScreen . applyTerminalString s + ScancodeEscape -> return . popScreen + ScancodeReturn -> return . popScreen . applyTerminalString s ScancodeBackspace - -> popScreen >=> pushScreen (InputScreen $ dropLast s) - _ -> popScreen >=> pushScreen (InputScreen $ s ++ [scodeToChar scode]) + -> return . (popScreen >=> pushScreen (InputScreen $ dropLast s)) + _ -> return . (popScreen >=> pushScreen (InputScreen $ s ++ [scodeToChar scode])) where dropLast (x:xs) = init (x:xs) dropLast _ = [] -optionListToEffects :: [MenuOption] -> (Universe -> Maybe Universe) -> Scancode - -> Universe -> Maybe Universe + +optionListToEffects :: [MenuOption] -> (Universe -> IO (Maybe Universe)) -> Scancode + -> Universe -> IO (Maybe Universe) optionListToEffects mos defaulteff sc w = case lookup sc listEffects of Nothing -> defaulteff w - Just eff -> eff w + Just eff -> return $ eff w where listEffects = concatMap menuOptionToEffects mos diff --git a/src/Dodge/Menu.hs b/src/Dodge/Menu.hs index 0747305df..6d23f2df1 100644 --- a/src/Dodge/Menu.hs +++ b/src/Dodge/Menu.hs @@ -13,20 +13,24 @@ import Dodge.Config.Update import SDL import SDL.Internal.Numbered --import Preload.Update -import Dodge.Base.Window import Dodge.SoundLogic import Dodge.LevelGen import Control.Lens import System.Random -optionMenu :: ScreenLayer -optionMenu = OptionScreen - { _scTitle = const "OPTIONS" - , _scOptions = optionsOptions - , _scDefaultEff = popScreen +titleOptions title ops = titleOptionsEff title ops (return . popScreen . writeConfig) + +titleOptionsEff title ops eff = OptionScreen + { _scTitle = const title + , _scOptions = ops + , _scDefaultEff = eff , _scOptionFlag = NormalOptions } + +optionMenu :: ScreenLayer +optionMenu = titleOptionsEff "OPTIONS" optionsOptions (return . popScreen) + optionsOptions :: [MenuOption] optionsOptions = [ anOption ScancodeV soundMenu "VOLUME" @@ -37,12 +41,9 @@ optionsOptions = where anOption scode submenu t = Toggle scode (pushScreen submenu) (const t) debugMenu :: ScreenLayer -debugMenu = OptionScreen - { _scTitle = const "OPTIONS:GAMEPLAY" - , _scOptions = debugMenuOptions - , _scDefaultEff = popScreen . writeConfig - , _scOptionFlag = NormalOptions - } +debugMenu = titleOptions + "OPTIONS:GAMEPLAY" + debugMenuOptions debugMenuOptions :: [MenuOption] debugMenuOptions = [ doption ScancodeF debug_seconds_frame "SHOW SECONDS/FRAME" _debug_seconds_frame @@ -55,12 +56,10 @@ debugMenuOptions = doption scode l t rec = Toggle scode (Just . (config . l %~ not)) (\w -> t ++ ":" ++ show (rec $ _config w)) gameplayMenu :: ScreenLayer -gameplayMenu = OptionScreen - { _scTitle = const "OPTIONS:GAMEPLAY" - , _scOptions = gameplayMenuOptions - , _scDefaultEff = popScreen . writeConfig - , _scOptionFlag = NormalOptions - } +gameplayMenu = titleOptions + "OPTIONS:GAMEPLAY" + gameplayMenuOptions + gameplayMenuOptions :: [MenuOption] gameplayMenuOptions = [ option ScancodeR rotate_to_wall "ROTATE TO WALL" _rotate_to_wall @@ -71,12 +70,10 @@ gameplayMenuOptions = (\w -> t ++ ":" ++ show (rec $ _config w)) soundMenu :: ScreenLayer -soundMenu = OptionScreen - { _scTitle = const "OPTIONS:VOLUME" - , _scOptions = soundMenuOptions - , _scDefaultEff = popScreen . writeConfig - , _scOptionFlag = NormalOptions - } +soundMenu = titleOptions + "OPTIONS:VOLUME" + soundMenuOptions + soundMenuOptions :: [MenuOption] soundMenuOptions = [ Toggle2 ScancodeY (master dec . sw) @@ -89,7 +86,6 @@ soundMenuOptions = where dec x = max 0 (x - 0.1) inc x = min 1 (x + 0.1) - --sw w = w & sideEffects %~ (setVol (_config w) : ) sw w = w & uvWorld . sideEffects %~ setVolThen (_config w) master g = Just . (config . volume_master %~ g) soundEffs g = Just . (config . volume_sound %~ g) @@ -110,12 +106,8 @@ writeConfig :: Universe -> Universe writeConfig w = w & uvWorld . sideEffects %~ saveConfig (_config w) graphicsMenu :: ScreenLayer -graphicsMenu = OptionScreen - { _scTitle = const "OPTIONS:GRAPHICS" - , _scOptions = graphicsMenuOptions - , _scDefaultEff = popScreen . writeConfig - , _scOptionFlag = NormalOptions - } +graphicsMenu = titleOptions "OPTIONS:GRAPHICS" graphicsMenuOptions + graphicsMenuOptions :: [MenuOption] graphicsMenuOptions = [ Toggle ScancodeW (Just . (config . wall_textured %~ not)) wtextstring @@ -138,17 +130,13 @@ gameOverMenu :: ScreenLayer gameOverMenu = OptionScreen { _scTitle = const "GAME OVER" , _scOptions = pauseMenuOptions - , _scDefaultEff = Just + , _scDefaultEff = return . Just , _scOptionFlag = GameOverOptions } pauseMenu :: ScreenLayer -pauseMenu = OptionScreen - { _scTitle = const "PAUSED" - , _scOptions = pauseMenuOptions - , _scDefaultEff = unpause - , _scOptionFlag = NormalOptions - } +pauseMenu = titleOptionsEff "PAUSED" pauseMenuOptions (return . unpause) + pauseMenuOptions :: [MenuOption] pauseMenuOptions = [ Toggle ScancodeN startNewGame (const "NEW LEVEL") diff --git a/src/Dodge/Render.hs b/src/Dodge/Render.hs index d660650e4..5399968fa 100644 --- a/src/Dodge/Render.hs +++ b/src/Dodge/Render.hs @@ -5,7 +5,6 @@ module Dodge.Render ) where import Dodge.Data -import Dodge.Base.Window import Dodge.Render.Picture import Dodge.Render.ShapePicture import Dodge.Render.Walls @@ -32,10 +31,10 @@ import Graphics.GL.Core43 doDrawing :: RenderData -> Universe -> IO Word32 doDrawing pdata u = do + sTicks <- SDL.ticks let w = _uvWorld u cfig = _config u - sTicks <- SDL.ticks - let rot = _cameraRot w + rot = _cameraRot w camzoom = _cameraZoom w trans = _cameraCenter w wins@(V2 winx winy) = V2 (_windowX cfig) (_windowY cfig) diff --git a/src/Dodge/Render/HUD.hs b/src/Dodge/Render/HUD.hs index ea04b5d14..72383457e 100644 --- a/src/Dodge/Render/HUD.hs +++ b/src/Dodge/Render/HUD.hs @@ -24,7 +24,7 @@ import SDL (MouseButton (..)) hudDrawings :: Configuration -> World -> Picture hudDrawings cfig w = pictures [ winScale cfig . dShadCol white $ displayHP 0 cfig w - , renderListAt (halfWidth cfig) 0 cfig w $ map (,white) (_testString w w) + , renderListAt (halfWidth cfig) 0 cfig $ map (,white) (_testString w w) , selectionText ] where @@ -46,19 +46,19 @@ subInventoryDisplay cfig w = case _inventoryMode w of TweakInventory -> pictures [ mCurs it cfig w , cursorAt 120 col 5 0 iPos cfig - , cursorsZ cfig w iPos it - , displayMidList cfig w (ammoTweakStrings it) "TWEAK" + , cursorsZ cfig iPos it + , displayMidList cfig (ammoTweakStrings it) "TWEAK" ] - CombineInventory -> invHead cfig w "COMBINE" - InspectInventory -> invHead cfig w "INSPECT" + CombineInventory -> invHead cfig "COMBINE" + InspectInventory -> invHead cfig "INSPECT" where itCol = fromMaybe (greyN 0.5) . (^? itInvColor) iPos = _crInvSel $ _creatures w IM.! _yourID w it = yourItem w col = itCol it -cursorsZ :: Configuration -> World -> Int -> Item -> Picture -cursorsZ cfig w ipos it = case it ^? wpAmmo . aoType . amParamSel of +cursorsZ :: Configuration -> Int -> Item -> Picture +cursorsZ cfig ipos it = case it ^? wpAmmo . aoType . amParamSel of Nothing -> f $ zConnect sp (V2 (155- hw) ( hh - 77.5)) Just jpos -> f $ zConnect sp (V2 (155 - hw) ( hh - (20 * fromIntegral jpos + 77.5))) where @@ -96,17 +96,20 @@ mCurs it cfig w = case it ^? wpAmmo . aoType . amParamSel of pjTweakString :: PjParam -> String pjTweakString pj = _pjDisplayParam pj $ _pjIntParam pj -displayMidList :: Configuration -> World -> [String] -> String -> Picture -displayMidList cfig w strs s = - invHead cfig w s - `appendPic` renderListAt 150 (-60) cfig w (map (,white) strs) +displayMidList :: Configuration -> [String] -> String -> Picture +displayMidList cfig strs s = invHead cfig s + `appendPic` renderListAt 150 (-60) cfig (strs <&> (,white)) -invHead :: Configuration -> World -> String -> Picture -invHead cfig w s = winScale cfig . translate (-130) (halfHeight cfig - 40) . dShadCol white . scale 0.4 0.4 $ text s +invHead :: Configuration -> String -> Picture +invHead cfig s = winScale cfig + . translate (-130) (halfHeight cfig - 40) + . dShadCol white + . scale 0.4 0.4 + $ text s renderItemMapAt :: Float -> Float -> Configuration -> IM.IntMap Item -> Picture {-# INLINE renderItemMapAt #-} -renderItemMapAt tx ty w = concatMapPic (uncurry $ listItemAt tx ty w) . IM.toList +renderItemMapAt tx ty cfig = concatMapPic (uncurry $ listItemAt tx ty cfig) . IM.toList displayInv :: Int -> Configuration -> World -> Picture displayInv n cfig w = renderItemMapAt 0 0 cfig (_crInv cr) @@ -119,7 +122,7 @@ displayInv n cfig w = renderItemMapAt 0 0 cfig (_crInv cr) drawLocations :: Configuration -> World -> Picture drawLocations cfig w = pictures $ - renderListAt 0 0 cfig w locs + renderListAt 0 0 cfig locs : zipWith bConnect (displayListEndCoords cfig locTexts) locPoss ++ mapOverlay cfig w ++ [mainListCursor white iPos cfig] @@ -134,7 +137,6 @@ displayListEndCoords cfig ss = map (doWindowScale cfig) $ zipWith h ss $ map f [ where f :: Int -> Point2 f i = V2 ( 15 - halfWidth cfig ) ( 2.5 + halfHeight cfig - (20 * fromIntegral i)) - --g (V2 x y) = V2 (2*x / getWindowX w) ( 2*y / getWindowY w) h :: String -> Point2 -> Point2 h s (V2 x y) = V2 (x + 9 * fromIntegral (length s)) y @@ -156,8 +158,7 @@ mapWall cfig w wl = {- | Pictures of popup text for items close to your position.-} closeObjectTexts :: Configuration -> World -> Picture closeObjectTexts cfig w = pictures $ - renderListAt pushout (negate 20 * fromIntegral invPos) - cfig w (map colAndText $ _closeObjects w) + renderListAt pushout (negate 20 * fromIntegral invPos) cfig (map colAndText $ _closeObjects w) : maybeToList maybeLine where colAndText (Left x) = ( _itName $ _flIt x, _itInvColor $ _flIt x) @@ -239,8 +240,8 @@ cursorAt -> Int -- ^ y offset (discrete) -> Configuration -> Picture -cursorAt wth col xoff yoff yint w = winScale w - . translate (xoff-halfWidth w) (halfHeight w - (20* fromIntegral yint + yoff) - 20) +cursorAt wth col xoff yoff yint cfig = winScale cfig + . translate (xoff-halfWidth cfig) (halfHeight cfig - (20* fromIntegral yint + yoff) - 20) . color col $ line [V2 wth 12.5 diff --git a/src/Dodge/Render/List.hs b/src/Dodge/Render/List.hs index 905bc078a..f554edab9 100644 --- a/src/Dodge/Render/List.hs +++ b/src/Dodge/Render/List.hs @@ -9,20 +9,19 @@ import Dodge.Base.Window import Dodge.WinScale import Picture -renderListAt :: Float -> Float -> Configuration -> World -> [(String,Color)] -> Picture -renderListAt tx ty cfig w = - concatMapPic (winScale cfig) . zipWith (listPairAt tx ty cfig w) [0..] +renderListAt :: Float -> Float -> Configuration -> [(String,Color)] -> Picture +renderListAt tx ty cfig = + concatMapPic (winScale cfig) . zipWith (listPairAt tx ty cfig) [0..] listPairAt :: Float -- ^ x offset -> Float -- ^ y offset -> Configuration - -> World -> Int -- ^ y offset (discrete) -> (String,Color) -- ^ The text item -> Picture {-# INLINE listPairAt #-} -listPairAt xoff yoff cfig w yint (s,col) +listPairAt xoff yoff cfig yint (s,col) = translate (xoff + 15 - halfWidth cfig) (yoff + halfHeight cfig - (20 * (fromIntegral yint+1))) . scale 0.1 0.1 . dShadCol col diff --git a/src/Dodge/Render/MenuScreen.hs b/src/Dodge/Render/MenuScreen.hs index b3591d6fb..28fcc0e97 100644 --- a/src/Dodge/Render/MenuScreen.hs +++ b/src/Dodge/Render/MenuScreen.hs @@ -16,7 +16,7 @@ menuScreen w screen = case screen of (WaitScreen sf _) -> drawOptions w (sf w) [] (InputScreen s) -> drawOptions w ('>':s) [] (DisplayScreen sd ) -> sd w - (ColumnsScreen title pairs) -> drawTwoColumnsScreen (_config w) (_uvWorld w) title pairs + (ColumnsScreen title pairs) -> drawTwoColumnsScreen (_config w) title pairs --displayStringList :: World -> [String] -> Picture --displayStringList w ss = pictures @@ -28,15 +28,15 @@ menuScreen w screen = case screen of -- ys = [0,22..] -- f y s = translate (10-hw) y . scale 0.15 0.15 $ text s -drawTwoColumnsScreen :: Configuration -> World -> String -> [(String,String)] -> Picture -drawTwoColumnsScreen cfig w title lps = pictures +drawTwoColumnsScreen :: Configuration -> String -> [(String,String)] -> Picture +drawTwoColumnsScreen cfig title lps = pictures [darkenBackground cfig - ,drawTitle cfig w title - ,drawTwoColumns cfig w lps + ,drawTitle cfig title + ,drawTwoColumns cfig lps ] -drawTwoColumns :: Configuration -> World -> [(String,String)] -> Picture -drawTwoColumns cfig w lps = pictures $ zipWith f [hh-100,hh-130..] lps +drawTwoColumns :: Configuration -> [(String,String)] -> Picture +drawTwoColumns cfig lps = pictures $ zipWith f [hh-100,hh-130..] lps where f y (s1,s2) = translate (50-hw) y $ sc $ rightPad ln '.' s1 ++ s2 sc = scale 0.15 0.15 . color white . text @@ -49,11 +49,12 @@ drawOptions -> String -- ^ Title -> [MenuOption] -- ^ Options -> Picture -drawOptions w title ops = pictures $ - [darkenBackground (_config w) - ,drawTitle (_config w) (_uvWorld w) title] - ++ - zipWith (\ s vpos -> placeString (-hw + 50) vpos 0.2 s) (map (menuOptionToString w) ops') [hh-100,hh-150 ..] +drawOptions u title ops = pictures $ + [darkenBackground cfig + , drawTitle cfig title] ++ + zipWith (\s vpos -> placeString (-hw + 50) vpos 0.2 s) + (map (menuOptionToString u) ops') + [hh-100,hh-150 ..] where ops' = filter notInvisible ops notInvisible InvisibleToggle {} = False @@ -61,13 +62,13 @@ drawOptions w title ops = pictures $ placeString x y sc t = translate x y $ scale sc sc $ color white $ text t hh = halfHeight cfig hw = halfWidth cfig - cfig = _config w + cfig = _config u darkenBackground :: Configuration -> Picture darkenBackground = color (withAlpha 0.5 black) . polygon . screenBox -drawTitle :: Configuration -> World -> String -> Picture -drawTitle cfig w = placeString (-hw + 30) (hh - 50) 0.4 +drawTitle :: Configuration -> String -> Picture +drawTitle cfig = placeString (-hw + 30) (hh - 50) 0.4 where placeString x y sc t = translate x y $ scale sc sc $ color white $ text t hh = halfHeight cfig @@ -76,7 +77,6 @@ drawTitle cfig w = placeString (-hw + 30) (hh - 50) 0.4 menuOptionToString :: Universe -> MenuOption -> String menuOptionToString w mo = theKeys ++ _moString mo w where - theKeys :: String theKeys = case mo of Toggle {_moKey = k} -> stc k : ":" Toggle2 {_moKey1 = k1, _moKey2 = k2} -> stc k1 : '/' : stc k2 : ":" diff --git a/src/Dodge/Render/Picture.hs b/src/Dodge/Render/Picture.hs index 721fe9e00..b165e3b5e 100644 --- a/src/Dodge/Render/Picture.hs +++ b/src/Dodge/Render/Picture.hs @@ -3,7 +3,7 @@ module Dodge.Render.Picture ( fixedCoordPictures ) where import Dodge.Data -import Dodge.Base.Window +--import Dodge.Base.Window import Dodge.WinScale import Dodge.Picture.Layer import Dodge.Render.HUD @@ -12,20 +12,18 @@ import Geometry import Picture fixedCoordPictures :: Universe -> Picture -fixedCoordPictures w = case _menuLayers w of +fixedCoordPictures u = case _menuLayers u of [] -> pictures - [ hudDrawings (_config w) (_uvWorld w) - , customMouseCursor (_config w) (_uvWorld w) + [ hudDrawings cfig w + , customMouseCursor cfig w ] - (lay:_) -> scaler . onLayer MenuDepth $ menuScreen w lay + (lay:_) -> setDepth (-1) . winScale cfig . onLayer MenuDepth $ menuScreen u lay where - scaler = setDepth (-1) . winScale cfig - cfig = _config w + w = _uvWorld u + cfig = _config u customMouseCursor :: Configuration -> World -> Picture -customMouseCursor cfig w = - winScale cfig +customMouseCursor cfig w = winScale cfig . uncurryV translate (_mousePos w) . color white $ pictures [ line [V2 (-5) 0,V2 5 0] , line [V2 0 (-5),V2 0 5] ] - diff --git a/src/Dodge/Render/ShapePicture.hs b/src/Dodge/Render/ShapePicture.hs index df2adce0f..11648d2e9 100644 --- a/src/Dodge/Render/ShapePicture.hs +++ b/src/Dodge/Render/ShapePicture.hs @@ -7,7 +7,7 @@ import Dodge.Config.Data import Dodge.Picture.SizeInvariant import Dodge.Data import Dodge.Base -import Dodge.Base.Window +--import Dodge.Base.Window import Dodge.SoundLogic.LoadSound import Dodge.Graph import Dodge.GameRoom diff --git a/src/Loop.hs b/src/Loop.hs index 63962b4d7..955f0d89a 100644 --- a/src/Loop.hs +++ b/src/Loop.hs @@ -23,7 +23,7 @@ setupLoop -> (world -> IO ()) -- ^ Function for cleaning up parameters, applied when exiting loop. -> IO world -- ^ Initial simulation state. -> (world -> IO world) -- ^ update, called once per frame. Allows for side effects such as rendering. - -> (world -> Event -> Maybe world) + -> (world -> Event -> IO (Maybe world)) -- ^ SDL Event handling, once per frame. Evaluating 'Nothing' exits the loop. -> IO () setupLoop spf (xSize,ySize) winpos paramCleanup ioStartWorld sideEffects eventFn = do @@ -43,7 +43,7 @@ doLoop :: Int -- ^ target msec per frame -> Window -- ^ The SDL window. -> (world -> IO world) -- ^ simulation update. - -> (world -> Event -> Maybe world) -- ^ SDL Event handling. + -> (world -> Event -> IO (Maybe world)) -- ^ SDL Event handling. -> world -- ^ Current simulation state. -> IO () doLoop @@ -70,13 +70,17 @@ doLoop Nothing -> return () -- | Handle quit events in a manner to exit the loop. Other events handled as -- determined by the custom function, although resize events also change the viewport. -applyEventIO :: (world -> Event -> Maybe world) -> Maybe world -> Event -> IO (Maybe world) +applyEventIO :: (world -> Event -> IO (Maybe world)) -> Maybe world -> Event -> IO (Maybe world) applyEventIO fn mw e = case eventPayload e of QuitEvent -> return Nothing WindowClosedEvent _ -> return Nothing WindowSizeChangedEvent WindowSizeChangedEventData {windowSizeChangedEventSize = V2 x y} - -> GL.viewport $= (GL.Position 0 0,GL.Size x y) >> return (mw >>= \w -> fn w e) - _ -> return $ mw >>= flip fn e + -> (GL.viewport $= (GL.Position 0 0,GL.Size x y)) >> mupdate + _ -> mupdate + where + mupdate = case mw of + Nothing -> return Nothing + Just w -> fn w e -- | Create an OpenGL SDL window configuration with a given x and y size. winConfig :: Int -> Int -> Maybe (Int, Int) -> WindowConfig winConfig x y winpos = defaultWindow