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