diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# Twirl + +Twirl is a 2D game engine, which focuses in simplicity, ease of use, and strong static typing. Twirl is scripted using Haskell, a purely functional programming language with a strong static type system. Twirl is used as an imported Haskell library. diff --git a/example/Main.hs b/example/Main.hs new file mode 100644 --- /dev/null +++ b/example/Main.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad (unless) +import Data.Fixed (mod') +import qualified Data.Text as Text +import Twirl +import Twirl.Graphics + +type GameState = (Double, Double, Texture, Bool, Bool, Bool, Triangle) + +data Triangle = Triangle (Double, Double) Double + +main :: IO () +main = + runApp $ + TwirlConfig + { initialState = initState + , updateFunction = update + , drawFunction = draw + , fps = 60 + } + +initState :: TwirlMonad GameState +initState = do + texture <- loadTexture "sample-blue-100x75.png" + setWindowSize 800 600 + setWindowTitle "Twirl example" + pure (200, 200, texture, False, False, False, Triangle (200, 200) 1) + +update :: GameState -> InputState -> Double -> TwirlMonad GameState +update (x, y, texture, _, _, _, Triangle (tx, ty) scale) inputs dt = do + let (tx', ty') = updatePosition inputs False $ updatePosition inputs True (tx, ty) + scale' = updateScale inputs scale + pure + ( (x + 400 * dt) `mod'` 800 + , y + , texture + , if isKeyDown inputs KeycodeA then True else False + , if isControllerButtonDown inputs 0 ControllerButtonStart then True else False + , isMouseDown inputs ButtonLeft + , Triangle (tx', ty') scale' + ) + +draw :: GameState -> TwirlMonad () +draw (x, y, texture, invisible, controllerStartDown, mouseDown, Triangle (tx, ty) scale) = do + setColor 0 0 0 255 + rectangle (round x) (round y) 30 30 Hollow + printText (Text.pack "Hello!") 100 100 + unless invisible $ printText (Text.pack "Press A to turn me invisible!") 500 100 + unless controllerStartDown $ printText (Text.pack "Press Start to turn me invisible!") 500 120 + unless mouseDown $ printText (Text.pack "Press left mouse to turn me invisible!") 500 140 + drawTexture texture 300 300 + polyLine [(400, 400), (440, 420), (410, 440), (450, 450)] + polyLine $ map (\(xx, yy) -> ((round $ scale * xx) + round tx, (round $ scale * yy) + round ty)) [(0, 0), (40, 0), (0, 30), (0, 0)] + +updatePosition :: InputState -> Bool -> (Double, Double) -> (Double, Double) +updatePosition inputs leftStick (tx, ty) = + let xValue = controllerAxis inputs 0 (if leftStick then ControllerAxisLeftX else ControllerAxisRightX) + yValue = controllerAxis inputs 0 (if leftStick then ControllerAxisLeftY else ControllerAxisRightY) + tx' = if abs xValue > 0.3 then tx + xValue * 4 else tx + ty' = if abs yValue > 0.3 then ty + yValue * 4 else ty + in (tx', ty') + +updateScale :: InputState -> Double -> Double +updateScale inputs scale = + scale + (0.1 * (controllerAxis inputs 0 ControllerAxisTriggerLeft)) - (0.1 * (controllerAxis inputs 0 ControllerAxisTriggerRight)) diff --git a/src/Twirl.hs b/src/Twirl.hs new file mode 100644 --- /dev/null +++ b/src/Twirl.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Twirl ( + runApp + , TwirlConfig (..) + , TwirlMonad + , module Twirl.Inputs + , module Keys +) where + +import Control.Concurrent (threadDelay) +import Control.Exception (bracket_) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Data.List (sortBy) +import Data.Ord (comparing) +import Foreign.C.Types (CInt) +import SDL hiding (get) +import qualified SDL.Font as Font +import qualified SDL.Input.Keyboard.Codes as Keys +import qualified SDL.Mixer as Mixer +import Twirl.Graphics +import Twirl.Inputs + +data TwirlConfig a = TwirlConfig + { initialState :: TwirlMonad a + , updateFunction :: a -> InputState -> Double -> TwirlMonad a + , drawFunction :: a -> TwirlMonad () + , fps :: Int + } + +runApp :: TwirlConfig a -> IO () +runApp config@TwirlConfig{..} = do + initializeAll + withFont $ do + Mixer.withAudio Mixer.defaultAudio audioChunkSize $ do + displays <- getDisplays + let primaryWindowSize = getPrimaryDisplaySize displays + windowSettings = defaultWindow{windowInitialSize = primaryWindowSize, windowBorder = False} + window <- createWindow "" windowSettings + defaultFont <- loadDefaultFont + rendererType <- chooseRendererType + let rendererSettings = + RendererConfig + { rendererType = rendererType + , rendererTargetTexture = True + } + renderer <- createRenderer window (-1) rendererSettings + rendererDrawBlendMode renderer $= BlendAlphaBlend + _ <- flip runTwirlMonad (TwirlContext renderer window defaultFont) $ do + state <- initialState + fpsState <- + liftIO $ + initFPSState + 60 + ( case rendererType of + AcceleratedVSyncRenderer -> True + _ -> False + ) + appLoop config state emptyInputState renderer 0 fpsState window + pure () + +withFont :: IO () -> IO () +withFont = bracket_ Font.initialize Font.quit + +getPrimaryDisplaySize :: [Display] -> V2 CInt +getPrimaryDisplaySize modes = + let primaryModes = filter ((==) (P (V2 0 0)) . displayBoundsPosition) modes + in displayBoundsSize $ head primaryModes + +chooseRendererType :: IO RendererType +chooseRendererType = do + rendererInfos <- getRenderDriverInfo + pure $ case sortBy (comparing rendererPriority) rendererInfos of + p : _ -> getRendererType p + [] -> SoftwareRenderer + where + getRendererType RendererInfo{rendererInfoFlags = RendererConfig{rendererType}} = rendererType + rendererPriority rendererInfo = + case getRendererType rendererInfo of + AcceleratedRenderer -> 1 :: Int + AcceleratedVSyncRenderer -> 2 + UnacceleratedRenderer -> 3 + SoftwareRenderer -> 4 + +audioChunkSize :: Int +audioChunkSize = 128 + +appLoop :: TwirlConfig a -> a -> InputState -> Renderer -> Double -> FPSState -> Window -> TwirlMonad () +appLoop config@TwirlConfig{..} state previousInputState renderer carriedOverAccumulator fpsState window = do + (newInputState, quitApp) <- updateInputs previousInputState + (newFPSState, frameTime) <- sleepRemainingTime fpsState + (newState, remainingAccumulator) <- updateState state newInputState (carriedOverAccumulator + frameTime) + + rendererDrawColor renderer $= V4 255 255 255 255 + clear renderer + drawFunction newState + present renderer + if quitApp + then closeControllers newInputState + else appLoop config newState newInputState renderer remainingAccumulator newFPSState window + where + updateState previousState inputState accumulator = do + let timeStep = 1 / (fromIntegral fps) + if accumulator > timeStep + then do + newState <- updateFunction previousState inputState timeStep + updateState newState inputState (accumulator - timeStep) + else do + pure (previousState, accumulator) + +data FPSState = FPSState + { frameCount :: !Int + , resetTime :: !Double + , secondsPerFrame :: !Double + , lastTime :: !Double + , vsyncActive :: !Bool + } + +sleepRemainingTime :: MonadIO m => FPSState -> m (FPSState, Double) +sleepRemainingTime fpsState@FPSState{frameCount, resetTime, secondsPerFrame, lastTime, vsyncActive} = do + currentTime <- time + let targetTime = resetTime + (fromIntegral frameCount) * secondsPerFrame + frameTime = currentTime - lastTime + if vsyncActive + then pure (fpsState{frameCount = frameCount + 1, lastTime = currentTime}, frameTime) + else + if currentTime <= targetTime + then do + let requestedDelay = round $ (targetTime - currentTime) * 1000000 + liftIO $ threadDelay requestedDelay + pure (fpsState{frameCount = frameCount + 1, lastTime = currentTime}, frameTime) + else do + pure (fpsState{frameCount = 1, resetTime = currentTime, secondsPerFrame = secondsPerFrame, lastTime = currentTime}, frameTime) + +initFPSState :: Int -> Bool -> IO FPSState +initFPSState fps vsyncActive = do + startTime <- time + pure $ FPSState 0 startTime (1 / (fromIntegral fps)) startTime vsyncActive diff --git a/src/Twirl/Graphics.hs b/src/Twirl/Graphics.hs new file mode 100644 --- /dev/null +++ b/src/Twirl/Graphics.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TemplateHaskell #-} + +module Twirl.Graphics ( + line + , polyLine + , rectangle + , circle + , drawTexture + , loadTexture + , decodeTexture + , setColor + , setLogicalSize + , setWindowSize + , WindowMode (..) + , setWindowMode + , Texture + , Quad + , mkQuad + , quadWidth + , quadHeight + , drawQuad + , TwirlMonad + , TwirlContext (..) + , FillMode (..) + , loadFont + , loadDefaultFont + , PointSize + , setFont + , printText + , runTwirlMonad + , setWindowTitle +) where + +import Control.Monad.IO.Class (MonadIO) +import Control.Monad.State (MonadState, StateT, get, gets, modify, runStateT) +import Data.ByteString (ByteString) +import Data.FileEmbed (embedFile) +import Data.List (nub) +import Data.Text (Text) +import Data.Vector.Storable hiding ( + foldl + , length + , map + , mapM_ + , modify + , tail + , (++) + ) +import Foreign.C.Types +import SDL (Point (..), Rectangle (..), Renderer, Texture, V2 (..), V4 (..), Window, WindowMode (..), windowTitle, ($=)) +import qualified SDL +import SDL.Font (Font, PointSize) +import qualified SDL.Font as Font +import qualified SDL.Image + +newtype TwirlMonad a = TwirlMonad (StateT TwirlContext IO a) deriving (Applicative, Functor, Monad, MonadIO, MonadState TwirlContext) + +runTwirlMonad :: TwirlMonad a -> TwirlContext -> IO (a, TwirlContext) +runTwirlMonad (TwirlMonad action) initialState = runStateT action initialState + +data TwirlContext = TwirlContext + { renderer :: Renderer + , window :: Window + , font :: Font + } + +data FillMode + = Fill + | Hollow + +loadTexture :: FilePath -> TwirlMonad Texture +loadTexture path = do + renderer <- gets renderer + SDL.Image.loadTexture renderer path + +decodeTexture :: ByteString -> TwirlMonad Texture +decodeTexture texture = do + renderer <- gets renderer + SDL.Image.decodeTexture renderer texture + +-- |Draw a texture +-- +-- The texture position is specified as its top-left corner's position +drawTexture :: + -- |The texture to draw + Texture -> + -- |X coordinate of the texture's top-left corner + Int -> + -- |Y coordinate of the texture's top-left corner + Int -> + TwirlMonad () +drawTexture texture x y = do + context <- get + textureInfo <- SDL.queryTexture texture + _ <- + SDL.copy + (renderer context) + texture + Nothing + (Just (Rectangle (P $ V2 (fromIntegral x) (fromIntegral y)) (V2 (SDL.textureWidth textureInfo) (SDL.textureHeight textureInfo)))) + return () + +data Quad = Quad + { quadRectangle :: Rectangle CInt + , quadTexture :: Texture + } + deriving (Eq) + +mkQuad :: Texture -> Int -> Int -> Int -> Int -> Quad +mkQuad texture x y w h = + Quad{quadRectangle = Rectangle (P $ V2 (fromIntegral x) (fromIntegral y)) (V2 (fromIntegral w) (fromIntegral h)), quadTexture = texture} + +quadWidth :: Quad -> Int +quadWidth Quad{quadRectangle = Rectangle _ (V2 w _)} = fromIntegral w + +quadHeight :: Quad -> Int +quadHeight Quad{quadRectangle = Rectangle _ (V2 _ h)} = fromIntegral h + +drawQuad :: Quad -> Int -> Int -> Int -> Int -> Bool -> Bool -> TwirlMonad () +drawQuad Quad{quadRectangle, quadTexture} x y sx sy flipX flipY = do + renderer <- gets renderer + let Rectangle _ (V2 w h) = quadRectangle + SDL.copyEx renderer quadTexture (Just quadRectangle) (Just $ Rectangle (P $ V2 (fromIntegral x) (fromIntegral y)) (V2 (w * fromIntegral sx) (h * fromIntegral sy))) 0 Nothing (V2 flipX flipY) + +-- |Draw a line from one point to another +line :: + -- |X coordinate of one end of the line + Int -> + -- |Y coordinate of one end of the line + Int -> + -- |X coordinate of the other end of the line + Int -> + -- |Y coordinate of the other end of the line + Int -> + TwirlMonad () +line x1 y1 x2 y2 = do + let point1 = P $ V2 (fromIntegral x1 :: CInt) (fromIntegral y1 :: CInt) + point2 = P $ V2 (fromIntegral x2 :: CInt) (fromIntegral y2 :: CInt) + context <- get + SDL.drawLine (renderer context) point1 point2 + +polyLine :: [(Int, Int)] -> TwirlMonad () +polyLine coordinates = do + context <- get + let points = fromList $ map (\(x, y) -> P $ V2 (fromIntegral x) (fromIntegral y)) coordinates + SDL.drawLines (renderer context) points + +-- |Draw an axis aligned rectangle +rectangle :: + -- |X coordinate of the rectangle + Int -> + -- |Y coordinate of the rectangle + Int -> + -- |Width of the rectangle + Int -> + -- |Height of the rectangle + Int -> + FillMode -> + TwirlMonad () +rectangle x y width height fillMode = do + rend <- gets renderer + let pos = P $ V2 (fromIntegral x) (fromIntegral y) + dimensions = V2 (fromIntegral width) (fromIntegral height) + rect = Rectangle pos dimensions + case fillMode of + Fill -> SDL.fillRect rend $ Just rect + Hollow -> SDL.drawRect rend (Just rect) + +-- |Draw a circle +-- +-- The drawn shape is not actually a circle, but rather a polygon consisting +-- of a number of segments. Larger value results in a smoother circle, +-- but is slower to draw. +circle :: + -- |X coordinate of the top-left "corner" of the circle + Int -> + -- |Y coordinate of the top-left "corner" of the circle + Int -> + -- |Radius of the circle + Double -> + -- |How many segments the circle should be made of + Int -> + -- |Whether to draw the circle hollow or filled + FillMode -> + TwirlMonad () +circle x y radius segments fill = do + let points = generate (segments + 1) arcPoint + context <- get + SDL.drawLines (renderer context) points + case fill of + Fill -> fillPolygon points + Hollow -> return () + where + arcPoint i = + let theta = fromIntegral i / fromIntegral segments * 2 * pi + x' = radius * cos theta + y' = radius * sin theta + in P $ V2 (fromIntegral $ round x' + x) (fromIntegral $ round y' + y) + +intersectionX :: CInt -> Point V2 CInt -> Point V2 CInt -> Maybe CInt +intersectionX y (P (V2 x1 y1)) (P (V2 x2 y2)) + | y1 == y2 = Nothing + | (y1 <= y && y <= y2) || (y2 <= y && y <= y1) = + let a :: Double + a = + (fromIntegral x1 - fromIntegral x2) + / (fromIntegral y1 - fromIntegral y2) + in Just $ + round $ fromIntegral y * a - fromIntegral y1 * a + fromIntegral x1 + | otherwise = Nothing + +fillPolygon :: Vector (Point V2 CInt) -> TwirlMonad () +fillPolygon points = do + let (P (V2 _ maxY)) = maximumBy comparePointY points + (P (V2 _ minY)) = minimumBy comparePointY points + mapM_ (scanLine (toList points)) [minY .. maxY] + where + comparePointY (P (V2 _ y)) (P (V2 _ y2)) = compare y y2 + +scanLine :: [Point V2 CInt] -> CInt -> TwirlMonad () +scanLine points y = do + let xs = findXs points y + paintScans y xs + where + findXs pts y' = + let polygonLines = zip pts (tail pts) + in nub $ + foldl + ( \xs (p1, p2) -> + case intersectionX y' p1 p2 of + Just x -> x : xs + Nothing -> xs + ) + [] + polygonLines + paintScans :: CInt -> [CInt] -> TwirlMonad () + paintScans y' (x1 : x2 : xs) = do + context <- get + SDL.drawLine (renderer context) (P (V2 x1 y')) (P (V2 x2 y')) + paintScans y xs + paintScans _ [_] = return () + paintScans _ [] = return () + +-- |Set the drawing colour for the next 'TwirlMonad's +setColor :: + -- | Red channel value in the interval @[0,255]@ + Int -> + -- | Green channel value in the interval @[0,255]@ + Int -> + -- | Blue channel value in the interval @[0,255]@ + Int -> + -- | Alpha value in the interval @[0,255]@ + Int -> + TwirlMonad () +setColor r g b a = do + context <- get + SDL.rendererDrawColor (renderer context) + $= V4 (fromIntegral r) (fromIntegral g) (fromIntegral b) (fromIntegral a) + +setLogicalSize :: Int -> Int -> TwirlMonad () +setLogicalSize w h = do + renderer <- gets renderer + SDL.rendererLogicalSize renderer $= Just (V2 (fromIntegral w) (fromIntegral h)) + +setWindowSize :: Int -> Int -> TwirlMonad () +setWindowSize w h = do + window <- gets window + SDL.windowSize window $= V2 (fromIntegral w) (fromIntegral h) + +setWindowMode :: WindowMode -> TwirlMonad () +setWindowMode mode = do + window <- gets window + SDL.setWindowMode window mode + +loadFont :: (MonadIO m) => FilePath -> PointSize -> m Font +loadFont = Font.load + +loadDefaultFont :: MonadIO m => m Font +loadDefaultFont = Font.decode defaultFontData 16 + +defaultFontData :: ByteString +defaultFontData = $(embedFile "PixelOperator.ttf") + +setFont :: Font -> TwirlMonad () +setFont newFont = + modify (\context -> context{font = newFont}) + +data RenderedText = RenderedText + { dimensions :: !(V2 CInt) + , texture :: !Texture + } + +renderText :: Text -> TwirlMonad RenderedText +renderText text = do + context <- get + color <- SDL.get $ SDL.rendererDrawColor $ renderer context + renderedSurface <- Font.solid (font context) color text + surfaceDimensions <- SDL.surfaceDimensions renderedSurface + texture <- SDL.createTextureFromSurface (renderer context) renderedSurface + pure $ RenderedText surfaceDimensions texture + +printRenderedText :: RenderedText -> Int -> Int -> TwirlMonad () +printRenderedText RenderedText{dimensions, texture} x y = do + context <- get + SDL.copy (renderer context) texture Nothing (Just $ Rectangle (P $ V2 (fromIntegral x) (fromIntegral y)) dimensions) + +printText :: Text -> Int -> Int -> TwirlMonad () +printText text x y = do + rendered <- renderText text + printRenderedText rendered x y + +setWindowTitle :: Text -> TwirlMonad () +setWindowTitle title = do + window <- gets window + windowTitle window $= title diff --git a/src/Twirl/Inputs.hs b/src/Twirl/Inputs.hs new file mode 100644 --- /dev/null +++ b/src/Twirl/Inputs.hs @@ -0,0 +1,271 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Twirl.Inputs ( + InputState + , ControllerAxis (..) + , ControllerButton (..) + , MouseButton (..) + , updateInputs + , closeControllers + , emptyInputState + , numControllers + , isControllerButtonDown + , controllerAxis + , isKeyDown + , isMouseDown + , mousePosition +) where + +import Control.Monad.IO.Class (MonadIO) +import Data.Foldable (foldlM) +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Word (Word8) +import Foreign.C.Types (CInt) +import GHC.Int (Int16, Int32) +import SDL ( + ControllerAxisEventData (..) + , ControllerButtonEventData (..) + , ControllerDeviceEventData (..) + , Event (..) + , EventPayload (ControllerAxisEvent, ControllerButtonEvent, ControllerDeviceEvent, KeyboardEvent, QuitEvent) + , InputMotion (Pressed, Released) + , KeyboardEventData (..) + , Keycode + , Keysym (..) + , MouseButton (..) + , Point (..) + , V2 (..) + , getAbsoluteMouseLocation + , getMouseButtons + , keyboardEventKeyMotion + , pollEvents + ) +import SDL.Input.GameController ( + ControllerButton (..) + , ControllerButtonState (..) + , ControllerDeviceConnection (..) + ) +import SDL.Raw.Event (gameControllerClose, gameControllerFromInstanceID, gameControllerGetJoystick, gameControllerOpen, joystickInstanceID) +import SDL.Raw.Types (GameController) +import Twirl.Graphics + +data ControllerAxis = ControllerAxisLeftX | ControllerAxisLeftY | ControllerAxisRightX | ControllerAxisRightY | ControllerAxisTriggerLeft | ControllerAxisTriggerRight + +data ControllerAxes = ControllerAxes + { controllerAxisLeftX :: Int16 + , controllerAxisLeftY :: Int16 + , controllerAxisRightX :: Int16 + , controllerAxisRightY :: Int16 + , controllerAxisTriggerLeft :: Int16 + , controllerAxisTriggerRight :: Int16 + } + deriving (Show) + +data ControllerState = ControllerState + { controllerStateButtons :: Set ControllerButton + , controllerStateAxes :: ControllerAxes + } + deriving (Show) + +emptyControllerState :: ControllerState +emptyControllerState = + ControllerState + { controllerStateButtons = Set.empty + , controllerStateAxes = + ControllerAxes + { controllerAxisLeftX = 0 + , controllerAxisLeftY = 0 + , controllerAxisRightX = 0 + , controllerAxisRightY = 0 + , controllerAxisTriggerLeft = 0 + , controllerAxisTriggerRight = 0 + } + } + +data InputState = InputState + { controllers :: Map Int ControllerState + , keyDownSet :: Set Keycode + , instanceIdToControllerNo :: Map Int32 Int + , mouseButtons :: (MouseButton -> Bool) + , mousePos :: (Int, Int) + } + deriving (Show) + +instance Show (MouseButton -> Bool) where + show _ = "" + +updateInputs :: MonadIO m => InputState -> m (InputState, Bool) +updateInputs inputState = do + events <- pollEvents + mouseInputFn <- getMouseButtons + mouseLocation <- getAbsoluteMouseLocation + let quitApp = any ((== QuitEvent) . eventPayload) events + updatedInputs <- handleEvents events inputState{mouseButtons = mouseInputFn, mousePos = toMousePos mouseLocation} + pure (updatedInputs, quitApp) + +toMousePos :: Point V2 CInt -> (Int, Int) +toMousePos (P (V2 x y)) = (fromIntegral x, fromIntegral y) + +emptyInputState :: InputState +emptyInputState = InputState{controllers = Map.empty, keyDownSet = Set.empty, instanceIdToControllerNo = Map.empty, mouseButtons = const False, mousePos = (0, 0)} + +getControllerAxis :: ControllerAxis -> ControllerState -> Int16 +getControllerAxis ControllerAxisLeftX controllerState = controllerAxisLeftX $ controllerStateAxes controllerState +getControllerAxis ControllerAxisLeftY controllerState = controllerAxisLeftY $ controllerStateAxes controllerState +getControllerAxis ControllerAxisRightX controllerState = controllerAxisRightX $ controllerStateAxes controllerState +getControllerAxis ControllerAxisRightY controllerState = controllerAxisRightY $ controllerStateAxes controllerState +getControllerAxis ControllerAxisTriggerLeft controllerState = controllerAxisTriggerLeft $ controllerStateAxes controllerState +getControllerAxis ControllerAxisTriggerRight controllerState = controllerAxisTriggerRight $ controllerStateAxes controllerState + +-- | Get number of controllers +-- +-- Returns the maximum number of controllers that have been connected simultaneously. This means that if +-- you connect four controllers and unplug one, this function will return 4. +numControllers :: InputState -> Int +numControllers InputState{controllers} = (length . Map.elems) controllers + +-- | Query the state of controller buttons +-- +-- Returns True if the queried button is down on the queried controller. Returns False if the controller is disconnected or doesn't exist +-- (e.g. you query controller number 4 but there are only 2 controllers). +isControllerButtonDown :: + InputState -> + -- | Controller number to be queried + Int -> + -- | The Controller button to be queried + ControllerButton -> + Bool +isControllerButtonDown InputState{controllers} controllerNumber button = + case Map.lookup controllerNumber controllers of + Nothing -> False + Just controllerState -> Set.member button (controllerStateButtons controllerState) + +-- | Query axes of controllers +-- +-- For the stick axes, the returned value is between -1.0 and 1.0, where 0.0 is the neutral position. +-- For triggers the value is between 0.0 and 1.0 where 0.0 is the neutral position. Bear in mind that +-- usually the level of quality of controller sticks is so low that the sticks don't return exactly to +-- the 0.0 position, so you have to ignore some values which are too close to zero. +controllerAxis :: + InputState -> + -- | Controller number + Int -> + -- | The queried axis + ControllerAxis -> + Double +controllerAxis InputState{controllers} controllerNumber axis = + case Map.lookup controllerNumber controllers of + Nothing -> 0 + Just controllerState -> (fromIntegral $ getControllerAxis axis controllerState) / 32767 + +-- | Query keyboard state +isKeyDown :: InputState -> Keycode -> Bool +isKeyDown InputState{keyDownSet} keycode = Set.member keycode keyDownSet + +-- | Query mouse button state +isMouseDown :: InputState -> MouseButton -> Bool +isMouseDown InputState{mouseButtons} = mouseButtons + +-- | Get mouse position on screen +mousePosition :: InputState -> (Int, Int) +mousePosition InputState{mousePos} = mousePos + +handleEvents :: MonadIO m => [Event] -> InputState -> m InputState +handleEvents events keySet = + foldlM + handleEvent + keySet + events + +handleEvent :: MonadIO m => InputState -> Event -> m InputState +handleEvent inputState event = + case eventPayload event of + KeyboardEvent keyboardEvent -> + case keyboardEventKeyMotion keyboardEvent of + Pressed -> pure inputState{keyDownSet = Set.insert (keysymKeycode $ keyboardEventKeysym keyboardEvent) (keyDownSet inputState)} + Released -> pure inputState{keyDownSet = Set.delete (keysymKeycode $ keyboardEventKeysym keyboardEvent) (keyDownSet inputState)} + ControllerDeviceEvent (ControllerDeviceEventData{controllerDeviceEventConnection, controllerDeviceEventWhich}) -> case controllerDeviceEventConnection of + -- Type cast is necessary because SDL returns either device index or instance id + -- (https://wiki.libsdl.org/SDL_ControllerDeviceEvent) depending on whether the + -- controller was added or removed, but Haskell bindings always report to return + -- instance id (which must be wrong since added but unopened controllers don't have + -- an instance id yet) + ControllerDeviceAdded -> gameControllerOpen (fromIntegral controllerDeviceEventWhich) >>= addControllerMapping inputState + ControllerDeviceRemoved -> do + controllerPtr <- gameControllerFromInstanceID controllerDeviceEventWhich + updatedInputs <- removeControllerMapping inputState controllerPtr + gameControllerClose controllerPtr + pure updatedInputs + _ -> pure inputState + ControllerButtonEvent e -> do + let updatedState = updateInputStateController e inputState + pure updatedState + ControllerAxisEvent e -> do + let updatedState = updateInputStateControllerAxis e inputState + pure updatedState + _ -> pure inputState + +addControllerMapping :: MonadIO m => InputState -> GameController -> m InputState +addControllerMapping inputState@InputState{instanceIdToControllerNo} controller = do + instanceId <- gameControllerGetJoystick controller >>= joystickInstanceID + let controllerNo = nextFreeController inputState + pure inputState{instanceIdToControllerNo = Map.insert instanceId controllerNo instanceIdToControllerNo} + +nextFreeController :: InputState -> Int +nextFreeController InputState{instanceIdToControllerNo} = + let mappedControllers = Set.fromList $ Map.elems instanceIdToControllerNo + in findSmallestNaturalNotInSet mappedControllers + where + findSmallestNaturalNotInSet :: Set Int -> Int + findSmallestNaturalNotInSet set = + let go n = if not (Set.member n set) then n else go (n + 1) + in go 0 + +removeControllerMapping :: MonadIO m => InputState -> GameController -> m InputState +removeControllerMapping inputState@InputState{instanceIdToControllerNo} controller = do + instanceId <- gameControllerGetJoystick controller >>= joystickInstanceID + pure inputState{instanceIdToControllerNo = Map.delete instanceId instanceIdToControllerNo} + +closeControllers :: InputState -> TwirlMonad () +closeControllers InputState{instanceIdToControllerNo} = do + let controllerIds = Map.keys instanceIdToControllerNo + controllerPtrs <- mapM gameControllerFromInstanceID controllerIds + mapM_ gameControllerClose controllerPtrs + +updateInputStateController :: ControllerButtonEventData -> InputState -> InputState +updateInputStateController ControllerButtonEventData{controllerButtonEventWhich, controllerButtonEventState, controllerButtonEventButton} inputState@InputState{controllers, instanceIdToControllerNo} = + let controller = fromMaybe (nextFreeController inputState) $ Map.lookup controllerButtonEventWhich instanceIdToControllerNo + in inputState{controllers = Map.alter (updateControllerState controllerButtonEventState controllerButtonEventButton) controller controllers} + +updateControllerState :: ControllerButtonState -> ControllerButton -> Maybe ControllerState -> Maybe ControllerState +updateControllerState stateChange button maybeState = + let state = fromMaybe emptyControllerState maybeState + action = case stateChange of + ControllerButtonPressed -> Set.insert + ControllerButtonReleased -> Set.delete + _ -> flip const + in pure state{controllerStateButtons = action button (controllerStateButtons state)} + +updateInputStateControllerAxis :: ControllerAxisEventData -> InputState -> InputState +updateInputStateControllerAxis ControllerAxisEventData{controllerAxisEventWhich, controllerAxisEventValue, controllerAxisEventAxis} inputState@InputState{controllers, instanceIdToControllerNo} = + let controller = fromMaybe (nextFreeController inputState) $ Map.lookup controllerAxisEventWhich instanceIdToControllerNo + in inputState{controllers = Map.alter (updateControllerStateAxis controllerAxisEventValue controllerAxisEventAxis) controller controllers} + +updateControllerStateAxis :: Int16 -> Word8 -> Maybe ControllerState -> Maybe ControllerState +updateControllerStateAxis value axis maybeState = + let state = fromMaybe emptyControllerState maybeState + in pure state{controllerStateAxes = updateControllerAxis (controllerStateAxes state) value axis} + +updateControllerAxis :: ControllerAxes -> Int16 -> Word8 -> ControllerAxes +updateControllerAxis axes value axis = case axis of + 0 -> axes{controllerAxisLeftX = value} + 1 -> axes{controllerAxisLeftY = value} + 2 -> axes{controllerAxisRightX = value} + 3 -> axes{controllerAxisRightY = value} + 4 -> axes{controllerAxisTriggerLeft = value} + _ -> axes{controllerAxisTriggerRight = value} diff --git a/twirl.cabal b/twirl.cabal new file mode 100644 --- /dev/null +++ b/twirl.cabal @@ -0,0 +1,90 @@ +cabal-version: 2.2 + +-- This file has been generated from package.yaml by hpack version 0.34.7. +-- +-- see: https://github.com/sol/hpack + +name: twirl +version: 0.4.0.3 +synopsis: Simple 2D Game Engine +description: A batteries included 2D game engine focusing on simplicity and ease of use. +category: Game Engine +author: Lassi Haasio +maintainer: ilikeavocadoes@devmail.cc +copyright: (c) 2021-2023 Lassi Haasio +license: Zlib +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://git.sr.ht/~ilikeavocadoes/twirl + +flag debug + manual: True + default: False + +library + exposed-modules: + Twirl + Twirl.Graphics + Twirl.Inputs + other-modules: + Paths_twirl + autogen-modules: + Paths_twirl + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , bytestring + , containers + , file-embed + , linear + , mtl + , pretty-simple + , sdl2 + , sdl2-image + , sdl2-mixer + , sdl2-ttf + , text + , time + , transformers + , vector + if flag(debug) + ghc-options: -W -Wall -fwrite-ide-info -hiedir=.hie + else + ghc-options: -W -Wall -Werror -Wno-orphans + default-language: Haskell2010 + +executable example + main-is: Main.hs + other-modules: + Paths_twirl + autogen-modules: + Paths_twirl + hs-source-dirs: + example + build-depends: + base >=4.7 && <5 + , bytestring + , containers + , file-embed + , linear + , mtl + , pretty-simple + , sdl2 + , sdl2-image + , sdl2-mixer + , sdl2-ttf + , text + , time + , transformers + , twirl + , vector + if flag(debug) + ghc-options: -W -Wall -fwrite-ide-info -hiedir=.hie + else + ghc-options: -W -Wall -Werror -Wno-orphans + default-language: Haskell2010