netwire-input-glfw 0.0.11 → 0.0.12
raw patch · 6 files changed
+446/−443 lines, 6 filessetup-changed
Files
- LICENSE +20/−20
- README.md +5/−5
- Setup.hs +2/−2
- examples/Cursor.hs +1/−0
- lib/FRP/Netwire/Input/GLFW.hs +346/−344
- netwire-input-glfw.cabal +72/−72
LICENSE view
@@ -1,20 +1,20 @@-Copyright (c) 2014 Pavel Krajcevski - -Permission is hereby granted, free of charge, to any person obtaining -a copy of this software and associated documentation files (the -"Software"), to deal in the Software without restriction, including -without limitation the rights to use, copy, modify, merge, publish, -distribute, sublicense, and/or sell copies of the Software, and to -permit persons to whom the Software is furnished to do so, subject to -the following conditions: - -The above copyright notice and this permission notice shall be included -in all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. -IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY -CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, -TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE -SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +Copyright (c) 2014 Pavel Krajcevski++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
README.md view
@@ -1,5 +1,5 @@-netwire-input-glfw [](https://travis-ci.org/Mokosha/netwire-input-glfw) -============ - -This library contains the necessary typeclasses to interface with -[netwire-input](https://github.com/Mokosha/netwire-input) +netwire-input-glfw [](https://travis-ci.org/Mokosha/netwire-input-glfw)+============++This library contains the necessary typeclasses to interface with+[netwire-input](https://github.com/Mokosha/netwire-input)
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
examples/Cursor.hs view
@@ -1,6 +1,7 @@ module Main where -------------------------------------------------------------------------------- +import Control.Monad (unless) import Control.Monad.State import Control.Wire hiding (unless)
lib/FRP/Netwire/Input/GLFW.hs view
@@ -1,344 +1,346 @@-{-| -Module : FRP.Netwire.Input.GLFW -Description : netwire-input instances for use with GLFW -Copyright : (c) Pavel Krajcevski, 2018 -License : MIT -Maintainer : Krajcevski@gmail.com -Stability : experimental -Portability : POSIX - -This module contains data types with instances needed to create wires -that can be used with the netwire-input combinators. In particular, this -package implements 'GLFWInputT' which has instances of 'MonadKeyboard' and -'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 - --------------------------------------------------------------------------------- -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Graphics.UI.GLFW as GLFW -import Control.Applicative -import Control.Concurrent.STM -import Control.DeepSeq -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 --------------------------------------------------------------------------------- - -clamp :: Ord a => a -> a -> a -> a -clamp x a b - | x < a = a - | x > b = b - | otherwise = x - -newRange :: Floating a => a -> (a, a) -> (a, a) -> a -newRange x (omin, omax) (nmin, nmax) = - nmin + (nmax - nmin) * ((x - omin) / (omax - omin)) - -newRangeC :: (Ord a, Floating a) => a -> (a, a) -> (a, a) -> a -newRangeC x o n@(nmin, nmax) = clamp (newRange x o n) nmin nmax - -modeToGLFWMode :: CursorMode -> GLFW.CursorInputMode -modeToGLFWMode CursorMode'Reset = GLFW.CursorInputMode'Disabled -modeToGLFWMode CursorMode'Disabled = GLFW.CursorInputMode'Disabled -modeToGLFWMode CursorMode'Hidden = GLFW.CursorInputMode'Hidden -modeToGLFWMode CursorMode'Enabled = GLFW.CursorInputMode'Normal - --- | The GLFW input state is a record that keeps track of which buttons and keys --- are currently pressed. Because GLFW works with callbacks, a call to pollEvents --- must be made in order to process any of the events. At this time, all of the --- 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 :: 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) -} deriving(Show, Generic) - -instance NFData GLFWInputState - -instance Key GLFW.Key -instance MouseButton GLFW.MouseButton - --- | The 'GLFWInputT' monad transformer is simply a state monad transformer using --- 'GLFWInputState' -newtype GLFWInputT m a = - GLFWInputT (StateT GLFWInputState m a) - deriving ( Functor - , Applicative - , Alternative - , Monad - , MonadFix - , MonadIO - , MonadWriter w - , MonadReader r - , MonadError e - , MonadPlus - , MonadCont - , 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 --- 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 = runIdentity . runGLFWInputT m - -instance MonadGLFWInput m => MonadKeyboard GLFW.Key m where - keyIsPressed :: GLFW.Key -> m Bool - keyIsPressed key = liftM (isKeyDown key) getGLFWInput - - releaseKey :: GLFW.Key -> m () - releaseKey key = getGLFWInput >>= (putGLFWInput . debounceKey key) - -instance MonadGLFWInput m => MonadMouse GLFW.MouseButton m where - mbIsPressed :: GLFW.MouseButton -> m Bool - mbIsPressed mb = liftM (isButtonPressed mb) getGLFWInput - - releaseButton :: GLFW.MouseButton -> m () - releaseButton mb = getGLFWInput >>= (putGLFWInput . debounceButton mb) - - cursor :: m (Float, Float) - cursor = liftM cursorPos getGLFWInput - - setCursorMode :: CursorMode -> m () - setCursorMode mode = do - ipt <- getGLFWInput - putGLFWInput (ipt { cmode = mode }) - - scroll :: m (Double, Double) - scroll = liftM scrollAmt getGLFWInput - -isKeyDown :: GLFW.Key -> GLFWInputState -> Bool -isKeyDown key = (Map.member key) . keysPressed - -withPressedKey :: GLFWInputState -> GLFW.Key -> (a -> a) -> a -> a -withPressedKey input key fn - | isKeyDown key input = fn - | otherwise = id - -debounceKey :: GLFW.Key -> GLFWInputState -> GLFWInputState -debounceKey key input = input { keysPressed = Map.delete key (keysPressed input) } - -isButtonPressed :: GLFW.MouseButton -> GLFWInputState -> Bool -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 = 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. -data GLFWInputControl = IptCtl (TVar GLFWInputState) GLFW.Window - -setCursorToWindowCenter :: GLFW.Window -> IO () -setCursorToWindowCenter win = do - (w, h) <- GLFW.getWindowSize win - GLFW.setCursorPos win (fromIntegral w / 2.0) (fromIntegral h / 2.0) - --- | Returns a current snapshot of the input -getInput :: GLFWInputControl -> IO GLFWInputState -getInput (IptCtl var _) = readTVarIO var - -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) - unless (newMode == curMode) $ - GLFW.setCursorInputMode win newMode - - -- Write the new input - atomically $ writeTVar var $!! (ipt { scrollAmt = (0, 0) }) - -resetCursorPos :: GLFWInputState -> GLFWInputState -resetCursorPos input = input { cursorPos = (0, 0) } - -resolveReleased :: GLFWInputState -> GLFWInputState -resolveReleased input = input { - keysPressed = - (+1) <$> - foldl (flip Map.delete) (keysPressed input) (Set.elems $ keysReleased input), - keysReleased = Set.empty, - 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 - 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 - where - modifyKeys :: GLFWInputState -> GLFWInputState - 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 - modify :: GLFWInputState -> GLFWInputState - 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 - let xf = newRangeC (double2Float x) (0, fromIntegral w) (-1, 1) - 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 (emptyGLFWState { cmode = CursorMode'Enabled }) - let ctl = IptCtl ctlvar win - GLFW.setScrollCallback win (Just $ scrollCallback ctl) - GLFW.setKeyCallback win (Just $ keyCallback ctl) - GLFW.setCursorPosCallback win (Just $ cursorPosCallback ctl) - GLFW.setMouseButtonCallback win (Just $ mouseButtonCallback ctl) - return ctl - --- | Allows GLFW to interact with the windowing system to update the current --- state. The old state must be passed in order to properly reset certain --- properties such as the scroll wheel. The returned input state is identical --- 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 - then do - setCursorToWindowCenter win - setInput iptctl (resetCursorPos ipt') - else setInput iptctl ipt' - - GLFW.pollEvents - getInput iptctl +{-|+Module : FRP.Netwire.Input.GLFW+Description : netwire-input instances for use with GLFW+Copyright : (c) Pavel Krajcevski, 2018+License : MIT+Maintainer : Krajcevski@gmail.com+Stability : experimental+Portability : POSIX++This module contains data types with instances needed to create wires+that can be used with the netwire-input combinators. In particular, this+package implements 'GLFWInputT' which has instances of 'MonadKeyboard' and+'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++--------------------------------------------------------------------------------+import qualified Data.Map as Map+import qualified Data.Set as Set+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+--------------------------------------------------------------------------------++clamp :: Ord a => a -> a -> a -> a+clamp x a b+ | x < a = a+ | x > b = b+ | otherwise = x++newRange :: Floating a => a -> (a, a) -> (a, a) -> a+newRange x (omin, omax) (nmin, nmax) =+ nmin + (nmax - nmin) * ((x - omin) / (omax - omin))++newRangeC :: (Ord a, Floating a) => a -> (a, a) -> (a, a) -> a+newRangeC x o n@(nmin, nmax) = clamp (newRange x o n) nmin nmax++modeToGLFWMode :: CursorMode -> GLFW.CursorInputMode+modeToGLFWMode CursorMode'Reset = GLFW.CursorInputMode'Disabled+modeToGLFWMode CursorMode'Disabled = GLFW.CursorInputMode'Disabled+modeToGLFWMode CursorMode'Hidden = GLFW.CursorInputMode'Hidden+modeToGLFWMode CursorMode'Enabled = GLFW.CursorInputMode'Normal++-- | The GLFW input state is a record that keeps track of which buttons and keys+-- are currently pressed. Because GLFW works with callbacks, a call to pollEvents+-- must be made in order to process any of the events. At this time, all of the+-- 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 :: 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)+} deriving(Show, Generic)++instance NFData GLFWInputState++instance Key GLFW.Key+instance MouseButton GLFW.MouseButton++-- | The 'GLFWInputT' monad transformer is simply a state monad transformer using+-- 'GLFWInputState'+newtype GLFWInputT m a =+ GLFWInputT (StateT GLFWInputState m a)+ deriving ( Functor+ , Applicative+ , Alternative+ , Monad+ , MonadFix+ , MonadIO+ , MonadWriter w+ , MonadReader r+ , MonadError e+ , MonadPlus+ , MonadCont+ , 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+-- 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 = runIdentity . runGLFWInputT m++instance MonadGLFWInput m => MonadKeyboard GLFW.Key m where+ keyIsPressed :: GLFW.Key -> m Bool+ keyIsPressed key = liftM (isKeyDown key) getGLFWInput++ releaseKey :: GLFW.Key -> m ()+ releaseKey key = getGLFWInput >>= (putGLFWInput . debounceKey key)++instance MonadGLFWInput m => MonadMouse GLFW.MouseButton m where+ mbIsPressed :: GLFW.MouseButton -> m Bool+ mbIsPressed mb = liftM (isButtonPressed mb) getGLFWInput++ releaseButton :: GLFW.MouseButton -> m ()+ releaseButton mb = getGLFWInput >>= (putGLFWInput . debounceButton mb)++ cursor :: m (Float, Float)+ cursor = liftM cursorPos getGLFWInput++ setCursorMode :: CursorMode -> m ()+ setCursorMode mode = do+ ipt <- getGLFWInput+ putGLFWInput (ipt { cmode = mode })++ scroll :: m (Double, Double)+ scroll = liftM scrollAmt getGLFWInput++isKeyDown :: GLFW.Key -> GLFWInputState -> Bool+isKeyDown key = (Map.member key) . keysPressed++withPressedKey :: GLFWInputState -> GLFW.Key -> (a -> a) -> a -> a+withPressedKey input key fn+ | isKeyDown key input = fn+ | otherwise = id++debounceKey :: GLFW.Key -> GLFWInputState -> GLFWInputState+debounceKey key input = input { keysPressed = Map.delete key (keysPressed input) }++isButtonPressed :: GLFW.MouseButton -> GLFWInputState -> Bool+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 = 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.+data GLFWInputControl = IptCtl (TVar GLFWInputState) GLFW.Window++setCursorToWindowCenter :: GLFW.Window -> IO ()+setCursorToWindowCenter win = do+ (w, h) <- GLFW.getWindowSize win+ GLFW.setCursorPos win (fromIntegral w / 2.0) (fromIntegral h / 2.0)++-- | Returns a current snapshot of the input+getInput :: GLFWInputControl -> IO GLFWInputState+getInput (IptCtl var _) = readTVarIO var++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)+ unless (newMode == curMode) $+ GLFW.setCursorInputMode win newMode++ -- Write the new input+ atomically $ writeTVar var $!! (ipt { scrollAmt = (0, 0) })++resetCursorPos :: GLFWInputState -> GLFWInputState+resetCursorPos input = input { cursorPos = (0, 0) }++resolveReleased :: GLFWInputState -> GLFWInputState+resolveReleased input = input {+ keysPressed =+ (+1) <$>+ foldl (flip Map.delete) (keysPressed input) (Set.elems $ keysReleased input),+ keysReleased = Set.empty,+ 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+ 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+ where+ modifyKeys :: GLFWInputState -> GLFWInputState+ 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+ modify :: GLFWInputState -> GLFWInputState+ 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+ let xf = newRangeC (double2Float x) (0, fromIntegral w) (-1, 1)+ 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 (emptyGLFWState { cmode = CursorMode'Enabled })+ let ctl = IptCtl ctlvar win+ GLFW.setScrollCallback win (Just $ scrollCallback ctl)+ GLFW.setKeyCallback win (Just $ keyCallback ctl)+ GLFW.setCursorPosCallback win (Just $ cursorPosCallback ctl)+ GLFW.setMouseButtonCallback win (Just $ mouseButtonCallback ctl)+ return ctl++-- | Allows GLFW to interact with the windowing system to update the current+-- state. The old state must be passed in order to properly reset certain+-- properties such as the scroll wheel. The returned input state is identical+-- 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+ then do+ setCursorToWindowCenter win+ setInput iptctl (resetCursorPos ipt')+ else setInput iptctl ipt'++ GLFW.pollEvents+ getInput iptctl
netwire-input-glfw.cabal view
@@ -1,72 +1,72 @@--- Initial netwire-input-glfw.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: netwire-input-glfw -version: 0.0.11 -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. -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-2018 -category: Game -build-type: Simple -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 - -library - exposed-modules: FRP.Netwire.Input.GLFW - 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 - --------------------------------------------------------------------------------- --- --- Examples --- --------------------------------------------------------------------------------- - -executable glfw-input-example - main-is: Cursor.hs - hs-source-dirs: examples - ghc-options: -Wall -rtsopts -O3 - default-language: Haskell2010 - - build-depends: base > 4.5, - netwire >= 5, - netwire-input, - netwire-input-glfw, - OpenGL, - GLFW-b, - transformers, - array, - bytestring, - mtl, - containers, - directory, - filepath - - if flag(examples) - buildable: True - else - buildable: False +-- Initial netwire-input-glfw.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: netwire-input-glfw+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.+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-2018+category: Game+build-type: Simple+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++library+ exposed-modules: FRP.Netwire.Input.GLFW+ 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++--------------------------------------------------------------------------------+--+-- Examples+--+--------------------------------------------------------------------------------++executable glfw-input-example+ main-is: Cursor.hs+ hs-source-dirs: examples+ ghc-options: -Wall -rtsopts -O3+ default-language: Haskell2010++ build-depends: base > 4.5,+ netwire >= 5,+ netwire-input,+ netwire-input-glfw,+ OpenGL,+ GLFW-b,+ transformers,+ array,+ bytestring,+ mtl,+ containers,+ directory,+ filepath++ if flag(examples)+ buildable: True+ else+ buildable: False