packages feed

twirl (empty) → 0.4.0.3

raw patch · 6 files changed

+887/−0 lines, 6 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, file-embed, linear, mtl, pretty-simple, sdl2, sdl2-image, sdl2-mixer, sdl2-ttf, text, time, transformers, twirl, vector

Files

+ README.md view
@@ -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.
+ example/Main.hs view
@@ -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))
+ src/Twirl.hs view
@@ -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
+ src/Twirl/Graphics.hs view
@@ -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
+ src/Twirl/Inputs.hs view
@@ -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 _ = "<mouseButtonFunction>"++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}
+ twirl.cabal view
@@ -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