packages feed

gelatin-sdl2 (empty) → 0.1.0.0

raw patch · 6 files changed

+240/−0 lines, 6 filesdep +basedep +eitherdep +filepathsetup-changedbinary-added

Dependencies added: base, either, filepath, gelatin-gl, gelatin-sdl2, mtl, sdl2, transformers

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2016 Schell Scivally++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE LambdaCase #-}+import           Control.Arrow+import           Control.Concurrent         (threadDelay)+import           Control.Monad              (forM_, forever, when)+import           Control.Monad.Trans.Either (runEitherT)+import           Gelatin.SDL2+import           Paths_gelatin_sdl2+import           SDL+import           System.Exit                (exitFailure, exitSuccess)+import           System.FilePath            ((</>))++--------------------------------------------------------------------------------+-- Regular pure pictures+--------------------------------------------------------------------------------+colorGeometry :: Geometry (V2 Float, V4 Float)+colorGeometry = do+  triangles tris+  beziers $ mapVertices (first (+ V2 100 0)) tris+  line $ mapVertices (first (+V2 200 0)) tris+  line $ mapVertices (first (+V2 300 0)) bcurve+  line $ mapVertices (first ((+V2 300 100) . (*V2 1 (-1)))) bcurve+  line $ mapVertices (first (+V2 350 50)) circle+  where tris = do tri (0, red) (V2 100 0, green) (100, blue)+                  tri (0, magenta) (V2 0 100, canary) (100, cyan)+        bcurve = mapVertices (\v -> (v,white)) $+                   curve (V2 0 100) (V2 50 (-50)) 100+        circle = mapVertices (\v -> (v,white)) $ arc 50 50 0 (2*pi)++colorPicture :: ColorPicture ()+colorPicture = do+  setStroke [StrokeWidth 3, StrokeFeather 1]+  setGeometry colorGeometry++bezierPicture :: ColorPicture ()+bezierPicture = setGeometry $ beziers $ do+  bez (V2 0   0,   white) (V2 200 0, blue) (V2 200 200, green)+  bez (V2 400 200, white) (V2 400 0, blue) (V2 200 0,   green)++texturePicture :: GLuint -> V2 Int -> TexturePicture ()+texturePicture tex (V2 w h) = do+  setStroke [StrokeWidth 3, StrokeFeather 1]+  setTextures [tex]+  setGeometry $ mapGeometry toUV colorGeometry+    where toUV (V2 x y, _) = (V2 x y, V2 (x/fromIntegral w) (y/fromIntegral h))++isQuit :: Event -> Bool+isQuit (Event _ payload) = isKeyQ payload || payload == QuitEvent+  where+    isKeyQ (KeyboardEvent (KeyboardEventData _ _ _ (Keysym _ KeycodeQ _))) = True+    isKeyQ _ = False++-- Start up our backend(s) and go!+main :: IO ()+main =+  runEitherT (startupSDL2Backends 920 420 "gelatin-sdl2-example" True) >>= \case+    Left err -> putStrLn err >> exitFailure+    Right (SDL2Backends glv2v4 glv2v2) -> do+      -- Load up a texture. This can be done with either backend, as they both+      -- share the same OpenGL context.+      imgName <- getDataFileName $ "img" </> "lava.png"+      Just (tex, sz) <- allocTexture glv2v2 imgName+      -- Compiler our picture descriptions, sending their geometry to the GPU and+      -- returning a renderable resource and a cleanup action. The result of the+      -- picture computation is discarded.+      (_, colorRender)     <- compilePicture glv2v4 colorPicture+      (_, bezierRenderer)  <- compilePicture glv2v4 bezierPicture+      (_, texRender)       <- compilePicture glv2v2 $ texturePicture tex sz+      -- Forever run the main loop, which polls for SDL events, clear the window,+      -- render our resources at different places with different transforms, and+      -- update the window with the new frame.+      forever $ do+        threadDelay 1+        events <- getEvents glv2v4+        when (any isQuit events) exitSuccess+        clearWindow glv2v4+        let indices = [0..10]+        forM_ indices $ \i -> do+          let txy  = move (100 - 10 * i) (100 - 10 * i)+              a    = alpha $ i/10+              rs   = [txy, a]+          snd colorRender rs+          snd bezierRenderer $ move 400 0 : rs+          snd texRender $ move 0 200 : rs+        updateWindow glv2v4
+ gelatin-sdl2.cabal view
@@ -0,0 +1,38 @@+name:                gelatin-sdl2+version:             0.1.0.0+synopsis:            An SDL2 backend for the gelatin renderer.+description:         Using SDL2 this package provides a backend to+                     gelatin, an EDSL rendering pictures.+homepage:            https://github.com/schell/gelatin+license:             MIT+license-file:        LICENSE+author:              Schell Scivally+maintainer:          schell@takt.com+category:            Graphics+build-type:          Simple+cabal-version:       >= 1.10+data-files:          img/*.png+stability:           experimental++library+  exposed-modules:     Gelatin.SDL2+  ghc-options:         -Wall+  build-depends:       base                 >=4.8 && <4.11+                     , sdl2                 >=2.1 && <2.4+                     , gelatin-gl           >=0.1 && <0.2+                     , mtl                  >=2.2 && <2.3+                     , transformers         >=0.4 && <0.6+  hs-source-dirs:      src+  default-language:    Haskell2010++executable gelatin-sdl2-example+  hs-source-dirs:      app+  main-is:             Main.hs+  other-modules:       Paths_gelatin_sdl2+  ghc-options:         -Wall+  default-language:    Haskell2010+  build-depends:       base                 >=4.8 && <4.11+                     , gelatin-sdl2+                     , sdl2                 >=2.1 && <2.4+                     , filepath             >=1.4 && <1.5+                     , either               >=4.4 && <4.6
+ img/lava.png view

binary file changed (absent → 361 bytes)

+ src/Gelatin/SDL2.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies          #-}+-- | This module provides an entry point for your gelatin+-- apps that run on sdl2.+module Gelatin.SDL2+  ( -- * Backend definitions+    SDL2Backends(..)+    -- * Obtaining the backends+  , startupSDL2Backends+  , startupSDL2BackendsWithConfig+    -- * Re-exports+  , module Gelatin.GL+  ) where++import           Control.Monad.Except   (MonadError)+import           Control.Monad.IO.Class (MonadIO, liftIO)+import           Data.String            (fromString)+import           Gelatin.GL+import           SDL                    hiding (Rectangle, Renderer,+                                         glBindTexture, glUnbindTexture)+++-- | A record containing both V2V4 and V2V2 backends.+data SDL2Backends = SDL2Backends+  { backendV2V4 :: Backend GLuint Event V2V4 (V2 Float) Float Raster+  , backendV2V2 :: Backend GLuint Event V2V2 (V2 Float) Float Raster+  }+++-- | Start up and return the sdl2 backends according to the given+-- sdl2 'WindowConfig'.+startupSDL2BackendsWithConfig+  :: (MonadIO m, MonadError String m)+  => WindowConfig+  -- ^ The configuration used to set up the window.+  -> String+  -- ^ The window title+  -> m SDL2Backends+startupSDL2BackendsWithConfig cfg str = do+  w <- liftIO $ do+    initializeAll+    w     <- createWindow (fromString str) cfg+    _     <- glCreateContext w+    return w+  sh <- loadSimple2DShader++  liftIO $ do+    glEnable GL_BLEND+    glBlendFunc GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA++  let wsize =  do V2 x y <- get $ windowSize w+                  return (fromIntegral x, fromIntegral y)+      fsize = do V2 x y <- glGetDrawableSize w+                 return (fromIntegral x, fromIntegral y)++      ctx = Context { ctxFramebufferSize = fsize+                    , ctxWindowSize = wsize+                    }+      rz   = Rez sh ctx+      ops  = glOps rz (updateWindowSDL2 w) pollEvents+      v2v4 = Backend ops $ glV2V4Compiler rz+      v2v2 = Backend ops $ glV2V2Compiler rz+  return $ SDL2Backends v2v4 v2v2+++-- | Start up and return the default backends.+-- Uses OpenGL 3.3 with debugging turned on.+startupSDL2Backends+  :: (MonadIO m, MonadError String m)+  => Int+  -- ^ Window width+  -> Int+  -- ^ Window height+  -> String+  -- ^ Window title+  -> Bool+  -- ^ Whether or not to request a high DPI window.+  -- Passing 'True' typically results in a framebuffer with 2x+  -- the window size.+  -> m SDL2Backends+startupSDL2Backends ww wh ws highDPI = do+    let openGL = defaultOpenGL{ glProfile = Core Debug 3 3+                              }+        window = defaultWindow{ windowInitialSize = V2 (fromIntegral ww)+                                                       (fromIntegral wh)+                              , windowOpenGL = Just openGL+                              , windowResizable = True+                              , windowHighDPI = highDPI+                              }+    startupSDL2BackendsWithConfig window ws+++updateWindowSDL2 :: Window -> IO ()+updateWindowSDL2 = glSwapWindow