netwire-input-glfw 0.0.10 → 0.0.11
raw patch · 5 files changed
+443/−437 lines, 5 filessetup-changed
Files
- LICENSE +20/−20
- README.md +5/−5
- Setup.hs +2/−2
- lib/FRP/Netwire/Input/GLFW.hs +344/−338
- 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
lib/FRP/Netwire/Input/GLFW.hs view
@@ -1,338 +1,344 @@-{-|-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,- 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--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) }--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)})---- | 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- 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.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.10-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.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