GLGpuProgram.hs

module Graphics.LambdaCube.RenderSystem.GL.GLGpuProgram where

import Data.Either

import System.Log.Logger
import Graphics.Rendering.OpenGL (($=))
import qualified Graphics.Rendering.OpenGL as GL

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

-- 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
    --; _ -> error "Missing attribute!"
    }

isAttributeValid :: VertexElementSemantic -> Int -> Bool
isAttributeValid semantic index = 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
    { glgpType                  :: GpuProgramType        -- ^ The type of the program
    , glgpFilename              :: String                -- ^ The name of the file to load source from (may be blank)
    , glgpSource                :: String                -- ^ The assembler source of the program (may be blank until file loaded)
    , glgpLoadFromFile          :: Bool                  -- ^ Whether we need to load source from file or not
    , glgpSyntaxCode            :: String                -- ^ Syntax code e.g. arbvp1, vs_2_0 etc
    , glgpSkeletalAnimation     :: Bool                  -- ^ Does this (vertex) program include skeletal animation?
    , glgpMorphAnimation        :: Bool                  -- ^ Does this (vertex) program include morph animation?
    , glgpPoseAnimation         :: Int                   -- ^ Does this (vertex) program include pose animation (count of number of poses supported)
    , glgpVertexTextureFetch    :: Bool                  -- ^ Does this (vertex) program require support for vertex texture fetch?
    , glgpNeedsAdjacencyInfo    :: Bool                  -- ^ Does this (geometry) program require adjacency information?
    , glgpDefaultParams         :: GpuProgramParameters  -- ^ The default parameters for use with this object
    , glgpCompileError          :: Bool                  -- ^ Did we encounter a compilation error?

    , glgpProgramObject         :: GL.Program
    }
-}
data GLGpuProgram
    = GLGpuProgram
    { glgpShaderObject          :: Either GL.VertexShader GL.FragmentShader
    }
    deriving Eq

data GLLinkedGpuProgram
    = GLLinkedGpuProgram
    { gllgpProgramObject        :: GL.Program
    }
    deriving Eq

instance LinkedGpuProgram GLLinkedGpuProgram --where

instance GpuProgram GLGpuProgram --where
--    gpType  = undefined

compileShader src = do
    [shader] <- GL.genObjectNames 1
    GL.shaderSource shader $= [src]
    GL.compileShader shader

    -- TEMP CODE
    infoLog <- GL.get (GL.shaderInfoLog shader)
    infoM "ResourceLibrary" $ "infoLog cmp " ++ infoLog
    ok <- GL.get (GL.compileStatus shader)
    case ok of
        { False -> do
            GL.deleteObjectNames [shader]
            errl <- GL.get GL.errors
            return $ Right $ "shader compilation failed: " ++ concat [show c ++ " - " ++ m ++ "\n" | GL.Error c m <- errl]
        ; True  -> return $ Left shader
        }

mkGLGpuProgram ptype src = case ptype of
    { GPT_VERTEX_PROGRAM    -> do
        debugM "ResourceLibrary" $ "compiling vertex shader: "
        s <- compileShader src
        case s of
            { Right m   -> return $ Right m
            ; Left sh   -> return $ Left $ GLGpuProgram $ Left sh
            }
    ; GPT_FRAGMENT_PROGRAM  -> do
        debugM "ResourceLibrary" $ "compiling fragment shader: "
        s <- compileShader src
        case s of
            { Right m   -> return $ Right m
            ; Left sh   -> return $ Left $ GLGpuProgram $ Right sh
            }
    ; GPT_GEOMETRY_PROGRAM  -> undefined
    }

mkGLLinkedGpuProgram :: [GLGpuProgram] -> IO (Either GLLinkedGpuProgram String)
mkGLLinkedGpuProgram pl = do
    [p] <- GL.genObjectNames 1
    let vp = lefts $ map glgpShaderObject pl
        fp = rights $ map glgpShaderObject pl
    GL.attachedShaders p $= (vp, fp)
    GL.linkProgram p

    ok <- GL.get (GL.linkStatus p)
    infoLog <- GL.get (GL.programInfoLog p)
    infoM "ResourceLibrary"  $ "infoLog link " ++ infoLog
    case ok of
        { False -> do
            GL.deleteObjectNames [p]
            errl <- GL.get GL.errors
            return $ Right $ "GpuProgram linking failed: " ++ concat [show c ++ " - " ++ m ++ "\n" | GL.Error c m <- errl]
        ; True  -> return $ Left $ GLLinkedGpuProgram p
        }