diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/gelatin-sdl2.cabal b/gelatin-sdl2.cabal new file mode 100644 --- /dev/null +++ b/gelatin-sdl2.cabal @@ -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 diff --git a/img/lava.png b/img/lava.png new file mode 100644 Binary files /dev/null and b/img/lava.png differ diff --git a/src/Gelatin/SDL2.hs b/src/Gelatin/SDL2.hs new file mode 100644 --- /dev/null +++ b/src/Gelatin/SDL2.hs @@ -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