lambdacube-engine-0.2.1: Graphics/LambdaCube/RenderSystem/GL/GpuProgram.hs

module Graphics.LambdaCube.RenderSystem.GL.GpuProgram where

import Data.List
import Control.Monad
import Foreign
import Foreign.C.String

import Graphics.Rendering.OpenGL.Raw.Core31
import qualified Graphics.Rendering.OpenGL.Raw.EXT as EXT

import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.HardwareVertexBuffer

-- Some drivers (e.g. OS X on nvidia) incorrectly determine the attribute binding automatically
-- and end up aliasing existing built-ins. So avoid! Fixed builtins are:

--  a  builtin				custom attrib name
-- ----------------------------------------------
--	0  gl_Vertex			vertex
--  1  n/a					blendWeights
--	2  gl_Normal			normal
--	3  gl_Color				colour
--	4  gl_SecondaryColor	secondary_colour
--	5  gl_FogCoord			fog_coord
--  7  n/a					blendIndices
--	8  gl_MultiTexCoord0	uv0
--	9  gl_MultiTexCoord1	uv1
--	10 gl_MultiTexCoord2	uv2
--	11 gl_MultiTexCoord3	uv3
--	12 gl_MultiTexCoord4	uv4
--	13 gl_MultiTexCoord5	uv5
--	14 gl_MultiTexCoord6	uv6, tangent
--	15 gl_MultiTexCoord7	uv7, binormal
getFixedAttributeIndex :: VertexElementSemantic -> Int -> Int
getFixedAttributeIndex semantic index = case semantic of
    VES_POSITION              -> 0
    VES_BLEND_WEIGHTS         -> 1
    VES_NORMAL                -> 2
    VES_DIFFUSE               -> 3
    VES_SPECULAR              -> 4
    VES_BLEND_INDICES         -> 7
    VES_TEXTURE_COORDINATES   -> 8 + index
    VES_TANGENT               -> 14
    VES_BINORMAL              -> 15

isAttributeValid :: VertexElementSemantic -> Int -> Bool
isAttributeValid semantic _ = case semantic of
    VES_POSITION              -> False
    VES_NORMAL                -> False
    VES_DIFFUSE               -> False
    VES_SPECULAR              -> False
    VES_TEXTURE_COORDINATES   -> False
    VES_BLEND_WEIGHTS         -> True
    VES_BLEND_INDICES         -> True
    VES_BINORMAL              -> True
    VES_TANGENT               -> True

data GLGpuProgram
    = GLGpuProgram
    { glgpShaderObject          :: GLuint
    }
    deriving (Eq,Ord)

data GLLinkedGpuProgram
    = GLLinkedGpuProgram
    { gllgpProgramObject        :: GLuint
    }
    deriving (Eq,Ord)

instance LinkedGpuProgram GLLinkedGpuProgram

instance GpuProgram GLGpuProgram

withGLStringLen :: String -> ((Ptr b, Int) -> IO a) -> IO a
withGLStringLen s act =
   withCAStringLen s $ \(p,len) ->
      act (castPtr p, fromIntegral len)

setShaderSource :: GLuint -> [String] -> IO ()
setShaderSource shader srcs = do
   let len = genericLength srcs
   withMany withGLStringLen srcs $ \charBufsAndLengths -> do
      let (charBufs, lengths) = unzip charBufsAndLengths
      withArray charBufs $ \charBufsBuf ->
         withArray (map fromIntegral lengths) $ \lengthsBuf ->
            glShaderSource shader len charBufsBuf lengthsBuf

shaderInfoLog :: GLuint -> IO String
shaderInfoLog a = allocaArray maxLen $ \s -> alloca $ \l -> do
    glGetShaderInfoLog a (fromIntegral maxLen) l s
    len <- peek l
    peekCStringLen (castPtr s, fromIntegral len)
  where
    maxLen = 256

programInfoLog :: GLuint -> IO String
programInfoLog a = allocaArray maxLen $ \s -> alloca $ \l -> do
    glGetProgramInfoLog a (fromIntegral maxLen) l s
    len <- peek l
    peekCStringLen (castPtr s, fromIntegral len)
  where
    maxLen = 256

--compileShader :: GpuProgramType -> String -> IO (Either a String)
compileShader :: Integral a => a -> String -> IO (Either GLuint [Char])
compileShader ptype src = do
    shader <- glCreateShader $ fromIntegral ptype
    setShaderSource shader [src]
    glCompileShader shader

    -- TEMP CODE
    infoLog <- shaderInfoLog shader
    --infoM "ResourceLibrary" $ "shader infoLog cmp " ++ infoLog
    ok <- alloca $ \buf -> glGetShaderiv shader gl_COMPILE_STATUS buf >> peek buf
    case ok == fromIntegral gl_TRUE of
        False -> do
            glDeleteShader shader
            --errl <- GL.get GL.errors
            return $ Right $ "shader compilation failed: " ++ infoLog -- ++ concat [show c ++ " - " ++ m ++ "\n" | GL.Error c m <- errl]
        True  -> return $ Left shader

mkGLGpuProgram :: GpuProgramType -> String -> IO (Either GLGpuProgram String)
mkGLGpuProgram ptype src = do
    let stype = case ptype of
            GPT_VERTEX_PROGRAM      -> gl_VERTEX_SHADER
            GPT_FRAGMENT_PROGRAM    -> gl_FRAGMENT_SHADER
            GPT_GEOMETRY_PROGRAM    -> EXT.gl_GEOMETRY_SHADER
    s <- compileShader stype src
    case s of
        Right m   -> return $ Right m
        Left sh   -> return $ Left $ GLGpuProgram sh

mkGLLinkedGpuProgram :: [GLGpuProgram] -> IO (Either GLLinkedGpuProgram String)
mkGLLinkedGpuProgram pl = do
    p <- glCreateProgram
    forM_ (map glgpShaderObject pl) $ \sh -> glAttachShader p sh
    glLinkProgram p

    infoLog <- programInfoLog p
    -- infoM "ResourceLibrary" $ "program infoLog cmp " ++ infoLog
    ok <- alloca $ \buf -> glGetProgramiv p gl_LINK_STATUS buf >> peek buf
    case ok == fromIntegral gl_TRUE of
        False -> do
            glDeleteProgram p
            --errl <- GL.get GL.errors
            return $ Right $ "GpuProgram linking failed: " ++ infoLog -- ++ concat [show c ++ " - " ++ m ++ "\n" | GL.Error c m <- errl]
        True  -> return $ Left $ GLLinkedGpuProgram p