diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,5 +1,5 @@ -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 -[netwire-input](https://github.com/Mokosha/netwire-input) +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 +[netwire-input](https://github.com/Mokosha/netwire-input) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain 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,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 diff --git a/netwire-input-glfw.cabal b/netwire-input-glfw.cabal --- a/netwire-input-glfw.cabal +++ b/netwire-input-glfw.cabal @@ -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