module Helm.Engine.SDL
(
SDLEngine
, SDLEngineConfig(..)
, defaultConfig
, startup
, startupWith
, withImage
) where
import Control.Monad (when)
import qualified Data.Text as T
import FRP.Elerea.Param
import Linear.Affine (Point(P))
import Linear.Metric (distance)
import Linear.V2 (V2(V2))
import qualified SDL
import qualified SDL.Event as Event
import qualified SDL.Init as Init
import SDL.Input.Keyboard (Keysym(..))
import qualified SDL.Time as Time
import qualified SDL.Video as Video
import SDL.Video (WindowConfig(..))
import qualified SDL.Video.Renderer as Renderer
import Helm.Engine (Engine(..))
import Helm.Engine.SDL.Asset (withImage)
import Helm.Engine.SDL.Engine (SDLEngine(..), SDLEngineConfig(..))
import qualified Helm.Engine.SDL.Graphics2D as Graphics2D
import Helm.Engine.SDL.Keyboard (mapKey)
import Helm.Engine.SDL.Mouse (mapMouseButton)
import Helm.Graphics (Graphics(..))
import Helm.Graphics2D (Collage)
instance Engine SDLEngine where
render engine (Graphics2D coll) = render2d engine coll
cleanup SDLEngine { window, renderer, texture } = do
Renderer.destroyTexture texture
Video.destroyWindow window
Video.destroyRenderer renderer
Init.quit
tick engine = do
mayhaps <- Event.pumpEvents >> Event.pollEvent
case mayhaps of
Just Event.Event { eventPayload = Event.QuitEvent } ->
return Nothing
Just Event.Event { .. } ->
sinkEvent engine eventPayload >>= tick
Nothing -> return $ Just engine
mouseMoveSignal = mouseMoveEventSignal
mouseDownSignal = mouseDownEventSignal
mouseUpSignal = mouseUpEventSignal
mouseClickSignal = mouseClickEventSignal
keyboardDownSignal = keyboardDownEventSignal
keyboardUpSignal = keyboardUpEventSignal
keyboardPressSignal = keyboardPressEventSignal
windowResizeSignal = windowResizeEventSignal
runningTime _ = fromIntegral <$> Time.ticks
windowSize SDLEngine { window } = fmap (fmap fromIntegral) . SDL.get $ Video.windowSize window
defaultConfig :: SDLEngineConfig
defaultConfig = SDLEngineConfig
{ windowDimensions = V2 800 600
, windowIsFullscreen = False
, windowIsResizable = True
, windowTitle = "Helm"
}
startup :: IO SDLEngine
startup = startupWith defaultConfig
prepTexture :: V2 Int -> Video.Renderer -> IO Renderer.Texture
prepTexture dims renderer =
Renderer.createTexture renderer mode access $ fromIntegral <$> dims
where
mode = Renderer.ARGB8888
access = Renderer.TextureAccessStreaming
startupWith :: SDLEngineConfig -> IO SDLEngine
startupWith config@SDLEngineConfig { .. } = do
Init.initializeAll
window <- Video.createWindow (T.pack windowTitle) windowConfig
renderer <- Video.createRenderer window (1) rendererConfig
texture <- prepTexture windowDimensions renderer
mouseMoveEvent <- externalMulti
mouseDownEvent <- externalMulti
mouseUpEvent <- externalMulti
mouseClickEvent <- externalMulti
keyboardDownEvent <- externalMulti
keyboardUpEvent <- externalMulti
keyboardPressEvent <- externalMulti
windowResizeEvent <- externalMulti
Video.showWindow window
return SDLEngine
{ window = window
, renderer = renderer
, texture = texture
, engineConfig = config
, lastMousePress = Nothing
, mouseMoveEventSignal = fst mouseMoveEvent
, mouseMoveEventSink = snd mouseMoveEvent
, mouseDownEventSignal = fst mouseDownEvent
, mouseDownEventSink = snd mouseDownEvent
, mouseUpEventSignal = fst mouseUpEvent
, mouseUpEventSink = snd mouseUpEvent
, mouseClickEventSignal = fst mouseClickEvent
, mouseClickEventSink = snd mouseClickEvent
, keyboardDownEventSignal = fst keyboardDownEvent
, keyboardDownEventSink = snd keyboardDownEvent
, keyboardUpEventSignal = fst keyboardUpEvent
, keyboardUpEventSink = snd keyboardUpEvent
, keyboardPressEventSignal = fst keyboardPressEvent
, keyboardPressEventSink = snd keyboardPressEvent
, windowResizeEventSignal = fst windowResizeEvent
, windowResizeEventSink = snd windowResizeEvent
}
where
rendererConfig = Video.RendererConfig Video.AcceleratedVSyncRenderer False
windowConfig = Video.defaultWindow
{ windowInitialSize = fromIntegral <$> windowDimensions
, windowMode = if windowIsFullscreen
then Video.Fullscreen
else Video.Windowed
, windowResizable = windowIsResizable
}
render2d :: SDLEngine -> Collage SDLEngine -> IO ()
render2d SDLEngine { window, renderer, texture } element = do
dims <- SDL.get $ Video.windowSize window
Graphics2D.render texture dims element
Renderer.clear renderer
Renderer.copy renderer texture Nothing Nothing
Renderer.present renderer
depoint :: Point f a -> f a
depoint (P x) = x
sinkEvent :: SDLEngine -> Event.EventPayload -> IO SDLEngine
sinkEvent engine (Event.WindowResizedEvent Event.WindowResizedEventData { .. }) = do
windowResizeEventSink engine dims
Renderer.destroyTexture texture
resized <- prepTexture dims renderer
return engine { texture = resized }
where
dims = fromIntegral <$> windowResizedEventSize
SDLEngine { texture, renderer } = engine
sinkEvent engine (Event.MouseMotionEvent Event.MouseMotionEventData { .. }) = do
mouseMoveEventSink engine $ fromIntegral <$> depoint mouseMotionEventPos
return engine
sinkEvent engine (Event.KeyboardEvent Event.KeyboardEventData { .. }) =
case keyboardEventKeyMotion of
Event.Pressed -> do
keyboardDownEventSink engine key
if keyboardEventRepeat
then keyboardPressEventSink engine key >> return engine
else return engine
Event.Released -> do
keyboardUpEventSink engine key
keyboardPressEventSink engine key
return engine
where
Keysym { .. } = keyboardEventKeysym
key = mapKey keysymKeycode
sinkEvent engine (Event.MouseButtonEvent Event.MouseButtonEventData { .. }) =
case mouseButtonEventMotion of
Event.Pressed -> do
ticks <- Time.ticks
mouseDownEventSink engine tup
return engine { lastMousePress = Just (ticks, dubPos) }
Event.Released -> do
mouseUpEventSink engine tup
case lastMousePress of
Just (lastTicks, lastPos) -> do
ticks <- Time.ticks
when (distance dubPos lastPos <= clickRadius && ticks lastTicks < clickMs)
(mouseClickEventSink engine tup)
Nothing -> return ()
return engine
where
SDLEngine { lastMousePress } = engine
clickMs = 500
clickRadius = 3
pos = depoint mouseButtonEventPos
dubPos = fromIntegral <$> pos
tup = (mapMouseButton mouseButtonEventButton, fromIntegral <$> pos)
sinkEvent engine _ = return engine