netwire-input-glfw 0.0.6 → 0.0.7
raw patch · 3 files changed
+253/−242 lines, 3 filesdep ~netwire-input-glfwPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: netwire-input-glfw
API changes (from Hackage documentation)
+ FRP.Netwire.Input.GLFW: instance Control.Monad.State.Class.MonadState s m => Control.Monad.State.Class.MonadState s (FRP.Netwire.Input.GLFW.GLFWInputT m)
Files
- examples/Cursor.hs +231/−232
- lib/FRP/Netwire/Input/GLFW.hs +11/−2
- netwire-input-glfw.cabal +11/−8
examples/Cursor.hs view
@@ -1,232 +1,231 @@-module Main where-----------------------------------------------------------------------------------import Control.Monad.State-import Control.Monad.Trans.Class-import Control.Wire hiding (unless)--import Data.Array.IO-import Data.Array.Storable-import qualified Data.ByteString.Char8 as BS-import Data.List-import Data.Word--import FRP.Netwire.Input-import FRP.Netwire.Input.GLFW--import qualified Graphics.UI.GLFW as GLFW-import qualified Graphics.Rendering.OpenGL as GL--import Foreign.Storable-import Foreign.Ptr-------------------------------------------------------------------------------------------------------------------------------------------------------------------------- Boilerplate--data Shape = Shape GL.NumArrayIndices GL.BufferObject GL.BufferObject--mkCircle :: IO (Shape)-mkCircle = let- slices = 50- vptrsize = toEnum $ (slices + 2) * (sizeOf (undefined :: GL.Vertex2 Float))- iptrsize = toEnum $ (slices + 2) * (sizeOf (undefined :: Int))- winding = [0,(2*pi/(fromIntegral slices))..] :: [Float]- in do- vbuf <- GL.genObjectName- GL.bindBuffer GL.ArrayBuffer GL.$= (Just vbuf)- let vl = (GL.Vertex2 0 0) : (zipWith GL.Vertex2 (map cos winding) (map sin winding))- verts <- newListArray (0, slices + 1) vl- withStorableArray verts- (\ptr -> GL.bufferData GL.ArrayBuffer GL.$= (vptrsize, ptr, GL.StaticDraw))-- ibuf <- GL.genObjectName- GL.bindBuffer GL.ElementArrayBuffer GL.$= (Just ibuf)- idxs <- newListArray (0, slices + 1) ([0,1..] :: [Word16])- withStorableArray idxs- (\ptr -> GL.bufferData GL.ElementArrayBuffer GL.$= (iptrsize, ptr, GL.StaticDraw))-- return $ Shape (toEnum $ slices + 2) vbuf ibuf--vertShader :: BS.ByteString-vertShader = BS.pack $ intercalate ['\n'] [- "attribute vec2 position;",- "uniform vec2 offset;",- "void main() {",- " gl_Position = vec4(offset + 0.1*position, 1.0, 1.0);",- "}"]--fragShader :: BS.ByteString-fragShader = BS.pack $ intercalate ['\n'] [- "uniform vec3 color;",- "void main() {",- " gl_FragColor = vec4(color, 1.0);",- "}"]--compileShader :: GL.ShaderType -> BS.ByteString -> IO (GL.Shader)-compileShader shdrTy src = do- shdr <- GL.createShader shdrTy- GL.shaderSourceBS shdr GL.$= src- GL.compileShader shdr- shaderLog <- GL.get $ GL.shaderInfoLog shdr- unless (shaderLog == []) $ putStrLn shaderLog- return shdr--mkRenderFunc :: IO (Shape -> GL.Vertex2 Float -> GL.Color3 Float -> IO ())-mkRenderFunc = do- -- Compile shaders- vshdr <- compileShader GL.VertexShader vertShader- fshdr <- compileShader GL.FragmentShader fragShader-- -- Create program- prg <- GL.createProgram- mapM_ (GL.attachShader prg) [vshdr, fshdr]- GL.linkProgram prg-- -- Find variable locations- colorLoc <- GL.get $ GL.uniformLocation prg "color"- offsetLoc <- GL.get $ GL.uniformLocation prg "offset"- positionLoc <- GL.get $ GL.attribLocation prg "position"-- GL.currentProgram GL.$= Just prg-- -- Define function- return $ \(Shape numIdxs vbo ibo) pos color -> do-- -- Enable buffers- GL.vertexAttribArray positionLoc GL.$= GL.Enabled-- -- Set uniforms- GL.uniform colorLoc GL.$= ((fmap realToFrac color) :: GL.Color3 GL.GLfloat)- GL.uniform offsetLoc GL.$= ((fmap realToFrac pos) :: GL.Vertex2 GL.GLfloat)-- -- Bind buffers- GL.bindBuffer GL.ArrayBuffer GL.$= Just vbo- GL.vertexAttribPointer positionLoc GL.$=- (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 (nullPtr :: Ptr Float))-- GL.bindBuffer GL.ElementArrayBuffer GL.$= Just ibo-- -- Render- GL.drawElements GL.TriangleFan numIdxs GL.UnsignedShort nullPtr-- -- Disable buffers- GL.vertexAttribArray positionLoc GL.$= GL.Disabled -------------------------------------------------------------------------------------- Some type synonyms to keep our code clean-type RenderFn = GL.Vertex2 Float -> GL.Color3 Float -> IO ()-type GameMonad = GLFWInputT IO-type GameSession = Session IO (Timed Float ())---- This wire produces the position of the circle. It simply follows the mouse cursor--- but negates the y-value. The origin of the mouse coordinates are in the top left--- corner of the screen with the y-axis pointing down while the y-axis for rendering--- points up.-posWire :: Monoid e => Wire s e GameMonad a (GL.Vertex2 Float)-posWire = mouseCursor >>> (second $ arr negate) >>> (arr $ uncurry GL.Vertex2)---- This wire produces color for the circle. If the R, G, or B keys are pressed,--- then the circle will turn red, green, or blue, respectively. Otherwise,--- the red and green channels of the circle pulsate-colorWire :: (HasTime t s, Monoid e) => Wire s e GameMonad a (GL.Color3 Float)-colorWire =- -- Key debounced means that it will only flash blue for one frame- (keyDebounced GLFW.Key'B >>> (pure $ GL.Color3 0 0 1)) <|>-- -- Key pressed means that it will remain this color- (keyPressed GLFW.Key'R >>> (pure $ GL.Color3 1 0 0)) <|>- (keyPressed GLFW.Key'G >>> (pure $ GL.Color3 0 1 0)) <|>-- -- Otherwise, pulsate based on the amount of time passed- (timeF >>> (arr (cos &&& sin)) >>> (arr $ \(x, y) -> GL.Color3 x y 1))---- This wire simply takes a vertex position and color and renders according to the--- passed in renderFn. In reality, this wire doesn't need to be a wire, and could just--- be a monad to render, but this way we can render what we need without having to--- go through the plumbing of our main game loop-renderWire :: Monoid e => RenderFn -> Wire s e GameMonad (GL.Vertex2 Float, GL.Color3 Float) ()-renderWire rfn = mkGen_ $ \(pos, color) -> lift $ rfn pos color >> (return $ Right ())---- Wire that behaves like the identity wire until Q is pressed, then inhibits forever.--- We can compose our main gameWire with this wire to simply quit the program when q is pressed-quitWire :: Monoid e => Wire s e GameMonad a a-quitWire = (mkId &&& eventWire) >>> (rSwitch mkId)- where- eventWire :: Monoid e => Wire s e GameMonad a (Event (Wire s e m a a))- eventWire = (keyPressed GLFW.Key'Q >>> pure mkEmpty >>> now) <|> never---- This is our main game wire, it feeds the position and color into the rendering loop--- and finally quits if q is pressed.-gameWire :: (HasTime t s, Monoid e) => RenderFn -> Wire s e GameMonad a ()-gameWire rfn = posWire &&& colorWire >>> (renderWire rfn) >>> quitWire--run :: GLFW.Window -> GLFWInputControl -> IO ()-run win ictl = do- -- initialize the input- ipt <- getInput ictl-- -- load vertex arrays and whatnot for the circle- circle <- mkCircle-- -- load the render function for getting rendering ready- renderFn <- mkRenderFunc-- -- run the game loop- runGame ipt (countSession_ 0.02) (gameWire $ renderFn circle)-- where-- -- The game loop takes the current input state, the time session and- -- our main game wire, and simply steps the wire until it inhibits.- runGame ipt sess w = do-- -- Before rendering clear the framebuffer- GL.clearColor GL.$= GL.Color4 0.0 0.0 0.0 1- GL.clear [GL.ColorBuffer]-- -- Poll the current input- ipt' <- pollGLFW ipt ictl-- -- Figure out our next timestep- (timeState, sess') <- stepSession sess-- -- Since the GameMonad is a 'StateT GLFWInputState m', in order to- -- step the wires, we have to extract the value from our wire. That means- -- that when we runStateT, we will get the results of our wire and a new- -- state (for example if the wire debounced any keys). This is what we pass- -- back to GLFW.- -- renderPrg :: IO ((Either e (), Wire s e GameMonad a ()), GLFWInputState)- let renderPrg = runGLFWInputT (stepWire w timeState (Right undefined)) ipt'-- -- Now run the actual IO program to extract the values from it.- ((result, w'), ipt'') <- renderPrg-- -- End of frame cleanup- GL.flush- GLFW.swapBuffers win-- -- Our quit condition is if the OS asked us to quit, or the wire inhibits- -- (i.e. someone hit the Q key)- case result of- Left () -> return ()- Right () -> do- q <- GLFW.windowShouldClose win- unless q $ runGame ipt'' sess' w'--main :: IO ()-main = do- -- Setup GLFW- GLFW.init- (Just m) <- GLFW.createWindow 400 400 "Netwire Input Demo" Nothing Nothing- GLFW.makeContextCurrent (Just m)-- -- Hack for retina displays- (szx, szy) <- GLFW.getFramebufferSize m- GL.viewport GL.$= (GL.Position 0 0, GL.Size (fromIntegral szx) (fromIntegral szy))-- -- Run the scene- mkInputControl m >>= run m+module Main where + +-------------------------------------------------------------------------------- +import Control.Monad.State +import Control.Wire hiding (unless) + +import Data.Array.IO +import Data.Array.Storable +import qualified Data.ByteString.Char8 as BS +import Data.List +import Data.Word + +import FRP.Netwire.Input +import FRP.Netwire.Input.GLFW + +import qualified Graphics.UI.GLFW as GLFW +import qualified Graphics.Rendering.OpenGL as GL + +import Foreign.Storable +import Foreign.Ptr + +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- +-- Boilerplate + +data Shape = Shape GL.NumArrayIndices GL.BufferObject GL.BufferObject + +mkCircle :: IO (Shape) +mkCircle = let + slices = 50 + vptrsize = toEnum $ (slices + 2) * (sizeOf (undefined :: GL.Vertex2 Float)) + iptrsize = toEnum $ (slices + 2) * (sizeOf (undefined :: Int)) + winding = [0,(2*pi/(fromIntegral slices))..] :: [Float] + in do + vbuf <- GL.genObjectName + GL.bindBuffer GL.ArrayBuffer GL.$= (Just vbuf) + let vl = (GL.Vertex2 0 0) : (zipWith GL.Vertex2 (map cos winding) (map sin winding)) + verts <- newListArray (0, slices + 1) vl + withStorableArray verts + (\ptr -> GL.bufferData GL.ArrayBuffer GL.$= (vptrsize, ptr, GL.StaticDraw)) + + ibuf <- GL.genObjectName + GL.bindBuffer GL.ElementArrayBuffer GL.$= (Just ibuf) + idxs <- newListArray (0, slices + 1) ([0,1..] :: [Word16]) + withStorableArray idxs + (\ptr -> GL.bufferData GL.ElementArrayBuffer GL.$= (iptrsize, ptr, GL.StaticDraw)) + + return $ Shape (toEnum $ slices + 2) vbuf ibuf + +vertShader :: BS.ByteString +vertShader = BS.pack $ intercalate ['\n'] [ + "attribute vec2 position;", + "uniform vec2 offset;", + "void main() {", + " gl_Position = vec4(offset + 0.1*position, 1.0, 1.0);", + "}"] + +fragShader :: BS.ByteString +fragShader = BS.pack $ intercalate ['\n'] [ + "uniform vec3 color;", + "void main() {", + " gl_FragColor = vec4(color, 1.0);", + "}"] + +compileShader :: GL.ShaderType -> BS.ByteString -> IO (GL.Shader) +compileShader shdrTy src = do + shdr <- GL.createShader shdrTy + GL.shaderSourceBS shdr GL.$= src + GL.compileShader shdr + shaderLog <- GL.get $ GL.shaderInfoLog shdr + unless (shaderLog == []) $ putStrLn shaderLog + return shdr + +mkRenderFunc :: IO (Shape -> GL.Vertex2 Float -> GL.Color3 Float -> IO ()) +mkRenderFunc = do + -- Compile shaders + vshdr <- compileShader GL.VertexShader vertShader + fshdr <- compileShader GL.FragmentShader fragShader + + -- Create program + prg <- GL.createProgram + mapM_ (GL.attachShader prg) [vshdr, fshdr] + GL.linkProgram prg + + -- Find variable locations + colorLoc <- GL.get $ GL.uniformLocation prg "color" + offsetLoc <- GL.get $ GL.uniformLocation prg "offset" + positionLoc <- GL.get $ GL.attribLocation prg "position" + + GL.currentProgram GL.$= Just prg + + -- Define function + return $ \(Shape numIdxs vbo ibo) pos color -> do + + -- Enable buffers + GL.vertexAttribArray positionLoc GL.$= GL.Enabled + + -- Set uniforms + GL.uniform colorLoc GL.$= ((fmap realToFrac color) :: GL.Color3 GL.GLfloat) + GL.uniform offsetLoc GL.$= ((fmap realToFrac pos) :: GL.Vertex2 GL.GLfloat) + + -- Bind buffers + GL.bindBuffer GL.ArrayBuffer GL.$= Just vbo + GL.vertexAttribPointer positionLoc GL.$= + (GL.ToFloat, GL.VertexArrayDescriptor 2 GL.Float 0 (nullPtr :: Ptr Float)) + + GL.bindBuffer GL.ElementArrayBuffer GL.$= Just ibo + + -- Render + GL.drawElements GL.TriangleFan numIdxs GL.UnsignedShort nullPtr + + -- Disable buffers + GL.vertexAttribArray positionLoc GL.$= GL.Disabled + +-------------------------------------------------------------------------------- + +-- Some type synonyms to keep our code clean +type RenderFn = GL.Vertex2 Float -> GL.Color3 Float -> IO () +type GameMonad = GLFWInputT IO +type GameSession = Session IO (Timed Float ()) + +-- This wire produces the position of the circle. It simply follows the mouse cursor +-- but negates the y-value. The origin of the mouse coordinates are in the top left +-- corner of the screen with the y-axis pointing down while the y-axis for rendering +-- points up. +posWire :: Wire s e GameMonad a (GL.Vertex2 Float) +posWire = mouseCursor >>> (second $ arr negate) >>> (arr $ uncurry GL.Vertex2) + +-- This wire produces color for the circle. If the R, G, or B keys are pressed, +-- then the circle will turn red, green, or blue, respectively. Otherwise, +-- the red and green channels of the circle pulsate +colorWire :: (HasTime t s, Monoid e) => Wire s e GameMonad a (GL.Color3 Float) +colorWire = + -- Key debounced means that it will only flash blue for one frame + (keyDebounced GLFW.Key'B >>> (pure $ GL.Color3 0 0 1)) <|> + + -- Key pressed means that it will remain this color + (keyPressed GLFW.Key'R >>> (pure $ GL.Color3 1 0 0)) <|> + (keyPressed GLFW.Key'G >>> (pure $ GL.Color3 0 1 0)) <|> + + -- Otherwise, pulsate based on the amount of time passed + (timeF >>> (arr (cos &&& sin)) >>> (arr $ \(x, y) -> GL.Color3 x y 1)) + +-- This wire simply takes a vertex position and color and renders according to the +-- passed in renderFn. In reality, this wire doesn't need to be a wire, and could just +-- be a monad to render, but this way we can render what we need without having to +-- go through the plumbing of our main game loop +renderWire :: RenderFn -> Wire s e GameMonad (GL.Vertex2 Float, GL.Color3 Float) () +renderWire rfn = mkGen_ $ \(pos, color) -> lift $ rfn pos color >> (return $ Right ()) + +-- Wire that behaves like the identity wire until Q is pressed, then inhibits forever. +-- We can compose our main gameWire with this wire to simply quit the program when q is pressed +quitWire :: Monoid e => Wire s e GameMonad a a +quitWire = (mkId &&& eventWire) >>> (rSwitch mkId) + where + eventWire :: Monoid e => Wire s e GameMonad a (Event (Wire s e m a a)) + eventWire = (keyPressed GLFW.Key'Q >>> pure mkEmpty >>> now) <|> never + +-- This is our main game wire, it feeds the position and color into the rendering loop +-- and finally quits if q is pressed. +gameWire :: (HasTime t s, Monoid e) => RenderFn -> Wire s e GameMonad a () +gameWire rfn = posWire &&& colorWire >>> (renderWire rfn) >>> quitWire + +run :: GLFW.Window -> GLFWInputControl -> IO () +run win ictl = do + -- initialize the input + ipt <- getInput ictl + + -- load vertex arrays and whatnot for the circle + circle <- mkCircle + + -- load the render function for getting rendering ready + renderFn <- mkRenderFunc + + -- run the game loop + runGame ipt (countSession_ (0.02 :: Double)) (gameWire $ renderFn circle) + + where + + -- The game loop takes the current input state, the time session and + -- our main game wire, and simply steps the wire until it inhibits. + runGame ipt sess w = do + + -- Before rendering clear the framebuffer + GL.clearColor GL.$= GL.Color4 0.0 0.0 0.0 1 + GL.clear [GL.ColorBuffer] + + -- Poll the current input + ipt' <- pollGLFW ipt ictl + + -- Figure out our next timestep + (timeState, sess') <- stepSession sess + + -- Since the GameMonad is a 'StateT GLFWInputState m', in order to + -- step the wires, we have to extract the value from our wire. That means + -- that when we runStateT, we will get the results of our wire and a new + -- state (for example if the wire debounced any keys). This is what we pass + -- back to GLFW. + -- renderPrg :: IO ((Either e (), Wire s e GameMonad a ()), GLFWInputState) + let renderPrg = runGLFWInputT (stepWire w timeState (Right undefined)) ipt' + + -- Now run the actual IO program to extract the values from it. + ((result, w'), ipt'') <- renderPrg + + -- End of frame cleanup + GL.flush + GLFW.swapBuffers win + + -- Our quit condition is if the OS asked us to quit, or the wire inhibits + -- (i.e. someone hit the Q key) + case result of + Left () -> return () + Right () -> do + q <- GLFW.windowShouldClose win + unless q $ runGame ipt'' sess' w' + +main :: IO () +main = do + -- Setup GLFW + _ <- GLFW.init + (Just m) <- GLFW.createWindow 400 400 "Netwire Input Demo" Nothing Nothing + GLFW.makeContextCurrent (Just m) + + -- Hack for retina displays + (szx, szy) <- GLFW.getFramebufferSize m + GL.viewport GL.$= (GL.Position 0 0, GL.Size (fromIntegral szx) (fromIntegral szy)) + + -- Run the scene + mkInputControl m >>= run m
lib/FRP/Netwire/Input/GLFW.hs view
@@ -1,7 +1,7 @@ {-| Module : FRP.Netwire.Input.GLFW Description : netwire-input instances for use with GLFW-Copyright : (c) Pavel Krajcevski, 2014+Copyright : (c) Pavel Krajcevski, 2017 License : MIT Maintainer : Krajcevski@gmail.com Stability : experimental@@ -15,6 +15,7 @@ -} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE UndecidableInstances #-} module FRP.Netwire.Input.GLFW ( -- * GLFW Input@@ -100,6 +101,14 @@ , MonadTrans ) +instance MonadState s m => MonadState s (GLFWInputT m) where+ get = lift get+ put = lift . put+ state = lift . state++-- | To execute a computation with the current input snapshot, we need to give+-- supply the current 'GLFWInputState'. This comes from the 'GLFWInputControl'+-- associated with the given window. runGLFWInputT :: GLFWInputT m a -> GLFWInputState -> m (a, GLFWInputState) runGLFWInputT (GLFWInputT m) = runStateT m @@ -108,7 +117,7 @@ type GLFWInput = GLFWInputT Identity runGLFWInput :: GLFWInput a -> GLFWInputState -> (a, GLFWInputState)-runGLFWInput m is = runIdentity (runGLFWInputT m is)+runGLFWInput m = runIdentity . runGLFWInputT m instance Monad m => MonadKeyboard GLFW.Key (GLFWInputT m) where
netwire-input-glfw.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: netwire-input-glfw-version: 0.0.6+version: 0.0.7 synopsis: GLFW instance of netwire-input description: This package contains the necessary glue to allow the use of wires from the netwire-input package. In general, the types@@ -14,7 +14,7 @@ license-file: LICENSE author: Pavel Krajcevski maintainer: Krajcevski@gmail.com-copyright: Pavel Krajcevski, 2014-2016+copyright: Pavel Krajcevski, 2014-2017 category: Game build-type: Simple extra-source-files: examples/Cursor.hs README.md@@ -51,15 +51,15 @@ -------------------------------------------------------------------------------- executable glfw-input-example- main-is: Cursor.hs- hs-source-dirs: examples- ghc-options: -Wall -rtsopts -O3+ main-is: Cursor.hs+ hs-source-dirs: examples+ ghc-options: -Wall -rtsopts -O3+ default-language: Haskell2010 - if flag(examples)- build-depends: base > 4.5,+ build-depends: base > 4.5, netwire >= 5, netwire-input,- netwire-input-glfw == 0.0.6,+ netwire-input-glfw, OpenGL, GLFW-b, transformers,@@ -69,5 +69,8 @@ containers, directory, filepath++ if flag(examples)+ buildable: True else buildable: False