packages feed

yampa-sdl2 0.0.3.1 → 0.1.0.0

raw patch · 33 files changed

+891/−935 lines, 33 filesdep +memoizedep +vectordep −sdl2-gfxdep −stmdep ~sdl2

Dependencies added: memoize, vector

Dependencies removed: sdl2-gfx, stm

Dependency ranges changed: sdl2

Files

src/YampaSDL2.hs view
@@ -1,51 +1,13 @@ module YampaSDL2-  ( module YampaSDL2.MainLoop-  , module YampaSDL2.Backend-  , module YampaSDL2.Backend.SDL-  , module YampaSDL2.AppInput-  , module YampaSDL2.AppOutput-  , module YampaSDL2.Geometry-  , module YampaSDL2.Animation-  , module Data.Colour.Names-  , module Data.Colour.SRGB-  , module Linear.V2-  , module SDL.Input.Keyboard.Codes+  ( module YampaSDL2.Animation+  , module YampaSDL2.Init+  , module YampaSDL2.InputOutput+  , module YampaSDL2.Draw+  , module YampaSDL2.ReExports   ) where -import Linear.V2-import Data.Colour.Names-import Data.Colour.SRGB-import SDL.Input.Keyboard.Codes--import YampaSDL2.AppInput-  ( AppInput-  , quit-  , anyKeyActive-  , anyKeyPress-  , mouseLeftActive-  , mouseLeftPress-  , mouseRightActive-  , mouseRightPress-  , mousePosition-  )-import YampaSDL2.AppOutput-  ( AppOutput(..)-  , Graphics(..)-  , Sound(..)-  , RenderShape(..)-  , Camera(..)-  , container-  )-import YampaSDL2.Backend (defaultBackendConfiguration, BackendConfiguration(..))-import YampaSDL2.Geometry-  ( Shape(..)-  , ShapeColour(..)-  )-import YampaSDL2.MainLoop (mainLoop)+import YampaSDL2.Draw+import YampaSDL2.Init+import YampaSDL2.InputOutput+import YampaSDL2.ReExports import YampaSDL2.Animation-  ( Animation-  , AnimationType(..)-  , animate-  , newAnimation-  )-import YampaSDL2.Backend.SDL (sdlBackend)
src/YampaSDL2/Animation.hs view
@@ -1,45 +1,67 @@-{-|-Module      : Animation-Description : Provide an easy way to do animations--} {-# Language Arrows #-}  module YampaSDL2.Animation   ( -- * Animation     animate-  , Animation(..)-  , AnimationType(..)-  , newAnimation+  -- ** Animatable Properties+  , animateNumber+  , animateV2+  , animateColour+  -- ** Animation curves+  , linear+  , easeIn+  , easeOut   ) where  import FRP.Yampa+import Linear.V2+import Data.Maybe+import FRP.Yampa.Event+import Data.List+import Data.Colour -import YampaSDL2.AppOutput (RenderShape)+type Curve = Double -> Extent+-- | Extent is always between 0 and 1 (including 0 and 1). Starts with 0 and is at 1 at the end of the duration.+type Extent = Double+-- | Animation duration in seconds+type Duration = Double -data Animation = Animation-  { frames :: [(Time, RenderShape)] -- ^ Time specifies how long the RenderShape is displayed, for example [(0.5, renderShape1), (0.5, renderShape2)]-  , type_ :: AnimationType-  }+-- | Create an animation+--+-- Example:+--+-- > animate animateV2 (V2 0 0) [(2, easeOut, V2 0 100), (2, easeIn, V2 0 0)] +animate ::+    (a -> a -> Extent -> a) -- ^ The property to animate+  -> a -- ^ The starting point+  -> [(Duration, Curve,a)] -- ^ The animations to execute one after another+  -> SF () a+animate _ a [] = constant a+animate f aB ((dur,curve,aE):rest) = switch (sf aB f dur) (cont f rest)+  where sf propertyB animateF duration = proc _ -> do+          currentRS <- f aB aE  ^<< (boundExtent curve) ^<< (/duration) ^<< time -< ()+          event <- after duration () -< ()+          returnA -< (currentRS,tag event currentRS)+        cont f rest propertyB = animate f propertyB rest -newAnimation = Animation+animateNumber :: Double -> Double -> Extent -> Double+animateNumber beginning end e = beginning + (end - beginning) * e -data AnimationType = Once | Endless | Repeat Int | Alternate | AlternateEndless+animateV2 :: V2 Double -> V2 Double -> Extent -> V2 Double+animateV2 beginning end e = beginning + (end - beginning)*V2 e e -animate :: Animation -> SF a (Maybe RenderShape)-animate animation-  | (null $ frames animation) = constant Nothing-  | otherwise = proc _ -> do-      frameEvent <- afterEach (getFrames animation) -< ()-      frame <- hold initialFrame -< frameEvent-      returnA -< return frame-        where initialFrame = let (_,frame) = head $ frames animation-                       in frame+animateColour :: AlphaColour Double -> AlphaColour Double -> Extent -> AlphaColour Double+animateColour beginning end e = blend e end beginning -getFrames :: Animation -> [(Time, RenderShape)]-getFrames (Animation{frames=frames,type_=type_}) =-  case type_ of-    Once -> frames-    Endless -> cycle frames-    Repeat times -> concat $ replicate times frames-    Alternate -> frames ++ reverse frames-    AlternateEndless -> cycle (frames ++ reverse frames)+linear = id++easeIn x = x*x++easeOut x = 1-(x-1)^2++boundExtent :: Curve -> Double -> Double+boundExtent f time+  | f time < 0 = 0+  | f time > 1 = 1+  | otherwise = f time+
− src/YampaSDL2/AppInput.hs 
@@ -1,69 +0,0 @@-{-|-Module      : Input-Description : Contains all input SF functions--}--{-# Language Arrows #-}--module YampaSDL2.AppInput-  ( -- * Input-    AppInput(..)-  , initAppInput-    -- ** SFs-  , quit-  , anyKeyActive-  , anyKeyPress-  , mouseLeftActive-  , mouseLeftPress-  , mouseRightActive-  , mouseRightPress-  , mousePosition-  ) where--import FRP.Yampa-import FRP.Yampa.Event (maybeToEvent)-import Data.Maybe (isJust)-import SDL.Input.Keyboard.Codes-import Linear.V2---- | Your main SF receives AppInput as input-data AppInput = AppInput-  { inpQuit :: Bool-  , inpKey :: Maybe Scancode-  , inpMousePos :: V2 Double-  , inpMouseLeft :: Maybe (V2 Double)-  , inpMouseRight :: Maybe (V2 Double)-  } deriving Show--initAppInput :: AppInput-initAppInput = AppInput-  { inpQuit = False-  , inpKey = Nothing-  , inpMousePos = V2 0 0-  , inpMouseLeft = Nothing-  , inpMouseRight = Nothing-  }--quit :: SF AppInput (Event ())-quit = inpQuit ^>> edge--anyKeyActive :: SF AppInput (Event Scancode)-anyKeyActive = inpKey ^>> arr maybeToEvent--anyKeyPress :: SF AppInput (Event Scancode)-anyKeyPress = inpKey ^>> edgeJust--mouseLeftActive :: SF AppInput (Event (V2 Double))-mouseLeftActive = inpMouseLeft ^>> arr maybeToEvent--mouseLeftPress :: SF AppInput (Event (V2 Double))-mouseLeftPress = inpMouseLeft ^>> edgeJust--mouseRightActive :: SF AppInput (Event (V2 Double))-mouseRightActive = inpMouseRight ^>> arr maybeToEvent--mouseRightPress :: SF AppInput (Event (V2 Double))-mouseRightPress = inpMouseRight ^>> edgeJust--mousePosition :: SF AppInput (V2 Double)-mousePosition = arr inpMousePos
− src/YampaSDL2/AppOutput.hs 
@@ -1,49 +0,0 @@-{-|-Module      : Output-Description : Datatypes to describe the output--}--module YampaSDL2.AppOutput-  ( -- * Output-    AppOutput(..)-  , Graphics(..)-  , Camera(..)-  , RenderShape(..)-  , Sound(..)-  , container-  ) where--import Linear.V2--import YampaSDL2.Geometry (Shape(..))------ | Your main SF needs to create an AppOutput-data AppOutput = AppOutput-  { graphics :: Graphics-  , sound :: [Sound]-  , shouldExit :: Bool-  }--data Graphics = Graphics-  { camera :: Camera-  , objects :: [RenderShape]-  } deriving Show--data Camera = Camera-  { cPos :: V2 Double -- ^Moves the viewpoint-  , cSize :: V2 Double -- ^Set the size of the viewpoint, for example to zoom.-  } deriving Show--container :: V2 Double -> [RenderShape] -> [RenderShape]-container translateV2 children =-  fmap (\rs -> rs {shapeCentre=shapeCentre rs + translateV2}) children--data RenderShape-  = RS { shapeCentre :: V2 Double-       , shape :: Shape-       , zIndex :: Int -- ^ Higher zIndex means the RenderShape is in front of the others-       } deriving (Show, Eq)-data Sound =-  NotImplementedYet
− src/YampaSDL2/Backend.hs 
@@ -1,38 +0,0 @@-{-|-Module      : Backend--}-module YampaSDL2.Backend-  ( -- * Backend-    Backend(..)-  , BackendConfiguration(..)-  , defaultBackendConfiguration-  ) where--import FRP.Yampa--import YampaSDL2.AppInput (AppInput)---data Backend a b = Backend-  { initAction :: IO a-  , inputAction :: Bool -> IO (DTime, Maybe a)-  , outputAction :: Bool -> b -> IO Bool-  , parseInput :: SF a AppInput-  , closeAction :: IO ()-  }--data BackendConfiguration = BackendConfiguration-  { windowWidth :: Int-  , windowHeight :: Int-  , windowName :: String-  , windowResizable :: Bool-  , fps :: Double-  }--defaultBackendConfiguration = BackendConfiguration-  { windowWidth = 800-  , windowHeight = 600-  , windowName = "App"-  , windowResizable = True-  , fps = 60-  }
− src/YampaSDL2/Backend/Close.hs 
@@ -1,10 +0,0 @@-module YampaSDL2.Backend.Close-  (closeAction) where--import qualified SDL--closeAction :: SDL.Renderer -> SDL.Window -> IO ()-closeAction r w = do-  SDL.destroyRenderer r-  SDL.destroyWindow w-  SDL.quit
− src/YampaSDL2/Backend/ExperimentalOutput.hs 
@@ -1,284 +0,0 @@-module YampaSDL2.Backend.ExperimentalOutput-  (outputAction) where-import qualified SDL-import qualified SDL.Primitive as GFX-import Data.Colour.SRGB-import Control.Monad-import Control.Exception-import Linear.V4-import Linear.V2-import Data.Maybe-import Control.Concurrent.MVar-import Data.StateVar (($=), get)-import Data.List-import Data.Colour.Names-import Debug.Trace--import YampaSDL2.AppOutput ( AppOutput(..)-                           , Graphics (..)-                           , Camera (..)-                           , RenderShape (..)-                           )-import YampaSDL2.Geometry----- changed bool variable does not do anything-outputAction :: Double -> MVar [(String, (SDL.Texture, V2 Int))]-> MVar Double -> MVar Bool -> MVar (Maybe Graphics) -> SDL.Window -> SDL.Renderer -> Bool -> AppOutput -> IO Bool-outputAction fps mvarTextures mvarFPS mvarReady mvarG window renderer _ ao = do-  lastTime <- readMVar mvarFPS-  currentTime <- SDL.time-  ensureFPS <- if currentTime - lastTime > 1/fps-    then modifyMVar_ mvarFPS (return . const currentTime) >> return True-    else return False-  ready <- readMVar mvarReady-  when (ensureFPS && ready) $ do-    modifyMVar_ mvarReady (\_ -> return False)-    renderGraphics mvarTextures mvarG window renderer (graphics ao)-    modifyMVar_ mvarReady (\_ -> return True)-  return (shouldExit ao)---- Experimental render, inefficient right now--- Rendering of preprocessed shapes-renderGraphics :: MVar [(String, (SDL.Texture, V2 Int))] -> MVar (Maybe Graphics) -> SDL.Window -> SDL.Renderer -> Graphics -> IO ()-renderGraphics mvarTextures mvarG window renderer gra = do-  textures <- readMVar mvarTextures-  let newGraphics =-        splitObjects textures 100 $-          adjustToCamera $-            removeOutOfBounds gra-  oldObjects <- fromMaybe [] <$> fmap objects <$> swapMVar mvarG (return newGraphics)-  (V2 wW wH) <- fmap (fromIntegral . fromEnum) <$> get (SDL.windowSize window)-  (V2 cW cH) <- return (cSize $ camera gra)-  SDL.rendererScale renderer $= realToFrac <$> (V2 (wW/cW) (wH/cH))-  render mvarTextures renderer oldObjects gra--render :: MVar [(String, (SDL.Texture, V2 Int))] -> SDL.Renderer -> [RenderShape] -> Graphics -> IO ()-render mvarTextures renderer oldRS gra = do-  let oldSortedRS = sortBy (\rs1 rs2 -> zIndex rs1 `compare` zIndex rs2) oldRS-      newSortedRS = sortBy (\rs1 rs2 -> zIndex rs1 `compare` zIndex rs2) (objects gra)-      obsChanged = checkChanged oldSortedRS newSortedRS-      rerenderList = render' obsChanged-  mapM_ (renderShape mvarTextures renderer) $-      sortBy (\r1 r2 -> zIndex r1 `compare` zIndex r2) newSortedRS-  SDL.present renderer--  -removeOutOfBounds :: Graphics -> Graphics-removeOutOfBounds graphics =-  let cam = camera graphics-      objs = objects graphics-      (V2 bR bT) =  cPos cam + cSize cam/2-      (V2 bL bB) = cPos cam - cSize cam/2-      notOutOfBounds s = not $-        let (V4 r l u d) = shapeToBorders s-        in r < bL || l > bR || u < bB || d > bT-  in graphics{objects=filter (notOutOfBounds) objs}--adjustToCamera :: Graphics -> Graphics-adjustToCamera gra =-  let cam = camera gra-      obs = objects gra-  in gra{objects = (\rs -> adjustToCamera' cam rs) <$> obs}---adjustToCamera' :: Camera -> RenderShape -> RenderShape-adjustToCamera' c rs =-  let (V2 cx cy) = cPos c-      (V2 w h) = cSize c-      s = shape rs-      adjustPoint (V2 x y) = V2 (x+w/2-cx) (h/2-(y+cy))-      inverseY (V2 x y) = V2 x (-y)-      adjustedCentre = adjustPoint (shapeCentre rs)-      adjustedShape = case s of-       Triangle{ pointA=pA, pointB=pB, pointC=pC} ->-         s{pointA=inverseY pA, pointB = inverseY pB, pointC=inverseY pC}-       otherwise -> s-  in rs{shapeCentre=adjustedCentre, shape=adjustedShape}---- actual renderfunction-renderShape :: MVar [(String, (SDL.Texture, V2 Int))] -> SDL.Renderer -> RenderShape -> IO ()-renderShape mvarTextures renderer renderShape =-      let shape' = shape renderShape-          centre' = shapeCentre renderShape-      in case shape' of-        Rectangle {rectSize = rectSize'} -> do-          let (RGB r g b) = toSRGB24 (sColour shape')-          let draw = if sFilled shape' then GFX.fillRectangle else GFX.rectangle-          draw renderer-            (round <$> centre'-rectSize'/2)-            (round <$> centre'+rectSize'/2)-            (V4 r g b maxBound)-        Circle {radius=rad'} -> do-          let (RGB r g b) = toSRGB24 (sColour shape')-          let draw = if sFilled shape' then GFX.fillCircle else GFX.circle-          draw renderer-            (round <$> centre')-            (round rad')-            (V4 r g b maxBound)-        Triangle {pointA=V2 pax pay, pointB=V2 pbx pby, pointC=V2 pcx pcy, colour=c'} -> do-          let (RGB r g b) = toSRGB24 (sColour shape')-              (V2 x y) = centre'-              draw = if sFilled shape' then GFX.fillTriangle else GFX.smoothTriangle-          draw renderer-            (round <$> V2 (x + pax) (y + pay))-            (round <$> V2 (x + pbx) (y + pby))-            (round <$> V2 (x + pcx) (y + pcy))-            (V4 r g b maxBound)-        Image {size=size', sourceRect=maybeRect, imgPath=path} -> do-          textures <- readMVar mvarTextures-          case lookup path textures of-              (Just (t,size)) ->-                let newSize = fromMaybe ((fromIntegral<$>size)/2, fromIntegral <$> size) maybeRect-                in drawImage renderer t (return newSize) centre' size'-              Nothing -> do-                eitherSurface <- try $ SDL.loadBMP path :: IO (Either SomeException SDL.Surface)-                case eitherSurface of-                  Left ex -> putStrLn $ "IMG Loading failed: " ++ show ex-                  Right val -> do--                    newTexture <- SDL.createTextureFromSurface renderer val-                    attrs <- SDL.queryTexture newTexture-                    let w = SDL.textureWidth attrs-                        h = SDL.textureHeight attrs-                    modifyMVar_ mvarTextures $ return . ((path,(newTexture, fromEnum <$> V2 w h)):)-                    drawImage renderer newTexture maybeRect centre' size'-  where drawImage renderer texture source position size = do-          let toSDLRect (V2 x y, V2 w h) =-                SDL.Rectangle (round <$> SDL.P (V2 (x-w/2) (y-h/2))) (round <$> V2 w h)-          SDL.copy renderer texture (toSDLRect <$> source) (return $ toSDLRect (position,size))------ wrapper for RenderShape to add shapes which are not drawn to decide if a rerender is necessary-data RenderAction = RealAction RenderShape | ShadowAction RenderShape deriving (Show, Eq)--getShape :: RenderAction -> RenderShape-getShape (RealAction s) = s-getShape (ShadowAction s) = s--isReal :: RenderAction -> Bool-isReal (RealAction _) = True-isReal _ = False---- TODO: More efficient algorhytm -> delete oldRS elements that are already found;-checkChanged :: [RenderShape] -> [RenderShape] -> [(Bool, RenderAction)]-checkChanged oldRS newRS =-  let changedOldRS = filter (\rs -> rs `notElem` newRS) oldRS-  in fmap (\rs -> ((not (any (==rs) oldRS) || null oldRS), RealAction rs)) newRS ++ fmap (\rs -> (True, ShadowAction rs)) changedOldRS---- decide which rendershapes need rendering-render' :: [(Bool, RenderAction)] -> [RenderShape]-render' rs = fmap getShape . filter isReal $-  let unchanged = snd <$> filter (not . fst) rs-      changed = snd <$> filter fst rs-  in areUnchangedSame [] unchanged changed--areUnchangedSame :: [RenderAction] -> [RenderAction] -> [RenderAction] -> [RenderAction]-areUnchangedSame compare unchanged changed-  | compare == unchanged = changed-  | otherwise = uncurry (areUnchangedSame unchanged) (checkRenders unchanged $ changed)---checkRenders :: [RenderAction] -> [RenderAction] -> ([RenderAction],[RenderAction])-checkRenders unchanged changed =-  if null unchanged-    then ([],changed)-    else let tests = fmap (\uc -> ((any (checkIfRenderIsNecessary uc) changed),uc)) unchanged-         in (snd <$> filter (not.fst) tests, changed++(snd <$> filter (fst) tests))-  where checkIfRenderIsNecessary unchangedObject changedObject =-             unchangedObject `isColliding` changedObject---hasHigherZIndex :: RenderAction -> RenderAction -> Bool-hasHigherZIndex rs1 rs2 = zIndex (getShape rs1) > zIndex (getShape rs2)--isCoveredBy :: RenderAction -> RenderAction -> Bool-isCoveredBy a b =-  let (V4 rr rl rt rb) = shapeToBorders (getShape a)-      (V4 cr cl ct cb) = shapeToBorders (getShape b)-  in rr <= cr && rl >= cl && rt <= ct && rb >= cb---- FIXME: Not sure if this is right-isColliding :: RenderAction -> RenderAction -> Bool-isColliding s1 s2 =-  let (V4 r1 l1 t1 b1) = shapeToBorders (getShape s1)-      (V4 r2 l2 t2 b2) = shapeToBorders (getShape s2)-  in (((r2 > l1 && r2 < r1) || (l2 > l1 && l2 < r1)) && ((t2 > b1 && t2 < t1) || (b2 > b1 && b2 < t1)))-  || (((r1 > l2 && r1 < r2) || (l1 > l2 && l1 < r2)) && ((t1 > b2 && t1 < t2) || (b1 > b2 && b1 < t2)))---- TODO: Need to properly implement this; Color and Image can be transparent!-isTransparent :: RenderAction -> Bool-isTransparent = const False---- Split objects at every x/givenSize==0 to minimize necessary rendering for big shapes if just a part of them changed.--splitObjects :: [(String, (SDL.Texture, V2 Int))] -> Double -> Graphics -> Graphics-splitObjects textures givenSize gra =-  gra{objects=concatMap (splitObjects' textures givenSize) (objects gra)}--splitObjects' :: [(String, (SDL.Texture, V2 Int))] -> Double -> RenderShape -> [RenderShape]-splitObjects' textures xSize rs =- let (V2 x y) = shapeCentre rs- in case shape rs of-    Rectangle{rectSize=V2 w h, colour=c} ->-      let (firstPoint, sizes) = calculateSize xSize x w-      in snd $ mapAccumL-        (\curPos (s,nextS) -> (curPos+s/2+nextS/2,RS (V2 curPos y) (Rectangle (V2 s h) c) (zIndex rs)))-        firstPoint-        sizes-    Image{size=V2 w h,imgPath=path,sourceRect=maybeRect} ->-      let sourceR = (flip fromMaybe) maybeRect <$> (\(_,s) -> ((fromIntegral <$> s)/2, fromIntegral <$> s)) <$> lookup path textures-      in case sourceR of-        Just (V2 sX sY,V2 sW sH) ->-          let (firstPoint, sizes) = calculateSize xSize x w-          in snd $ mapAccumL-             (\curPos (s,nextS) -> (curPos+s/2+nextS/2,RS (V2 curPos y) (Image (V2 s h) (return (V2 (curPos*sW/w) sY, V2 ((sW/w)*s) sH)) path) (zIndex rs)))-             firstPoint-             sizes--        Nothing -> [rs]-    otherwise -> [rs]-  where calculateSize :: Double -> Double -> Double -> (Double, [(Double,Double)])-        calculateSize preferredSize screenPos actualWidth =-          let leftSide = screenPos - (actualWidth / 2)-              firstSize = preferredSize - fromIntegral (round leftSide `rem` round preferredSize)-          in if firstSize < actualWidth-                then let lastSize = fromIntegral $ round (actualWidth - firstSize) `rem` round preferredSize-                         howManyNormal = round $ (actualWidth - (lastSize + firstSize)) / preferredSize-                         firstPoint = leftSide + (firstSize / 2)--                         sizes = firstSize:replicate howManyNormal preferredSize++if lastSize /= 0 then [lastSize] else []-                     in (firstPoint, sizes `zip` (tail sizes ++ [0]))-                else (leftSide+actualWidth / 2,[(actualWidth,0)])----- helper functions-shapeToBorders :: RenderShape -> V4 Double-shapeToBorders rs =-  let s = shape rs-      (V2 x y) = shapeCentre rs-  in case s of-    Rectangle {rectSize=V2 w h} ->-      V4 (x+w/2) (x-w/2) (y+h/2) (y-h/2)-    Circle {radius=r} ->-      V4 (x+r) (x-r) (y+r) (y-r)-    Triangle {pointA=V2 xa ya, pointB=V2 xb yb, pointC=V2 xc yc} ->-      V4 (x+maximum [xa, xb, xc]) (x+minimum [xa, xb, xc]) (y+maximum [ya,yb,yc]) (y-maximum [ya,yb,yc])-    Image {size=V2 w h} ->-      V4 (x+w/2) (x-w/2) (y+h/2) (y-h/2)---sColour :: Shape -> Colour Double-sColour s =-  case colour s of-    (Filled a) -> a-    (Unfilled a) -> a--sFilled :: Shape -> Bool-sFilled s =-  case colour s of-    (Filled _) -> True-    (Unfilled _) -> False--getY :: V2 a -> a-getY (V2 _ y) = y
− src/YampaSDL2/Backend/Init.hs 
@@ -1,9 +0,0 @@-module YampaSDL2.Backend.Init-  (initAction) where--import FRP.Yampa-import qualified SDL--initAction :: IO (Event SDL.EventPayload)-initAction = return NoEvent-
− src/YampaSDL2/Backend/Input.hs 
@@ -1,18 +0,0 @@-module YampaSDL2.Backend.Input-  (inputAction) where--import qualified SDL-import Control.Concurrent-import FRP.Yampa--inputAction :: MVar DTime -> Bool -> IO (DTime, Maybe (Event SDL.EventPayload))-inputAction lastInteraction _canBlock = do-  maybeEvent <- SDL.waitEventTimeout maximumWaitTime-  currentTime <- SDL.time-  dt <- (currentTime -) <$> swapMVar lastInteraction currentTime--  return (dt, Event . SDL.eventPayload <$> maybeEvent)--minIPS = 30--maximumWaitTime = round $ 1000/fromIntegral minIPS
− src/YampaSDL2/Backend/Output.hs 
@@ -1,173 +0,0 @@-module YampaSDL2.Backend.Output-  (outputAction) where--import qualified SDL-import qualified SDL.Primitive as GFX-import Data.Colour.SRGB-import Control.Monad-import Control.Exception-import Linear.V4-import Linear.V2-import Data.Maybe-import Control.Concurrent.MVar-import Data.StateVar (($=), get)-import Data.List-import Data.Colour.Names-import Debug.Trace--import YampaSDL2.AppOutput ( AppOutput(..)-                           , Graphics (..)-                           , Camera (..)-                           , RenderShape (..)-                           )-import YampaSDL2.Geometry----- changed bool variable does not do anything-outputAction :: Double -> MVar [(String, (SDL.Texture, V2 Int))]-> MVar Double -> MVar Bool -> MVar (Maybe Graphics) -> SDL.Window -> SDL.Renderer -> Bool -> AppOutput -> IO Bool-outputAction fps mvarTextures mvarFPS mvarReady mvarG window renderer _ ao = do-  lastTime <- readMVar mvarFPS-  currentTime <- SDL.time-  ensureFPS <- if currentTime - lastTime > 1/fps-    then modifyMVar_ mvarFPS (return . const currentTime) >> return True-    else return False-  ready <- readMVar mvarReady-  when (ensureFPS && ready) $ do-    modifyMVar_ mvarReady (\_ -> return False)-    renderGraphics mvarTextures window renderer (graphics ao)-    modifyMVar_ mvarReady (\_ -> return True)-  return (shouldExit ao)---renderGraphics :: MVar [(String, (SDL.Texture, V2 Int))] -> SDL.Window -> SDL.Renderer -> Graphics -> IO ()-renderGraphics mvarTextures window renderer gra = do-  textures <- readMVar mvarTextures-  let newGraphics =-         adjustToCamera $-          removeOutOfBounds gra-  (V2 wW wH) <- fmap (fromIntegral . fromEnum) <$> get (SDL.windowSize window)-  (V2 cW cH) <- return (cSize $ camera gra)-  SDL.rendererScale renderer $= realToFrac <$> (V2 (wW/cW) (wH/cH))-  render mvarTextures renderer newGraphics-  --- Preprocessing rendershapes for rendering--render :: MVar [(String, (SDL.Texture, V2 Int))] -> SDL.Renderer -> Graphics -> IO ()-render mvarTextures renderer gra = do-  mapM_ (renderShape mvarTextures renderer) $-      sortBy (\r1 r2 -> zIndex r1 `compare` zIndex r2) (objects gra)-  SDL.present renderer---removeOutOfBounds :: Graphics -> Graphics-removeOutOfBounds graphics =-  let cam = camera graphics-      objs = objects graphics-      (V2 bR bT) =  cPos cam + cSize cam/2-      (V2 bL bB) = cPos cam - cSize cam/2-      notOutOfBounds s = not $-        let (V4 r l u d) = shapeToBorders s-        in r < bL || l > bR || u < bB || d > bT-  in graphics{objects=filter (notOutOfBounds) objs}--adjustToCamera :: Graphics -> Graphics-adjustToCamera gra =-  let cam = camera gra-      obs = objects gra-  in gra{objects = (\rs -> adjustToCamera' cam rs) <$> obs}---adjustToCamera' :: Camera -> RenderShape -> RenderShape-adjustToCamera' c rs =-  let (V2 cx cy) = cPos c-      (V2 w h) = cSize c-      s = shape rs-      adjustPoint (V2 x y) = V2 (x+w/2-cx) (h/2-(y+cy))-      inverseY (V2 x y) = V2 x (-y)-      adjustedCentre = adjustPoint (shapeCentre rs)-      adjustedShape = case s of-       Triangle{ pointA=pA, pointB=pB, pointC=pC} ->-         s{pointA=inverseY pA, pointB = inverseY pB, pointC=inverseY pC}-       otherwise -> s-  in rs{shapeCentre=adjustedCentre, shape=adjustedShape}---- actual renderfunction-renderShape :: MVar [(String, (SDL.Texture, V2 Int))] -> SDL.Renderer -> RenderShape -> IO ()-renderShape mvarTextures renderer renderShape =-      let shape' = shape renderShape-          centre' = shapeCentre renderShape-      in case shape' of-        Rectangle {rectSize = rectSize'} -> do-          let (RGB r g b) = toSRGB24 (sColour shape')-          let draw = if sFilled shape' then GFX.fillRectangle else GFX.rectangle-          draw renderer-            (round <$> centre'-rectSize'/2)-            (round <$> centre'+rectSize'/2)-            (V4 r g b maxBound)-        Circle {radius=rad'} -> do-          let (RGB r g b) = toSRGB24 (sColour shape')-          let draw = if sFilled shape' then GFX.fillCircle else GFX.circle-          draw renderer-            (round <$> centre')-            (round rad')-            (V4 r g b maxBound)-        Triangle {pointA=V2 pax pay, pointB=V2 pbx pby, pointC=V2 pcx pcy, colour=c'} -> do-          let (RGB r g b) = toSRGB24 (sColour shape')-              (V2 x y) = centre'-              draw = if sFilled shape' then GFX.fillTriangle else GFX.smoothTriangle-          draw renderer-            (round <$> V2 (x + pax) (y + pay))-            (round <$> V2 (x + pbx) (y + pby))-            (round <$> V2 (x + pcx) (y + pcy))-            (V4 r g b maxBound)-        Image {size=size', sourceRect=maybeRect, imgPath=path} -> do-          textures <- readMVar mvarTextures-          case lookup path textures of-              (Just (t,size)) ->-                let newSize = fromMaybe ((fromIntegral<$>size)/2, fromIntegral <$> size) maybeRect-                in drawImage renderer t (return newSize) centre' size'-              Nothing -> do-                eitherSurface <- try $ SDL.loadBMP path :: IO (Either SomeException SDL.Surface)-                case eitherSurface of-                  Left ex -> putStrLn $ "IMG Loading failed: " ++ show ex-                  Right val -> do--                    newTexture <- SDL.createTextureFromSurface renderer val-                    attrs <- SDL.queryTexture newTexture-                    let w = SDL.textureWidth attrs-                        h = SDL.textureHeight attrs-                    modifyMVar_ mvarTextures $ return . ((path,(newTexture, fromEnum <$> V2 w h)):)-                    drawImage renderer newTexture maybeRect centre' size'-  where drawImage renderer texture source position size = do-          let toSDLRect (V2 x y, V2 w h) =-                SDL.Rectangle (round <$> SDL.P (V2 (x-w/2) (y-h/2))) (round <$> V2 w h)-          SDL.copy renderer texture (toSDLRect <$> source) (return $ toSDLRect (position,size))----- helper functions-shapeToBorders :: RenderShape -> V4 Double-shapeToBorders rs =-  let s = shape rs-      (V2 x y) = shapeCentre rs-  in case s of-    Rectangle {rectSize=V2 w h} ->-      V4 (x+w/2) (x-w/2) (y+h/2) (y-h/2)-    Circle {radius=r} ->-      V4 (x+r) (x-r) (y+r) (y-r)-    Triangle {pointA=V2 xa ya, pointB=V2 xb yb, pointC=V2 xc yc} ->-      V4 (x+maximum [xa, xb, xc]) (x+minimum [xa, xb, xc]) (y+maximum [ya,yb,yc]) (y-maximum [ya,yb,yc])-    Image {size=V2 w h} ->-      V4 (x+w/2) (x-w/2) (y+h/2) (y-h/2)---sColour :: Shape -> Colour Double-sColour s =-  case colour s of-    (Filled a) -> a-    (Unfilled a) -> a--sFilled :: Shape -> Bool-sFilled s =-  case colour s of-    (Filled _) -> True-    (Unfilled _) -> False
− src/YampaSDL2/Backend/Parse.hs 
@@ -1,46 +0,0 @@-module YampaSDL2.Backend.Parse-  (parseInput) where--import qualified SDL-import SDL.Vect-import FRP.Yampa--import YampaSDL2.AppInput (AppInput(..), initAppInput)--parseInput :: SF (Event SDL.EventPayload) AppInput-parseInput = accumHoldBy onSDLInput initAppInput--onSDLInput :: AppInput -> SDL.EventPayload -> AppInput-onSDLInput ai SDL.QuitEvent = ai {inpQuit = True}-onSDLInput ai (SDL.KeyboardEvent ev)-  | SDL.keyboardEventKeyMotion ev == SDL.Pressed =-    ai {inpKey = Just $ getKeyCode ev}-  | SDL.keyboardEventKeyMotion ev == SDL.Released =-    ai-    { inpKey =-        if inpKey ai == return (getKeyCode ev)-          then Nothing-          else inpKey ai-    }-  where-    getKeyCode = SDL.keysymScancode . SDL.keyboardEventKeysym-onSDLInput ai (SDL.MouseMotionEvent ev) =-  ai {inpMousePos = fromIntegral <$> V2 x y}-  where-    P (V2 x y) = SDL.mouseMotionEventPos ev-onSDLInput ai (SDL.MouseButtonEvent ev) =-  ai {inpMouseLeft = lmb, inpMouseRight = rmb}-  where-    motion = SDL.mouseButtonEventMotion ev-    button = SDL.mouseButtonEventButton ev-    pos = inpMousePos ai-    inpMod =-      case (motion, button) of-        (SDL.Released, SDL.ButtonLeft) -> first (const Nothing)-        (SDL.Pressed, SDL.ButtonLeft) -> first (const (Just pos))-        (SDL.Released, SDL.ButtonRight) -> second (const Nothing)-        (SDL.Pressed, SDL.ButtonRight) -> second (const (Just pos))-        _ -> id-    (lmb, rmb) = inpMod $ (inpMouseLeft &&& inpMouseRight) ai-onSDLInput ai _ = ai-
− src/YampaSDL2/Backend/SDL.hs 
@@ -1,49 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module YampaSDL2.Backend.SDL-  (sdlBackend) where--import qualified SDL-import SDL.Vect-import Control.Concurrent.MVar-import FRP.Yampa-import Data.Text (pack)--import qualified YampaSDL2.Backend.Init as Init-import qualified YampaSDL2.Backend.Input as Input-import qualified YampaSDL2.Backend.Output as Output-import qualified YampaSDL2.Backend.Parse as Parse-import qualified YampaSDL2.Backend.Close as Close--import YampaSDL2.AppOutput (AppOutput)-import YampaSDL2.Backend---- | Set up SDL-sdlBackend ::-     BackendConfiguration -> IO (Backend (Event SDL.EventPayload) AppOutput)-sdlBackend bc = do-  SDL.initialize [SDL.InitVideo]-  window <- SDL.createWindow (pack $ windowName bc) windowConf-  SDL.showWindow window-  renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer-  lastInteraction <- newMVar =<< SDL.time-  lastGraphics <- newMVar Nothing-  lastRender <- newMVar 0-  imageTextures <- newMVar []-  ready <- newMVar True-  return $-    Backend-    { initAction = Init.initAction-    , inputAction = Input.inputAction lastInteraction-    , outputAction = Output.outputAction (fps bc) imageTextures lastRender ready lastGraphics window renderer-    , parseInput = Parse.parseInput-    , closeAction = Close.closeAction renderer window-    }-  where-    windowConf =-      SDL.defaultWindow-      { SDL.windowInitialSize =-          V2 (fromIntegral (windowWidth bc)) (fromIntegral (windowHeight bc))-        , SDL.windowResizable = windowResizable (bc)-      } -
+ src/YampaSDL2/Draw.hs view
@@ -0,0 +1,11 @@+module YampaSDL2.Draw+  ( -- * Draw functions+    -- Use these functions to create 'RenderObject's which can be drawn to the screen.+    circle+  , rectangle+  , image+  ) where++import YampaSDL2.Drawable.Circle+import YampaSDL2.Drawable.Image+import YampaSDL2.Drawable.Rectangle
+ src/YampaSDL2/Drawable/Circle.hs view
@@ -0,0 +1,108 @@+module YampaSDL2.Drawable.Circle+  ( circle+  ) where++import Data.Function.Memoize+import Data.StateVar (($=))+import qualified Data.Vector.Storable as Vector+import Linear.V2+import Linear.V4+import qualified SDL++import YampaSDL2.Internal.AppOutput++-- | Draw a circle+--+-- Example:+--+-- > circle (V2 0 0) 100 (Filled orange) 2+circle ::+     Center -- ^ center of the circle+  -> Double -- ^ radius+  -> ShapeColour -- ^ colour+  -> Int -- ^ zIndex+  -> RenderObject+circle center r colour zIndex =+  let (V2 x y) = center+      bounds = V4 (y + r) (x + r) (y - r) (x - r)+      draw _ (V2 xNew yNew) renderer = do+        SDL.rendererDrawColor renderer $= colourToV4 colour+        let sdlRect = calculateRectangle (round xNew) (round yNew) (round r)+            points =+              if isFilled colour+                then fullPoints (round xNew) (round yNew) (round r)+                else linePoints (round xNew) (round yNew) (round r)+        SDL.drawPoints renderer points+        if isFilled colour+          then SDL.fillRect renderer . return $ toEnum <$> sdlRect+          else return ()+  in RO center bounds zIndex draw++calculateRectangle :: Int -> Int -> Int -> SDL.Rectangle Int+calculateRectangle = memoize3 f+  where+    f x y r =+      let a = 0.7071067811865476 * (fromIntegral r)+      in SDL.Rectangle+           (SDL.P $ V2 x y - (truncate <$> V2 a a))+           (ceiling <$> V2 (2 * a) (2 * a))++fullPoints = memoize3 f+  where+    f x y r =+      Vector.fromList $+      SDL.P . fmap (toEnum) <$> (+ (V2 x y)) <$> rasterCircleFull r++linePoints = memoize3 f+  where+    f x y r =+      Vector.fromList $+      SDL.P . fmap (toEnum) <$> (+ (V2 x y)) <$> rasterCircleLine r++-- Get octant points for a circle of given radius.+octantLine :: Int -> [V2 Int]+octantLine r =+  takeWhile inOctant . map (toV2 . fst) $ iterate step ((r, 0), 1 - r)+  where+    inOctant (V2 x y) = x >= y+    step ((x, y), e)+      | e < 0 = ((x, y + 1), e + 2 * (y + 1) + 1)+      | otherwise = ((x - 1, y + 1), e + 2 * (y - x + 2) + 1)++octantFull :: Int -> [V2 Int]+octantFull r =+  fmap round <$> filter inOctant [V2 x y | x <- [0 .. l], y <- [0 .. h]]+  where+    l = fromIntegral r+    h = 0.7071067811865476 * (fromIntegral r)+    inOctant (V2 x y) =+      x ^ 2 + y ^ 2 <= (fromIntegral r) ^ 2 &&+      y ^ 2 <= (fromIntegral r) ^ 2 - x ^ 2 &&+      (ceiling x) + 1 > ceiling ((fromIntegral r) * 0.7071067811865476)++-- Get quadrant points for a circle of given radius.+quadrant :: [V2 Int] -> [V2 Int]+quadrant octantPoints = octantPoints >>= mirror+  where+    mirror (V2 x y) = [(V2 x y), (V2 y x)]++-- Get points of a circle of given radius.+fcircle :: [V2 Int] -> [V2 Int]+fcircle quadrantPoints = quadrantPoints >>= mirror+  where+    mirror (V2 0 y) = [V2 0 y, V2 0 (-y)]+    mirror (V2 x 0) = [V2 x 0, V2 (-x) 0]+    mirror (V2 x y) = [(V2 u v) | u <- [x, -x], v <- [y, -y]]++rasterCircleLine :: Int -> [V2 Int]+rasterCircleLine = memoize (fcircle . quadrant . octantLine)++rasterCircleFull :: Int -> [V2 Int]+rasterCircleFull = memoize (fcircle . quadrant . octantFull)++-- Helper functions+toV2 :: (a, a) -> V2 a+toV2 (a, b) = V2 a b++fromV2 :: V2 a -> (a, a)+fromV2 (V2 a b) = (a, b)
+ src/YampaSDL2/Drawable/Image.hs view
@@ -0,0 +1,117 @@+module YampaSDL2.Drawable.Image+  ( image+  ) where++import Control.Concurrent.MVar+import Control.Exception+import Control.Monad+import Data.Dynamic+import Data.Function.Memoize+import Data.List+import Data.Maybe+import Data.StateVar (($=))+import Linear.V2+import Linear.V4+import qualified SDL++import YampaSDL2.Internal.AppOutput++-- | Draw an image+--+-- Example:+--+-- > image (V2 0 0) (V2 800 600) Nothing "./path/to/image.bmp" 0+image ::+     Center -- ^ set the center point of the image+  -> V2 Double -- ^ set the size of the image (V2 length height)+  -> Maybe (V2 Double) -- ^ you can only use a part of the image, Nothing for the whole image+  -> String -- ^ the file name, image must be in BMP format+  -> Int -- ^ zIndex+  -> RenderObject+image center size source path zIndex =+  let (V2 r t) = center + size / 2+      (V2 l b) = center - size / 2+  in RO center (V4 t r b l) zIndex (drawImage size source path)++drawImage ::+     V2 Double+  -> Maybe (V2 Double)+  -> String+  -> Cache+  -> Center+  -> SDL.Renderer+  -> IO ()+drawImage size source path mvarCache center renderer = do+  (eitherTexture) <- loadTexture mvarCache path renderer+  either+    handleError+    (\t -> drawImage renderer t Nothing center size)+    eitherTexture+  where+    drawImage renderer texture source position size = do+      let toSDLRect (V2 x y, V2 w h) =+            SDL.Rectangle+              (round <$> SDL.P (V2 (x - w / 2) (y - h / 2)))+              (round <$> V2 w h)+      SDL.copy+        renderer+        texture+        (toSDLRect <$> source)+        (return $ toSDLRect (position, size))++loadTexture ::+     Cache -> String -> SDL.Renderer -> IO (Either SomeException SDL.Texture)+loadTexture mvarCache path renderer = do+  cache <- readMVar mvarCache+  maybe+    (loadAndCache mvarCache path renderer)+    (return . Right)+    (lookup path cache >>= fromDynamic)+  where+    loadAndCache mvarCache path renderer = do+      loadedTexture <- loadImage path renderer+      either+        (return . Left)+        (\t -> do+           modifyMVar_ mvarCache (return . ((path, toDyn t) :))+           return (Right t))+        (loadedTexture)++loadImage :: String -> SDL.Renderer -> IO (Either SomeException SDL.Texture)+loadImage p renderer = do+  eitherSurface <-+    (try (SDL.loadBMP p) :: IO (Either SomeException SDL.Surface))+  let eitherTexture =+        case eitherSurface of+          Left err -> return $ Left err+          Right val -> surfaceToTexture renderer val >>= return . Right+      surfaceToTexture renderer s = do+        texture <- SDL.createTextureFromSurface renderer s+        SDL.textureBlendMode texture $= SDL.BlendAlphaBlend+        SDL.freeSurface s+        return texture+  eitherTexture++handleError :: SomeException -> IO ()+handleError e = print e+--Image {shapeCentre=centre', size=size', sourceRect=maybeRect, imgPath=path} -> do+--         textures <- readMVar mvarTextures+--         case lookup path textures of+--           (Just (t,size)) ->+--             let newSize = fromMaybe ((fromIntegral<$>size)/2, fromIntegral <$> size) maybeRect+--             in drawImage renderer t (return newSize) centre' size'+--           Nothing -> do+--             eitherSurface <- try $ SDL.loadBMP path :: IO (Either SomeException SDL.Surface)+--             case eitherSurface of+--               Left ex -> putStrLn $ "IMG Loading failed: " ++ show ex+--               Right val -> do+--                 newTexture <- SDL.createTextureFromSurface renderer val+--                 attrs <- SDL.queryTexture newTexture+--                 let w = SDL.textureWidth attrs+--                     h = SDL.textureHeight attrs+--                 modifyMVar_ mvarTextures $ return . ((path,(newTexture, fromEnum <$> V2 w h)):)+--                 drawImage renderer newTexture maybeRect centre' size'+--   where drawImage renderer texture source position size = do+--           let toSDLRect (V2 x y, V2 w h) =+--                 SDL.Rectangle (round <$> SDL.P (V2 (x-w/2) (y-h/2))) (round <$> V2 w h)+--           SDL.copy renderer texture (toSDLRect <$> source) (return $ toSDLRect (position,size))
+ src/YampaSDL2/Drawable/Rectangle.hs view
@@ -0,0 +1,34 @@+module YampaSDL2.Drawable.Rectangle+  ( rectangle+  ) where++import Data.StateVar (($=))+import Linear.V2+import Linear.V4+import qualified SDL++import YampaSDL2.Internal.AppOutput+++-- | Draw a rectangle+--+-- Example:+--+-- > rectangle (V2 0 0) (V2 100 200) (Filled blue) 3+rectangle :: Center -- ^ center of the rectangle+          -> V2 Double -- ^ size+          -> ShapeColour -- ^ colour+          -> Int -- ^ zIndex+          -> RenderObject+rectangle center dimensions colour zIndex =+  let (V2 r t) = center + dimensions / 2+      (V2 l b) = center - dimensions / 2+      draw _ c renderer = do+        SDL.rendererDrawColor renderer $= colourToV4 colour+        let draw' =+              if isFilled colour+                then SDL.fillRect+                else SDL.drawRect+            newCenter = SDL.P $ (c - dimensions / 2)+        draw' renderer (return $ round <$> SDL.Rectangle newCenter dimensions)+  in RO center (V4 t r b l) zIndex draw
− src/YampaSDL2/Geometry.hs 
@@ -1,42 +0,0 @@-{-|-Module      : Geometry-Description : Declares all shapes--}--module YampaSDL2.Geometry-  ( -- ** Shapes-    Shape(..)-  , ShapeColour(..)-  ) where--import Linear.V2-import Data.Colour--data Shape =-    Rectangle-      { rectSize :: V2 Double-      , colour :: ShapeColour-      }-  | Circle-     { radius :: Double-     , colour :: ShapeColour-     }-  | Triangle-     { pointA :: V2 Double-     , pointB :: V2 Double-     , pointC :: V2 Double-     , colour :: ShapeColour-     }-     -- ^ Think of shapeCentre as a vector which is applied to all 3 points of the triangle-  | Image-    { size :: V2 Double-    , sourceRect :: Maybe (V2 Double, V2 Double) -- ^ the section of the image that you want to render-    , imgPath :: String-    } deriving (Eq, Show)--data ShapeColour-  = Filled (Colour Double)-  | Unfilled (Colour Double) deriving (Show,Eq)---
+ src/YampaSDL2/Init.hs view
@@ -0,0 +1,23 @@+module YampaSDL2.Init+  ( -- * Initialization+    initSDL+  , SDLConfiguration(..)+  , defaultSDLConfiguration+  , SDLInit+  , mainLoop+  , defaultLoop+  ) where++import FRP.Yampa++import YampaSDL2.Internal.AppInput (AppInput)+import YampaSDL2.Internal.AppOutput (AppOutput)+import YampaSDL2.Internal.MainLoop (mainLoop)+import YampaSDL2.Internal.SDL+       (SDLConfiguration(..), SDLInit, defaultSDLConfiguration, initSDL)++-- | 'mainLoop' with default configurations+defaultLoop :: SF AppInput AppOutput -> IO ()+defaultLoop sf = do+  sdl <- initSDL defaultSDLConfiguration+  mainLoop sdl sf
+ src/YampaSDL2/InputOutput.hs view
@@ -0,0 +1,76 @@+module YampaSDL2.InputOutput+  ( -- * Input+    AppInput+    -- ** Input Signals+  , mouseLeftActive+  , mouseLeftPress+  , mouseRightActive+  , mouseRightPress+  , anyKeyActive+  , anyKeyPress+  , quit+  -- * Output+  , AppOutput (..)+  , output+  -- ** Scene+  , Scene (..)+  , render+  -- *** Camera+  , Camera (..)+  , camera+  -- *** RenderObject+  , Center+  , Bounds+  , Cache+  , RenderObject (..)+  , translate+  , ShapeColour (..)+  -- ** Sound+  , Sound (..)+  ) where++import FRP.Yampa+import FRP.Yampa.Event (maybeToEvent)+import Data.Maybe (isJust)+import SDL.Input.Keyboard.Codes+import Linear.V2++import YampaSDL2.Internal.AppInput+import YampaSDL2.Internal.AppOutput++-- Output++output :: Scene -> [Sound] -> Bool -> AppOutput+output = AppOutput++camera :: V2 Double -> V2 Double -> Camera+camera = Camera++render :: Camera -> [RenderObject] -> Scene+render = Scene++-- Input++quit :: SF AppInput (Event ())+quit = inpQuit ^>> edge++anyKeyActive :: SF AppInput (Event [Scancode])+anyKeyActive = inpKey ^>> (\e -> if e == [] then Nothing else return e) ^>> arr maybeToEvent++anyKeyPress :: SF AppInput (Event [Scancode])+anyKeyPress = inpKey ^>> (\e -> if e == [] then Nothing else return e) ^>> edgeJust++mouseLeftActive :: SF AppInput (Event (V2 Double))+mouseLeftActive = inpMouseLeft ^>> arr maybeToEvent++mouseLeftPress :: SF AppInput (Event (V2 Double))+mouseLeftPress = inpMouseLeft ^>> edgeJust++mouseRightActive :: SF AppInput (Event (V2 Double))+mouseRightActive = inpMouseRight ^>> arr maybeToEvent++mouseRightPress :: SF AppInput (Event (V2 Double))+mouseRightPress = inpMouseRight ^>> edgeJust++mousePosition :: SF AppInput (V2 Double)+mousePosition = arr inpMousePos
+ src/YampaSDL2/Internal/AppInput.hs view
@@ -0,0 +1,26 @@+module YampaSDL2.Internal.AppInput+  ( initAppInput+  , AppInput(..)+  ) where++import Linear.V2+import SDL.Input.Keyboard.Codes++-- | Data type which stores all user inputs at the current time. You should not interact with this type directly, but use signal functions like 'anyKeyActive' to get events.+data AppInput = AppInput+  { inpQuit :: Bool -- ^ If the app receives a quit event+  , inpKey :: [Scancode] -- ^ All pressed keys+  , inpMousePos :: V2 Double -- ^ The current mouse position+  , inpMouseLeft :: Maybe (V2 Double) -- ^ User presses the left mouse button+  , inpMouseRight :: Maybe (V2 Double) -- ^ User presses the right mouse button+  }++initAppInput :: AppInput+initAppInput =+  AppInput+  { inpQuit = False+  , inpKey = []+  , inpMousePos = V2 0 0+  , inpMouseLeft = Nothing+  , inpMouseRight = Nothing+  }
+ src/YampaSDL2/Internal/AppOutput.hs view
@@ -0,0 +1,88 @@+module YampaSDL2.Internal.AppOutput+  ( RenderObject(..)+  , translate+  , Scene(..)+  , AppOutput(..)+  , Camera(..)+  , ShapeColour(..)+  , Sound(..)+  , isFilled+  , getColour+  , colourToV4+  , Center+  , Bounds+  , Cache+  ) where++import Control.Concurrent.MVar+import Data.Colour+import Data.Colour.SRGB+import Data.Dynamic+import Data.Word+import Linear.V2+import Linear.V4+import qualified SDL++-- | The Main signal function needs to return an AppOutput which tells SDL what to do.+--+-- Use 'output' to create an AppOutput+data AppOutput = AppOutput+  { scene :: Scene -- ^ Sets what will be drawn+  , sound :: [Sound] -- ^ Sadly not working yet+  , shouldExit :: Bool -- ^ Set if the app should exit+  }++-- | Properties of the scene+data Scene = Scene+  { cam :: Camera -- ^ Sets the viewpoint+  , objects :: [RenderObject] -- ^ All objects that are drawn+  }++data Camera = Camera+  { cPos :: V2 Double -- ^ Moves the viewpoint+  , cSize :: V2 Double -- ^ Set the size of the viewpoint, for example to zoom.+  }++type Center = V2 Double++type Bounds = V4 Double++type Cache = MVar [(String, Dynamic)]++-- To draw something on the scene, you need to create RenderObjects. The easiest way is to use functions like 'rectangle'. If you have special needs or want direct access to SDL, you can also create your own RenderObjects from scratch.+data RenderObject = RO+  { center :: Center -- ^ center+  , bounds :: Bounds -- ^ rectangular bounds used for optimizations+  , zIndex :: Int -- ^ RenderObject with higher zIndex will be rendered atop ones with lower zIndex+  , draw :: Cache -> Center -> SDL.Renderer -> IO ()+  }+++-- | Move a RenderObject+translate :: (Center -> Center) -> RenderObject -> RenderObject+translate f r = r {center = f $ center r}++-- | Used to set the colour of shapes like 'rectangle' or 'circle' and whether they are filled or not. This library uses "Data.Colour" to create colours.+data ShapeColour+  = Filled (AlphaColour Double)+  | Unfilled (AlphaColour Double)+  deriving (Show, Eq)++isFilled :: ShapeColour -> Bool+isFilled (Filled _) = True+isFilled _ = False++getColour :: ShapeColour -> AlphaColour Double+getColour (Filled c) = c+getColour (Unfilled c) = c++colourToV4 :: ShapeColour -> V4 Word8+colourToV4 sc =+  let c = getColour sc+      (RGB r g b) = toSRGB24 (colourChannel c)+      alpha = truncate $ alphaChannel c * 255+  in V4 r g b alpha++-- | Not implemented yet+data Sound =+  NotImplementedYet
+ src/YampaSDL2/Internal/MainLoop.hs view
@@ -0,0 +1,22 @@+module YampaSDL2.Internal.MainLoop+  ( mainLoop+  ) where++import FRP.Yampa++import YampaSDL2.Internal.AppInput (AppInput)+import YampaSDL2.Internal.AppOutput (AppOutput)+import YampaSDL2.Internal.SDL (SDLInit(..))++-- | Starts the game loop+mainLoop ::+     SDLInit a AppOutput+  -> SF AppInput AppOutput -- ^ The main signal function+  -> IO ()+mainLoop backend sf = do+  reactimate+    (initAction backend)+    (inputAction backend)+    (outputAction backend)+    (parseInput backend >>> sf)+  closeAction backend
+ src/YampaSDL2/Internal/SDL.hs view
@@ -0,0 +1,10 @@+module YampaSDL2.Internal.SDL+  ( SDLInit(..)+  , SDLConfiguration(..)+  , defaultSDLConfiguration+  , initSDL+  ) where++import YampaSDL2.Internal.SDL.Init+       (SDLConfiguration(..), SDLInit(..), defaultSDLConfiguration)+import YampaSDL2.Internal.SDL.Start (initSDL)
+ src/YampaSDL2/Internal/SDL/Close.hs view
@@ -0,0 +1,10 @@+module YampaSDL2.Internal.SDL.Close+  (closeAction) where++import qualified SDL++closeAction :: SDL.Renderer -> SDL.Window -> IO ()+closeAction r w = do+  SDL.destroyRenderer r+  SDL.destroyWindow w+  SDL.quit
+ src/YampaSDL2/Internal/SDL/Init.hs view
@@ -0,0 +1,42 @@+module YampaSDL2.Internal.SDL.Init+  ( firstEvent+  , SDLInit(..)+  , SDLConfiguration(..)+  , defaultSDLConfiguration+  ) where++import FRP.Yampa+import qualified SDL++import YampaSDL2.Internal.AppInput (AppInput)++firstEvent :: IO (Event SDL.EventPayload)+firstEvent = return NoEvent++data SDLInit a b = SDLInit+  { initAction :: IO a+  , inputAction :: Bool -> IO (DTime, Maybe a)+  , outputAction :: Bool -> b -> IO Bool+  , parseInput :: SF a AppInput+  , closeAction :: IO ()+  }++-- | Configurations regarding the window.+data SDLConfiguration = SDLConfiguration+  { windowWidth :: Int+  , windowHeight :: Int+  , windowName :: String+  , windowResizable :: Bool+  , fps :: Double+  }+++defaultSDLConfiguration :: SDLConfiguration+defaultSDLConfiguration =+  SDLConfiguration+  { windowWidth = 800+  , windowHeight = 600+  , windowName = "App"+  , windowResizable = True+  , fps = 60+  }
+ src/YampaSDL2/Internal/SDL/Input.hs view
@@ -0,0 +1,18 @@+module YampaSDL2.Internal.SDL.Input+  (inputAction) where++import qualified SDL+import Control.Concurrent+import FRP.Yampa++inputAction :: MVar DTime -> Bool -> IO (DTime, Maybe (Event SDL.EventPayload))+inputAction lastInteraction _canBlock = do+  maybeEvent <- SDL.waitEventTimeout maximumWaitTime+  currentTime <- SDL.time+  dt <- (currentTime -) <$> swapMVar lastInteraction currentTime++  return (dt, Event . SDL.eventPayload <$> maybeEvent)++minIPS = 30++maximumWaitTime = round $ 1000/fromIntegral minIPS
+ src/YampaSDL2/Internal/SDL/Output.hs view
@@ -0,0 +1,84 @@+module YampaSDL2.Internal.SDL.Output+  ( outputAction+  ) where++import Control.Concurrent.MVar+import Control.Monad+import Data.Colour+import Data.Colour.Names+import Data.Colour.SRGB+import Data.List+import Data.Maybe+import Data.StateVar (($=), get)+import Debug.Trace+import Linear.V2+import Linear.V4+import qualified SDL++import YampaSDL2.Internal.AppOutput++-- changed bool variable does not do anything+outputAction ::+     Cache+  -> Double+  -> MVar Double+  -> MVar Bool+  -> MVar (Maybe Scene)+  -> SDL.Window+  -> SDL.Renderer+  -> Bool+  -> AppOutput+  -> IO Bool+outputAction mvarCache fps mvarFPS mvarReady mvarG window renderer _ ao = do+  lastTime <- readMVar mvarFPS+  currentTime <- SDL.time+  ensureFPS <-+    if currentTime - lastTime > 1 / fps+      then modifyMVar_ mvarFPS (return . const currentTime) >> return True+      else return False+  ready <- readMVar mvarReady+  when (ensureFPS && ready) $ do+    modifyMVar_ mvarReady (\_ -> return False)+    renderScene mvarCache window renderer (scene ao)+    modifyMVar_ mvarReady (\_ -> return True)+  return (shouldExit ao)++renderScene :: Cache -> SDL.Window -> SDL.Renderer -> Scene -> IO ()+renderScene mvarCache window renderer gra = do+  let newScene = adjustToCamera $ removeOutOfBounds gra+  (V2 wW wH) <- fmap (fromIntegral . fromEnum) <$> get (SDL.windowSize window)+  (V2 cW cH) <- return (cSize $ cam gra)+  SDL.rendererScale renderer $= realToFrac <$> (V2 (wW / cW) (wH / cH))+  renderObjects mvarCache renderer newScene++-- Preprocessing rendershapes for rendering+renderObjects :: Cache -> SDL.Renderer -> Scene -> IO ()+renderObjects mvarCache renderer gra = do+  mapM_ (\r -> (draw r) mvarCache (center r) renderer) $+    sortBy (\r1 r2 -> zIndex r1 `compare` zIndex r2) (objects gra)+  SDL.present renderer++removeOutOfBounds :: Scene -> Scene+removeOutOfBounds scene =+  let camera = cam scene+      objs = objects scene+      (V2 bR bT) = cPos camera + cSize camera / 2+      (V2 bL bB) = cPos camera - cSize camera / 2+      notOutOfBounds s =+        not $+        let (V4 u r d l) = bounds s+        in r < bL || l > bR || u < bB || d > bT+  in scene {objects = filter (notOutOfBounds) objs}++adjustToCamera :: Scene -> Scene+adjustToCamera gra =+  let camera = cam gra+      obs = objects gra+  in gra {objects = adjustToCamera' camera <$> obs}++adjustToCamera' :: Camera -> RenderObject -> RenderObject+adjustToCamera' c rs =+  let (V2 cx cy) = cPos c+      (V2 w h) = cSize c+      adjustPoint (V2 x y) = V2 (x + w / 2 - cx) (h / 2 - (y + cy))+  in translate adjustPoint rs
+ src/YampaSDL2/Internal/SDL/Parse.hs view
@@ -0,0 +1,42 @@+module YampaSDL2.Internal.SDL.Parse+  ( parseInput+  ) where++import FRP.Yampa+import qualified SDL+import SDL.Vect++import YampaSDL2.Internal.AppInput (AppInput(..), initAppInput)++parseInput :: SF (Event SDL.EventPayload) AppInput+parseInput = accumHoldBy onSDLInput initAppInput++onSDLInput :: AppInput -> SDL.EventPayload -> AppInput+onSDLInput ai SDL.QuitEvent = ai {inpQuit = True}+onSDLInput ai (SDL.KeyboardEvent ev)+  | SDL.keyboardEventKeyMotion ev == SDL.Pressed =+    ai+    {inpKey = filter (/= getKeyCode ev) (inpKey ai) `mappend` [getKeyCode ev]}+  | SDL.keyboardEventKeyMotion ev == SDL.Released =+    ai {inpKey = filter (/= getKeyCode ev) (inpKey ai)}+  where+    getKeyCode = SDL.keysymScancode . SDL.keyboardEventKeysym+onSDLInput ai (SDL.MouseMotionEvent ev) =+  ai {inpMousePos = fromIntegral <$> V2 x y}+  where+    P (V2 x y) = SDL.mouseMotionEventPos ev+onSDLInput ai (SDL.MouseButtonEvent ev) =+  ai {inpMouseLeft = lmb, inpMouseRight = rmb}+  where+    motion = SDL.mouseButtonEventMotion ev+    button = SDL.mouseButtonEventButton ev+    pos = inpMousePos ai+    inpMod =+      case (motion, button) of+        (SDL.Released, SDL.ButtonLeft) -> first (const Nothing)+        (SDL.Pressed, SDL.ButtonLeft) -> first (const (Just pos))+        (SDL.Released, SDL.ButtonRight) -> second (const Nothing)+        (SDL.Pressed, SDL.ButtonRight) -> second (const (Just pos))+        _ -> id+    (lmb, rmb) = inpMod $ (inpMouseLeft &&& inpMouseRight) ai+onSDLInput ai _ = ai
+ src/YampaSDL2/Internal/SDL/Start.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE OverloadedStrings #-}++module YampaSDL2.Internal.SDL.Start+  ( initSDL+  ) where++import Control.Concurrent.MVar+import Data.StateVar (($=))+import Data.Text (pack)+import FRP.Yampa+import Linear.V2+import qualified SDL++import qualified YampaSDL2.Internal.SDL.Close as Close+import qualified YampaSDL2.Internal.SDL.Init as Init+import qualified YampaSDL2.Internal.SDL.Input as Input+import qualified YampaSDL2.Internal.SDL.Output as Output+import qualified YampaSDL2.Internal.SDL.Parse as Parse++import YampaSDL2.Internal.AppOutput (AppOutput)+import YampaSDL2.Internal.SDL.Init+       (SDLConfiguration(..), SDLInit(..))++-- | Set up SDL+initSDL :: SDLConfiguration -> IO (SDLInit (Event SDL.EventPayload) AppOutput)+initSDL bc = do+  SDL.initialize [SDL.InitVideo]+  window <- SDL.createWindow (pack $ windowName bc) windowConf+  SDL.showWindow window+  renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer+  SDL.rendererDrawBlendMode renderer $= SDL.BlendAlphaBlend+  lastInteraction <- newMVar =<< SDL.time+  lastScene <- newMVar Nothing+  lastRender <- newMVar 0+  cache <- newMVar []+  ready <- newMVar True+  return $+    SDLInit+    { initAction = Init.firstEvent+    , inputAction = Input.inputAction lastInteraction+    , outputAction =+        Output.outputAction+          cache+          (fps bc)+          lastRender+          ready+          lastScene+          window+          renderer+    , parseInput = Parse.parseInput+    , closeAction = Close.closeAction renderer window+    }+  where+    windowConf =+      SDL.defaultWindow+      { SDL.windowInitialSize =+          V2 (fromIntegral (windowWidth bc)) (fromIntegral (windowHeight bc))+      , SDL.windowResizable = windowResizable (bc)+      }
− src/YampaSDL2/MainLoop.hs 
@@ -1,25 +0,0 @@-{-|-Module      : MainLoop--}---module YampaSDL2.MainLoop-  ( -- * MainLoop-    mainLoop-  ) where--import FRP.Yampa--import YampaSDL2.AppInput-import YampaSDL2.AppOutput-import YampaSDL2.Backend---- | Starts the Yampa loop-mainLoop :: Backend a AppOutput -> SF AppInput AppOutput -> IO ()-mainLoop backend sf = do-  reactimate-    (initAction backend)-    (inputAction backend)-    (outputAction backend)-    (parseInput backend >>> sf)-  closeAction backend
+ src/YampaSDL2/ReExports.hs view
@@ -0,0 +1,14 @@+module YampaSDL2.ReExports+  ( -- * Re-exports for convenience+    module Data.Colour.Names+  , module Data.Colour.SRGB+  , module Data.Colour+  , module Linear.V2+  , module SDL.Input.Keyboard.Codes+  ) where++import Linear.V2+import Data.Colour.Names+import Data.Colour.SRGB+import Data.Colour+import SDL.Input.Keyboard.Codes
test/Main.hs view
@@ -4,42 +4,36 @@ import YampaSDL2 import Debug.Trace import Data.Maybe+import Data.Foldable  main :: IO () main = do-  backend <- sdlBackend defaultBackendConfiguration+  backend <- initSDL defaultSDLConfiguration   mainLoop backend sf  sf :: SF AppInput AppOutput sf = proc input -> do   anyKeyE <- anyKeyActive -< input   point <- accumHoldBy-    (\p int -> p + direction int)+    (\p keys -> p + foldl (\acc key -> acc + direction key) (V2 0 0) keys)     (V2 0 0) -< anyKeyE   shouldQuit <- quit -< input+  position <- animate animateV2 (V2 0 0) [(2,easeIn,V2 100 100), (2,easeOut,V2 0 0)] -< ()+  circleColour <- animate animateColour (green `withOpacity` 1)+    (cycle [(10,linear, orange `withOpacity` 1),(10,linear,green `withOpacity` 1)]) -< ()+  returnA -< output+    (render cam+        [ rectangle position (V2 100 100) (Filled (blue `withOpacity` 1)) 2+        , circle (V2 0 0) 150 (Filled circleColour) 1+        , image (V2 0 0) (V2 800 600) Nothing "./test/MARBLES.BMP" 0+        ]+    )+    []+    (isEvent shouldQuit) -  objAnimated <- animate animation -< ()-  returnA -< AppOutput-    { graphics = Graphics-      { camera = camera-      , objects = [background] ++ container (V2 100 100) [obj1 point, fromMaybe obj5 -objAnimated]-      }-    , sound = []-    , shouldExit = isEvent shouldQuit-    }-  where camera = Camera (V2 0 0) (V2 800 600)-        shape1 colour = Triangle (V2 0 50) (V2 50 (-50)) (V2 (-50) (-50)) (Filled colour)-        shape2 = Rectangle (V2 50 50) (Filled blue)-        obj1 point = RS point shape2 2-        obj2 = RS (V2 0 0) (shape1 orange) 1-        obj3 = RS (V2 0 0) (shape1 white) 1-        obj4 = RS (V2 0 0) (shape1 green) 1-        obj5 = RS (V2 0 0) (shape1 yellow) 1-        animation = newAnimation [(0.5,obj2), (0.5,obj3), (0.5,obj4), (0.5, obj5)] Endless+  where cam = camera (V2 0 0) (V2 800 600)         direction ScancodeRight = V2 2 0         direction ScancodeLeft = V2 (-2) 0         direction ScancodeDown = V2 0 (-2)         direction ScancodeUp = V2 0 2         direction _ = V2 0 0-        background = RS (V2 0 0) (Image (V2 800 600) Nothing "./test/MARBLES.BMP") 0
yampa-sdl2.cabal view
@@ -1,14 +1,14 @@--- This file has been generated from package.yaml by hpack version 0.21.2.+-- This file has been generated from package.yaml by hpack version 0.27.0. -- -- see: https://github.com/sol/hpack ----- hash: cce52dd189679a994cdbaa8dcc65371aa6c08473eb4bba5e5a75d5acadbde803+-- hash: 66458a0f51aeaa5ab3e3b160e0f59b4753353f4477586442aacdeaf91e06ae84  name:           yampa-sdl2-version:        0.0.3.1+version:        0.1.0.0 synopsis:       Yampa and SDL2 made easy description:    yampa-sdl2 lets you start coding your app right away instead of dealing with SDL2 first.-category:       Graphics+category:       Scene homepage:       https://github.com/Simre1/YampaSDL2#readme author:         Simre maintainer:     simre4775@gmail.com@@ -24,33 +24,39 @@ library   exposed-modules:       YampaSDL2-  other-modules:       YampaSDL2.Animation-      YampaSDL2.AppInput-      YampaSDL2.AppOutput-      YampaSDL2.Backend-      YampaSDL2.Backend.Close-      YampaSDL2.Backend.ExperimentalOutput-      YampaSDL2.Backend.Init-      YampaSDL2.Backend.Input-      YampaSDL2.Backend.Output-      YampaSDL2.Backend.Parse-      YampaSDL2.Backend.SDL-      YampaSDL2.Geometry-      YampaSDL2.MainLoop+      YampaSDL2.Draw+      YampaSDL2.Drawable.Circle+      YampaSDL2.Drawable.Image+      YampaSDL2.Drawable.Rectangle+      YampaSDL2.Init+      YampaSDL2.InputOutput+      YampaSDL2.Internal.AppInput+      YampaSDL2.Internal.AppOutput+      YampaSDL2.Internal.MainLoop+      YampaSDL2.Internal.SDL+      YampaSDL2.Internal.SDL.Close+      YampaSDL2.Internal.SDL.Init+      YampaSDL2.Internal.SDL.Input+      YampaSDL2.Internal.SDL.Output+      YampaSDL2.Internal.SDL.Parse+      YampaSDL2.Internal.SDL.Start+      YampaSDL2.ReExports+  other-modules:       Paths_yampa_sdl2   hs-source-dirs:       src+  ghc-options: -O2   build-depends:       StateVar     , Yampa     , base >=4.7 && <5     , colour     , linear-    , sdl2 >=2.2.0-    , sdl2-gfx-    , stm+    , memoize+    , sdl2     , text+    , vector   default-language: Haskell2010  test-suite YampaSDL2-test@@ -66,9 +72,9 @@     , base     , colour     , linear-    , sdl2 >=2.2.0-    , sdl2-gfx-    , stm+    , memoize+    , sdl2     , text+    , vector     , yampa-sdl2   default-language: Haskell2010