{-# 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