module FRP.Netwire.Input.GLFW (
GLFWInput, runGLFWInput,
GLFWInputT, runGLFWInputT,
MonadGLFWInput(..),
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.Monad.RWS
import Control.Monad.State
import Control.Monad.Except
import Control.Monad.Cont
import Control.Monad.Identity
import GHC.Float hiding (clamp)
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
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)
instance Key GLFW.Key
instance MouseButton GLFW.MouseButton
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
class Monad m => MonadGLFWInput m where
getGLFWInput :: m GLFWInputState
putGLFWInput :: GLFWInputState -> m ()
instance Monad m => MonadGLFWInput (GLFWInputT m) where
getGLFWInput :: GLFWInputT m GLFWInputState
getGLFWInput = GLFWInputT get
putGLFWInput :: GLFWInputState -> GLFWInputT m ()
putGLFWInput = GLFWInputT . put
runGLFWInputT :: GLFWInputT m a -> GLFWInputState -> m (a, GLFWInputState)
runGLFWInputT (GLFWInputT m) = runStateT m
type GLFWInput = GLFWInputT Identity
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) }
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)
getInput :: GLFWInputControl -> IO GLFWInputState
getInput (IptCtl var _) = readTVarIO var
setInput :: GLFWInputControl -> GLFWInputState -> IO ()
setInput (IptCtl var win) ipt = do
curMode <- GLFW.getCursorInputMode win
let newMode = modeToGLFWMode (cmode ipt)
unless (newMode == curMode) $
GLFW.setCursorInputMode win newMode
atomically $ writeTVar var (ipt { scrollAmt = (0, 0) })
resetCursorPos :: GLFWInputState -> GLFWInputState
resetCursorPos input = input { cursorPos = (0, 0) }
resolveReleased :: GLFWInputState -> GLFWInputState
resolveReleased input = input {
keysPressed = Map.map (+1) $
foldl (flip Map.delete) (keysPressed input) (Set.elems $ keysReleased input),
keysReleased = Set.empty,
mbPressed = Map.map (+1) $
foldl (flip Map.delete) (mbPressed input) (Set.elems $ mbReleased input),
mbReleased = Set.empty
}
scrollCallback :: GLFWInputControl -> GLFW.Window -> Double -> Double -> IO ()
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
Just 0 -> Set.insert key (keysReleased input)
_ -> 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)})
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
pollGLFW :: GLFWInputState -> GLFWInputControl -> IO GLFWInputState
pollGLFW ipt iptctl@(IptCtl _ win) = do
let ipt' = resolveReleased ipt
if cmode ipt' == CursorMode'Reset
then do
setCursorToWindowCenter win
setInput iptctl (resetCursorPos ipt')
else setInput iptctl ipt'
GLFW.pollEvents
getInput iptctl