--------------------------------------------------------------------------------
-- |
-- Module      :  Graphics.UI.GLUT.GameMode
-- Copyright   :  (c) Sven Panne 2002-2013
-- License     :  BSD3
--
-- Maintainer  :  Sven Panne <svenpanne@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- In addition to the functionality offered by
-- 'Graphics.UI.GLUT.Window.fullScreen', GLUT offers an sub-API to change the
-- screen resolution, color depth, and refresh rate of the display for a single
-- full screen window. This mode of operation is called /game mode/, and is
-- restricted in various ways: No pop-up menus are allowed for this full screen
-- window, no other (sub-)windows can be created, and all other applications are
-- hidden.
--
-- /X Implementation Notes:/ Note that game mode is not fully supported in the
-- original GLUT for X, it is essentially the same as using
-- 'Graphics.UI.GLUT.Window.fullScreen'. The GLUT clone freeglut
-- (see <http://freeglut.sourceforge.net/>) does not have this restriction.
--
--------------------------------------------------------------------------------

module Graphics.UI.GLUT.GameMode (
   GameModeCapability(..), GameModeCapabilityDescription(..),
   gameModeCapabilities, enterGameMode, leaveGameMode,
   BitsPerPlane, RefreshRate, GameModeInfo(..), gameModeInfo,
   gameModeActive
) where

import Control.Monad.IO.Class ( MonadIO(..) )
import Data.List ( intersperse )
import Data.StateVar ( GettableStateVar, makeGettableStateVar
                     , SettableStateVar, makeSettableStateVar )
import Foreign.C.String ( withCString )
import Graphics.Rendering.OpenGL ( Size(..), GLenum )

import Graphics.UI.GLUT.Raw
import Graphics.UI.GLUT.Types

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

-- | Capabilities for 'gameModeCapabilities'

data GameModeCapability
   = GameModeWidth         -- ^ Width of the screen resolution in pixels
   | GameModeHeight        -- ^ Height of the screen resolution in pixels
   | GameModeBitsPerPlane  -- ^ Color depth of the screen in bits
   | GameModeRefreshRate   -- ^ Refresh rate in Hertz
   | GameModeNum           -- ^ Match the Nth frame buffer configuration
                           --   compatible with the given capabilities
                           --   (numbering starts at 1)
   deriving ( Eq, Ord, Show )

gameModeCapabilityToString :: GameModeCapability -> String
gameModeCapabilityToString x = case x of
   GameModeWidth        -> "width"
   GameModeHeight       -> "height"
   GameModeBitsPerPlane -> "bpp"
   GameModeRefreshRate  -> "hertz"
   GameModeNum          -> "num"

-- | A single capability description for 'gameModeCapabilities'.

data GameModeCapabilityDescription = Where' GameModeCapability Relation Int
   deriving ( Eq, Ord, Show )

gameModeCapabilityDescriptionToString :: GameModeCapabilityDescription -> String
gameModeCapabilityDescriptionToString (Where' c r i) =
      gameModeCapabilityToString c ++ relationToString r ++ show i

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

-- | Controls the /game mode/ to be used when 'enterGameMode' is called. It is
-- described by a list of zero or more capability descriptions, which are
-- translated into a set of criteria used to select the appropriate screen
-- configuration. The criteria are matched in strict left to right order of
-- precdence. That is, the first specified criterion (leftmost) takes precedence
-- over the later criteria for non-exact criteria
-- ('Graphics.UI.GLUT.Initialization.IsGreaterThan',
-- 'Graphics.UI.GLUT.Initialization.IsLessThan', etc.). Exact criteria
-- ('Graphics.UI.GLUT.Initialization.IsEqualTo',
-- 'Graphics.UI.GLUT.Initialization.IsNotEqualTo') must match exactly so
-- precedence is not relevant.
--
-- To determine which configuration will actually be tried by 'enterGameMode'
-- (if any), use 'gameModeInfo'.
--
-- Note that even for game mode the current values of
-- 'Graphics.UI.GLUT.Initialization.initialDisplayMode'or
-- 'Graphics.UI.GLUT.Initialization.initialDisplayCapabilities' will
-- determine which buffers are available, if double buffering is used or not,
-- etc.

gameModeCapabilities :: SettableStateVar [GameModeCapabilityDescription]
gameModeCapabilities = makeSettableStateVar $ \ds ->
   withCString (descriptionsToString ds) glutGameModeString

-- freeglut currently handles only simple game mode descriptions like "WxH:B@R",
-- so we try hard to use this format instead of the more general format allowed
-- by the "real" GLUT.
descriptionsToString :: [GameModeCapabilityDescription] -> String
descriptionsToString ds =
   let ws = [ x | Where' GameModeWidth        IsEqualTo x <- ds ]
       hs = [ x | Where' GameModeHeight       IsEqualTo x <- ds ]
       bs = [ x | Where' GameModeBitsPerPlane IsEqualTo x <- ds ]
       rs = [ x | Where' GameModeRefreshRate  IsEqualTo x <- ds ]
       allSimple = (length ws + length hs + length bs + length rs) == (length ds)
       dimensionsOK = (null ws) == (null hs)
   in if allSimple && dimensionsOK
         then simpleCapStr ws hs bs rs
         else generalCapStr ds

simpleCapStr :: [Int] -> [Int] -> [Int] -> [Int] -> String
simpleCapStr ws hs bs rs =
   showCap "" ws ++ showCap "x" hs ++ showCap ":" bs ++ showCap "@" rs
   where showCap _      []    = ""
         showCap prefix (x:_) = prefix ++ show x

generalCapStr :: [GameModeCapabilityDescription] -> String
generalCapStr =
   concat . intersperse " " . map gameModeCapabilityDescriptionToString

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

-- | Enter /game mode/, trying to change resolution, refresh rate, etc., as
-- specified by the current value of 'gameModeCapabilities'. An identifier for
-- the game mode window and a flag, indicating if the display mode actually
-- changed, are returned. The game mode window is made the /current window/.
--
-- Re-entering /game mode/ is allowed, the previous game mode window gets
-- destroyed by this, and a new one is created.

enterGameMode :: MonadIO m => m (Window, Bool)
enterGameMode = do
   w <- glutEnterGameMode
   c <- getBool glut_GAME_MODE_DISPLAY_CHANGED
   return (Window w, c)

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

-- | Leave /game mode/, restoring the old display mode and destroying the game
-- mode window.

leaveGameMode :: MonadIO m => m ()
leaveGameMode = glutLeaveGameMode

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

-- | The color depth of the screen, measured in bits (e.g. 8, 16, 24, 32, ...)

type BitsPerPlane = Int

-- | The refresh rate of the screen, measured in Hertz (e.g. 60, 75, 100, ...)

type RefreshRate = Int

data GameModeInfo = GameModeInfo Size BitsPerPlane RefreshRate
   deriving ( Eq, Ord, Show )

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

-- | Return 'Just' the mode which would be tried by the next call to
-- 'enterGameMode'. Returns 'Nothing' if the mode requested by the current value
-- of 'gameModeCapabilities' is not possible, in which case 'enterGameMode'
-- would simply create a full screen window using the current mode.

gameModeInfo :: GettableStateVar (Maybe GameModeInfo)
gameModeInfo = makeGettableStateVar $ do
   possible <- getBool glut_GAME_MODE_POSSIBLE
   if possible
      then do
         w <- glutGameModeGet glut_GAME_MODE_WIDTH
         h <- glutGameModeGet glut_GAME_MODE_HEIGHT
         let size = Size (fromIntegral w) (fromIntegral h)
         b <- glutGameModeGet glut_GAME_MODE_PIXEL_DEPTH
         r <- glutGameModeGet glut_GAME_MODE_REFRESH_RATE
         return $ Just $ GameModeInfo size (fromIntegral b) (fromIntegral r)
      else return Nothing

getBool :: MonadIO m => GLenum -> m Bool
getBool x = do
  val <- glutGameModeGet x
  return $ val /= 0

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

-- | Contains 'True' when the /game mode/ is active, 'False' otherwise.

gameModeActive :: GettableStateVar Bool
gameModeActive = makeGettableStateVar $ getBool glut_GAME_MODE_ACTIVE