fwgl-glfw 0.1.0.5 → 0.1.1.0
raw patch · 5 files changed
+202/−87 lines, 5 filesdep +vectdep −Yampadep ~fwgldep ~vector
Dependencies added: vect
Dependencies removed: Yampa
Dependency ranges changed: fwgl, vector
Files
- FWGL/Backend/GLFW/Common.hs +138/−65
- FWGL/Backend/GLFW/GL20.hs +24/−2
- FWGL/Backend/OpenGL/Common.hs +9/−0
- FWGL/Backend/OpenGL/GL20.hs +29/−18
- fwgl-glfw.cabal +2/−2
FWGL/Backend/GLFW/Common.hs view
@@ -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
FWGL/Backend/GLFW/GL20.hs view
@@ -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
FWGL/Backend/OpenGL/Common.hs view
@@ -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
FWGL/Backend/OpenGL/GL20.hs view
@@ -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
fwgl-glfw.cabal view
@@ -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