diff --git a/examples/Cursor.hs b/examples/Cursor.hs --- a/examples/Cursor.hs +++ b/examples/Cursor.hs @@ -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 diff --git a/lib/FRP/Netwire/Input/GLFW.hs b/lib/FRP/Netwire/Input/GLFW.hs --- a/lib/FRP/Netwire/Input/GLFW.hs +++ b/lib/FRP/Netwire/Input/GLFW.hs @@ -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) diff --git a/netwire-input-glfw.cabal b/netwire-input-glfw.cabal --- a/netwire-input-glfw.cabal +++ b/netwire-input-glfw.cabal @@ -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