--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.GLUT.State
-- Copyright   :  (c) Sven Panne 2002-2005
-- License     :  BSD-style (see the file libraries/GLUT/LICENSE)
--
-- Maintainer  :  sven.panne@aedion.de
-- Stability   :  stable
-- Portability :  portable
--
-- GLUT maintains a considerable amount of programmer visible state. Some (but
-- not all) of this state may be directly retrieved.
--
--------------------------------------------------------------------------------

module Graphics.UI.GLUT.State (
  -- * State of all windows
  windowBorderWidth, windowHeaderHeight,

  -- * State of the /current window/
  rgba,
  BufferDepth, rgbaBufferDepths, colorBufferDepth,
  doubleBuffered, stereo,
  accumBufferDepths, depthBufferDepth, stencilBufferDepth,
  SampleCount, sampleCount, formatID,
  fullScreenMode,

  -- * GLUT state pertaining to the layers of the /current window/
  damaged,

  -- * Timing
  elapsedTime,

  -- * Device information

  -- $DeviceInformation
  screenSize, screenSizeMM,
  hasKeyboard,
  ButtonCount, numMouseButtons,
  numSpaceballButtons,
  DialCount, numDialsAndButtons,
  numTabletButtons,
  AxisCount, PollRate, joystickInfo,
  supportedNumAuxBuffers, supportedSamplesPerPixel,

  -- * GLUT information
  glutVersion, initState
) where

import Control.Monad ( unless )
import Foreign.C.Types ( CInt )
import Foreign.Marshal.Alloc ( alloca )
import Foreign.Marshal.Array ( peekArray )
import Foreign.Ptr ( Ptr, nullFunPtr )
import Foreign.Storable ( Storable(..) )
import Graphics.Rendering.OpenGL.GL.BasicTypes ( GLenum )
import Graphics.Rendering.OpenGL.GL.CoordTrans ( Size(..) )
import Graphics.Rendering.OpenGL.GL.StateVar (
   StateVar, makeStateVar, GettableStateVar, makeGettableStateVar )
import Graphics.UI.GLUT.Constants (
   glut_WINDOW_RGBA,
   glut_WINDOW_RED_SIZE, glut_WINDOW_GREEN_SIZE, glut_WINDOW_BLUE_SIZE,
   glut_WINDOW_ALPHA_SIZE, glut_WINDOW_BUFFER_SIZE,
   glut_WINDOW_DOUBLEBUFFER, glut_WINDOW_STEREO,
   glut_WINDOW_ACCUM_RED_SIZE, glut_WINDOW_ACCUM_GREEN_SIZE,
   glut_WINDOW_ACCUM_BLUE_SIZE, glut_WINDOW_ACCUM_ALPHA_SIZE,
   glut_WINDOW_DEPTH_SIZE, glut_WINDOW_STENCIL_SIZE, glut_WINDOW_NUM_SAMPLES,
   glut_WINDOW_FORMAT_ID, glut_ELAPSED_TIME,
   glut_NORMAL_DAMAGED, glut_OVERLAY_DAMAGED,
   glut_SCREEN_WIDTH, glut_SCREEN_HEIGHT,
   glut_SCREEN_WIDTH_MM, glut_SCREEN_HEIGHT_MM,
   glut_FULL_SCREEN,
   glut_HAS_KEYBOARD,
   glut_HAS_MOUSE, glut_NUM_MOUSE_BUTTONS,
   glut_HAS_SPACEBALL, glut_NUM_SPACEBALL_BUTTONS,
   glut_HAS_DIAL_AND_BUTTON_BOX, glut_NUM_DIALS, glut_NUM_BUTTON_BOX_BUTTONS,
   glut_HAS_TABLET, glut_NUM_TABLET_BUTTONS,
   glut_HAS_JOYSTICK, glut_JOYSTICK_BUTTONS, glut_JOYSTICK_POLL_RATE,
   glut_JOYSTICK_AXES,
   glut_AUX, glut_MULTISAMPLE,
   glut_VERSION, glut_WINDOW_BORDER_WIDTH, glut_WINDOW_HEADER_HEIGHT,
   glut_INIT_STATE )
import Graphics.UI.GLUT.Overlay ( Layer(..) )
import Graphics.UI.GLUT.QueryUtils ( simpleGet, layerGet, deviceGet )
import Graphics.UI.GLUT.Window ( fullScreenToggle )
import Graphics.UI.GLUT.Extensions

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

#include "HsGLUTExt.h"

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

-- | Contains 'True' when the current layer of the /current window/ is in RGBA
-- mode, 'False' means color index mode.

rgba :: GettableStateVar Bool
rgba = makeGettableStateVar$ simpleGet i2b glut_WINDOW_RGBA

-- | Bit depth of a buffer

type BufferDepth = Int

-- | Contains the number of red, green, blue, and alpha bits in the color buffer
-- of the /current window\'s/ current layer (0 in color index mode).

rgbaBufferDepths ::
   GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth)
rgbaBufferDepths = makeGettableStateVar $ do
   r <- simpleGet fromIntegral glut_WINDOW_RED_SIZE
   g <- simpleGet fromIntegral glut_WINDOW_GREEN_SIZE
   b <- simpleGet fromIntegral glut_WINDOW_BLUE_SIZE
   a <- simpleGet fromIntegral glut_WINDOW_ALPHA_SIZE
   return (r, g, b, a)

-- | Contains the total number of bits in the color buffer of the /current
-- window\'s/ current layer. For an RGBA layer, this is the sum of the red,
-- green, blue, and alpha bits. For an color index layer, this is the number
-- of bits of the color indexes.

colorBufferDepth :: GettableStateVar BufferDepth
colorBufferDepth =
   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_BUFFER_SIZE

-- | Contains 'True' when the current layer of the /current window/ is double
-- buffered, 'False' otherwise.

doubleBuffered :: GettableStateVar Bool
doubleBuffered = makeGettableStateVar $ simpleGet i2b glut_WINDOW_DOUBLEBUFFER

-- | Contains 'True' when the current layer of the /current window/ is stereo,
-- 'False' otherwise.

stereo :: GettableStateVar Bool
stereo = makeGettableStateVar $ simpleGet i2b glut_WINDOW_STEREO

-- | Contains the number of red, green, blue, and alpha bits in the accumulation
-- buffer of the /current window\'s/ current layer (0 in color index mode).

accumBufferDepths ::
   GettableStateVar (BufferDepth, BufferDepth, BufferDepth, BufferDepth)
accumBufferDepths = makeGettableStateVar $ do
   r <- simpleGet fromIntegral glut_WINDOW_ACCUM_RED_SIZE
   g <- simpleGet fromIntegral glut_WINDOW_ACCUM_GREEN_SIZE
   b <- simpleGet fromIntegral glut_WINDOW_ACCUM_BLUE_SIZE
   a <- simpleGet fromIntegral glut_WINDOW_ACCUM_ALPHA_SIZE
   return (r, g, b, a)

-- | Contains the number of bits in the depth buffer of the /current window\'s/
-- current layer.

depthBufferDepth :: GettableStateVar BufferDepth
depthBufferDepth =
   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_DEPTH_SIZE

-- | Contains the number of bits in the stencil buffer of the /current
-- window\'s/ current layer.

stencilBufferDepth :: GettableStateVar BufferDepth
stencilBufferDepth =
   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_STENCIL_SIZE

-- | Number of samples for multisampling

type SampleCount = Int

-- | Contains the number of samples for multisampling for the /current window./

sampleCount :: GettableStateVar SampleCount
sampleCount =
   makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_NUM_SAMPLES

-- | Contains the window system dependent format ID for the current layer of the
-- /current window/. On X11 GLUT implementations, this is the X visual ID. On
-- Win32 GLUT implementations, this is the Win32 Pixel Format Descriptor number.
-- This value is returned for debugging, benchmarking, and testing ease.

formatID :: GettableStateVar Int
formatID = makeGettableStateVar $ simpleGet fromIntegral glut_WINDOW_FORMAT_ID

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

-- | (/freeglut only/) Contains 'True' if the /current window/ is in full screen
-- mode, 'False' otherwise.

fullScreenMode :: StateVar Bool
fullScreenMode = makeStateVar getFullScreenMode setFullScreenMode

getFullScreenMode :: IO Bool
getFullScreenMode = simpleGet i2b glut_FULL_SCREEN

setFullScreenMode :: Bool -> IO ()
setFullScreenMode newMode = do
   oldMode <- getFullScreenMode
   unless (newMode == oldMode) fullScreenToggle

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

-- | Contains the number of milliseconds since
-- 'Graphics.UI.GLUT.Initialization.initialize' was called.

elapsedTime :: GettableStateVar Int
elapsedTime = makeGettableStateVar $ simpleGet fromIntegral glut_ELAPSED_TIME

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

-- | Contains 'True' if the given plane of the /current window/ has been
-- damaged (by window system activity) since the last display callback was
-- triggered. Calling 'Graphics.UI.GLUT.Window.postRedisplay' or
-- 'Graphics.UI.GLUT.Overlay.postOverlayRedisplay' will not set this 'True'.

damaged :: Layer -> GettableStateVar Bool
damaged l = makeGettableStateVar $ layerGet isDamaged (marshalDamagedLayer l)
   where isDamaged d = d /= 0 && d /= -1
         marshalDamagedLayer x = case x of
            Normal -> glut_NORMAL_DAMAGED
            Overlay -> glut_OVERLAY_DAMAGED

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

-- $DeviceInformation
-- If a device is not available, the following state variables contain
-- 'Nothing', otherwise they return 'Just' the specific device information.
-- Only a screen is always assumed.

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

-- | The size of the screen in pixels.

screenSize :: GettableStateVar Size
screenSize =
   makeGettableStateVar $ do
      wpx <- simpleGet fromIntegral glut_SCREEN_WIDTH
      hpx <- simpleGet fromIntegral glut_SCREEN_HEIGHT
      return $ Size wpx hpx

-- | The size of the screen in millimeters.

screenSizeMM :: GettableStateVar Size
screenSizeMM =
   makeGettableStateVar $ do
      wmm <- simpleGet fromIntegral glut_SCREEN_WIDTH_MM
      hmm <- simpleGet fromIntegral glut_SCREEN_HEIGHT_MM
      return $ Size wmm hmm

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

-- | Contains 'True' if a keyboard is present, 'False' otherwise.

hasKeyboard :: GettableStateVar Bool
hasKeyboard = makeGettableStateVar $ deviceGet i2b glut_HAS_KEYBOARD

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

-- | Number of buttons of an input device

type ButtonCount = Int

-- | Contains 'Just' the number of buttons of an attached mouse or 'Nothing' if
-- there is none.

numMouseButtons :: GettableStateVar (Maybe ButtonCount)
numMouseButtons =
   getDeviceInfo glut_HAS_MOUSE $
      deviceGet fromIntegral glut_NUM_MOUSE_BUTTONS

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

-- | Contains 'Just' the number of buttons of the attached Spaceball or 'Nothing'
-- if there is none.

numSpaceballButtons :: GettableStateVar (Maybe ButtonCount)
numSpaceballButtons =
   getDeviceInfo glut_HAS_SPACEBALL $
      deviceGet fromIntegral glut_NUM_SPACEBALL_BUTTONS

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

-- | Number of dials of a dial and button box

type DialCount = Int

-- | Contains 'Just' the number of dials and buttons of an attached dial &
-- button box or 'Nothing' if there is none.

numDialsAndButtons :: GettableStateVar (Maybe (DialCount, ButtonCount))
numDialsAndButtons =
   getDeviceInfo glut_HAS_DIAL_AND_BUTTON_BOX $ do
      d <- deviceGet fromIntegral glut_NUM_DIALS
      b <- deviceGet fromIntegral glut_NUM_BUTTON_BOX_BUTTONS
      return (d, b)

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

-- | Contains 'Just' the number of buttons of an attached tablet or 'Nothing' if
-- there is none.

numTabletButtons :: GettableStateVar (Maybe ButtonCount)
numTabletButtons =
   getDeviceInfo glut_HAS_TABLET $
      deviceGet fromIntegral glut_NUM_TABLET_BUTTONS

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

-- | Number of axes of a joystick

type AxisCount = Int

-- | The a rate at which a joystick is polled (in milliseconds)

type PollRate = Int

-- | Contains 'Just' the number of buttons of an attached joystick, the number
-- of joystick axes, and the rate at which the joystick is polled. Contains
-- 'Nothing' if there is no joystick attached.

joystickInfo :: GettableStateVar (Maybe (ButtonCount, PollRate, AxisCount))
joystickInfo =
   getDeviceInfo glut_HAS_JOYSTICK $ do
      b <- deviceGet fromIntegral glut_JOYSTICK_BUTTONS
      a <- deviceGet fromIntegral glut_JOYSTICK_AXES
      r <- deviceGet fromIntegral glut_JOYSTICK_POLL_RATE
      return (b, a, r)

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

-- | (/freeglut only/) Contains a list of the number of auxiliary buffers
-- supported, in increasing order.

supportedNumAuxBuffers :: GettableStateVar [Int]
supportedNumAuxBuffers = getModeValues glut_AUX

-- | (/freeglut only/) Contains a list of the number of samples per pixel
-- supported for multisampling, in increasing order.

supportedSamplesPerPixel :: GettableStateVar [SampleCount]
supportedSamplesPerPixel = getModeValues (fromIntegral glut_MULTISAMPLE)

getModeValues :: Integral a => GLenum -> GettableStateVar [a]
getModeValues what = makeGettableStateVar $
   alloca $ \sizeBuffer -> do
      valuesBuffer <- glutGetModeValues what sizeBuffer
      size <- peek sizeBuffer
      fmap (map fromIntegral) $ peekArray (fromIntegral size) valuesBuffer

EXTENSION_ENTRY(unsafe,"freeglut",glutGetModeValues,GLenum -> Ptr CInt -> IO (Ptr CInt))

--------------------------------------------------------------------------------
-- Convenience unmarshalers

i2b :: CInt -> Bool
i2b = (/= 0)

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

getDeviceInfo :: GLenum -> IO a -> GettableStateVar (Maybe a)
getDeviceInfo dev act =
   makeGettableStateVar $ do
      hasDevice <- deviceGet i2b dev
      if hasDevice then fmap Just act else return Nothing

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

-- | Contains version of GLUT in the form of
-- @/flavour/ /major/./minor/./patchlevel/@, where @/flavour/@ is one of
-- @GLUT@, @freeglut@ or @OpenGLUT@.

glutVersion :: GettableStateVar String
glutVersion = makeGettableStateVar $ do
   let isGLUT = isUnknown "glutSetOption"
       isFreeglut = isUnknown "glutSetWindowStayOnTop"
       isUnknown = fmap (== nullFunPtr) . getProcAddressInternal
       showVersionPart x = shows (x `mod` 100)
       showVersion v = showVersionPart (v `div` 10000) . showChar '.' .
                       showVersionPart (v `div`   100) . showChar '.' .
                       showVersionPart  v
   g <- isGLUT
   if g
      then return "GLUT 3.7"   -- ToDo: just guessing
      else do f <- isFreeglut
              v <- simpleGet id glut_VERSION
              let prefix = if f then "freeglut" else "OpenGLUT"
              return $ showString prefix . showChar ' ' . showVersion v $ ""

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

-- | (/freeglut only/) Contains the thickness of the sizing border around the
-- perimeter of a window that can be resized, in pixels.

windowBorderWidth :: GettableStateVar Int
windowBorderWidth =
   makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_BORDER_WIDTH)

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

-- | (/freeglut only/) Contains the height of the header\/caption area of a
-- window in pixels.

windowHeaderHeight :: GettableStateVar Int
windowHeaderHeight =
   makeGettableStateVar (simpleGet fromIntegral glut_WINDOW_HEADER_HEIGHT)

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

-- | (/freeglut only/) Contains 'True' if GLUT has been initialized 
-- with 'Graphics.UI.GLUT.Initialization.initialize' or
-- 'Graphics.UI.GLUT.Initialization.getArgsAndInitialize' has and not yet
-- been de-initialized with 'Graphics.UI.GLUT.Initialization.exit'. Contains
-- 'False' otherwise.

initState :: GettableStateVar Bool
initState = makeGettableStateVar$ simpleGet i2b glut_INIT_STATE