content: {-# 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 = unsafePerformIO $ do newIORef False
  
  -- | State information for the GLUT backend.
  data GLUTState
          = GLUTState
          { -- Count of total number of frames that we have drawn.
            glutStateFrameCount   :: !Int
  
            -- Bool to remember if we've set the timeout callback.
          , glutStateHasTimeout   :: Bool
  
            -- Bool to remember if we've set the idle callback.
          , glutStateHasIdle      :: Bool }
          deriving Show
  
  
  -- | Initial GLUT state.
  glutStateInit :: GLUTState
  glutStateInit
          = GLUTState
          { glutStateFrameCount   = 0
          , glutStateHasTimeout   = False
          , glutStateHasIdle      = False }
  
  
  instance Backend GLUTState where
          initBackendState           = glutStateInit
          initializeBackend          = initializeGLUT
  
          -- non-freeglut doesn't like this: (\_ -> GLUT.leaveMainLoop)
          exitBackend                = (\_ -> System.exitWith System.ExitSuccess)
  
          openWindow                 = openWindowGLUT
          dumpBackendState           = dumpStateGLUT
          installDisplayCallback     = installDisplayCallbackGLUT
  
          -- We can ask for this in freeglut, but it doesn't seem to work :(.
          -- (\_ -> GLUT.actionOnWindowClose $= GLUT.MainLoopReturns)
          installWindowCloseCallback = (\_ -> return ())
  
          installReshapeCallback     = installReshapeCallbackGLUT
          installKeyMouseCallback    = installKeyMouseCallbackGLUT
          installMotionCallback      = installMotionCallbackGLUT
          installIdleCallback        = installIdleCallbackGLUT
  
          -- Call the GLUT mainloop.
          -- This function will return when something calls GLUT.leaveMainLoop
          runMainLoop _
           =      GLUT.mainLoop
  
          postRedisplay _
           =      GLUT.postRedisplay Nothing
  
          getWindowDimensions _
           = do   GL.Size sizeX sizeY   <- get GLUT.windowSize
                  return (fromEnum sizeX,fromEnum sizeY)
  
          getScreenSize _
           = do   GL.Size width height  <- get GLUT.screenSize
                  return (fromIntegral width, fromIntegral height)
  
          elapsedTime _
           = do   t       <- get GLUT.elapsedTime
                  return $ (fromIntegral t) / 1000
  
          sleep _ sec
           = do   threadDelay (round $ sec * 1000000)
  
  
  -- Initialise -----------------------------------------------------------------
  initializeGLUT
          :: IORef GLUTState
          -> Bool
          -> IO ()
  
  initializeGLUT _ debug
    = do initialized <- readIORef 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 _ 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 of
            InWindow windowName (sizeX, sizeY) (posX, posY) ->
              do GLUT.initialWindowSize
                       $= GL.Size
                            (fromIntegral sizeX)
                            (fromIntegral sizeY)
  
                 GLUT.initialWindowPosition
                       $= GL.Position
                            (fromIntegral posX)
                            (fromIntegral posY)
  
                 _ <- GLUT.createWindow windowName
  
                 GLUT.windowSize
                       $= GL.Size
                            (fromIntegral sizeX)
                            (fromIntegral sizeY)
  
            FullScreen ->
              do size <- get 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?
          GLUT.perWindowKeyRepeat   $= GLUT.PerWindowKeyRepeatOff
  
  
  -- Dump State -----------------------------------------------------------------
  dumpStateGLUT
          :: IORef GLUTState
          -> IO ()
  
  dumpStateGLUT _
   = do
          wbw             <- get 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 ref callbacks
          = GLUT.displayCallback $= callbackDisplay ref callbacks
  
  
  callbackDisplay
          :: IORef GLUTState -> [Callback]
          -> IO ()
  
  callbackDisplay refState callbacks
   = do
          -- Clear the display
          GL.clear [GL.ColorBuffer, GL.DepthBuffer]
          GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat)
  
          -- Run all the display callbacks to draw the window contents.
          let funs  = [f refState | (Display f) <- callbacks]
          sequence_ funs
  
          -- Swap front and back buffers
          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   <- readIORef 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 = 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
                   $ \s -> (s { glutStateHasTimeout = True }, ())
  
  
      -- Don't report errors by default.
      -- The windows OpenGL implementation seems to complain for no reason.
      --  GLUT.reportErrors
  
          atomicModifyIORef' refState
           $ \s -> ( s { glutStateFrameCount = glutStateFrameCount s + 1 }
                   , ())
  
          return ()
  
  
  -- | Oneshot timer callback that re-registers itself.
  timerCallback :: Int -> IO ()
  timerCallback msec
   = do   GLUT.addTimerCallback msec
           $ do   timerCallback msec
  
  
  -- Reshape Callback -----------------------------------------------------------
  installReshapeCallbackGLUT
          :: IORef GLUTState -> [Callback]
          -> IO ()
  
  installReshapeCallbackGLUT ref callbacks
          = GLUT.reshapeCallback $= Just (callbackReshape ref callbacks)
  
  callbackReshape
          :: IORef GLUTState -> [Callback]
          -> GLUT.Size
          -> IO ()
  
  callbackReshape ref callbacks (GLUT.Size sizeX sizeY)
          = sequence_
          $ map   (\f -> f (fromEnum sizeX, fromEnum sizeY))
                  [f ref | Reshape f <- callbacks]
  
  
  -- KeyMouse Callback ----------------------------------------------------------
  installKeyMouseCallbackGLUT
          :: IORef GLUTState -> [Callback]
          -> IO ()
  
  installKeyMouseCallbackGLUT ref callbacks
          = GLUT.keyboardMouseCallback $= Just (callbackKeyMouse ref callbacks)
  
  callbackKeyMouse
          :: IORef GLUTState -> [Callback]
          -> GLUT.Key
          -> GLUT.KeyState
          -> GLUT.Modifiers
          -> GLUT.Position
          -> IO ()
  
  callbackKeyMouse ref callbacks key keystate modifiers (GLUT.Position posX posY)
    = sequence_
    $ map (\f -> f key' keyState' modifiers' pos)
        [f ref | KeyMouse f <- callbacks]
    where
      key'       = glutKeyToKey key
      keyState'  = glutKeyStateToKeyState keystate
      modifiers' = glutModifiersToModifiers modifiers
      pos        = (fromEnum posX, fromEnum posY)
  
  
  -- Motion Callback ------------------------------------------------------------
  installMotionCallbackGLUT
          :: IORef GLUTState -> [Callback]
          -> IO ()
  
  installMotionCallbackGLUT ref callbacks
   = do   GLUT.motionCallback        $= Just (callbackMotion ref callbacks)
          GLUT.passiveMotionCallback $= Just (callbackMotion ref callbacks)
  
  callbackMotion
          :: IORef GLUTState -> [Callback]
          -> GLUT.Position
          -> IO ()
  
  callbackMotion ref callbacks (GLUT.Position posX posY)
   = do   let pos = (fromEnum posX, fromEnum posY)
          sequence_
           $ map  (\f -> f pos)
                  [f ref | Motion f <- callbacks]
  
  
  -- Idle Callback --------------------------------------------------------------
  installIdleCallbackGLUT
          :: IORef GLUTState -> [Callback]
          -> IO ()
  
  installIdleCallbackGLUT refState 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.
          | any isIdleCallback callbacks
          = do    GLUT.idleCallback $= Just (callbackIdle refState callbacks)
                  atomicModifyIORef' refState
                   $ \state -> (state { glutStateHasIdle = True }, ())
  
          | otherwise
          = return ()
  
  
  -- | Call back when glut is idle.
  callbackIdle
          :: IORef GLUTState -> [Callback]
          -> IO ()
  
  callbackIdle ref callbacks
          = sequence_
          $ [f ref | Idle f <- callbacks]
  
  
  -------------------------------------------------------------------------------
  -- | Convert GLUTs key codes to our internal ones.
  glutKeyToKey :: GLUT.Key -> Key
  glutKeyToKey key
   = case key of
          GLUT.Char '\32'                            -> SpecialKey KeySpace
          GLUT.Char '\13'                            -> SpecialKey KeyEnter
          GLUT.Char '\9'                             -> SpecialKey KeyTab
          GLUT.Char '\ESC'                           -> SpecialKey KeyEsc
          GLUT.Char '\DEL'                           -> SpecialKey KeyDelete
          GLUT.Char c                                -> Char c
          GLUT.SpecialKey GLUT.KeyF1                 -> SpecialKey KeyF1
          GLUT.SpecialKey GLUT.KeyF2                 -> SpecialKey KeyF2
          GLUT.SpecialKey GLUT.KeyF3                 -> SpecialKey KeyF3
          GLUT.SpecialKey GLUT.KeyF4                 -> SpecialKey KeyF4
          GLUT.SpecialKey GLUT.KeyF5                 -> SpecialKey KeyF5
          GLUT.SpecialKey GLUT.KeyF6                 -> SpecialKey KeyF6
          GLUT.SpecialKey GLUT.KeyF7                 -> SpecialKey KeyF7
          GLUT.SpecialKey GLUT.KeyF8                 -> SpecialKey KeyF8
          GLUT.SpecialKey GLUT.KeyF9                 -> SpecialKey KeyF9
          GLUT.SpecialKey GLUT.KeyF10                -> SpecialKey KeyF10
          GLUT.SpecialKey GLUT.KeyF11                -> SpecialKey KeyF11
          GLUT.SpecialKey GLUT.KeyF12                -> SpecialKey KeyF12
          GLUT.SpecialKey GLUT.KeyLeft               -> SpecialKey KeyLeft
          GLUT.SpecialKey GLUT.KeyUp                 -> SpecialKey KeyUp
          GLUT.SpecialKey GLUT.KeyRight              -> SpecialKey KeyRight
          GLUT.SpecialKey GLUT.KeyDown               -> SpecialKey KeyDown
          GLUT.SpecialKey GLUT.KeyPageUp             -> SpecialKey KeyPageUp
          GLUT.SpecialKey GLUT.KeyPageDown           -> SpecialKey KeyPageDown
          GLUT.SpecialKey GLUT.KeyHome               -> SpecialKey KeyHome
          GLUT.SpecialKey GLUT.KeyEnd                -> SpecialKey KeyEnd
          GLUT.SpecialKey GLUT.KeyInsert             -> SpecialKey KeyInsert
          GLUT.SpecialKey GLUT.KeyNumLock            -> SpecialKey KeyNumLock
          GLUT.SpecialKey GLUT.KeyBegin              -> SpecialKey KeyBegin
          GLUT.SpecialKey GLUT.KeyDelete             -> SpecialKey KeyDelete
          GLUT.SpecialKey (GLUT.KeyUnknown _)        -> SpecialKey KeyUnknown
          GLUT.SpecialKey GLUT.KeyShiftL             -> SpecialKey KeyShiftL
          GLUT.SpecialKey GLUT.KeyShiftR             -> SpecialKey KeyShiftR
          GLUT.SpecialKey GLUT.KeyCtrlL              -> SpecialKey KeyCtrlL
          GLUT.SpecialKey GLUT.KeyCtrlR              -> SpecialKey KeyCtrlR
          GLUT.SpecialKey GLUT.KeyAltL               -> SpecialKey KeyAltL
          GLUT.SpecialKey GLUT.KeyAltR               -> SpecialKey KeyAltR
          GLUT.MouseButton GLUT.LeftButton           -> MouseButton LeftButton
          GLUT.MouseButton GLUT.MiddleButton         -> MouseButton MiddleButton
          GLUT.MouseButton GLUT.RightButton          -> MouseButton RightButton
          GLUT.MouseButton GLUT.WheelUp              -> MouseButton WheelUp
          GLUT.MouseButton GLUT.WheelDown            -> MouseButton WheelDown
          GLUT.MouseButton (GLUT.AdditionalButton i) -> MouseButton (AdditionalButton i)
  
  -- | Convert GLUTs key states to our internal ones.
  glutKeyStateToKeyState :: GLUT.KeyState -> KeyState
  glutKeyStateToKeyState state
   = case state of
          GLUT.Down       -> Down
          GLUT.Up         -> Up
  
  
  -- | Convert GLUTs key states to our internal ones.
  glutModifiersToModifiers
          :: GLUT.Modifiers
          -> Modifiers
  
  glutModifiersToModifiers (GLUT.Modifiers a b c)
          = Modifiers     (glutKeyStateToKeyState a)
                          (glutKeyStateToKeyState b)
                          (glutKeyStateToKeyState c)
  