module Util.SDL.Video where
import Control.Monad.Writer
import Data.Maybe
import GHC.Conc ( numCapabilities )
import Text.Printf
import qualified Graphics.UI.SDL.Types as T
import qualified Graphics.UI.SDL.Video as V
import qualified Graphics.UI.SDL.WindowManagement as WM
-- | Datatype containing all the information needed to create a well
-- specified window. See 'defaultVideoOptions'. All the @Size@ fields
-- are how many bits are needed for that particular setting. I.e.
-- "normal" 32-bit color should have @vidopts {
data VideoOptions = VideoOptions
-- | Initial window width in pixels.
{ voWidth :: Int
-- | Initial window height in pixels.
, voHeight :: Int
-- | @Windowed@ or @Fullscreen@
, voDisplayMode :: DisplayMode
-- | @True@ if window should be able to be resized.
, voResizableWindow :: Bool
-- | Window name. Placed in titlebar when applicable.
, voWindowName :: String
-- | Window name to show when window is minimized.
, voTaskbarName :: String
-- | Icon for window. Should be @32x32@ pixels to be compatible
-- with Windows. This is currently being ignored since the
-- haskell SDL bindings doesn't export the SDL_WM_SetIcon.
, voWindowIcon :: Maybe T.Surface
, voRedSize :: V.GLValue
, voGreenSize :: V.GLValue
, voBlueSize :: V.GLValue
, voAlphaSize :: V.GLValue
, voDepthSize :: V.GLValue
, voStencilSize :: V.GLValue
, voAccumRedSize :: V.GLValue
, voAccumGreenSize :: V.GLValue
, voAccumBlueSize :: V.GLValue
, voAccumAlphaSize :: V.GLValue
} deriving (Eq, Show)
-- | These settings will with @'initVideo' defaultVideoOptions@ defines
-- a @640@x@480@ window (not @Fullscreen@), placed at @(0,0)@ with
-- @32@-bit colors that is not resizeable. The window name is
-- "Default", the name when minimized is "Default". No window icon.
defaultVideoOptions :: VideoOptions
defaultVideoOptions = VideoOptions
{ voWidth = 640
, voHeight = 480
, voDisplayMode = Window
, voResizableWindow = False
, voWindowName = "Default"
, voTaskbarName = "Default"
, voWindowIcon = Nothing
, voRedSize = 8
, voGreenSize = 8
, voBlueSize = 8
, voAlphaSize = 8
, voDepthSize = 8
, voStencilSize = 8
, voAccumRedSize = 8
, voAccumGreenSize = 8
, voAccumBlueSize = 8
, voAccumAlphaSize = 8
}
-- | If this isn't self explanatory you might need to file a complain
-- with the maker of @your brain@.
data DisplayMode
= Window
| Fullscreen
deriving (Eq, Show)
-- | Will create a 'Surface' for rendering in. Validates that the
-- 'VideoOptions' provided describes a useable mode.
initOpenGLSurface :: VideoOptions -> IO T.Surface
initOpenGLSurface vos = do
-- should be initialized before making a window:
initGLAttribs vos
mbSurface <- V.trySetVideoMode
(voWidth vos)
(voHeight vos)
(fromIntegral $ voRedSize vos
+ voGreenSize vos
+ voBlueSize vos
+ voAlphaSize vos)
(getSurfaceFlags vos)
WM.setCaption (voWindowName vos) (voTaskbarName vos)
-- doing a 2nd time because winbl0wz is fucking retarded:
initGLAttribs vos
case mbSurface of
Just surface -> do
putStrLn "Surface creation OK!"
return surface
Nothing -> do
putStrLn "Could not create surface! VideoOptions was:"
print vos
putStrLn "Now creating surface to cause an SDL error:"
V.setVideoMode
(voWidth vos)
(voHeight vos)
(fromIntegral $ voRedSize vos
+ voGreenSize vos
+ voBlueSize vos
+ voAlphaSize vos)
(getSurfaceFlags vos)
initGLAttribs :: VideoOptions -> IO ()
initGLAttribs vos = do
let tryWithError glAttr glVal = do
printf "%s = %d "
(fromJust (lookup glAttr glAttrTable))
(fromIntegral glVal :: Int)
ok <- V.tryGLSetAttribute glAttr glVal
if not ok
then do
printf "Failed!"
(error $ "initGLAttribs: could not set attribute "
++ fromJust (lookup glAttr glAttrTable) ++
" to " ++ show glVal)
else do
putStrLn "OK!"
-- first let's do all the bullshit we'll want anyway:
tryWithError V.glDoubleBuffer 1
tryWithError V.glStereo 0
-- TODO! FIX!! Multisample causes errors:
-- and now for the magicz0rz:
mapM_ (\(attr, selector) -> tryWithError attr (selector vos))
[ (V.glRedSize, voRedSize)
, (V.glGreenSize, voGreenSize)
, (V.glBlueSize, voBlueSize)
, (V.glAlphaSize, voAlphaSize)
, (V.glDepthSize, voDepthSize)
, (V.glStencilSize, voStencilSize)
, (V.glAccumRedSize, voAccumRedSize)
, (V.glAccumGreenSize, voAccumGreenSize)
, (V.glAccumBlueSize, voAccumBlueSize)
, (V.glAccumAlphaSize, voAccumAlphaSize) ]
tryWithError V.glBufferSize . sum . map ($ vos) $ [ voRedSize
, voGreenSize
, voBlueSize
, voAlphaSize ]
{-
glMSB | glMSS | outcome
----------+-------+---------------------------------------------
| |
0 | 0 | OK!
| |
1 | 4 | user error (SDL_SetVideoMode SDL message:
| | Couldn't find matching GLX visual)
| |
2 | 4 | user error (SDL_SetVideoMode SDL message:
| | Couldn't find matching GLX visual)
| |
-}
tryWithError V.glMultiSampleBuffers 0
tryWithError V.glMultiSampleSamples 0
where
-- if anything fail this table is used to look up which
-- glAttrib that was used.
glAttrTable :: [ (V.GLAttr, String) ]
glAttrTable =
[ (V.glRedSize, "glRedSize")
, (V.glGreenSize, "glGreenSize")
, (V.glBlueSize, "glBlueSize")
, (V.glAlphaSize, "glAlphaSize")
, (V.glBufferSize, "glBufferSize")
, (V.glDoubleBuffer, "glDoubleBuffer")
, (V.glDepthSize, "glDepthSize")
, (V.glStencilSize, "glStencilSize")
, (V.glAccumRedSize, "glAccumRedSize")
, (V.glAccumGreenSize, "glAccumGreenSize")
, (V.glAccumBlueSize, "glAccumBlueSize")
, (V.glAccumAlphaSize, "glAccumAlphaSize")
, (V.glStereo, "glStereo")
, (V.glMultiSampleBuffers, "glMultiSampleBuffers")
, (V.glMultiSampleSamples, "glMultiSampleSamples") ]
-- in this function, "docs" is this page:
-- http://www.libsdl.org/cgi/docwiki.cgi/SDL_SetVideoMode
getSurfaceFlags :: VideoOptions -- ^ The video settings
-> [T.SurfaceFlag] -- ^ List of Surface settings
getSurfaceFlags v = execWriter $ do
tell' T.OpenGL
tell' T.DoubleBuf -- probably redundant because of OpenGL
-- docs says that SMP processors migth benefit from this.
-- TODO: performance test this!
-- qualified: GHC.Conc.numCapabilities :: Int (:: IO Int?)
when (numCapabilities > 1) (tell' T.ASyncBlit)
when (voResizableWindow v) (tell' T.Resizable)
when (voDisplayMode v == Fullscreen) (tell' T.Fullscreen)
where
-- adds one item to the list monoi
tell' :: a -> Writer [a] ()
tell' x = tell [x]