[ create a new paste ] login | about

Link: http://codepad.org/LRGEkkDp    [ raw code | fork ]

Haskell, pasted on Feb 13:
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]


Create a new paste based on this one


Comments: