{-# OPTIONS_HADDOCK hide #-}
module Graphics.Gloss.Internals.Interface.Backend.GLUT
        (GLUTState)
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


-- | We don't maintain any state information for the GLUT backend, 
--   so this data type is empty.
data GLUTState 
        = GLUTState

glutStateInit :: GLUTState
glutStateInit  = GLUTState


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)

        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   (_progName, _args)  <- GLUT.getArgsAndInitialize

        glutVersion         <- get GLUT.glutVersion
        when debug
         $ putStr  $ "  glutVersion        = " ++ show glutVersion   ++ "\n"

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

        -- 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"


-- 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 (sizeX, sizeY) -> 
            do GLUT.gameModeCapabilities $= 
                 [ GLUT.Where' GLUT.GameModeWidth GLUT.IsEqualTo sizeX
                 , GLUT.Where' GLUT.GameModeHeight GLUT.IsEqualTo sizeY ]
               void $ GLUT.enterGameMode

        --  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 ref callbacks 
 = do   -- clear the display
        GL.clear [GL.ColorBuffer, GL.DepthBuffer]
        GL.color $ GL.Color4 0 0 0 (1 :: GL.GLfloat)

        -- get the display callbacks from the chain
        let funs  = [f ref | (Display f) <- callbacks]
        sequence_ funs

        -- swap front and back buffers
        GLUT.swapBuffers

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

        return ()

-- 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 ref callbacks
        = GLUT.idleCallback $= Just (callbackIdle ref callbacks)

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.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)