justin/loop
1
0
Fork 0
Code Issues Pull Requests 1 Packages Projects Releases Wiki Activity

Allow for events to do io

Browse Source
This commit is contained in:
justin
2021-11-29 01:02:15 +00:00
parent 8832a73d86
commit 3a605b8156
13 changed files with 127 additions and 142 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/Dodge/Base.hs
+5 -8
View File
@@ -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.-}
src/Dodge/Data.hs
+1 -1
View File
@@ -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)]
src/Dodge/Event.hs
+13 -15
View File
@@ -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
src/Dodge/Event/Keyboard.hs
+8 -8
View File
@@ -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
src/Dodge/Event/Menu.hs
+13 -12
View File
@@ -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
src/Dodge/Menu.hs
+26 -38
View File
@@ -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")
src/Dodge/Render.hs
+2 -3
View File
@@ -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)
src/Dodge/Render/HUD.hs
+21 -20
View File
@@ -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
src/Dodge/Render/List.hs
+4 -5
View File
@@ -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
src/Dodge/Render/MenuScreen.hs
+16 -16
View File
@@ -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 : ":"
src/Dodge/Render/Picture.hs
+8 -10
View File
@@ -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] ]
src/Dodge/Render/ShapePicture.hs
+1 -1
View File
@@ -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
src/Loop.hs
+9 -5
View File
@@ -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