diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Anton Gushcha (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gore-and-ash-sdl.cabal b/gore-and-ash-sdl.cabal new file mode 100644 --- /dev/null +++ b/gore-and-ash-sdl.cabal @@ -0,0 +1,46 @@ +name: gore-and-ash-sdl +version: 1.1.0.0 +synopsis: Gore&Ash core module for integration with SDL library +description: Please see README.md +homepage: git@github.com:Teaspot-Studio/gore-and-ash-sdl.git +license: BSD3 +license-file: LICENSE +author: Anton Gushcha +maintainer: ncrashed@gmail.com +copyright: 2016 Anton Gushcha +category: Game +build-type: Simple +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Game.GoreAndAsh.SDL + Game.GoreAndAsh.SDL.API + Game.GoreAndAsh.SDL.Module + Game.GoreAndAsh.SDL.State + + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , containers >= 0.5.6.2 + , deepseq >= 1.4.1.1 + , exceptions >= 0.8.0.2 + , gore-and-ash >= 1.1.0.0 + , lens >= 4.13 + , linear >= 1.20.3 + , mtl >= 2.2.1 + , sdl2 >= 2.1.1 + , text >= 1.2.2.0 + , transformers >= 0.4.2.0 + , unordered-containers >= 0.2.5.1 + + default-extensions: + BangPatterns + DeriveGeneric + FlexibleInstances + GeneralizedNewtypeDeriving + MultiParamTypeClasses + OverloadedStrings + RecordWildCards + ScopedTypeVariables + TypeFamilies + UndecidableInstances diff --git a/src/Game/GoreAndAsh/SDL.hs b/src/Game/GoreAndAsh/SDL.hs new file mode 100644 --- /dev/null +++ b/src/Game/GoreAndAsh/SDL.hs @@ -0,0 +1,74 @@ +{-| +Module : Game.GoreAndAsh.SDL +Description : Module that contains SDL integration for Gore&Ash +Copyright : (c) Anton Gushcha, 2015-2016 +License : BSD3 +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : POSIX + +The core module contains API for SDL2 library integration. +The module doesn't depends on others core modules and could be place in any place in +game monad stack. + +The module is NOT pure within first phase (see 'ModuleStack' docs), therefore currently only 'IO' end monad can handler the module. + +Example of embedding: + +@ +-- | Application monad is monad stack build from given list of modules over base monad (IO) +type AppStack = ModuleStack [SDLT, ... other modules ... ] IO +newtype AppState = AppState (ModuleState AppStack) + deriving (Generic) + +instance NFData AppState + +-- | Wrapper around type family +newtype AppMonad a = AppMonad (AppStack a) + deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, MonadSDL, ... other modules monads ... ) + +instance GameModule AppMonad AppState where + type ModuleState AppMonad = AppState + runModule (AppMonad m) (AppState s) = do + (a, s') <- runModule m s + return (a, AppState s') + newModuleState = AppState <$> newModuleState + withModule _ = withModule (Proxy :: Proxy AppStack) + cleanupModule (AppState s) = cleanupModule s + +-- | Arrow that is build over the monad stack +type AppWire a b = GameWire AppMonad a b +-- | Action that makes indexed app wire +type AppActor i a b = GameActor AppMonad i a b +@ + +-} +module Game.GoreAndAsh.SDL( + -- * Low level API + SDLState + , SDLT + , MonadSDL(..) + -- * Arrow API + , WindowConfig(..) + , RendererConfig(..) + , RendererType(..) + , module ReExport + -- ** Keyboard arrow API + , keyScancode + , keyPress + , keyRelease + , keyPressing + -- ** Mouse arrow API + , mouseScroll + , mouseScrollX + , mouseScrollY + , mouseClick + -- ** Window arrow API + , windowClosed + ) where + +import SDL as ReExport hiding (get, Event) + +import Game.GoreAndAsh.SDL.API as X +import Game.GoreAndAsh.SDL.Module as X +import Game.GoreAndAsh.SDL.State as X diff --git a/src/Game/GoreAndAsh/SDL/API.hs b/src/Game/GoreAndAsh/SDL/API.hs new file mode 100644 --- /dev/null +++ b/src/Game/GoreAndAsh/SDL/API.hs @@ -0,0 +1,383 @@ +{-| +Module : Game.GoreAndAsh.SDL.API +Description : Monadic and arrow API for SDL core module +Copyright : (c) Anton Gushcha, 2015-2016 +License : BSD3 +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : POSIX + +The module contains monadic and arrow API of the core module. +-} +module Game.GoreAndAsh.SDL.API( + MonadSDL(..) + , WindowConfig(..) + , RendererConfig(..) + , RendererType(..) + , module ReExport + -- | Keyboard arrow API + , keyScancode + , keyPress + , keyRelease + , keyPressing + -- | Mouse arrow API + , mouseScroll + , mouseScrollX + , mouseScrollY + , mouseClick + -- | Window arrow API + , windowClosed + ) where + +import Control.Lens ((^.)) +import Control.Monad.Catch +import Control.Monad.State.Strict +import Control.Wire +import Control.Wire.Unsafe.Event +import Data.Int +import Data.Sequence (Seq) +import Data.Text (Text) +import Data.Word +import Foreign +import GHC.Generics +import Linear +import Linear.Affine +import Prelude hiding (id, (.)) +import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S + +import SDL as ReExport hiding (get, Event) +import SDL.Internal.Types +import qualified SDL.Raw as SDLRaw + +import Game.GoreAndAsh +import Game.GoreAndAsh.SDL.Module +import Game.GoreAndAsh.SDL.State + +-- | Module specific exceptions +data SDL'ModuleException = + -- | Tried to register two windows with equal names + SDL'ConflictingWindows !Text + deriving (Generic, Show) + +instance Exception SDL'ModuleException + +-- | Low level API for module +class (MonadIO m, MonadThrow m) => MonadSDL m where + -- | Creates window and stores in module context + -- + -- Throws @SDL'ConflictingWindows@ on name conflict + sdlCreateWindowM :: + Text -- ^ Window name that is used to get the window (and renderer) from the module later + -> Text -- ^ Title of the window + -> WindowConfig -- ^ Window configuration + -> RendererConfig -- ^ Renderer configuration + -> m (Window, Renderer) + + -- | Getting window and renderer by name + sdlGetWindowM :: + Text -- ^ Window name that was used at @sdlCreateWindowM@ call + -> m (Maybe (Window, Renderer)) + + -- | Destroying window and renderer by name + sdlDestroyWindowM :: + Text -- ^ Window name that was used at @sdlCreateWindowM@ call + -> m () + + -- | Setup background color for window + sdlSetBackColor :: + Text -- ^ Window name that was used at @sdlCreateWindowM@ call + -> V4 Word8 -- ^ Color to set + -> m () + + -- | Getting window shown events that occurs scince last frame + sdlWindowShownEventsM :: m (Seq WindowShownEventData) + -- | Getting window hidden events that occurs scince last frame + sdlWindowHiddenEventsM :: m (Seq WindowHiddenEventData) + -- | Getting window exposed events that occurs scince last frame + sdlWindowExposedEventsM :: m (Seq WindowExposedEventData) + -- | Getting window move events that occurs scince last frame + sdlWindowMovedEventsM :: m (Seq WindowMovedEventData) + -- | Getting window resize events that occurs scince last frame + -- + -- This is event is always preceded by WindowSizeChangedEvent. + sdlWindowResizedEventsM :: m (Seq WindowResizedEventData) + -- | Getting window resize events that occurs scince last frame + -- + -- The window size has changed, either as a result of an API call or through the system or user changing the window size; this event is followed by WindowResizedEvent if the size was changed by an external event, i.e. the user or the window manager. + sdlWindowSizeChangedEventsM :: m (Seq WindowSizeChangedEventData) + -- | Getting window minimization events that occurs scince last frame + sdlWindowMinimizedEventsM :: m (Seq WindowMinimizedEventData) + -- | Getting window maximization events that occurs scince last frame + sdlWindowMaximizedEventsM :: m (Seq WindowMaximizedEventData) + -- | Getting window restore events that occurs scince last frame + sdlWindowRestoredEventsM :: m (Seq WindowRestoredEventData) + -- | Getting window focus events that occurs scince last frame + sdlWindowGainedMouseFocusEventsM :: m (Seq WindowGainedMouseFocusEventData) + -- | Getting window focus events that occurs scince last frame + sdlWindowLostMouseFocusEventsM :: m (Seq WindowLostMouseFocusEventData) + -- | Getting window focus events that occurs scince last frame + sdlWindowGainedKeyboardFocusEventsM :: m (Seq WindowGainedKeyboardFocusEventData) + -- | Getting window focus events that occurs scince last frame + sdlWindowLostKeyboardFocusEventsM :: m (Seq WindowLostKeyboardFocusEventData) + -- | Getting window close events that occurs scince last frame + sdlWindowClosedEventsM :: m (Seq WindowClosedEventData) + + -- | Getting keyboard events that occurs scince last frame + sdlKeyboardEventsM :: m (Seq KeyboardEventData) + -- | Getting input API events that occurs scince last frame + sdlTextEditingEventsM :: m (Seq TextEditingEventData) + -- | Getting input API events that occurs scince last frame + sdlTextInputEventsM :: m (Seq TextInputEventData) + + -- | Getting mouse events that occurs scince last frame + sdlMouseMotionEventsM :: m (Seq MouseMotionEventData) + -- | Getting mouse events that occurs scince last frame + sdlMouseButtonEventsM :: m (Seq MouseButtonEventData) + -- | Getting mouse events that occurs scince last frame + sdlMouseWheelEventsM :: m (Seq MouseWheelEventData) + + -- | Getting joystick events that occurs scince last frame + sdlJoyAxisEventsM :: m (Seq JoyAxisEventData) + -- | Getting joystick events that occurs scince last frame + sdlJoyBallEventsM :: m (Seq JoyBallEventData) + -- | Getting joystick events that occurs scince last frame + sdlJoyHatEventsM :: m (Seq JoyHatEventData) + -- | Getting joystick events that occurs scince last frame + sdlJoyButtonEventsM :: m (Seq JoyButtonEventData) + -- | Getting joystick events that occurs scince last frame + sdlJoyDeviceEventsM :: m (Seq JoyDeviceEventData) + + -- | Getting controller events that occurs scince last frame + sdlControllerAxisEventsM :: m (Seq ControllerAxisEventData) + -- | Getting controller events that occurs scince last frame + sdlControllerButtonEventsM :: m (Seq ControllerButtonEventData) + -- | Getting controller events that occurs scince last frame + sdlControllerDeviceEventsM :: m (Seq ControllerDeviceEventData) + + -- | Getting quit request event + sdlQuitEventM :: m Bool + -- | Getting user events that occurs scince last frame + sdlUserEventsM :: m (Seq UserEventData) + -- | Getting video driver specific events that occurs scince last frame + sdlSysWMEventsM :: m (Seq SysWMEventData) + + -- | Getting touch events that occurs scince last frame + sdlTouchFingerEventsM :: m (Seq TouchFingerEventData) + -- | Getting touch events that occurs scince last frame + sdlMultiGestureEventsM :: m (Seq MultiGestureEventData) + -- | Getting touch events that occurs scince last frame + sdlDollarGestureEventsM :: m (Seq DollarGestureEventData) + + -- | Getting file opened events that occurs scince last frame + sdlDropEventsM :: m (Seq DropEventData) + -- | Getting clipboard changed events that occurs scince last frame + sdlClipboardUpdateEventsM :: m (Seq ClipboardUpdateEventData) + +instance {-# OVERLAPPING #-} (MonadIO m, MonadThrow m) => MonadSDL (SDLT s m) where + sdlCreateWindowM n t wc rc = do + w <- createWindow t wc + r <- createRenderer w (-1) rc + s <- SDLT get + case H.lookup n . sdlWindows $! s of + Just _ -> throwM . SDL'ConflictingWindows $! n + Nothing -> do + SDLT . put $! s { + sdlWindows = H.insert n (w, r, defColor) . sdlWindows $! s + } + return (w, r) + where + defColor = V4 0 0 0 255 + + sdlGetWindowM n = do + s <- SDLT get + return . fmap (\(w, r, _) -> (w, r)) . H.lookup n . sdlWindows $! s + + sdlDestroyWindowM n = do + s <- SDLT get + case H.lookup n . sdlWindows $! s of + Just (w, r, _) -> do + destroyRenderer r + destroyWindow w + SDLT . put $! s { + sdlWindows = H.delete n . sdlWindows $! s + } + Nothing -> return () + + sdlSetBackColor n c = do + s <- SDLT get + case H.lookup n . sdlWindows $! s of + Just (w, r, _) -> SDLT . put $! s { + sdlWindows = H.insert n (w, r, c) . sdlWindows $! s + } + Nothing -> return () + + sdlWindowShownEventsM = sdlWindowShownEvents <$> get + sdlWindowHiddenEventsM = sdlWindowHiddenEvents <$> get + sdlWindowExposedEventsM = sdlWindowExposedEvents <$> get + sdlWindowMovedEventsM = sdlWindowMovedEvents <$> get + sdlWindowResizedEventsM = sdlWindowResizedEvents <$> get + sdlWindowSizeChangedEventsM = sdlWindowSizeChangedEvents <$> get + sdlWindowMinimizedEventsM = sdlWindowMinimizedEvents <$> get + sdlWindowMaximizedEventsM = sdlWindowMaximizedEvents <$> get + sdlWindowRestoredEventsM = sdlWindowRestoredEvents <$> get + sdlWindowGainedMouseFocusEventsM = sdlWindowGainedMouseFocusEvents <$> get + sdlWindowLostMouseFocusEventsM = sdlWindowLostMouseFocusEvents <$> get + sdlWindowGainedKeyboardFocusEventsM = sdlWindowGainedKeyboardFocusEvents <$> get + sdlWindowLostKeyboardFocusEventsM = sdlWindowLostKeyboardFocusEvents <$> get + sdlWindowClosedEventsM = sdlWindowClosedEvents <$> get + sdlKeyboardEventsM = sdlKeyboardEvents <$> get + sdlTextEditingEventsM = sdlTextEditingEvents <$> get + sdlTextInputEventsM = sdlTextInputEvents <$> get + sdlMouseMotionEventsM = sdlMouseMotionEvents <$> get + sdlMouseButtonEventsM = sdlMouseButtonEvents <$> get + sdlMouseWheelEventsM = sdlMouseWheelEvents <$> get + sdlJoyAxisEventsM = sdlJoyAxisEvents <$> get + sdlJoyBallEventsM = sdlJoyBallEvents <$> get + sdlJoyHatEventsM = sdlJoyHatEvents <$> get + sdlJoyButtonEventsM = sdlJoyButtonEvents <$> get + sdlJoyDeviceEventsM = sdlJoyDeviceEvents <$> get + sdlControllerAxisEventsM = sdlControllerAxisEvents <$> get + sdlControllerButtonEventsM = sdlControllerButtonEvents <$> get + sdlControllerDeviceEventsM = sdlControllerDeviceEvents <$> get + sdlQuitEventM = sdlQuitEvent <$> get + sdlUserEventsM = sdlUserEvents <$> get + sdlSysWMEventsM = sdlSysWMEvents <$> get + sdlTouchFingerEventsM = sdlTouchFingerEvents <$> get + sdlMultiGestureEventsM = sdlMultiGestureEvents <$> get + sdlDollarGestureEventsM = sdlDollarGestureEvents <$> get + sdlDropEventsM = sdlDropEvents <$> get + sdlClipboardUpdateEventsM = sdlClipboardUpdateEvents <$> get + +instance {-# OVERLAPPABLE #-} (MonadIO (mt m), MonadThrow (mt m), MonadSDL m, MonadTrans mt) => MonadSDL (mt m) where + sdlCreateWindowM n t wc rc = lift $ sdlCreateWindowM n t wc rc + sdlGetWindowM = lift . sdlGetWindowM + sdlDestroyWindowM = lift . sdlDestroyWindowM + sdlSetBackColor a b = lift $ sdlSetBackColor a b + + sdlWindowShownEventsM = lift sdlWindowShownEventsM + sdlWindowHiddenEventsM = lift sdlWindowHiddenEventsM + sdlWindowExposedEventsM = lift sdlWindowExposedEventsM + sdlWindowMovedEventsM = lift sdlWindowMovedEventsM + sdlWindowResizedEventsM = lift sdlWindowResizedEventsM + sdlWindowSizeChangedEventsM = lift sdlWindowSizeChangedEventsM + sdlWindowMinimizedEventsM = lift sdlWindowMinimizedEventsM + sdlWindowMaximizedEventsM = lift sdlWindowMaximizedEventsM + sdlWindowRestoredEventsM = lift sdlWindowRestoredEventsM + sdlWindowGainedMouseFocusEventsM = lift sdlWindowGainedMouseFocusEventsM + sdlWindowLostMouseFocusEventsM = lift sdlWindowLostMouseFocusEventsM + sdlWindowGainedKeyboardFocusEventsM = lift sdlWindowGainedKeyboardFocusEventsM + sdlWindowLostKeyboardFocusEventsM = lift sdlWindowLostKeyboardFocusEventsM + sdlWindowClosedEventsM = lift sdlWindowClosedEventsM + sdlKeyboardEventsM = lift sdlKeyboardEventsM + sdlTextEditingEventsM = lift sdlTextEditingEventsM + sdlTextInputEventsM = lift sdlTextInputEventsM + sdlMouseMotionEventsM = lift sdlMouseMotionEventsM + sdlMouseButtonEventsM = lift sdlMouseButtonEventsM + sdlMouseWheelEventsM = lift sdlMouseWheelEventsM + sdlJoyAxisEventsM = lift sdlJoyAxisEventsM + sdlJoyBallEventsM = lift sdlJoyBallEventsM + sdlJoyHatEventsM = lift sdlJoyHatEventsM + sdlJoyButtonEventsM = lift sdlJoyButtonEventsM + sdlJoyDeviceEventsM = lift sdlJoyDeviceEventsM + sdlControllerAxisEventsM = lift sdlControllerAxisEventsM + sdlControllerButtonEventsM = lift sdlControllerButtonEventsM + sdlControllerDeviceEventsM = lift sdlControllerDeviceEventsM + sdlQuitEventM = lift sdlQuitEventM + sdlUserEventsM = lift sdlUserEventsM + sdlSysWMEventsM = lift sdlSysWMEventsM + sdlTouchFingerEventsM = lift sdlTouchFingerEventsM + sdlMultiGestureEventsM = lift sdlMultiGestureEventsM + sdlDollarGestureEventsM = lift sdlDollarGestureEventsM + sdlDropEventsM = lift sdlDropEventsM + sdlClipboardUpdateEventsM = lift sdlClipboardUpdateEventsM + +-- | Fires when specific scancode key is pressed/unpressed +keyScancode :: MonadSDL m => Scancode -> InputMotion -> GameWire m a (Event (Seq KeyboardEventData)) +keyScancode sc im = liftGameMonad $ do + es <- S.filter isNeeded <$> sdlKeyboardEventsM + return $! if S.null es + then NoEvent + else Event es + where + isNeeded KeyboardEventData{..} = keyboardEventKeyMotion == im + && sc == keysymScancode keyboardEventKeysym + +-- | Fires when specific scancode key is pressed +keyPress :: MonadSDL m => Scancode -> GameWire m a (Event (Seq KeyboardEventData)) +keyPress sc = keyScancode sc Pressed + +-- | Fires when specific scancode key is released +keyRelease :: MonadSDL m => Scancode -> GameWire m a (Event (Seq KeyboardEventData)) +keyRelease sc = keyScancode sc Released + +-- | Fires event from moment of press until release of given key +keyPressing :: MonadSDL m => Scancode -> GameWire m a (Event KeyboardEventData) +keyPressing sc = go NoEvent + where + go !e = mkGen $ \_ _ -> do + !mks <- S.viewr . S.filter isNeeded <$> sdlKeyboardEventsM + return $! case mks of + S.EmptyR -> (Right e, go e) + _ S.:> mds@KeyboardEventData{..} -> case keyboardEventKeyMotion of + Pressed -> (Right $! Event mds, go $! Event mds) + Released -> (Right NoEvent, go NoEvent) + + isNeeded KeyboardEventData{..} = sc == keysymScancode keyboardEventKeysym + +-- | Returns accumulated mouse scroll scince last frame +mouseScroll :: MonadSDL m => GameWire m a (Event (V2 Int32)) +mouseScroll = liftGameMonad $ do + es <- sdlMouseWheelEventsM + return $! if S.null es + then NoEvent + else Event . sumV . fmap mouseWheelEventPos $! es + +-- | Returns accumulated mouse scroll scince last frame +mouseScrollX :: MonadSDL m => GameWire m a (Event Int32) +mouseScrollX = mapE (^. _x) . mouseScroll + +-- | Returns accumulated mouse scroll scince last frame +mouseScrollY :: MonadSDL m => GameWire m a (Event Int32) +mouseScrollY = mapE (^. _y) . mouseScroll + +-- | Fires when window with specific name is closed +windowClosed :: MonadSDL m => Text -> GameWire m a (Event ()) +windowClosed n = go Nothing + where + go Nothing = mkGen $ \_ _ -> do + mr <- sdlGetWindowM n + return $! case mr of + Nothing -> (Right NoEvent, go Nothing) + Just (w, _) -> (Right NoEvent, go $ Just w) + go (Just w) = liftGameMonad $ do + es <- S.filter isNeeded <$> sdlWindowClosedEventsM + return $! if S.null es + then NoEvent + else Event () + where + isNeeded WindowClosedEventData{..} = windowClosedEventWindow == w + +-- | Fires when user clicks within window. Click coordinates are in [-1 .. 1] range +mouseClick :: MonadSDL m => MouseButton -> GameWire m a (Event (V2 Double)) +mouseClick mb = liftGameMonad $ do + es <- S.filter isNeeded <$> sdlMouseButtonEventsM + case S.viewr es of + S.EmptyR -> return NoEvent + _ S.:> MouseButtonEventData{..} -> do + (size :: V2 Int) <- getWindowSize mouseButtonEventWindow + return . Event $! transformCoords size mouseButtonEventPos + where + isNeeded MouseButtonEventData{..} = mouseButtonEventButton == mb && mouseButtonEventMotion == Pressed + transformCoords (V2 w h) (P (V2 xi yi)) = + inv33 (viewportTransform2D 0 (V2 (fromIntegral w) (fromIntegral h))) + `applyTransform2D` + V2 (fromIntegral xi) (fromIntegral yi) + +-- | Helper to hide pointer manipulation while getting window size +getWindowSize :: (MonadIO m, Integral a) => Window -> m (V2 a) +getWindowSize (Window wptr) = liftIO $ with 0 $ \xptr -> with 0 $ \yptr -> do + SDLRaw.getWindowSize wptr xptr yptr + x <- peek xptr + y <- peek yptr + return $! V2 (fromIntegral x) (fromIntegral y) diff --git a/src/Game/GoreAndAsh/SDL/Module.hs b/src/Game/GoreAndAsh/SDL/Module.hs new file mode 100644 --- /dev/null +++ b/src/Game/GoreAndAsh/SDL/Module.hs @@ -0,0 +1,124 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module : Game.GoreAndAsh.SDL.Module +Description : Monad transformer of the module +Copyright : (c) Anton Gushcha, 2015-2016 +License : BSD3 +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : POSIX + +The module contains declaration of monad transformer of the core module and +instance for 'GameModule' class. +-} +module Game.GoreAndAsh.SDL.Module( + SDLT(..) + ) where + +import Control.Monad.Catch +import Control.Monad.Fix +import Control.Monad.IO.Class +import Control.Monad.State.Strict +import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as H +import qualified Data.Sequence as S + +import SDL + +import Game.GoreAndAsh +import Game.GoreAndAsh.SDL.State + +-- | Monad transformer of SDL core module. +-- +-- [@s@] - State of next core module in modules chain; +-- +-- [@m@] - Next monad in modules monad stack; +-- +-- [@a@] - Type of result value; +-- +-- How to embed module: +-- +-- @ +-- type AppStack = ModuleStack [SDLT, ... other modules ... ] IO +-- +-- newtype AppMonad a = AppMonad (AppStack a) +-- deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadThrow, MonadCatch, MonadSDL) +-- @ +-- +-- The module is NOT pure within first phase (see 'ModuleStack' docs), therefore currently only 'IO' end monad can handler the module. +newtype SDLT s m a = SDLT { runSDLT :: StateT (SDLState s) m a } + deriving (Functor, Applicative, Monad, MonadState (SDLState s), MonadFix, MonadTrans, MonadIO, MonadThrow, MonadCatch, MonadMask) + +instance GameModule m s => GameModule (SDLT s m) (SDLState s) where + type ModuleState (SDLT s m) = SDLState s + runModule (SDLT m) s = do + s' <- processEvents s + clearWindows s' + ((a, s''), nextState) <- runModule (runStateT m s') (sdlNextState s') + drawWindows s'' + return (a, flashSDLState $ s'' { + sdlNextState = nextState + }) + + newModuleState = emptySDLState <$> newModuleState + withModule _ io = initializeAll >> io + cleanupModule _ = quit + +-- | Takes all window and renderers and update them +drawWindows :: MonadIO m => SDLState s -> m () +drawWindows SDLState{..} = mapM_ go . H.elems $! sdlWindows + where + go (_, r, _) = present r + +-- | Clear surface of all windows +clearWindows :: MonadIO m => SDLState s -> m () +clearWindows SDLState{..} = mapM_ go . H.elems $! sdlWindows + where + go (_, r, c) = do + rendererDrawColor r $= c + clear r + +-- | Catch all SDL events +processEvents :: MonadIO m => SDLState s -> m (SDLState s) +processEvents sdlState = do + es <- pollEvents + return $! F.foldl' process sdlState (eventPayload <$> es) + where + process s e = case e of + WindowShownEvent d -> s { sdlWindowShownEvents = sdlWindowShownEvents s S.|> d } + WindowHiddenEvent d -> s { sdlWindowHiddenEvents = sdlWindowHiddenEvents s S.|> d } + WindowExposedEvent d -> s { sdlWindowExposedEvents = sdlWindowExposedEvents s S.|> d } + WindowMovedEvent d -> s { sdlWindowMovedEvents = sdlWindowMovedEvents s S.|> d } + WindowResizedEvent d -> s { sdlWindowResizedEvents = sdlWindowResizedEvents s S.|> d } + WindowSizeChangedEvent d -> s { sdlWindowSizeChangedEvents = sdlWindowSizeChangedEvents s S.|> d } + WindowMinimizedEvent d -> s { sdlWindowMinimizedEvents = sdlWindowMinimizedEvents s S.|> d } + WindowMaximizedEvent d -> s { sdlWindowMaximizedEvents = sdlWindowMaximizedEvents s S.|> d } + WindowRestoredEvent d -> s { sdlWindowRestoredEvents = sdlWindowRestoredEvents s S.|> d } + WindowGainedMouseFocusEvent d -> s { sdlWindowGainedMouseFocusEvents = sdlWindowGainedMouseFocusEvents s S.|> d } + WindowLostMouseFocusEvent d -> s { sdlWindowLostMouseFocusEvents = sdlWindowLostMouseFocusEvents s S.|> d } + WindowGainedKeyboardFocusEvent d -> s { sdlWindowGainedKeyboardFocusEvents = sdlWindowGainedKeyboardFocusEvents s S.|> d } + WindowLostKeyboardFocusEvent d -> s { sdlWindowLostKeyboardFocusEvents = sdlWindowLostKeyboardFocusEvents s S.|> d } + WindowClosedEvent d -> s { sdlWindowClosedEvents = sdlWindowClosedEvents s S.|> d } + KeyboardEvent d -> s { sdlKeyboardEvents = sdlKeyboardEvents s S.|> d } + TextEditingEvent d -> s { sdlTextEditingEvents = sdlTextEditingEvents s S.|> d } + TextInputEvent d -> s { sdlTextInputEvents = sdlTextInputEvents s S.|> d } + MouseMotionEvent d -> s { sdlMouseMotionEvents = sdlMouseMotionEvents s S.|> d } + MouseButtonEvent d -> s { sdlMouseButtonEvents = sdlMouseButtonEvents s S.|> d } + MouseWheelEvent d -> s { sdlMouseWheelEvents = sdlMouseWheelEvents s S.|> d } + JoyAxisEvent d -> s { sdlJoyAxisEvents = sdlJoyAxisEvents s S.|> d } + JoyBallEvent d -> s { sdlJoyBallEvents = sdlJoyBallEvents s S.|> d } + JoyHatEvent d -> s { sdlJoyHatEvents = sdlJoyHatEvents s S.|> d } + JoyButtonEvent d -> s { sdlJoyButtonEvents = sdlJoyButtonEvents s S.|> d } + JoyDeviceEvent d -> s { sdlJoyDeviceEvents = sdlJoyDeviceEvents s S.|> d } + ControllerAxisEvent d -> s { sdlControllerAxisEvents = sdlControllerAxisEvents s S.|> d } + ControllerButtonEvent d -> s { sdlControllerButtonEvents = sdlControllerButtonEvents s S.|> d } + ControllerDeviceEvent d -> s { sdlControllerDeviceEvents = sdlControllerDeviceEvents s S.|> d } + QuitEvent -> s { sdlQuitEvent = True } + UserEvent d -> s { sdlUserEvents = sdlUserEvents s S.|> d } + SysWMEvent d -> s { sdlSysWMEvents = sdlSysWMEvents s S.|> d } + TouchFingerEvent d -> s { sdlTouchFingerEvents = sdlTouchFingerEvents s S.|> d } + MultiGestureEvent d -> s { sdlMultiGestureEvents = sdlMultiGestureEvents s S.|> d } + DollarGestureEvent d -> s { sdlDollarGestureEvents = sdlDollarGestureEvents s S.|> d } + DropEvent d -> s { sdlDropEvents = sdlDropEvents s S.|> d } + ClipboardUpdateEvent d -> s { sdlClipboardUpdateEvents = sdlClipboardUpdateEvents s S.|> d } + _ -> s diff --git a/src/Game/GoreAndAsh/SDL/State.hs b/src/Game/GoreAndAsh/SDL/State.hs new file mode 100644 --- /dev/null +++ b/src/Game/GoreAndAsh/SDL/State.hs @@ -0,0 +1,222 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Module : Game.GoreAndAsh.SDL.State +Description : Internal core module state +Copyright : (c) Anton Gushcha, 2015-2016 +License : BSD3 +Maintainer : ncrashed@gmail.com +Stability : experimental +Portability : POSIX +-} +module Game.GoreAndAsh.SDL.State( + SDLState(..) + , emptySDLState + , flashSDLState + ) where + +import Control.DeepSeq +import Data.Text +import Data.Word +import GHC.Generics (Generic) +import Linear + +import SDL.Event +import SDL.Input.Keyboard +import SDL.Input.Mouse +import SDL.Internal.Types + +import Data.Sequence (Seq) +import qualified Data.Sequence as S + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as H + +-- | Inner state of SDL module. +-- +-- [@s@] - State of next module, the states are chained via nesting. +data SDLState s = SDLState { + sdlNextState :: !s +, sdlWindows :: !(HashMap Text (Window, Renderer, V4 Word8)) + +, sdlWindowShownEvents :: !(Seq WindowShownEventData) +, sdlWindowHiddenEvents :: !(Seq WindowHiddenEventData) +, sdlWindowExposedEvents :: !(Seq WindowExposedEventData) +, sdlWindowMovedEvents :: !(Seq WindowMovedEventData) +, sdlWindowResizedEvents :: !(Seq WindowResizedEventData) +, sdlWindowSizeChangedEvents :: !(Seq WindowSizeChangedEventData) +, sdlWindowMinimizedEvents :: !(Seq WindowMinimizedEventData) +, sdlWindowMaximizedEvents :: !(Seq WindowMaximizedEventData) +, sdlWindowRestoredEvents :: !(Seq WindowRestoredEventData) +, sdlWindowGainedMouseFocusEvents :: !(Seq WindowGainedMouseFocusEventData) +, sdlWindowLostMouseFocusEvents :: !(Seq WindowLostMouseFocusEventData) +, sdlWindowGainedKeyboardFocusEvents :: !(Seq WindowGainedKeyboardFocusEventData) +, sdlWindowLostKeyboardFocusEvents :: !(Seq WindowLostKeyboardFocusEventData) +, sdlWindowClosedEvents :: !(Seq WindowClosedEventData) +, sdlKeyboardEvents :: !(Seq KeyboardEventData) +, sdlTextEditingEvents :: !(Seq TextEditingEventData) +, sdlTextInputEvents :: !(Seq TextInputEventData) +, sdlMouseMotionEvents :: !(Seq MouseMotionEventData) +, sdlMouseButtonEvents :: !(Seq MouseButtonEventData) +, sdlMouseWheelEvents :: !(Seq MouseWheelEventData) +, sdlJoyAxisEvents :: !(Seq JoyAxisEventData) +, sdlJoyBallEvents :: !(Seq JoyBallEventData) +, sdlJoyHatEvents :: !(Seq JoyHatEventData) +, sdlJoyButtonEvents :: !(Seq JoyButtonEventData) +, sdlJoyDeviceEvents :: !(Seq JoyDeviceEventData) +, sdlControllerAxisEvents :: !(Seq ControllerAxisEventData) +, sdlControllerButtonEvents :: !(Seq ControllerButtonEventData) +, sdlControllerDeviceEvents :: !(Seq ControllerDeviceEventData) +, sdlQuitEvent :: !Bool +, sdlUserEvents :: !(Seq UserEventData) +, sdlSysWMEvents :: !(Seq SysWMEventData) +, sdlTouchFingerEvents :: !(Seq TouchFingerEventData) +, sdlMultiGestureEvents :: !(Seq MultiGestureEventData) +, sdlDollarGestureEvents :: !(Seq DollarGestureEventData) +, sdlDropEvents :: !(Seq DropEventData) +, sdlClipboardUpdateEvents :: !(Seq ClipboardUpdateEventData) +} deriving (Generic) + +instance NFData s => NFData (SDLState s) +instance NFData WindowShownEventData +instance NFData WindowHiddenEventData +instance NFData WindowExposedEventData +instance NFData WindowMovedEventData +instance NFData WindowResizedEventData +instance NFData WindowSizeChangedEventData +instance NFData WindowMinimizedEventData +instance NFData WindowMaximizedEventData +instance NFData WindowRestoredEventData +instance NFData WindowGainedMouseFocusEventData +instance NFData WindowLostMouseFocusEventData +instance NFData WindowGainedKeyboardFocusEventData +instance NFData WindowLostKeyboardFocusEventData +instance NFData WindowClosedEventData +instance NFData KeyboardEventData +instance NFData TextEditingEventData +instance NFData TextInputEventData +instance NFData MouseMotionEventData +instance NFData MouseButtonEventData +instance NFData MouseWheelEventData +instance NFData JoyAxisEventData +instance NFData JoyBallEventData +instance NFData JoyHatEventData +instance NFData JoyButtonEventData +instance NFData JoyDeviceEventData +instance NFData ControllerAxisEventData +instance NFData ControllerButtonEventData +instance NFData ControllerDeviceEventData +instance NFData TouchFingerEventData +instance NFData MultiGestureEventData +instance NFData DollarGestureEventData +instance NFData ClipboardUpdateEventData +instance NFData Keysym +instance NFData MouseButton +instance NFData InputMotion +instance NFData Scancode +instance NFData MouseDevice +instance NFData Keycode +instance NFData KeyModifier + +instance NFData Window where + rnf = (`seq` ()) + +instance NFData Renderer where + rnf = (`seq` ()) + +instance NFData SysWMEventData where + rnf SysWMEventData{..} = sysWMEventMsg `seq` () + +instance NFData UserEventData where + rnf UserEventData{..} = userEventWindow + `seq` userEventCode + `seq` userEventData1 + `seq` userEventData2 + `seq` () + +instance NFData DropEventData where + rnf DropEventData{..} = dropEventFile `seq` () + +-- | Creates empty module state +emptySDLState :: s -> SDLState s +emptySDLState s = SDLState { + sdlNextState = s + , sdlWindows = H.empty + + , sdlWindowShownEvents = S.empty + , sdlWindowHiddenEvents = S.empty + , sdlWindowExposedEvents = S.empty + , sdlWindowMovedEvents = S.empty + , sdlWindowResizedEvents = S.empty + , sdlWindowSizeChangedEvents = S.empty + , sdlWindowMinimizedEvents = S.empty + , sdlWindowMaximizedEvents = S.empty + , sdlWindowRestoredEvents = S.empty + , sdlWindowGainedMouseFocusEvents = S.empty + , sdlWindowLostMouseFocusEvents = S.empty + , sdlWindowGainedKeyboardFocusEvents = S.empty + , sdlWindowLostKeyboardFocusEvents = S.empty + , sdlWindowClosedEvents = S.empty + , sdlKeyboardEvents = S.empty + , sdlTextEditingEvents = S.empty + , sdlTextInputEvents = S.empty + , sdlMouseMotionEvents = S.empty + , sdlMouseButtonEvents = S.empty + , sdlMouseWheelEvents = S.empty + , sdlJoyAxisEvents = S.empty + , sdlJoyBallEvents = S.empty + , sdlJoyHatEvents = S.empty + , sdlJoyButtonEvents = S.empty + , sdlJoyDeviceEvents = S.empty + , sdlControllerAxisEvents = S.empty + , sdlControllerButtonEvents = S.empty + , sdlControllerDeviceEvents = S.empty + , sdlQuitEvent = False + , sdlUserEvents = S.empty + , sdlSysWMEvents = S.empty + , sdlTouchFingerEvents = S.empty + , sdlMultiGestureEvents = S.empty + , sdlDollarGestureEvents = S.empty + , sdlDropEvents = S.empty + , sdlClipboardUpdateEvents = S.empty + } + +-- | After full cycle of simulation all events are dropped +flashSDLState :: SDLState s -> SDLState s +flashSDLState s = s { + sdlWindowShownEvents = S.empty + , sdlWindowHiddenEvents = S.empty + , sdlWindowExposedEvents = S.empty + , sdlWindowMovedEvents = S.empty + , sdlWindowResizedEvents = S.empty + , sdlWindowSizeChangedEvents = S.empty + , sdlWindowMinimizedEvents = S.empty + , sdlWindowMaximizedEvents = S.empty + , sdlWindowRestoredEvents = S.empty + , sdlWindowGainedMouseFocusEvents = S.empty + , sdlWindowLostMouseFocusEvents = S.empty + , sdlWindowGainedKeyboardFocusEvents = S.empty + , sdlWindowLostKeyboardFocusEvents = S.empty + , sdlWindowClosedEvents = S.empty + , sdlKeyboardEvents = S.empty + , sdlTextEditingEvents = S.empty + , sdlTextInputEvents = S.empty + , sdlMouseMotionEvents = S.empty + , sdlMouseButtonEvents = S.empty + , sdlMouseWheelEvents = S.empty + , sdlJoyAxisEvents = S.empty + , sdlJoyBallEvents = S.empty + , sdlJoyHatEvents = S.empty + , sdlJoyButtonEvents = S.empty + , sdlJoyDeviceEvents = S.empty + , sdlControllerAxisEvents = S.empty + , sdlControllerButtonEvents = S.empty + , sdlControllerDeviceEvents = S.empty + , sdlQuitEvent = False + , sdlUserEvents = S.empty + , sdlSysWMEvents = S.empty + , sdlTouchFingerEvents = S.empty + , sdlMultiGestureEvents = S.empty + , sdlDollarGestureEvents = S.empty + , sdlDropEvents = S.empty + , sdlClipboardUpdateEvents = S.empty + }