diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,10 +1,15 @@ # YampaSDL2 -YampaSDL2 provides SDL2 bindings to use with the FRP library [Yampa](https://github.com/ivanperez-keera/Yampa). +YampaSDL2 is basically a headstart for the FRP library [Yampa](https://github.com/ivanperez-keera/Yampa) and SDL2. All the boilerplate which is normally necessary for these two libraries to work together is already taken care of. In the end, all that remains is a high-level interface specifically tailored to Yampa which should get you going in no time. ![Screenshot](./screenshot.png) -A screenshot of some drawn shapes. +Screenshot of some drawn shapes. + +**My primary Goals:** +- As little setup as possible +- Easy to use (some feedback would be appreciated) + ## Roadmap - [ ] Display Shapes @@ -32,16 +37,13 @@ ### Installation -1. Download the library: +yampa-sdl2 is now on hackage! Adding yampa-sdl2 to your dependencies and executing the following should do the trick. + ```bash -cd example-project -git clone https://github.com/Simre1/yampa-sdl2.git +stack update +stack solver --update-config +stack build ``` -2. Add it to your dependencies: -Edit your stack.yaml file and add yampa-sdl2 to packages. -Add the yampa-sdl2 dependency to your cabal file (or package.yaml) - -3. Import the library with: `import YampaSDL2` ## How to use diff --git a/src/YampaSDL2.hs b/src/YampaSDL2.hs --- a/src/YampaSDL2.hs +++ b/src/YampaSDL2.hs @@ -34,10 +34,13 @@ , Sound(..) , RenderShape(..) , Camera(..) - , ShapeColour(..) + , container ) import YampaSDL2.Backend (defaultBackendConfiguration, BackendConfiguration(..)) -import YampaSDL2.Geometry (Shape(..)) +import YampaSDL2.Geometry + ( Shape(..) + , ShapeColour(..) + ) import YampaSDL2.MainLoop (mainLoop) import YampaSDL2.Animation ( Animation diff --git a/src/YampaSDL2/AppOutput.hs b/src/YampaSDL2/AppOutput.hs --- a/src/YampaSDL2/AppOutput.hs +++ b/src/YampaSDL2/AppOutput.hs @@ -9,14 +9,13 @@ , Graphics(..) , Camera(..) , RenderShape(..) - , ShapeColour(..) , Sound(..) + , container ) where -import Data.Colour import Linear.V2 -import YampaSDL2.Geometry (Shape) +import YampaSDL2.Geometry (Shape(..)) @@ -30,26 +29,22 @@ data Graphics = Graphics { camera :: Camera , objects :: [RenderShape] - } + } deriving Show data Camera = Camera - { cPos :: V2 Double -- ^Moves the view point - , cSize :: V2 Double -- ^Set the size of the view, for example to zoom. - } + { 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 { + shape=(shape rs){shapeCentre=shapeCentre (shape rs) + translateV2} + }) children + data RenderShape = RS { shape :: Shape - , colour :: ShapeColour - , zIndex :: Int -- ^ Higher zIndex means the RenderShape is in front of the others. - } - - | -- | Allows you to move multiple RenderShapes at once with the same vector - Container { containerCentre :: V2 Double - , children :: [RenderShape] } - -data ShapeColour - = Filled (Colour Double) - | Unfilled (Colour Double) - + , zIndex :: Int -- ^ Higher zIndex means the RenderShape is in front of the others + } deriving (Show, Eq) data Sound = NotImplementedYet diff --git a/src/YampaSDL2/Backend.hs b/src/YampaSDL2/Backend.hs --- a/src/YampaSDL2/Backend.hs +++ b/src/YampaSDL2/Backend.hs @@ -26,6 +26,7 @@ , windowHeight :: Int , windowName :: String , windowResizable :: Bool + , fps :: Double } defaultBackendConfiguration = BackendConfiguration @@ -33,4 +34,5 @@ , windowHeight = 600 , windowName = "App" , windowResizable = True + , fps = 60 } diff --git a/src/YampaSDL2/Backend/Input.hs b/src/YampaSDL2/Backend/Input.hs --- a/src/YampaSDL2/Backend/Input.hs +++ b/src/YampaSDL2/Backend/Input.hs @@ -7,9 +7,12 @@ 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 - threadDelay $ round (10000 - dt) -- 10ms pause for roughly 100 FPS - mEvent <- SDL.pollEvent - return (dt, Event . SDL.eventPayload <$> mEvent) + return (dt, Event . SDL.eventPayload <$> maybeEvent) + +minIPS = 30 + +maximumWaitTime = round $ 1000/fromIntegral minIPS diff --git a/src/YampaSDL2/Backend/Output.hs b/src/YampaSDL2/Backend/Output.hs --- a/src/YampaSDL2/Backend/Output.hs +++ b/src/YampaSDL2/Backend/Output.hs @@ -3,93 +3,197 @@ import qualified SDL import qualified SDL.Primitive as GFX -import SDL.Vect import Data.Colour.SRGB -import Data.List (sortBy) -import Data.StateVar (($=)) 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 YampaSDL2.AppOutput ( AppOutput(..) , Graphics (..) , Camera (..) , RenderShape (..) - , ShapeColour (..) ) import YampaSDL2.Geometry -outputAction :: SDL.Renderer -> Bool -> AppOutput -> IO Bool -outputAction renderer changed ao = - when changed ( do - let os = - sortBy (\r1 r2 -> zIndex r1 `compare` zIndex r2) $ objects (graphics ao) - c = camera (graphics ao) +-- changed bool variable does not do anything +outputAction :: Double -> MVar [(String, SDL.Texture)]-> MVar Double -> MVar (Maybe Graphics) -> SDL.Window -> SDL.Renderer -> Bool -> AppOutput -> IO Bool +outputAction fps mvarTextures mvarFPS 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 - SDL.rendererDrawColor renderer $= V4 maxBound maxBound maxBound maxBound - texture <- - SDL.createTexture - renderer - SDL.RGB24 - SDL.TextureAccessTarget - ((fmap round . cSize) c) - SDL.rendererRenderTarget renderer $= return texture - SDL.clear renderer - mapM_ (renderView renderer c) os - SDL.rendererRenderTarget renderer $= Nothing - SDL.clear renderer - SDL.copy renderer texture Nothing Nothing - SDL.present renderer - SDL.destroyTexture texture - ) - >> return (shouldExit ao) + when ensureFPS (renderGraphics mvarTextures mvarG window renderer (graphics ao)) >> return (shouldExit ao) -renderView :: SDL.Renderer -> Camera -> RenderShape -> IO () -renderView renderer cam rs = do - let cameraPoint = (cPos cam) - cameraView = (cSize cam) +renderGraphics :: MVar [(String, SDL.Texture)] -> MVar (Maybe Graphics) -> SDL.Window -> SDL.Renderer -> Graphics -> IO () +renderGraphics mvarTextures mvarG window renderer gra = do + let newGraphics = + removeOutOfBounds $ + adjustToCamera 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) newGraphics - case rs of - Container {containerCentre=centre, children=cs } -> do - mapM_ (renderView renderer (Camera (cameraPoint - centre) cameraView)) (sortBy (\r1 r2 -> zIndex r1 `compare` zIndex r2) cs) - RS {shape=s} -> do - let shapePoint = shapeCentre (shape rs) - adjustedShape = - s { shapeCentre = - (shapePoint - cameraPoint) + cameraView/2 - } - case adjustedShape of - Rectangle {shapeCentre = V2 x y, rectSize = V2 w h} -> do - let (RGB r g b) = toSRGB24 (sColour rs) - let draw = if sFilled rs then GFX.fillRectangle else GFX.rectangle +render :: MVar [(String, SDL.Texture)] -> 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) rerenderList + SDL.present renderer + +adjustToCamera :: Graphics -> Graphics +adjustToCamera gra = + let cam = camera gra + obs = objects gra + in gra{objects = (\rs -> rs {shape=adjustToCamera' cam (shape rs)}) <$> obs} + + +adjustToCamera' :: Camera -> Shape -> Shape +adjustToCamera' c s = + let (V2 cx cy) = cPos c + (V2 w h) = cSize c + adjustPoint (V2 x y) = V2 (x+w/2-cx) (h/2-(y+cy)) + inverseY (V2 x y) = V2 x (-y) + in case s of + Rectangle{shapeCentre=centre} -> + s{shapeCentre=adjustPoint centre} + Circle{shapeCentre=centre} -> + s{shapeCentre=adjustPoint centre} + Triangle{shapeCentre=centre, pointA=pA, pointB=pB, pointC=pC} -> + s{shapeCentre=adjustPoint centre, pointA=inverseY pA, pointB = inverseY pB, pointC=inverseY pC} + Image{shapeCentre=centre} -> + s{shapeCentre=adjustPoint centre} + +render' :: [(Bool, RenderShape)] -> [RenderShape] +render' rs = fmap snd $ + foldl createRenderlist [] $ + -- highest zIndex first + sortBy (\(_,a) (_,b) -> compare (zIndex b) (zIndex a)) rs + +createRenderlist :: [(Bool,RenderShape)] -> (Bool,RenderShape) -> [(Bool,RenderShape)] +createRenderlist renderlist (changed,rs) = + let isCoveredBy a b = + let (V4 rr rl rt rb) = a + (V4 cr cl ct cb) = b + in rr < cr && rl > cl && rt < ct && rb > cb + rsToV4 = shapeToBorders . shape + v4RS = rsToV4 rs + v4List = (\(_,a) -> rsToV4 a) <$> renderlist + needRender = + all (\v4 -> not (v4 `isColliding` v4RS) && changed) v4List + || all (\v4 -> v4 `isColliding` v4RS && not (v4RS `isCoveredBy` v4)) v4List + in if needRender + then (True,rs):fmap (\(a,b) -> (a || v4RS `isColliding` rsToV4 b,b)) renderlist + else (False,rs):renderlist + + +-- TODO: More efficient algorhytm -> delete oldRS elements that are already found; +checkChanged :: [RenderShape] -> [RenderShape] -> [(Bool, RenderShape)] +checkChanged oldRS newRS = + fmap (\rs -> (all (/=rs) oldRS, rs)) newRS + + +-- TODO: Need to properly implement this; Color and Image can be transparent! +isTransparent :: Shape -> Bool +isTransparent = const False + +renderShape :: MVar [(String, SDL.Texture)] -> SDL.Renderer -> RenderShape -> IO () +renderShape mvarTextures renderer renderShape = + let shape' = shape renderShape in + case shape' of + Rectangle {shapeCentre = centre', 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 <$> V2 (x - w / 2) (getY cameraView - (y + h / 2))) - (round <$> V2 (x + w / 2) (getY cameraView - (y - h / 2))) + (round <$> centre'-rectSize'/2) + (round <$> centre'+rectSize'/2) (V4 r g b maxBound) - Circle {shapeCentre = V2 x y, radius=rad} -> do - let (RGB r g b) = toSRGB24 (sColour rs) - let draw = if sFilled rs then GFX.fillCircle else GFX.circle + Circle {shapeCentre = centre', 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 <$> V2 x y) - (round rad) + (round <$> centre') + (round rad') (V4 r g b maxBound) - Triangle {shapeCentre=V2 x y, pointA=V2 pax pay, pointB=V2 pbx pby, pointC=V2 pcx pcy} -> do - let (RGB r g b) = toSRGB24 (sColour rs) - let draw = if sFilled rs then GFX.fillTriangle else GFX.smoothTriangle + Triangle {shapeCentre=V2 x y, pointA=V2 pax pay, pointB=V2 pbx pby, pointC=V2 pcx pcy, colour=c'} -> do + let (RGB r g b) = toSRGB24 (sColour shape') + draw = if sFilled shape' then GFX.fillTriangle else GFX.smoothTriangle draw renderer - (round <$> V2 (x + pax) (getY cameraView - (y + pay))) - (round <$> V2 (x + pbx) (getY cameraView - (y + pby))) - (round <$> V2 (x + pcx) (getY cameraView - (y + pcy))) + (round <$> V2 (x + pax) (y + pay)) + (round <$> V2 (x + pbx) (y + pby)) + (round <$> V2 (x + pcx) (y + pcy)) (V4 r g b maxBound) - return () + Image {shapeCentre=centre', size=size', sourceRect=maybeRect, imgPath=path} -> do + textures <- readMVar mvarTextures + case lookup path textures of + (Just t) -> drawImage renderer t maybeRect 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 -sColour :: RenderShape -> Colour Double -sColour rs = - case colour rs of + newTexture <- SDL.createTextureFromSurface renderer val + modifyMVar_ mvarTextures $ return . ((path,newTexture):) + drawImage renderer newTexture maybeRect centre' size' + + + return () + 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)) + +shapeToBorders :: Shape -> V4 Int +shapeToBorders s = + case s of + Rectangle {shapeCentre=V2 x y, rectSize=V2 w h} -> + round <$> V4 (x+w/2) (x-w/2) (y+h/2) (y-h/2) + Circle {shapeCentre=V2 x y, radius=r} -> + round <$> V4 (x+r) (x-r) (y+r) (y-r) + Triangle {shapeCentre=V2 x y, pointA=V2 xa ya, pointB=V2 xb yb, pointC=V2 xc yc} -> + round <$> V4 (x+maximum [xa, xb, xc]) (x+minimum [xa, xb, xc]) (y+maximum [ya,yb,yc]) (y-maximum [ya,yb,yc]) + Image {shapeCentre=V2 x y, size=V2 w h} -> + round <$> V4 (x+w/2) (x-w/2) (y+h/2) (y-h/2) + +removeOutOfBounds :: Graphics -> Graphics +removeOutOfBounds graphics = + let cam = camera graphics + objs = objects graphics + (V2 bR bT) = round <$> cPos cam + cSize cam + (V2 bL bB) = round <$> cPos cam - cSize cam + 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 . shape) objs} + + +isColliding :: V4 Int -> V4 Int -> Bool +isColliding s1 s2 = not $ + let (V4 r1 l1 t1 b1) = s1 + (V4 r2 l2 t2 b2) = s2 + in r1 < l2 || l1 > r2 || t1 < b2 || b1 > t2 + +sColour :: Shape -> Colour Double +sColour s = + case colour s of (Filled a) -> a (Unfilled a) -> a -sFilled :: RenderShape -> Bool -sFilled rs = - case colour rs of +sFilled :: Shape -> Bool +sFilled s = + case colour s of (Filled _) -> True (Unfilled _) -> False diff --git a/src/YampaSDL2/Backend/SDL.hs b/src/YampaSDL2/Backend/SDL.hs --- a/src/YampaSDL2/Backend/SDL.hs +++ b/src/YampaSDL2/Backend/SDL.hs @@ -27,11 +27,14 @@ SDL.showWindow window renderer <- SDL.createRenderer window (-1) SDL.defaultRenderer lastInteraction <- newMVar =<< SDL.time + lastGraphics <- newMVar Nothing + lastRender <- newMVar 0 + imageTextures <- newMVar [] return $ Backend { initAction = Init.initAction , inputAction = Input.inputAction lastInteraction - , outputAction = Output.outputAction renderer + , outputAction = Output.outputAction (fps bc) imageTextures lastRender lastGraphics window renderer , parseInput = Parse.parseInput , closeAction = Close.closeAction renderer window } @@ -41,5 +44,5 @@ { SDL.windowInitialSize = V2 (fromIntegral (windowWidth bc)) (fromIntegral (windowHeight bc)) , SDL.windowResizable = windowResizable (bc) - } + } diff --git a/src/YampaSDL2/Geometry.hs b/src/YampaSDL2/Geometry.hs --- a/src/YampaSDL2/Geometry.hs +++ b/src/YampaSDL2/Geometry.hs @@ -6,26 +6,41 @@ module YampaSDL2.Geometry ( -- ** Shapes Shape(..) + , ShapeColour(..) ) where import Linear.V2 - - - +import Data.Colour data Shape = Rectangle { shapeCentre :: V2 Double , rectSize :: V2 Double + , colour :: ShapeColour } | Circle { shapeCentre :: V2 Double , radius :: Double + , colour :: ShapeColour } | Triangle { shapeCentre :: V2 Double , 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 + { shapeCentre :: V2 Double + , 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) + + + diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -22,23 +22,24 @@ returnA -< AppOutput { graphics = Graphics { camera = camera - , objects = [Container (V2 200 200) [obj1 point, fromMaybe obj5 objAnimated]] + , objects = concat [[background], container (V2 100 100) [obj1 point, fromMaybe obj5 +objAnimated]] } , sound = [] , shouldExit = isEvent shouldQuit } where camera = Camera (V2 0 0) (V2 800 600) - shape1 = Triangle (V2 0 0) (V2 0 50) (V2 50 (-50)) (V2 (-50) (-50)) - shape2 point = Rectangle point (V2 50 50) - obj1 point = RS (shape2 point) (Filled blue) 2 - obj2 = RS shape1 (Filled yellow) 1 - obj3 = RS shape1 (Filled violet) 1 - obj4 = RS shape1 (Filled green) 1 - obj5 = RS shape1 (Filled orange) 1 + shape1 colour = Triangle (V2 0 0) (V2 0 50) (V2 50 (-50)) (V2 (-50) (-50)) (Filled colour) + shape2 point = Rectangle point (V2 50 50) (Filled blue) + obj1 point = RS (shape2 point) 2 + obj2 = RS (shape1 orange) 1 + obj3 = RS (shape1 white) 1 + obj4 = RS (shape1 green) 1 + obj5 = RS (shape1 yellow) 1 animation = newAnimation [(0.5,obj2), (0.5,obj3), (0.5,obj4), (0.5, obj5)] Endless - direction ScancodeRight = V2 1 0 - direction ScancodeLeft = V2 (-1) 0 - direction ScancodeDown = V2 0 (-1) - direction ScancodeUp = V2 0 1 + 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 (Image (V2 0 0) (V2 800 600) Nothing "./test/MARBLES.BMP") 0 diff --git a/yampa-sdl2.cabal b/yampa-sdl2.cabal --- a/yampa-sdl2.cabal +++ b/yampa-sdl2.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: 03e817a47b063a73dd635929d74cec6d550986109c6361e048e24ba1ffe9b4be +-- hash: c570b1b1938d51918603a068252687f218bfc16e0da4f1c3e581ded264fb4bd8 name: yampa-sdl2 -version: 0.0.1.1 +version: 0.0.2.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