diff --git a/FWGL/Backend/GLFW/Common.hs b/FWGL/Backend/GLFW/Common.hs --- a/FWGL/Backend/GLFW/Common.hs +++ b/FWGL/Backend/GLFW/Common.hs @@ -1,19 +1,34 @@ module FWGL.Backend.GLFW.Common ( loadTextFile, loadImage, - setup, + initBackend, + createCanvas, + setCanvasSize, + setCanvasTitle, + setCanvasResizeCallback, + setCanvasRefreshCallback, + popInput, + getInput, + drawCanvas, + safeFork, + refreshLoop, + FWGL.Backend.GLFW.Common.getTime, + terminateBackend, + Canvas, + BackendState, ClientAPI(..) ) where import Codec.Picture import Codec.Picture.Types (promoteImage) import Control.Concurrent +import Control.Monad import Control.Exception.Base (catch) import qualified Data.HashMap.Strict as H +import Data.Hashable import Data.IORef import Data.Vector.Storable (unsafeWith) import Foreign.Ptr -import FRP.Yampa import FWGL.Backend.GLES hiding (Image) import FWGL.Input as Input import Graphics.UI.GLFW as GLFW @@ -43,61 +58,54 @@ catch (fmap (\s -> s `seq` Right s) $ readFile fname) (\e -> return (Left $ show (e :: IOError))) >>= handler -setup :: ClientAPI -> Int -> Int - -> (Int -> Int -> () -> IO state) - -> (out -> () -> state -> IO state) - -> IO inp - -> SF (Input inp) out - -> IO () -setup clientAPI maj min initState draw customInp sigf = - do GLFW.init -- TODO: checks - windowHint $ WindowHint'ClientAPI clientAPI +data BackendState = BackendState { + eventThread :: ThreadId +} + +data Canvas = Canvas GLFW.Window + (IORef (H.HashMap InputEvent [EventData])) + (IORef (Int -> Int -> IO ())) + (IORef (IO ())) + (MVar ()) + +initBackend :: IO BackendState +initBackend = do GLFW.init + setTime 0 + evTid <- forkIO . forever $ waitEvents >> threadDelay 10000 + return $ BackendState evTid + +createCanvas :: ClientAPI -> Int -> Int + -> String -> Int -> Int -> BackendState -> IO (Canvas, Int, Int) +createCanvas clientAPI maj min title w h _ = + do windowHint $ WindowHint'ClientAPI clientAPI windowHint $ WindowHint'ContextVersionMajor maj windowHint $ WindowHint'ContextVersionMinor min - Just win <- createWindow 640 480 "" Nothing Nothing -- TODO: custom size, title - makeContextCurrent $ Just win - (w, h) <- getFramebufferSize win + -- TODO: context sharing + Just win <- createWindow w h title Nothing Nothing + bufferSem <- newMVar () - eventsRef <- newMVar H.empty - drawStateRef <- initState w h () >>= newIORef - initCustom <- customInp - reactStateRef <- reactInit (return $ initInput w h initCustom) - (\_ _ -> actuate win drawStateRef) - sigf - setTime 0 + resizeRef <- newIORef $ \_ _ -> return () + refreshRef <- newIORef $ return () + eventsRef <- newIORef $ H.singleton Resize [ + emptyEventData { + dataFramebufferSize = Just (w, h) + }] - setKeyCallback win $ Just . const $ addKeyEvent eventsRef - setMouseButtonCallback win . Just $ addMouseEvent eventsRef - setCursorPosCallback win $ Just . const $ addCursorPos eventsRef - setFramebufferSizeCallback win $ Just . const $ - addFramebufferResize eventsRef - setWindowRefreshCallback win $ Just . const $ - refresh eventsRef reactStateRef - - let loop = do pollEvents - refresh eventsRef reactStateRef - close <- windowShouldClose win - if close - then do destroyWindow win - terminate - else threadDelay 16000 >> loop - loop - where refresh er rsf = do (Just tm) <- getTime - custom <- customInp - modifyMVar_ er $ \inp -> do - react rsf ( tm * 1000 - , Just $ Input inp custom) - return H.empty - setTime 0 + setKeyCallback win . Just . const $ keyCallback eventsRef + setMouseButtonCallback win . Just $ mouseCallback eventsRef + setCursorPosCallback win . Just . const $ cursorCallback eventsRef + -- XXX: windows that are not using refreshLoop should receive this + {- + setWindowRefreshCallback win . Just . const $ + refreshCallback bufferSem refreshRef + -} + setFramebufferSizeCallback win . Just . const $ + resizeCallback eventsRef resizeRef - actuate win stateRef out = do newState <- readIORef stateRef - >>= draw out () - swapBuffers win - writeIORef stateRef newState - return False + return (Canvas win eventsRef resizeRef refreshRef bufferSem, w, h) - addKeyEvent events key _ keyState _ = modifyEvents events $ + where keyCallback events key _ keyState _ = modifyIORef' events $ case keyState of KeyState'Pressed -> insertEvent KeyDown keyData KeyState'Released -> insertEvent KeyUp keyData @@ -106,9 +114,9 @@ dataKey = Just $ toKey key } - addMouseEvent events win mb mbState _ = do + mouseCallback events win mb mbState _ = do pos <- fmap convertCursorPos $ getCursorPos win - modifyEvents events $ + modifyIORef' events $ case mbState of MouseButtonState'Pressed -> insertEvent MouseDown $ keyData pos @@ -119,33 +127,98 @@ dataPointer = Just p } - addCursorPos events x y = modifyEvents events $ + cursorCallback events x y = modifyIORef' events $ insertEvent MouseMove $ emptyEventData { dataPointer = Just $ convertCursorPos (x, y) } - addFramebufferResize events x y = modifyEvents events $ - insertEvent Resize $ emptyEventData { - dataFramebufferSize = Just $ (x, y) - } - -- TODO: viewport + resizeCallback events resizeRef x y = + do callback <- readIORef resizeRef + modifyIORef' events $ + insertEvent Resize $ emptyEventData { + dataFramebufferSize = Just $ (x, y) + } + callback x y - convertCursorPos (x, y) = (floor x, floor y) + refreshCallback bufferSem refreshRef = + do empty <- isEmptyMVar bufferSem + unless empty $ + join $ readIORef refreshRef - initInput w h = Input $ H.singleton Resize [ - emptyEventData { - dataFramebufferSize = Just (w, h) - }] + convertCursorPos (x, y) = (floor x, floor y) insertEvent e = H.insertWith (flip (++)) e . return - modifyEvents m f = modifyMVar_ m $ return . f - emptyEventData = EventData { dataFramebufferSize = Nothing, dataPointer = Nothing, dataButton = Nothing, dataKey = Nothing } + +setCanvasSize :: Int -> Int -> Canvas -> BackendState -> IO () +setCanvasSize w h (Canvas win _ _ _ _) _ = setWindowSize win w h + +setCanvasTitle :: String -> Canvas -> BackendState -> IO () +setCanvasTitle str (Canvas win _ _ _ _) _ = setWindowTitle win str + +setCanvasResizeCallback :: (Int -> Int -> IO ()) -> Canvas + -> BackendState -> IO () +setCanvasResizeCallback callback (Canvas _ _ ref _ _) _ = + writeIORef ref callback + +setCanvasRefreshCallback :: IO () -> Canvas -> BackendState -> IO () +setCanvasRefreshCallback callback (Canvas _ _ _ ref _) _ = + writeIORef ref callback + +popInput :: a -> Canvas -> BackendState -> IO (Input a) +popInput c canvas@(Canvas _ events _ _ _) bs = do i <- getInput c canvas bs + writeIORef events H.empty + return i + +getInput :: a -> Canvas -> BackendState -> IO (Input a) +getInput c (Canvas _ events _ _ _) _ = flip Input c <$> readIORef events + +draw :: IO a -> Bool -> MVar () -> Window -> IO a +draw act shouldSwap bufferSem win = + do () <- takeMVar bufferSem + makeContextCurrent $ Just win + r <- act + when shouldSwap $ + swapBuffers win + makeContextCurrent Nothing + putMVar bufferSem () + return r + +drawCanvas :: (MVar () -> IO a) -> Bool -> Canvas -> BackendState -> IO a +drawCanvas act swap (Canvas win _ _ _ sem) _ = draw (act sem) swap sem win + +safeFork :: MVar () -> (IO () -> IO ThreadId) -> IO () -> IO ThreadId +safeFork sem fork thread = do mctx <- getCurrentContext + fork $ case mctx of + Just ctx -> draw thread False sem ctx + Nothing -> thread + +refreshLoop :: Int -> Canvas -> BackendState -> IO () +refreshLoop fps c@(Canvas win _ _ refreshCallback _) bs = + do Just t1 <- GLFW.getTime + closed <- windowShouldClose win + join $ readIORef refreshCallback + pollEvents + Just t2 <- GLFW.getTime + let passed = (t2 - t1) * 1000000 + if closed + then destroyWindow win + else do when (passed > 0) $ + threadDelay . ceiling $ delay - passed + refreshLoop fps c bs + where delay = 1000000 / fromIntegral fps + +getTime :: BackendState -> IO Double +getTime _ = do Just t <- GLFW.getTime + return t + +terminateBackend :: BackendState -> IO () +terminateBackend (BackendState tid) = killThread tid >> terminate toMouseButton :: GLFW.MouseButton -> Input.MouseButton toMouseButton MouseButton'1 = MouseLeft diff --git a/FWGL/Backend/GLFW/GL20.hs b/FWGL/Backend/GLFW/GL20.hs --- a/FWGL/Backend/GLFW/GL20.hs +++ b/FWGL/Backend/GLFW/GL20.hs @@ -1,12 +1,34 @@ {-# LANGUAGE NullaryTypeClasses, TypeFamilies #-} -module FWGL.Backend.GLFW.GL20 () where +module FWGL.Backend.GLFW.GL20 (createCanvas') where import FWGL.Backend.IO import FWGL.Backend.OpenGL.GL20 import qualified FWGL.Backend.GLFW.Common as C +createCanvas' :: String -- ^ Window title + -> Int -- ^ Window width + -> Int -- ^ Window height + -> BackendState + -> IO (C.Canvas, Int, Int) +createCanvas' = C.createCanvas C.ClientAPI'OpenGL 2 0 + instance BackendIO where + type Canvas = C.Canvas + type BackendState = C.BackendState + loadImage = C.loadImage loadTextFile = C.loadTextFile - setup = C.setup C.ClientAPI'OpenGL 2 0 -- TODO: enable extensions + initBackend = C.initBackend + createCanvas _ = createCanvas' "" 640 480 + setCanvasSize = C.setCanvasSize + setCanvasTitle = C.setCanvasTitle + setCanvasResizeCallback = C.setCanvasResizeCallback + setCanvasRefreshCallback = C.setCanvasRefreshCallback + popInput = C.popInput + getInput = C.getInput + drawCanvas = C.drawCanvas + safeFork = C.safeFork + refreshLoop = C.refreshLoop + getTime = C.getTime + terminateBackend = C.terminateBackend diff --git a/FWGL/Backend/OpenGL/Common.hs b/FWGL/Backend/OpenGL/Common.hs --- a/FWGL/Backend/OpenGL/Common.hs +++ b/FWGL/Backend/OpenGL/Common.hs @@ -36,6 +36,15 @@ -> ctx -> a -> (GLsizei, ForeignPtr b) -> IO () vertexAttrib f _ a (_, fp) = withForeignPtr fp $ f a +mkArrayLen :: Int -> IO (GLsizei, ForeignPtr b) +mkArrayLen len = do arr <- mallocForeignPtrArray (fromIntegral len) + :: IO (ForeignPtr Word8) + return (fromIntegral len, castForeignPtr arr) + +arrayToList :: Storable b => (GLsizei, ForeignPtr a) -> IO [b] +arrayToList (len, fptr) = withForeignPtr (castForeignPtr fptr) $ \ptr -> + peekArray (fromIntegral len) ptr + mkArray :: Storable a => [a] -> IO (GLsizei, ForeignPtr b) mkArray xs = do arr <- mallocForeignPtrArray len withForeignPtr arr $ flip pokeArray xs diff --git a/FWGL/Backend/OpenGL/GL20.hs b/FWGL/Backend/OpenGL/GL20.hs --- a/FWGL/Backend/OpenGL/GL20.hs +++ b/FWGL/Backend/OpenGL/GL20.hs @@ -2,19 +2,21 @@ module FWGL.Backend.OpenGL.GL20 () where +import Control.Concurrent (MVar) import Data.Word +import Data.Vect.Float import Foreign import Foreign.C.String import FWGL.Backend.OpenGL.Common import FWGL.Backend.GLES -import FWGL.Vector import qualified Graphics.GL.Standard20 as GL import qualified Graphics.GL.Ext.ARB.FramebufferObject as GL +import qualified Graphics.GL.Ext.ARB.VertexArrayObject as GL import qualified Graphics.GL.Ext.EXT.BlendColor as GL import Graphics.GL.Types as GL instance GLES where - type Ctx = () + type Ctx = MVar () type GLEnum = GLenum type GLUInt = GLuint type GLInt = GLint @@ -30,6 +32,7 @@ type Program = GLuint type FrameBuffer = GLuint type RenderBuffer = GLuint + type VertexArrayObject = GLuint -- type ShaderPrecisionFormat = GLint type Array = (GLsizei, ForeignPtr ()) type Float32Array = (GLsizei, ForeignPtr GLfloat) @@ -42,31 +45,35 @@ toGLString = id noBuffer = 0 noTexture = 0 + noVAO = 0 noArray = fmap ((,) 0) $ newForeignPtr_ nullPtr -- TODO: move to FWGL.Backend.OpenGL.Common - encodeM2 (M2 (V2 a1 a2) (V2 b1 b2)) = mkArray [ a1, a2, b1, b2 ] + encodeMat2 (Mat2 (Vec2 a1 a2) (Vec2 b1 b2)) = mkArray [ a1, a2, b1, b2 ] - encodeM3 (M3 (V3 a1 a2 a3) - (V3 b1 b2 b3) - (V3 c1 c2 c3)) = mkArray [ a1, a2, a3 - , b1, b2, b3 - , c1, c2, c3 ] - encodeM4 (M4 (V4 a1 a2 a3 a4) - (V4 b1 b2 b3 b4) - (V4 c1 c2 c3 c4) - (V4 d1 d2 d3 d4) ) = mkArray [ a1, a2, a3, a4 - , b1, b2, b3, b4 - , c1, c2, c3, c4 - , d1, d2, d3, d4 ] + encodeMat3 (Mat3 (Vec3 a1 a2 a3) + (Vec3 b1 b2 b3) + (Vec3 c1 c2 c3)) = mkArray [ a1, a2, a3 + , b1, b2, b3 + , c1, c2, c3 ] + encodeMat4 (Mat4 (Vec4 a1 a2 a3 a4) + (Vec4 b1 b2 b3 b4) + (Vec4 c1 c2 c3 c4) + (Vec4 d1 d2 d3 d4) ) = mkArray [ a1, a2, a3, a4 + , b1, b2, b3, b4 + , c1, c2, c3, c4 + , d1, d2, d3, d4 ] encodeFloats = mkArray - encodeV2s = mkArray - encodeV3s = mkArray - encodeV4s = mkArray + encodeVec2s = mkArray + encodeVec3s = mkArray + encodeVec4s = mkArray encodeUShorts = mkArray encodeColors = mkArray + newByteArray = mkArrayLen + decodeBytes = arrayToList + glActiveTexture = const GL.glActiveTexture glAttachShader = const GL.glAttachShader glBindAttribLocation _ a b c = withCString c $ GL.glBindAttribLocation a b @@ -74,6 +81,7 @@ glBindFramebuffer = const GL.glBindFramebuffer glBindRenderbuffer = const GL.glBindRenderbuffer glBindTexture = const GL.glBindTexture + glBindVertexArray = const GL.glBindVertexArray glBlendColor = const GL.glBlendColor glBlendEquation = const GL.glBlendEquation glBlendEquationSeparate = const GL.glBlendEquationSeparate @@ -102,6 +110,7 @@ glCreateRenderbuffer = genToCreate GL.glGenRenderbuffers glCreateShader = const GL.glCreateShader glCreateTexture = genToCreate GL.glGenTextures + glCreateVertexArray = genToCreate GL.glGenVertexArrays glCullFace = const GL.glCullFace glDeleteBuffer = deleteToDelete GL.glDeleteBuffers glDeleteFramebuffer = deleteToDelete GL.glDeleteFramebuffers @@ -109,6 +118,7 @@ glDeleteRenderbuffer = deleteToDelete GL.glDeleteRenderbuffers glDeleteShader = const GL.glDeleteShader glDeleteTexture = deleteToDelete GL.glDeleteTextures + glDeleteVertexArray = deleteToDelete GL.glDeleteVertexArrays glDepthFunc = const GL.glDepthFunc glDepthMask = const GL.glDepthMask glDepthRange _ a b = GL.glDepthRange (realToFrac a) (realToFrac b) @@ -139,6 +149,7 @@ glIsRenderbuffer = const GL.glIsRenderbuffer glIsShader = const GL.glIsShader glIsTexture = const GL.glIsTexture + glIsVertexArray = const GL.glIsVertexArray glLineWidth = const GL.glLineWidth glLinkProgram = const GL.glLinkProgram glPixelStorei = const GL.glPixelStorei diff --git a/fwgl-glfw.cabal b/fwgl-glfw.cabal --- a/fwgl-glfw.cabal +++ b/fwgl-glfw.cabal @@ -1,5 +1,5 @@ name: fwgl-glfw -version: 0.1.0.5 +version: 0.1.1.0 synopsis: FWGL GLFW backend description: FWGL GLFW backend. homepage: https://github.com/ziocroc/FWGL @@ -16,6 +16,6 @@ exposed-modules: FWGL.Backend.GLFW.GL20 other-modules: FWGL.Backend.OpenGL.Common, FWGL.Backend.GLFW.Common, FWGL.Backend.OpenGL.GL20 other-extensions: NullaryTypeClasses, TypeFamilies, MultiParamTypeClasses - build-depends: fwgl > 0.1.2.0 && <0.2, base >=4.7 && <4.9, Yampa >=0.9 && <0.10, hashable >=1.2 && <1.3, unordered-containers >=0.2 && <0.3, vector >=0.10 && <0.11, transformers, gl >=0.6, JuicyPixels >=3.2 && <3.3, GLFW-b >=1.4 && <1.5 + build-depends: fwgl > 0.1.3 && <0.1.4, base >=4.7 && <4.9, hashable >=1.2 && <1.3, unordered-containers >=0.2 && <0.3, vector >=0.10 && <0.12, transformers, gl >=0.6, JuicyPixels >=3.2 && <3.3, GLFW-b >=1.4 && <1.5, vect hs-source-dirs: . default-language: Haskell2010