{-# OPTIONS_HADDOCK hide #-}
module Graphics.Gloss.Internals.Interface.Backend.GLUT
        (GLUTState,glutStateInit,initializeGLUT)
where

import Data.IORef
import Control.Monad
import Control.Concurrent
import Graphics.UI.GLUT                           (get,($=))
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.UI.GLUT               as GLUT
import qualified System.Exit                    as System
import Graphics.Gloss.Internals.Interface.Backend.Types
import System.IO.Unsafe

-- Were we to support freeglut only, we could use GLUT.get to discover
-- whether we are initialized or not. If not, we do a quick initialize,
-- get the screenzie, and then do GLUT.exit. This avoids the use of
-- global variables. Unfortunately, there is no failsafe way to check
-- whether glut is initialized in some older versions of glut, which is
-- what we'd use instead of the global variable to get the required info.
glutInitialized :: IORef Bool
{-# NOINLINE glutInitialized #-}
glutInitialized :: IORef Bool
glutInitialized = IO (IORef Bool) -> IORef Bool
forall a. IO a -> a
unsafePerformIO (IO (IORef Bool) -> IORef Bool) -> IO (IORef Bool) -> IORef Bool
forall a b. (a -> b) -> a -> b
$ do Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False

-- | State information for the GLUT backend.
data GLUTState
        = GLUTState
        { -- Count of total number of frames that we have drawn.
          GLUTState -> Int
glutStateFrameCount   :: !Int

          -- Bool to remember if we've set the timeout callback.
        , GLUTState -> Bool
glutStateHasTimeout   :: Bool

          -- Bool to remember if we've set the idle callback.
        , GLUTState -> Bool
glutStateHasIdle      :: Bool }
        deriving Int -> GLUTState -> ShowS
[GLUTState] -> ShowS
GLUTState -> String
(Int -> GLUTState -> ShowS)
-> (GLUTState -> String)
-> ([GLUTState] -> ShowS)
-> Show GLUTState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GLUTState -> ShowS
showsPrec :: Int -> GLUTState -> ShowS
$cshow :: GLUTState -> String
show :: GLUTState -> String
$cshowList :: [GLUTState] -> ShowS
showList :: [GLUTState] -> ShowS
Show


-- | Initial GLUT state.
glutStateInit :: GLUTState
glutStateInit :: GLUTState
glutStateInit
        = GLUTState
        { glutStateFrameCount :: Int
glutStateFrameCount   = Int
0
        , glutStateHasTimeout :: Bool
glutStateHasTimeout   = Bool
False
        , glutStateHasIdle :: Bool
glutStateHasIdle      = Bool
False }


instance Backend GLUTState where
        initBackendState :: GLUTState
initBackendState           = GLUTState
glutStateInit
        initializeBackend :: IORef GLUTState -> Bool -> IdleCallback
initializeBackend          = IORef GLUTState -> Bool -> IdleCallback
initializeGLUT

        -- non-freeglut doesn't like this: (\_ -> GLUT.leaveMainLoop)
        exitBackend :: IORef GLUTState -> IdleCallback
exitBackend                = (\IORef GLUTState
_ -> ExitCode -> IdleCallback
forall a. ExitCode -> IO a
System.exitWith ExitCode
System.ExitSuccess)

        openWindow :: IORef GLUTState -> Display -> IdleCallback
openWindow                 = IORef GLUTState -> Display -> IdleCallback
openWindowGLUT
        dumpBackendState :: IORef GLUTState -> IdleCallback
dumpBackendState           = IORef GLUTState -> IdleCallback
dumpStateGLUT
        installDisplayCallback :: IORef GLUTState -> [Callback] -> IdleCallback
installDisplayCallback     = IORef GLUTState -> [Callback] -> IdleCallback
installDisplayCallbackGLUT

        -- We can ask for this in freeglut, but it doesn't seem to work :(.
        -- (\_ -> GLUT.actionOnWindowClose $= GLUT.MainLoopReturns)
        installWindowCloseCallback :: IORef GLUTState -> IdleCallback
installWindowCloseCallback = (\IORef GLUTState
_ -> () -> IdleCallback
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

        installReshapeCallback :: IORef GLUTState -> [Callback] -> IdleCallback
installReshapeCallback     = IORef GLUTState -> [Callback] -> IdleCallback
installReshapeCallbackGLUT
        installKeyMouseCallback :: IORef GLUTState -> [Callback] -> IdleCallback
installKeyMouseCallback    = IORef GLUTState -> [Callback] -> IdleCallback
installKeyMouseCallbackGLUT
        installMotionCallback :: IORef GLUTState -> [Callback] -> IdleCallback
installMotionCallback      = IORef GLUTState -> [Callback] -> IdleCallback
installMotionCallbackGLUT
        installIdleCallback :: IORef GLUTState -> [Callback] -> IdleCallback
installIdleCallback        = IORef GLUTState -> [Callback] -> IdleCallback
installIdleCallbackGLUT

        -- Call the GLUT mainloop.
        -- This function will return when something calls GLUT.leaveMainLoop
        runMainLoop :: IORef GLUTState -> IdleCallback
runMainLoop IORef GLUTState
_
         =      IdleCallback
forall (m :: * -> *). MonadIO m => m ()
GLUT.mainLoop

        postRedisplay :: IORef GLUTState -> IdleCallback
postRedisplay IORef GLUTState
_
         =      Maybe Window -> IdleCallback
forall (m :: * -> *). MonadIO m => Maybe Window -> m ()
GLUT.postRedisplay Maybe Window
forall a. Maybe a
Nothing

        getWindowDimensions :: IORef GLUTState -> IO (Int, Int)
getWindowDimensions IORef GLUTState
_
         = do   GL.Size sizeX sizeY   <- StateVar Size -> GettableStateVar Size
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *). MonadIO m => StateVar Size -> m Size
get StateVar Size
GLUT.windowSize
                return (fromEnum sizeX,fromEnum sizeY)

        getScreenSize :: IORef GLUTState -> IO (Int, Int)
getScreenSize IORef GLUTState
_
         = do   GL.Size width height  <- GettableStateVar Size -> GettableStateVar Size
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *). MonadIO m => GettableStateVar Size -> m Size
get GettableStateVar Size
GLUT.screenSize
                return (fromIntegral width, fromIntegral height)

        elapsedTime :: IORef GLUTState -> IO Double
elapsedTime IORef GLUTState
_
         = do   t       <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *). MonadIO m => GettableStateVar Int -> m Int
get GettableStateVar Int
GLUT.elapsedTime
                return $ (fromIntegral t) / 1000

        sleep :: IORef GLUTState -> Double -> IdleCallback
sleep IORef GLUTState
_ Double
sec
         = do   Int -> IdleCallback
threadDelay (Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ Double
sec Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double
1000000)


-- Initialise -----------------------------------------------------------------
initializeGLUT
        :: IORef GLUTState
        -> Bool
        -> IO ()

initializeGLUT :: IORef GLUTState -> Bool -> IdleCallback
initializeGLUT IORef GLUTState
_ Bool
debug
  = do initialized <- IORef Bool -> GettableStateVar Bool
forall a. IORef a -> IO a
readIORef IORef Bool
glutInitialized
       if not initialized
         then do  (_progName, _args)  <- GLUT.getArgsAndInitialize
                  glutVersion         <- get GLUT.glutVersion
                  when debug
                    $ putStr  $ "  glutVersion        = " ++ show glutVersion   ++ "\n"

                  GLUT.initialDisplayMode
                    $= [ GLUT.RGBMode
                       , GLUT.DoubleBuffered]

                  writeIORef glutInitialized True

                  -- See if our requested display mode is possible
                  displayMode         <- get GLUT.initialDisplayMode
                  displayModePossible <- get GLUT.displayModePossible
                  when debug
                    $ do putStr $  "  displayMode        = " ++ show displayMode ++ "\n"
                                ++ "       possible      = " ++ show displayModePossible ++ "\n"
                                ++ "\n"
         else when debug (putStrLn "Already initialized")

-- Open Window ----------------------------------------------------------------
openWindowGLUT
        :: IORef GLUTState
        -> Display
        -> IO ()

openWindowGLUT :: IORef GLUTState -> Display -> IdleCallback
openWindowGLUT IORef GLUTState
_ Display
display
 = do
       -- Setup and create a new window.
       -- Be sure to set initialWindow{Position,Size} before calling
       -- createWindow. If we don't do this we get wierd half-created
       -- windows some of the time.
        case Display
display of
          InWindow String
windowName (Int
sizeX, Int
sizeY) (Int
posX, Int
posY) ->
            do StateVar Size
GLUT.initialWindowSize
                     StateVar Size -> ReshapeCallback
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *). MonadIO m => StateVar Size -> Size -> m ()
$= GLsizei -> GLsizei -> Size
GL.Size
                          (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeX)
                          (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
sizeY)

               StateVar Position
GLUT.initialWindowPosition
                     StateVar Position -> MotionCallback
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar Position -> Position -> m ()
$= GLsizei -> GLsizei -> Position
GL.Position
                          (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
posX)
                          (Int -> GLsizei
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
posY)

               _ <- String -> IO Window
forall (m :: * -> *). MonadIO m => String -> m Window
GLUT.createWindow String
windowName

               GLUT.windowSize
                     $= GL.Size
                          (fromIntegral sizeX)
                          (fromIntegral sizeY)

          Display
FullScreen ->
            do size <- GettableStateVar Size -> GettableStateVar Size
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *). MonadIO m => GettableStateVar Size -> m Size
get GettableStateVar Size
GLUT.screenSize
               GLUT.initialWindowSize $= size
               _ <- GLUT.createWindow "Gloss Application"
               GLUT.fullScreen

        --  Switch some things.
        --  auto repeat interferes with key up / key down checks.
        --  BUGS: this doesn't seem to work?
        StateVar PerWindowKeyRepeat
GLUT.perWindowKeyRepeat   StateVar PerWindowKeyRepeat -> PerWindowKeyRepeat -> IdleCallback
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
StateVar PerWindowKeyRepeat -> PerWindowKeyRepeat -> m ()
$= PerWindowKeyRepeat
GLUT.PerWindowKeyRepeatOff


-- Dump State -----------------------------------------------------------------
dumpStateGLUT
        :: IORef GLUTState
        -> IO ()

dumpStateGLUT :: IORef GLUTState -> IdleCallback
dumpStateGLUT IORef GLUTState
_
 = do
        wbw             <- GettableStateVar Int -> GettableStateVar Int
forall t a (m :: * -> *). (HasGetter t a, MonadIO m) => t -> m a
forall (m :: * -> *). MonadIO m => GettableStateVar Int -> m Int
get GettableStateVar Int
GLUT.windowBorderWidth
        whh             <- get GLUT.windowHeaderHeight
        rgba            <- get GLUT.rgba

        rgbaBD          <- get GLUT.rgbaBufferDepths
        colorBD         <- get GLUT.colorBufferDepth
        depthBD         <- get GLUT.depthBufferDepth
        accumBD         <- get GLUT.accumBufferDepths
        stencilBD       <- get GLUT.stencilBufferDepth

        doubleBuffered  <- get GLUT.doubleBuffered

        colorMask       <- get GLUT.colorMask
        depthMask       <- get GLUT.depthMask

        putStr  $  "* dumpGlutState\n"
                ++ "  windowBorderWidth  = " ++ show wbw            ++ "\n"
                ++ "  windowHeaderHeight = " ++ show whh            ++ "\n"
                ++ "  rgba               = " ++ show rgba           ++ "\n"
                ++ "  depth      rgba    = " ++ show rgbaBD         ++ "\n"
                ++ "             color   = " ++ show colorBD        ++ "\n"
                ++ "             depth   = " ++ show depthBD        ++ "\n"
                ++ "             accum   = " ++ show accumBD        ++ "\n"
                ++ "             stencil = " ++ show stencilBD      ++ "\n"
                ++ "  doubleBuffered     = " ++ show doubleBuffered ++ "\n"
                ++ "  mask         color = " ++ show colorMask      ++ "\n"
                ++ "               depth = " ++ show depthMask      ++ "\n"
                ++ "\n"

-- Display Callback -----------------------------------------------------------
installDisplayCallbackGLUT
        :: IORef GLUTState -> [Callback]
        -> IO ()
installDisplayCallbackGLUT :: IORef GLUTState -> [Callback] -> IdleCallback
installDisplayCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
        = SettableStateVar IdleCallback
GLUT.displayCallback SettableStateVar IdleCallback -> IdleCallback -> IdleCallback
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar IdleCallback -> IdleCallback -> m ()
$= IORef GLUTState -> [Callback] -> IdleCallback
callbackDisplay IORef GLUTState
ref [Callback]
callbacks


callbackDisplay
        :: IORef GLUTState -> [Callback]
        -> IO ()

callbackDisplay :: IORef GLUTState -> [Callback] -> IdleCallback
callbackDisplay IORef GLUTState
refState [Callback]
callbacks
 = do
        -- Clear the display
        [ClearBuffer] -> IdleCallback
GL.clear [ClearBuffer
GL.ColorBuffer, ClearBuffer
GL.DepthBuffer]
        Color4 GLfloat -> IdleCallback
forall a. Color a => a -> IdleCallback
GL.color (Color4 GLfloat -> IdleCallback) -> Color4 GLfloat -> IdleCallback
forall a b. (a -> b) -> a -> b
$ GLfloat -> GLfloat -> GLfloat -> GLfloat -> Color4 GLfloat
forall a. a -> a -> a -> a -> Color4 a
GL.Color4 GLfloat
0 GLfloat
0 GLfloat
0 (GLfloat
1 :: GL.GLfloat)

        -- Run all the display callbacks to draw the window contents.
        let funs :: [IdleCallback]
funs  = [IORef GLUTState -> IdleCallback
DisplayCallback
f IORef GLUTState
refState | (Display DisplayCallback
f) <- [Callback]
callbacks]
        [IdleCallback] -> IdleCallback
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IdleCallback]
funs

        -- Swap front and back buffers
        IdleCallback
forall (m :: * -> *). MonadIO m => m ()
GLUT.swapBuffers

        -- Timeout.
        -- When there is no idle callback set the GLUT mainloop will block
        -- forever waiting for display events. This prevents us from updating
        -- the display on external events like files changing. The API doesn't
        -- provide a way to wake it up on these other events.
        --
        -- Set a timeout so that GLUT will return from its mainloop after a
        -- a second and give us a chance to check for other events.
        --
        -- The alternative would be to set an Idle callback and spin the CPU.
        -- This is ok for real-time animations, but a CPU hog for mostly static
        -- displays.
        --
        -- We only want to add a timeout when one doesn't already exist,
        -- otherwise we'll get both events.
        --
        state   <- IORef GLUTState -> IO GLUTState
forall a. IORef a -> IO a
readIORef IORef GLUTState
refState
        when (  (not $ glutStateHasTimeout state)
             && (not $ glutStateHasIdle    state))
         $ do
                -- Setting the timer interrupt to 1sec keeps CPU usage for a
                -- single process to < 0.5% or so on OSX. This is the rate
                -- that the process is woken up, but GLUT will only actually
                -- call the display call if postRedisplay has been set.
                let msecHeartbeat = Int
1000

                -- We're installing this callback on the first display
                -- call because it's a GLUT specific mechanism.
                -- We don't do the same thing for other Backends.
                GLUT.addTimerCallback msecHeartbeat
                 $ timerCallback msecHeartbeat

                -- Rember that we've done this filthy hack.
                atomicModifyIORef' refState
                 $ \GLUTState
s -> (GLUTState
s { glutStateHasTimeout = True }, ())


    -- Don't report errors by default.
    -- The windows OpenGL implementation seems to complain for no reason.
    --  GLUT.reportErrors

        atomicModifyIORef' refState
         $ \GLUTState
s -> ( GLUTState
s { glutStateFrameCount = glutStateFrameCount s + 1 }
                 , ())

        return ()


-- | Oneshot timer callback that re-registers itself.
timerCallback :: Int -> IO ()
timerCallback :: Int -> IdleCallback
timerCallback Int
msec
 = do   Int -> IdleCallback -> IdleCallback
GLUT.addTimerCallback Int
msec
         (IdleCallback -> IdleCallback) -> IdleCallback -> IdleCallback
forall a b. (a -> b) -> a -> b
$ do   Int -> IdleCallback
timerCallback Int
msec


-- Reshape Callback -----------------------------------------------------------
installReshapeCallbackGLUT
        :: IORef GLUTState -> [Callback]
        -> IO ()

installReshapeCallbackGLUT :: IORef GLUTState -> [Callback] -> IdleCallback
installReshapeCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
        = SettableStateVar (Maybe ReshapeCallback)
GLUT.reshapeCallback SettableStateVar (Maybe ReshapeCallback)
-> Maybe ReshapeCallback -> IdleCallback
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe ReshapeCallback)
-> Maybe ReshapeCallback -> m ()
$= ReshapeCallback -> Maybe ReshapeCallback
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> ReshapeCallback
callbackReshape IORef GLUTState
ref [Callback]
callbacks)

callbackReshape
        :: IORef GLUTState -> [Callback]
        -> GLUT.Size
        -> IO ()

callbackReshape :: IORef GLUTState -> [Callback] -> ReshapeCallback
callbackReshape IORef GLUTState
ref [Callback]
callbacks (GLUT.Size GLsizei
sizeX GLsizei
sizeY)
        = [IdleCallback] -> IdleCallback
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        ([IdleCallback] -> IdleCallback) -> [IdleCallback] -> IdleCallback
forall a b. (a -> b) -> a -> b
$ (((Int, Int) -> IdleCallback) -> IdleCallback)
-> [(Int, Int) -> IdleCallback] -> [IdleCallback]
forall a b. (a -> b) -> [a] -> [b]
map   (\(Int, Int) -> IdleCallback
f -> (Int, Int) -> IdleCallback
f (GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
sizeX, GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
sizeY))
                [IORef GLUTState -> (Int, Int) -> IdleCallback
ReshapeCallback
f IORef GLUTState
ref | Reshape ReshapeCallback
f <- [Callback]
callbacks]


-- KeyMouse Callback ----------------------------------------------------------
installKeyMouseCallbackGLUT
        :: IORef GLUTState -> [Callback]
        -> IO ()

installKeyMouseCallbackGLUT :: IORef GLUTState -> [Callback] -> IdleCallback
installKeyMouseCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
        = SettableStateVar (Maybe KeyboardMouseCallback)
GLUT.keyboardMouseCallback SettableStateVar (Maybe KeyboardMouseCallback)
-> Maybe KeyboardMouseCallback -> IdleCallback
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe KeyboardMouseCallback)
-> Maybe KeyboardMouseCallback -> m ()
$= KeyboardMouseCallback -> Maybe KeyboardMouseCallback
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> KeyboardMouseCallback
callbackKeyMouse IORef GLUTState
ref [Callback]
callbacks)

callbackKeyMouse
        :: IORef GLUTState -> [Callback]
        -> GLUT.Key
        -> GLUT.KeyState
        -> GLUT.Modifiers
        -> GLUT.Position
        -> IO ()

callbackKeyMouse :: IORef GLUTState -> [Callback] -> KeyboardMouseCallback
callbackKeyMouse IORef GLUTState
ref [Callback]
callbacks Key
key KeyState
keystate Modifiers
modifiers (GLUT.Position GLsizei
posX GLsizei
posY)
  = [IdleCallback] -> IdleCallback
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
  ([IdleCallback] -> IdleCallback) -> [IdleCallback] -> IdleCallback
forall a b. (a -> b) -> a -> b
$ ((Key -> KeyState -> Modifiers -> (Int, Int) -> IdleCallback)
 -> IdleCallback)
-> [Key -> KeyState -> Modifiers -> (Int, Int) -> IdleCallback]
-> [IdleCallback]
forall a b. (a -> b) -> [a] -> [b]
map (\Key -> KeyState -> Modifiers -> (Int, Int) -> IdleCallback
f -> Key -> KeyState -> Modifiers -> (Int, Int) -> IdleCallback
f Key
key' KeyState
keyState' Modifiers
modifiers' (Int, Int)
pos)
      [IORef GLUTState
-> Key -> KeyState -> Modifiers -> (Int, Int) -> IdleCallback
KeyboardMouseCallback
f IORef GLUTState
ref | KeyMouse KeyboardMouseCallback
f <- [Callback]
callbacks]
  where
    key' :: Key
key'       = Key -> Key
glutKeyToKey Key
key
    keyState' :: KeyState
keyState'  = KeyState -> KeyState
glutKeyStateToKeyState KeyState
keystate
    modifiers' :: Modifiers
modifiers' = Modifiers -> Modifiers
glutModifiersToModifiers Modifiers
modifiers
    pos :: (Int, Int)
pos        = (GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posX, GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posY)


-- Motion Callback ------------------------------------------------------------
installMotionCallbackGLUT
        :: IORef GLUTState -> [Callback]
        -> IO ()

installMotionCallbackGLUT :: IORef GLUTState -> [Callback] -> IdleCallback
installMotionCallbackGLUT IORef GLUTState
ref [Callback]
callbacks
 = do   SettableStateVar (Maybe MotionCallback)
GLUT.motionCallback        SettableStateVar (Maybe MotionCallback)
-> Maybe MotionCallback -> IdleCallback
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe MotionCallback)
-> Maybe MotionCallback -> m ()
$= MotionCallback -> Maybe MotionCallback
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> MotionCallback
callbackMotion IORef GLUTState
ref [Callback]
callbacks)
        SettableStateVar (Maybe MotionCallback)
GLUT.passiveMotionCallback SettableStateVar (Maybe MotionCallback)
-> Maybe MotionCallback -> IdleCallback
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe MotionCallback)
-> Maybe MotionCallback -> m ()
$= MotionCallback -> Maybe MotionCallback
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> MotionCallback
callbackMotion IORef GLUTState
ref [Callback]
callbacks)

callbackMotion
        :: IORef GLUTState -> [Callback]
        -> GLUT.Position
        -> IO ()

callbackMotion :: IORef GLUTState -> [Callback] -> MotionCallback
callbackMotion IORef GLUTState
ref [Callback]
callbacks (GLUT.Position GLsizei
posX GLsizei
posY)
 = do   let pos :: (Int, Int)
pos = (GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posX, GLsizei -> Int
forall a. Enum a => a -> Int
fromEnum GLsizei
posY)
        [IdleCallback] -> IdleCallback
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
         ([IdleCallback] -> IdleCallback) -> [IdleCallback] -> IdleCallback
forall a b. (a -> b) -> a -> b
$ (((Int, Int) -> IdleCallback) -> IdleCallback)
-> [(Int, Int) -> IdleCallback] -> [IdleCallback]
forall a b. (a -> b) -> [a] -> [b]
map  (\(Int, Int) -> IdleCallback
f -> (Int, Int) -> IdleCallback
f (Int, Int)
pos)
                [IORef GLUTState -> (Int, Int) -> IdleCallback
ReshapeCallback
f IORef GLUTState
ref | Motion ReshapeCallback
f <- [Callback]
callbacks]


-- Idle Callback --------------------------------------------------------------
installIdleCallbackGLUT
        :: IORef GLUTState -> [Callback]
        -> IO ()

installIdleCallbackGLUT :: IORef GLUTState -> [Callback] -> IdleCallback
installIdleCallbackGLUT IORef GLUTState
refState [Callback]
callbacks
        -- If the callback list does not actually contain an idle callback
        -- then don't install one that just does nothing. If we do then GLUT
        -- will still call us back after whenever it's idle and waste CPU time.
        | (Callback -> Bool) -> [Callback] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Callback -> Bool
isIdleCallback [Callback]
callbacks
        = do    SettableStateVar (Maybe IdleCallback)
GLUT.idleCallback SettableStateVar (Maybe IdleCallback)
-> Maybe IdleCallback -> IdleCallback
forall t a (m :: * -> *).
(HasSetter t a, MonadIO m) =>
t -> a -> m ()
forall (m :: * -> *).
MonadIO m =>
SettableStateVar (Maybe IdleCallback) -> Maybe IdleCallback -> m ()
$= IdleCallback -> Maybe IdleCallback
forall a. a -> Maybe a
Just (IORef GLUTState -> [Callback] -> IdleCallback
callbackIdle IORef GLUTState
refState [Callback]
callbacks)
                IORef GLUTState -> (GLUTState -> (GLUTState, ())) -> IdleCallback
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef GLUTState
refState
                 ((GLUTState -> (GLUTState, ())) -> IdleCallback)
-> (GLUTState -> (GLUTState, ())) -> IdleCallback
forall a b. (a -> b) -> a -> b
$ \GLUTState
state -> (GLUTState
state { glutStateHasIdle = True }, ())

        | Bool
otherwise
        = () -> IdleCallback
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()


-- | Call back when glut is idle.
callbackIdle
        :: IORef GLUTState -> [Callback]
        -> IO ()

callbackIdle :: IORef GLUTState -> [Callback] -> IdleCallback
callbackIdle IORef GLUTState
ref [Callback]
callbacks
        = [IdleCallback] -> IdleCallback
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_
        ([IdleCallback] -> IdleCallback) -> [IdleCallback] -> IdleCallback
forall a b. (a -> b) -> a -> b
$ [IORef GLUTState -> IdleCallback
DisplayCallback
f IORef GLUTState
ref | Idle DisplayCallback
f <- [Callback]
callbacks]


-------------------------------------------------------------------------------
-- | Convert GLUTs key codes to our internal ones.
glutKeyToKey :: GLUT.Key -> Key
glutKeyToKey :: Key -> Key
glutKeyToKey Key
key
 = case Key
key of
        GLUT.Char Char
'\32'                            -> SpecialKey -> Key
SpecialKey SpecialKey
KeySpace
        GLUT.Char Char
'\13'                            -> SpecialKey -> Key
SpecialKey SpecialKey
KeyEnter
        GLUT.Char Char
'\9'                             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyTab
        GLUT.Char Char
'\ESC'                           -> SpecialKey -> Key
SpecialKey SpecialKey
KeyEsc
        GLUT.Char Char
'\DEL'                           -> SpecialKey -> Key
SpecialKey SpecialKey
KeyDelete
        GLUT.Char Char
c                                -> Char -> Key
Char Char
c
        GLUT.SpecialKey SpecialKey
GLUT.KeyF1                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF1
        GLUT.SpecialKey SpecialKey
GLUT.KeyF2                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF2
        GLUT.SpecialKey SpecialKey
GLUT.KeyF3                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF3
        GLUT.SpecialKey SpecialKey
GLUT.KeyF4                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF4
        GLUT.SpecialKey SpecialKey
GLUT.KeyF5                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF5
        GLUT.SpecialKey SpecialKey
GLUT.KeyF6                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF6
        GLUT.SpecialKey SpecialKey
GLUT.KeyF7                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF7
        GLUT.SpecialKey SpecialKey
GLUT.KeyF8                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF8
        GLUT.SpecialKey SpecialKey
GLUT.KeyF9                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF9
        GLUT.SpecialKey SpecialKey
GLUT.KeyF10                -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF10
        GLUT.SpecialKey SpecialKey
GLUT.KeyF11                -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF11
        GLUT.SpecialKey SpecialKey
GLUT.KeyF12                -> SpecialKey -> Key
SpecialKey SpecialKey
KeyF12
        GLUT.SpecialKey SpecialKey
GLUT.KeyLeft               -> SpecialKey -> Key
SpecialKey SpecialKey
KeyLeft
        GLUT.SpecialKey SpecialKey
GLUT.KeyUp                 -> SpecialKey -> Key
SpecialKey SpecialKey
KeyUp
        GLUT.SpecialKey SpecialKey
GLUT.KeyRight              -> SpecialKey -> Key
SpecialKey SpecialKey
KeyRight
        GLUT.SpecialKey SpecialKey
GLUT.KeyDown               -> SpecialKey -> Key
SpecialKey SpecialKey
KeyDown
        GLUT.SpecialKey SpecialKey
GLUT.KeyPageUp             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyPageUp
        GLUT.SpecialKey SpecialKey
GLUT.KeyPageDown           -> SpecialKey -> Key
SpecialKey SpecialKey
KeyPageDown
        GLUT.SpecialKey SpecialKey
GLUT.KeyHome               -> SpecialKey -> Key
SpecialKey SpecialKey
KeyHome
        GLUT.SpecialKey SpecialKey
GLUT.KeyEnd                -> SpecialKey -> Key
SpecialKey SpecialKey
KeyEnd
        GLUT.SpecialKey SpecialKey
GLUT.KeyInsert             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyInsert
        GLUT.SpecialKey SpecialKey
GLUT.KeyNumLock            -> SpecialKey -> Key
SpecialKey SpecialKey
KeyNumLock
        GLUT.SpecialKey SpecialKey
GLUT.KeyBegin              -> SpecialKey -> Key
SpecialKey SpecialKey
KeyBegin
        GLUT.SpecialKey SpecialKey
GLUT.KeyDelete             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyDelete
        GLUT.SpecialKey (GLUT.KeyUnknown Int
_)        -> SpecialKey -> Key
SpecialKey SpecialKey
KeyUnknown
        GLUT.SpecialKey SpecialKey
GLUT.KeyShiftL             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyShiftL
        GLUT.SpecialKey SpecialKey
GLUT.KeyShiftR             -> SpecialKey -> Key
SpecialKey SpecialKey
KeyShiftR
        GLUT.SpecialKey SpecialKey
GLUT.KeyCtrlL              -> SpecialKey -> Key
SpecialKey SpecialKey
KeyCtrlL
        GLUT.SpecialKey SpecialKey
GLUT.KeyCtrlR              -> SpecialKey -> Key
SpecialKey SpecialKey
KeyCtrlR
        GLUT.SpecialKey SpecialKey
GLUT.KeyAltL               -> SpecialKey -> Key
SpecialKey SpecialKey
KeyAltL
        GLUT.SpecialKey SpecialKey
GLUT.KeyAltR               -> SpecialKey -> Key
SpecialKey SpecialKey
KeyAltR
        GLUT.MouseButton MouseButton
GLUT.LeftButton           -> MouseButton -> Key
MouseButton MouseButton
LeftButton
        GLUT.MouseButton MouseButton
GLUT.MiddleButton         -> MouseButton -> Key
MouseButton MouseButton
MiddleButton
        GLUT.MouseButton MouseButton
GLUT.RightButton          -> MouseButton -> Key
MouseButton MouseButton
RightButton
        GLUT.MouseButton MouseButton
GLUT.WheelUp              -> MouseButton -> Key
MouseButton MouseButton
WheelUp
        GLUT.MouseButton MouseButton
GLUT.WheelDown            -> MouseButton -> Key
MouseButton MouseButton
WheelDown
        GLUT.MouseButton (GLUT.AdditionalButton Int
i) -> MouseButton -> Key
MouseButton (Int -> MouseButton
AdditionalButton Int
i)

-- | Convert GLUTs key states to our internal ones.
glutKeyStateToKeyState :: GLUT.KeyState -> KeyState
glutKeyStateToKeyState :: KeyState -> KeyState
glutKeyStateToKeyState KeyState
state
 = case KeyState
state of
        KeyState
GLUT.Down       -> KeyState
Down
        KeyState
GLUT.Up         -> KeyState
Up


-- | Convert GLUTs key states to our internal ones.
glutModifiersToModifiers
        :: GLUT.Modifiers
        -> Modifiers

glutModifiersToModifiers :: Modifiers -> Modifiers
glutModifiersToModifiers (GLUT.Modifiers KeyState
a KeyState
b KeyState
c)
        = KeyState -> KeyState -> KeyState -> Modifiers
Modifiers     (KeyState -> KeyState
glutKeyStateToKeyState KeyState
a)
                        (KeyState -> KeyState
glutKeyStateToKeyState KeyState
b)
                        (KeyState -> KeyState
glutKeyStateToKeyState KeyState
c)