diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -netwire-input-glfw +netwire-input-glfw [![Build Status](https://travis-ci.org/Mokosha/netwire-input-glfw.svg?branch=master)](https://travis-ci.org/Mokosha/netwire-input-glfw) ============ This library contains the necessary typeclasses to interface with diff --git a/examples/Cursor.hs b/examples/Cursor.hs --- a/examples/Cursor.hs +++ b/examples/Cursor.hs @@ -134,13 +134,13 @@ -- 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)) <|> - -- Key debounced means that it will only flash blue for one frame - (keyDebounced GLFW.Key'B >>> (pure $ GL.Color3 0 0 1)) <|> - -- Otherwise, pulsate based on the amount of time passed (timeF >>> (arr (cos &&& sin)) >>> (arr $ \(x, y) -> GL.Color3 x y 1)) @@ -177,6 +177,7 @@ -- 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 @@ -228,4 +229,4 @@ GL.viewport GL.$= (GL.Position 0 0, GL.Size (fromIntegral szx) (fromIntegral szy)) -- Run the scene - run m =<< (mkInputControl m) + 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 @@ -28,6 +28,7 @@ ) where -------------------------------------------------------------------------------- +import qualified Data.Map as Map import qualified Data.Set as Set import qualified Graphics.UI.GLFW as GLFW import Control.Applicative @@ -60,8 +61,10 @@ -- appropriate callbacks are fired in order of the events received, and this record -- is updated to reflect the most recent input state. data GLFWInputState = GLFWInputState { - keysPressed :: Set.Set GLFW.Key, - mbPressed :: Set.Set GLFW.MouseButton, + keysPressed :: Map.Map GLFW.Key Int, + keysReleased :: Set.Set GLFW.Key, + mbPressed :: Map.Map GLFW.MouseButton Int, + mbReleased :: Set.Set GLFW.MouseButton, cursorPos :: (Float, Float), cmode :: CursorMode, scrollAmt :: (Double, Double) @@ -109,29 +112,31 @@ scroll = get >>= (return . scrollAmt) kEmptyInput :: GLFWInputState -kEmptyInput = GLFWInputState { keysPressed = Set.empty, - mbPressed = Set.empty, +kEmptyInput = GLFWInputState { keysPressed = Map.empty, + keysReleased = Set.empty, + mbPressed = Map.empty, + mbReleased = Set.empty, cursorPos = (0, 0), cmode = CursorMode'Enabled, scrollAmt = (0, 0) } isKeyPressed :: GLFW.Key -> GLFWInputState -> Bool -isKeyPressed key = (Set.member key) . keysPressed +isKeyPressed key = (Map.member key) . keysPressed withPressedKey :: GLFWInputState -> GLFW.Key -> (a -> a) -> a -> a withPressedKey input key fn = if isKeyPressed key input then fn else id debounceKey :: GLFW.Key -> GLFWInputState -> GLFWInputState -debounceKey key = (\input -> input { keysPressed = Set.delete key (keysPressed input) }) +debounceKey key input = input { keysPressed = Map.delete key (keysPressed input) } isButtonPressed :: GLFW.MouseButton -> GLFWInputState -> Bool -isButtonPressed mb = (Set.member mb) . mbPressed +isButtonPressed mb = (Map.member mb) . mbPressed withPressedButton :: GLFWInputState -> GLFW.MouseButton -> (a -> a) -> a -> a withPressedButton input mb fn = if isButtonPressed mb input then fn else id debounceButton :: GLFW.MouseButton -> GLFWInputState -> GLFWInputState -debounceButton mb = (\input -> input { mbPressed = Set.delete mb (mbPressed input) }) +debounceButton mb input = input { mbPressed = Map.delete mb (mbPressed input) } -- | This is an 'STM' variable that holds the current input state. It cannot be -- manipulated directly, but it is updated by GLFW each time 'pollGLFW' is called. @@ -143,7 +148,7 @@ GLFW.setCursorPos win (fromIntegral w / 2.0) (fromIntegral h / 2.0) -- | Returns a current snapshot of the input -getInput :: GLFWInputControl -> IO(GLFWInputState) +getInput :: GLFWInputControl -> IO (GLFWInputState) getInput (IptCtl var _) = readTVarIO var setInput :: GLFWInputControl -> GLFWInputState -> IO () @@ -160,8 +165,18 @@ atomically $ writeTVar var (ipt { scrollAmt = (0, 0) }) resetCursorPos :: GLFWInputState -> GLFWInputState -resetCursorPos = (\input -> input { cursorPos = (0, 0) }) +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), + keysReleased = Set.empty, + mbPressed = Map.map (+1) $ + foldl (flip Map.delete) (mbPressed input) (Set.elems $ mbReleased input), + mbReleased = Set.empty + } + -------------------------- scrollCallback :: GLFWInputControl -> GLFW.Window -> Double -> Double -> IO () @@ -174,30 +189,48 @@ GLFW.Key -> Int -> GLFW.KeyState -> GLFW.ModifierKeys -> IO () keyCallback (IptCtl ctl _) _ key _ keystate _ = atomically $ modifyTVar' ctl modifyKeys where - updateKeys :: (Set.Set GLFW.Key -> Set.Set GLFW.Key) -> GLFWInputState -> GLFWInputState - updateKeys fn = (\input -> input { keysPressed = fn (keysPressed input) }) - modifyKeys :: GLFWInputState -> GLFWInputState - modifyKeys = case keystate of - GLFW.KeyState'Pressed -> updateKeys $ Set.insert key - GLFW.KeyState'Released -> updateKeys $ Set.delete key - _ -> id + modifyKeys input = case keystate of + GLFW.KeyState'Pressed -> input { + keysPressed = Map.union (keysPressed input) (Map.singleton key 0) } + GLFW.KeyState'Released -> input { + keysPressed = Map.update removeReleased key (keysPressed input), + keysReleased = + case (Map.lookup key (keysPressed input)) of + -- If the key was just added... queue it up + Just 0 -> Set.insert key (keysReleased input) + -- If the key isn't pressed then it must have been debounced... do nothing + -- If the key wasn't just added we're removing it above... do nothing... + _ -> keysReleased input + } + _ -> input + removeReleased :: Int -> Maybe Int + removeReleased 0 = Just 0 + removeReleased _ = Nothing + mouseButtonCallback :: GLFWInputControl -> GLFW.Window -> GLFW.MouseButton -> GLFW.MouseButtonState -> GLFW.ModifierKeys -> IO () mouseButtonCallback (IptCtl ctl _) _ button state _ = atomically $ modifyTVar' ctl modify where - update :: (Set.Set GLFW.MouseButton -> Set.Set GLFW.MouseButton) -> - GLFWInputState -> GLFWInputState - update fn = (\ipt -> ipt { mbPressed = fn (mbPressed ipt) }) - modify :: GLFWInputState -> GLFWInputState - modify = case state of - GLFW.MouseButtonState'Pressed -> update $ Set.insert button - GLFW.MouseButtonState'Released -> update $ Set.delete button + modify input = case state of + GLFW.MouseButtonState'Pressed -> input { + mbPressed = Map.union (mbPressed input) (Map.singleton button 0) } + GLFW.MouseButtonState'Released -> input { + mbPressed = Map.update removeReleased button (mbPressed input), + mbReleased = + case Map.lookup button (mbPressed input) of + Just 0 -> Set.insert button (mbReleased input) + _ -> mbReleased input + } + removeReleased :: Int -> Maybe Int + removeReleased 0 = Just 0 + removeReleased _ = Nothing + cursorPosCallback :: GLFWInputControl -> GLFW.Window -> Double -> Double -> IO () cursorPosCallback (IptCtl ctl _) win x y = do (w, h) <- GLFW.getWindowSize win @@ -223,12 +256,14 @@ -- to a subsequent call to 'getInput' right after a call to 'GLFW.pollEvents' pollGLFW :: GLFWInputState -> GLFWInputControl -> IO (GLFWInputState) pollGLFW ipt iptctl@(IptCtl _ win) = do + let ipt' = resolveReleased ipt + -- Do we need to reset the cursor? - if (cmode ipt) == CursorMode'Reset + if (cmode ipt') == CursorMode'Reset then do setCursorToWindowCenter win - setInput iptctl (resetCursorPos ipt) - else setInput iptctl ipt + setInput iptctl (resetCursorPos ipt') + else setInput iptctl ipt' GLFW.pollEvents getInput iptctl diff --git a/netwire-input-glfw.cabal b/netwire-input-glfw.cabal --- a/netwire-input-glfw.cabal +++ b/netwire-input-glfw.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: netwire-input-glfw -version: 0.0.2 +version: 0.0.3 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 @@ -20,6 +20,10 @@ extra-source-files: examples/Cursor.hs README.md cabal-version: >=1.10 +flag examples + description: Build examples + default: False + source-repository head type: git location: https://github.com/Mokosha/netwire-input-glfw @@ -39,3 +43,31 @@ mtl hs-source-dirs: lib default-language: Haskell2010 + +-------------------------------------------------------------------------------- +-- +-- Examples +-- +-------------------------------------------------------------------------------- + +executable glfw-input-example + main-is: Cursor.hs + hs-source-dirs: examples + ghc-options: -Wall -rtsopts -O3 + + if flag(examples) + build-depends: base > 4.5, + netwire >= 5, + netwire-input, + netwire-input-glfw, + OpenGL, + GLFW-b, + transformers, + array, + bytestring, + mtl, + containers, + directory, + filepath + else + buildable: False