module Graphics.UI.GLUT.Input (
Key(..), KeyEvent(..), KeyBinder, InputHandler, StillDownHandler, initGLUTInput
) where
import Data.IORef(IORef, newIORef, readIORef, modifyIORef)
import Data.List(deleteBy)
import Graphics.UI.GLUT
data KeyEvent = Press | StillDown | Release deriving Eq
type KeyTable = IORef [(Key, Modifiers, Position)]
newKeyTable :: IO KeyTable
newKeyTable = newIORef []
getKeys :: KeyTable -> IO [(Key, Modifiers, Position)]
getKeys = readIORef
insertIntoKeyTable :: KeyTable -> Key -> Modifiers -> Position -> IO ()
insertIntoKeyTable keyTab key mods pos = modifyIORef keyTab ((key,mods,pos):)
deleteFromKeyTable :: KeyTable -> Key -> IO ()
deleteFromKeyTable keyTab key = modifyIORef keyTab (deleteBy (\(k,_,_) (l,_,_) -> k==l) (key, nullmods, nullpos))
where nullmods = Modifiers Up Up Up
nullpos = Position 0 0
type InputHandler = Modifiers -> Position -> IO ()
type KeyBinder = Key -> KeyEvent -> Maybe InputHandler -> IO ()
type BindingTable = IORef [((Key,KeyEvent), InputHandler)]
newBindingTable :: IO BindingTable
newBindingTable = newIORef []
bindKey :: BindingTable -> KeyBinder
bindKey bindingTable key event Nothing =
modifyIORef bindingTable (\t -> [ e | e@(b,a) <- t, b /= (key, event)])
bindKey bindingTable key event (Just action) = do
bindKey bindingTable key event Nothing
modifyIORef bindingTable (((key, event), action) :)
execAction :: BindingTable -> Key -> KeyEvent -> Modifiers -> Position -> IO ()
execAction bindingTable key event mods pos =
readIORef bindingTable >>= (maybe (return ()) (\a -> a mods pos) . lookup (key, event))
type StillDownHandler = IO ()
stillDown :: BindingTable -> KeyTable -> StillDownHandler
stillDown bindingTable pressedKeys =
getKeys pressedKeys >>= mapM_ (\(k,mods,pos) -> execAction bindingTable k StillDown mods pos)
initGLUTInput :: IO (KeyBinder, StillDownHandler)
initGLUTInput = do
globalKeyRepeat $= GlobalKeyRepeatOff
bindingTable <- newBindingTable
pressedKeys <- newKeyTable
let keyPress k mods pos = do
insertIntoKeyTable pressedKeys k mods pos
execAction bindingTable k Press mods pos
keyRelease k mods pos = do
deleteFromKeyTable pressedKeys k
execAction bindingTable k Release mods pos
keyboardMouse k Down mods pos = keyPress k mods pos
keyboardMouse k Up mods pos = keyRelease k mods pos
keyboardMouseCallback $= Just keyboardMouse
return (bindKey bindingTable, stillDown bindingTable pressedKeys)