yampa-sdl2 0.0.1.1 → 0.0.2.0
raw patch · 10 files changed
+246/−118 lines, 10 files
Files
- README.md +12/−10
- src/YampaSDL2.hs +5/−2
- src/YampaSDL2/AppOutput.hs +14/−19
- src/YampaSDL2/Backend.hs +2/−0
- src/YampaSDL2/Backend/Input.hs +6/−3
- src/YampaSDL2/Backend/Output.hs +168/−64
- src/YampaSDL2/Backend/SDL.hs +5/−2
- src/YampaSDL2/Geometry.hs +18/−3
- test/Main.hs +14/−13
- yampa-sdl2.cabal +2/−2
README.md view
@@ -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. -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
src/YampaSDL2.hs view
@@ -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
src/YampaSDL2/AppOutput.hs view
@@ -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
src/YampaSDL2/Backend.hs view
@@ -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 }
src/YampaSDL2/Backend/Input.hs view
@@ -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
src/YampaSDL2/Backend/Output.hs view
@@ -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
src/YampaSDL2/Backend/SDL.hs view
@@ -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)- }+ }
src/YampaSDL2/Geometry.hs view
@@ -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)+++
test/Main.hs view
@@ -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
yampa-sdl2.cabal view
@@ -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