{-
   GLUT-based keyboard/mouse handling
   Sven Panne 2000.   mailto:Sven.Panne@informatik.uni-muenchen.de
   obs.: the keyMouse and related events were a bit modified by Andre W B Furtado 2002 (mailto: awbf@cin.ufpe.br)
-}

module UserInput (
   Key(KeyNormal,KeySpecial,KeyMouse), KeyEvent(..), KeyBinder, StillDownHandler, initUserInput,
   MouseRegion(..), Orientation(..)
) where

import IOExts(IORef, newIORef, readIORef, modifyIORef)
import List(delete)
import GLUT

---------------------------------------------------------------------------

data Key
   = KeyNormal Char
   | KeySpecial SpecialKey
   | KeyMouse MouseButton MouseRegion
   | KeyMouseAux MouseButton WindowPosition -- not exported, internal use only!
   deriving Eq

data MouseRegion
        = Point Int Int						  -- point (x,y)
        | RectangleArea (Int,Int) (Int,Int) Orientation		  -- top left corner / bottom right corner / orientation
        | CircleArea (Int,Int) Float Orientation		  -- circle centre / radius / orientation
        | PolygonArea [(Int,Int)] Orientation			  -- point list (CCW order!) / orientation
        | Anywhere						  -- always matches
        deriving Eq

data Orientation
        = Inside
        | Outside
        deriving Eq

data KeyEvent = Press | StillDown | Release   deriving Eq

---------------------------------------------------------------------------

type KeyTable = IORef [Key]

newKeyTable :: IO KeyTable
newKeyTable = newIORef []

getKeys :: KeyTable -> IO [Key]
getKeys = readIORef

insertIntoKeyTable :: KeyTable -> Key -> IO ()
insertIntoKeyTable keyTab key = modifyIORef keyTab (key:)

deleteFromKeyTable :: KeyTable -> Key -> IO ()
deleteFromKeyTable keyTab key = modifyIORef keyTab (delete key)

---------------------------------------------------------------------------

type KeyBinder = Key -> KeyEvent -> Maybe (IO ()) -> IO ()

-- TODO: Improve type
type BindingTable = IORef [((Key,KeyEvent), IO ())]

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 -> IO ()
execAction bindingTable (KeyMouseAux button wp) event =
   readIORef bindingTable >>= lookupMouse (button, wp, event)
execAction bindingTable key event =
   readIORef bindingTable >>= (maybe (return ()) id . lookup (key, event))

lookupMouse :: (MouseButton,WindowPosition,KeyEvent) -> [((Key,KeyEvent), IO ())] -> IO()
lookupMouse _ [] = return ()
lookupMouse (button,wp,event) ((((KeyMouse mouseButton mouseRegion), mouseEvent),action):inputs)
        | (button == mouseButton && event == mouseEvent && wp `match` mouseRegion) = action >> lookupMouse (button,wp,event) inputs
        | otherwise = lookupMouse (button,wp,event) inputs
lookupMouse mouseInput (_:inputs) = lookupMouse mouseInput inputs

match :: WindowPosition -> MouseRegion -> Bool
match (WindowPosition x y) (Point pX pY) = (x == pX) && (y == pY)
match (WindowPosition x y) (RectangleArea (x1,y1) (x2,y2) Inside)  = (x >= x1) && (x <= x2) && (y >= y1) && (y <= y2)
match (WindowPosition x y) (RectangleArea (x1,y1) (x2,y2) Outside) = (x  < x1) || (x  > x2) || (y  < y1) || (y  > y2)
match (WindowPosition x y) (CircleArea (cX,cY) radius Inside) = fromIntegral (dX*dX + dY*dY) <= radius * radius
                                                                 where dX = (cX - x)
                                                                       dY = (cY - y)
match (WindowPosition x y) (CircleArea (cX,cY) radius Outside) = fromIntegral (dX*dX + dY*dY) > radius * radius
                                                                  where dX = (cX - x)
                                                                        dY = (cY - y)
match (WindowPosition x y) (PolygonArea pointList Inside) = pnpoly ((last pointList):pointList) x y
match (WindowPosition x y) (PolygonArea pointList Outside) = not $ pnpoly ((last pointList):pointList) x y
match _ Anywhere = True

-- checks if a point is inside a polygon
pnpoly :: [(Int,Int)] -> Int -> Int -> Bool
pnpoly [] _ _ = error "UserInput.pnpoly error: the impossible has happened!"
pnpoly (_:[]) _ _ = True
pnpoly ((x0,y0):(x1,y1):ps) x y = ((y - y0)*(x1 - x0) - (x - x0)*(y1 - y0) >= 0) && pnpoly ((x1,y1):ps) x y

---------------------------------------------------------------------------

type StillDownHandler = IO ()

stillDown :: BindingTable -> KeyTable -> StillDownHandler
stillDown bindingTable pressedKeys =
   getKeys pressedKeys >>= mapM_ (\k -> execAction bindingTable k StillDown)

---------------------------------------------------------------------------

initUserInput :: IO (KeyBinder, StillDownHandler)
initUserInput = do
   -- Using "setKeyRepeat KeyRepeatOff" would be a little bit more
   -- efficient, but has two disadvantages: It is not yet implemented
   -- for M$ and it changes the global state of X11.
   ignoreKeyRepeat True

   bindingTable <- newBindingTable
   pressedKeys  <- newKeyTable
   let keyPress   k = do insertIntoKeyTable pressedKeys k
                         execAction bindingTable k Press
       keyRelease k = do deleteFromKeyTable pressedKeys k
                         execAction bindingTable k Release

   keyboardFunc      (Just (\k _ -> keyPress   (KeyNormal  k)))
   keyboardUpFunc    (Just (\k _ -> keyRelease (KeyNormal  k)))
   specialFunc       (Just (\k _ -> keyPress   (KeySpecial k)))
   specialUpFunc     (Just (\k _ -> keyRelease (KeySpecial k)))
   mouseFunc         (Just (\k ud wp -> case ud of
                            Down -> keyPress   (KeyMouseAux   k wp)
                            Up   -> keyRelease (KeyMouseAux   k wp)))

   return (bindKey bindingTable, stillDown bindingTable pressedKeys)