netwire-input-glfw 0.0.6 → 0.0.12
raw patch · 3 files changed
Files
- examples/Cursor.hs +233/−232
- lib/FRP/Netwire/Input/GLFW.hs +93/−43
- netwire-input-glfw.cabal +22/−23
examples/Cursor.hs view
@@ -1,232 +1,233 @@-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 (unless) +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 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 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 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, 2018 License : MIT Maintainer : Krajcevski@gmail.com Stability : experimental@@ -13,19 +13,28 @@ 'MonadMouse' -}-+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE UndecidableInstances #-} module FRP.Netwire.Input.GLFW ( -- * GLFW Input -- ** Basic Input Monad GLFWInput, runGLFWInput,+ -- ** Monad Transformer GLFWInputT, runGLFWInputT, + -- * Typeclass+ MonadGLFWInput(..),+ -- * State Types GLFWInputControl, GLFWInputState,+ emptyGLFWState, getInput, mkInputControl, pollGLFW ) where @@ -35,12 +44,16 @@ import qualified Graphics.UI.GLFW as GLFW import Control.Applicative import Control.Concurrent.STM+import Control.DeepSeq+import Control.Monad+import Control.Monad.Fix import Control.Monad.RWS import Control.Monad.State import Control.Monad.Except import Control.Monad.Cont import Control.Monad.Identity import GHC.Float hiding (clamp)+import GHC.Generics import FRP.Netwire.Input --------------------------------------------------------------------------------@@ -77,8 +90,10 @@ cursorPos :: (Float, Float), cmode :: CursorMode, scrollAmt :: (Double, Double)-} deriving(Show)+} deriving(Show, Generic) +instance NFData GLFWInputState+ instance Key GLFW.Key instance MouseButton GLFW.MouseButton @@ -100,51 +115,69 @@ , MonadTrans ) +instance MonadState s m => MonadState s (GLFWInputT m) where+ get = lift get+ put = lift . put+ state = lift . state++-- | Describes a monad that provides stateful access to a 'GLFWInputState'. By+-- being able to modify the state, the context that satisfies this typeclass+-- can decide to debounce or "take ownership" of the button presses at a+-- specific point of the computation. This should be done via the 'MonadKey' and+-- 'MonadMouse' instances.+class Monad m => MonadGLFWInput m where+ -- | Retrieves the current input state+ getGLFWInput :: m GLFWInputState+ -- | Places a modified input state back into the context. This should probably+ -- not be called directly.+ putGLFWInput :: GLFWInputState -> m ()++instance Monad m => MonadGLFWInput (GLFWInputT m) where+ getGLFWInput :: GLFWInputT m GLFWInputState+ getGLFWInput = GLFWInputT get++ putGLFWInput :: GLFWInputState -> GLFWInputT m ()+ putGLFWInput = GLFWInputT . put++-- | 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 --- | The 'GLFWInput' monad is simply the GLFWInputT transformer around the+-- | The 'GLFWInput' monad is simply the 'GLFWInputT' transformer around the -- identity monad. type GLFWInput = GLFWInputT Identity +-- | Runs the 'GLFWInput' computation with a current input snapshot and returns+-- the potentially modified input. runGLFWInput :: GLFWInput a -> GLFWInputState -> (a, GLFWInputState)-runGLFWInput m is = runIdentity (runGLFWInputT m is)--instance Monad m => MonadKeyboard GLFW.Key (GLFWInputT m) where-- keyIsPressed :: GLFW.Key -> GLFWInputT m Bool- keyIsPressed key = GLFWInputT . liftM (isKeyDown key) $ get+runGLFWInput m = runIdentity . runGLFWInputT m - releaseKey :: GLFW.Key -> GLFWInputT m ()- releaseKey key = GLFWInputT (get >>= (put . debounceKey key))+instance MonadGLFWInput m => MonadKeyboard GLFW.Key m where+ keyIsPressed :: GLFW.Key -> m Bool+ keyIsPressed key = liftM (isKeyDown key) getGLFWInput -instance Monad m => MonadMouse GLFW.MouseButton (GLFWInputT m) where+ releaseKey :: GLFW.Key -> m ()+ releaseKey key = getGLFWInput >>= (putGLFWInput . debounceKey key) - mbIsPressed :: GLFW.MouseButton -> GLFWInputT m Bool- mbIsPressed mb = GLFWInputT . liftM (isButtonPressed mb) $ get+instance MonadGLFWInput m => MonadMouse GLFW.MouseButton m where+ mbIsPressed :: GLFW.MouseButton -> m Bool+ mbIsPressed mb = liftM (isButtonPressed mb) getGLFWInput - releaseButton :: GLFW.MouseButton -> GLFWInputT m ()- releaseButton mb = GLFWInputT (get >>= (put . debounceButton mb))+ releaseButton :: GLFW.MouseButton -> m ()+ releaseButton mb = getGLFWInput >>= (putGLFWInput . debounceButton mb) - cursor :: GLFWInputT m (Float, Float)- cursor = GLFWInputT . liftM cursorPos $ get+ cursor :: m (Float, Float)+ cursor = liftM cursorPos getGLFWInput - setCursorMode :: CursorMode -> GLFWInputT m ()+ setCursorMode :: CursorMode -> m () setCursorMode mode = do- ipt <- GLFWInputT get- GLFWInputT $ put (ipt { cmode = mode })-- scroll :: GLFWInputT m (Double, Double)- scroll = GLFWInputT . liftM scrollAmt $ get+ ipt <- getGLFWInput+ putGLFWInput (ipt { cmode = mode }) -kEmptyInput :: GLFWInputState-kEmptyInput = GLFWInputState { keysPressed = Map.empty,- keysReleased = Set.empty,- mbPressed = Map.empty,- mbReleased = Set.empty,- cursorPos = (0, 0),- cmode = CursorMode'Enabled,- scrollAmt = (0, 0) }+ scroll :: m (Double, Double)+ scroll = liftM scrollAmt getGLFWInput isKeyDown :: GLFW.Key -> GLFWInputState -> Bool isKeyDown key = (Map.member key) . keysPressed@@ -181,7 +214,6 @@ setInput :: GLFWInputControl -> GLFWInputState -> IO () setInput (IptCtl var win) ipt = do- -- Do we need to change the cursor mode? curMode <- GLFW.getCursorInputMode win let newMode = modeToGLFWMode (cmode ipt)@@ -189,32 +221,36 @@ GLFW.setCursorInputMode win newMode -- Write the new input- atomically $ writeTVar var (ipt { scrollAmt = (0, 0) })+ atomically $ writeTVar var $!! (ipt { scrollAmt = (0, 0) }) resetCursorPos :: GLFWInputState -> GLFWInputState resetCursorPos input = input { cursorPos = (0, 0) } resolveReleased :: GLFWInputState -> GLFWInputState resolveReleased input = input {- keysPressed = Map.map (+1) $- foldl (flip Map.delete) (keysPressed input) (Set.elems $ keysReleased input),+ keysPressed =+ (+1) <$>+ foldl (flip Map.delete) (keysPressed input) (Set.elems $ keysReleased input), keysReleased = Set.empty,- mbPressed = Map.map (+1) $- foldl (flip Map.delete) (mbPressed input) (Set.elems $ mbReleased input),+ mbPressed =+ (+1) <$>+ foldl (flip Map.delete) (mbPressed input) (Set.elems $ mbReleased input), mbReleased = Set.empty } -------------------------- scrollCallback :: GLFWInputControl -> GLFW.Window -> Double -> Double -> IO ()-scrollCallback (IptCtl ctl _) _ xoff yoff = atomically $ modifyTVar' ctl updateScroll+scrollCallback (IptCtl ctl _) _ xoff yoff =+ atomically $ modifyTVar' ctl updateScroll where updateScroll :: GLFWInputState -> GLFWInputState updateScroll = (\input -> input { scrollAmt = (xoff, yoff) }) keyCallback :: GLFWInputControl -> GLFW.Window -> GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO ()-keyCallback (IptCtl ctl _) _ key _ keystate _ = atomically $ modifyTVar' ctl modifyKeys+keyCallback (IptCtl ctl _) _ key _ keystate _ =+ atomically $ modifyTVar' ctl modifyKeys where modifyKeys :: GLFWInputState -> GLFWInputState modifyKeys input = case keystate of@@ -265,11 +301,25 @@ yf = newRangeC (double2Float y) (0, fromIntegral h) (-1, 1) atomically $ modifyTVar' ctl (\ipt -> ipt { cursorPos = (xf, yf)}) +-- | Returns the empty GLFW state. In this state, no buttons are pressed, and+-- the mouse and scroll positions are set to zero. The cursor is also placed in+-- the disabled state.+emptyGLFWState :: GLFWInputState+emptyGLFWState = GLFWInputState+ { keysPressed = Map.empty+ , keysReleased = Set.empty+ , mbPressed = Map.empty+ , mbReleased = Set.empty+ , cursorPos = (0, 0)+ , cmode = CursorMode'Disabled+ , scrollAmt = (0, 0)+ }+ -- | Creates and returns an 'STM' variable for the window that holds all of the -- most recent input state information mkInputControl :: GLFW.Window -> IO GLFWInputControl mkInputControl win = do- ctlvar <- newTVarIO kEmptyInput+ ctlvar <- newTVarIO (emptyGLFWState { cmode = CursorMode'Enabled }) let ctl = IptCtl ctlvar win GLFW.setScrollCallback win (Just $ scrollCallback ctl) GLFW.setKeyCallback win (Just $ keyCallback ctl)
netwire-input-glfw.cabal view
@@ -2,19 +2,19 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: netwire-input-glfw-version: 0.0.6+version: 0.0.12 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- associated here should be used only sparingly to plumb the input- state through your netwire program. Otherwise, the state should- not be modified directly.+ of wires from the netwire-input package. In general, the+ types associated here should be used only sparingly to+ plumb the input state through your netwire program.+ Otherwise, the state should not be modified directly. homepage: https://www.github.com/Mokosha/netwire-input-glfw license: MIT license-file: LICENSE author: Pavel Krajcevski maintainer: Krajcevski@gmail.com-copyright: Pavel Krajcevski, 2014-2016+copyright: Pavel Krajcevski, 2014-2018 category: Game build-type: Simple extra-source-files: examples/Cursor.hs README.md@@ -29,18 +29,14 @@ location: https://github.com/Mokosha/netwire-input-glfw library- default-extensions: FlexibleInstances,- TypeSynonymInstances,- MultiParamTypeClasses,- InstanceSigs exposed-modules: FRP.Netwire.Input.GLFW- -- other-modules: - build-depends: base >= 4.6 && < 6,- netwire-input,- containers,- GLFW-b,- stm,- mtl+ build-depends: base >= 4.6 && < 6+ , netwire-input >= 0.0.7+ , containers+ , deepseq+ , GLFW-b >= 1.4.8.2+ , stm+ , mtl hs-source-dirs: lib default-language: Haskell2010 @@ -51,15 +47,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 +65,8 @@ containers, directory, filepath++ if flag(examples)+ buildable: True else buildable: False