{-# LANGUAGE NoMonomorphismRestriction #-}
module Graphics.LambdaCube.Loader.MaterialScript (parseMaterial) where

import UU.Parsing
import UU.Scanner

import Data.Either
import System.FilePath.Posix

import Graphics.LambdaCube.BlendMode
import Graphics.LambdaCube.Common
import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.GpuProgramParams
import Graphics.LambdaCube.GpuProgramUsage
import Graphics.LambdaCube.Light
import Graphics.LambdaCube.Loader.Generated.MaterialScriptScanner
import Graphics.LambdaCube.Loader.ParserUtil
import Graphics.LambdaCube.Material
import Graphics.LambdaCube.Pass
import Graphics.LambdaCube.PixelFormat
import Graphics.LambdaCube.Technique
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.TextureUnitState
import Graphics.LambdaCube.Types

parseMaterial :: (Texture t, LinkedGpuProgram lp, GpuProgram p) => String -> String -> IO (Maybe ([Material t lp],[GpuProgramDescriptor p],[GpuProgramDescriptor p]))
parseMaterial file txt = case parseTokens pMaterialScript (tokenize file txt) of
    Left errs -> do
        mapM_ (\m -> putStrLn $ "MaterialScript " ++ m) errs
        return Nothing
    Right tree -> return (Just tree)

type TokenParser a = Parser Token a

parseTokens :: TokenParser a -> [Token] -> Either [String] a
parseTokens p tks = if null msgs then final `seq` Right v else Left (map show msgs)
  where
    steps = parse p tks
    msgs  = getMsgs steps
    (Pair v final) = evalSteps steps

-- * AST definitions

-- | Material Script
data (Texture t, GpuProgram p, LinkedGpuProgram lp) => MS_Attr t p lp
    = MS_material        (Material t lp)
    | MS_vertexprogram   (GpuProgramDescriptor p)
    | MS_fragmentprogram (GpuProgramDescriptor p)

-- | Material
data (Texture t, LinkedGpuProgram lp) => M_Attr t lp
    = M_technique                (Technique t lp)
    | M_receiveshadows           Bool
    | M_transparencycastsshadows Bool
    | M_loddistances             [FloatType]
    | M_settexturealias          String String

-- | Technique
data (Texture t, LinkedGpuProgram lp) => T_Attr t lp
    = T_pass                   (Pass t lp)
    | T_scheme                 String
    | T_lodindex               Int
    | T_shadowcastermaterial   String
    | T_shadowreceivermaterial String
    | T_gpuvendorrule          IncludeOrExclude String
    | T_gpudevicerule          IncludeOrExclude String Bool

-- | Pass
type Colour = Either ColourValue ()
data Texture t => P_Attr t
    = P_textureunit             (TextureUnitState t)
    | P_vertexprogramref        String [PR_Attr]
    | P_fragmentprogramref      String [PR_Attr]
    | P_shadowcastervertexprogramref        -- NOT SUPPORTED
    | P_shadowreceiververtexprogramref      -- NOT SUPPORTED
    | P_shadowreceiverfragmentprogramref    -- NOT SUPPORTED
    | P_ambient                 Colour
    | P_diffuse                 Colour
    | P_specular                Colour FloatType
    | P_emissive                Colour
    | P_sceneblend              (SceneBlendFactor,SceneBlendFactor)
    | P_sceneblendop            SceneBlendOperation
    | P_separatesceneblend      ((SceneBlendFactor,SceneBlendFactor),(SceneBlendFactor,SceneBlendFactor))
    | P_separatesceneblendop    SceneBlendOperation SceneBlendOperation
    | P_depthcheck              Bool
    | P_depthwrite              Bool
    | P_depthfunc               CompareFunction
    | P_depthbias               FloatType FloatType
    | P_iterationdepthbias      FloatType
    | P_alpharejection          CompareFunction Int
    | P_alphatocoverage         Bool
    | P_lightscissor            Bool
    | P_lightclipplanes         Bool
    | P_illuminationstage       IlluminationStage
    | P_normalisenormals        Bool
    | P_transparentsorting      Bool Bool
    | P_cullhardware            CullingMode
    | P_cullsoftware            ManualCullingMode
    | P_lighting                Bool
    | P_shading                 ShadeOptions
    | P_polygonmode             PolygonMode
    | P_polygonmodeoverrideable Bool
    | P_fogoverride             Bool FogMode FloatType3 FloatType FloatType FloatType
    | P_colourwrite             Bool
    | P_startlight              Int
    | P_maxlights               Int
    | P_iteration               Int (Maybe Int) (Maybe LightTypes)        -- ^ iteration count, n_light, light type
    | P_pointsize               FloatType
    | P_pointsprites            Bool
    | P_pointsizeattenuation    Bool FloatType3
    | P_pointsizemin            FloatType
    | P_pointsizemax            FloatType

-- | TextureUnit
data TU_Attr
    = TU_texturealias              String

    -- texture <texturename> [<type>] [unlimited | numMipMaps] [alpha] [<PixelFormat>] [gamma]
    | TU_texture                   String TextureType TextureMipmap Bool PixelFormat Bool

    | TU_animtexture               [String] FloatType
    | TU_cubictexture              String String String String String String Bool
    | TU_bindingtype               BindingType
    | TU_contenttype               ContentType
    | TU_texcoordset               Int
    | TU_texaddressmode            TextureAddressingMode TextureAddressingMode TextureAddressingMode
    | TU_texbordercolour           ColourValue
    | TU_filtering                 (FilterOptions,FilterOptions,FilterOptions)
    | TU_maxanisotropy             Int
    | TU_mipmapbias                FloatType
    | TU_colourop                  LayerBlendOperation
    | TU_colouropex                LayerBlendOperationEx LayerBlendSource LayerBlendSource FloatType ColourValue ColourValue
    | TU_colouropmultipassfallback (SceneBlendFactor,SceneBlendFactor)
    | TU_alphaopex                 LayerBlendOperationEx LayerBlendSource LayerBlendSource FloatType FloatType FloatType
    | TU_envmap                    (Maybe EnvMapType)
    | TU_scroll                    FloatType FloatType
    | TU_scrollanim                FloatType FloatType
    | TU_rotate                    FloatType
    | TU_rotateanim                FloatType
    | TU_scale                     FloatType FloatType
    | TU_wavexform                 TextureTransformType WaveformType FloatType FloatType FloatType FloatType
    | TU_transform                 FloatType4 FloatType4 FloatType4 FloatType4

-- | Texture
data TX_Attr
    = TX_type         TextureType
    | TX_mipmap       TextureMipmap
    | TX_alpha
    | TX_pixelformat  PixelFormat
    | TX_gamma

-- | Shader
data SH_Attr
    = SH_source                     String
    | SH_attach                     [String]
    | SH_includesskeletalanimation  Bool
    | SH_includesmorphanimation     Bool
    | SH_includesposeanimation      Int
    | SH_usesvertextexturefetch     Bool
    | SH_usesadjacencyinformation   Bool
    | SH_entrypoint                 String
    | SH_profiles                   [String]
    | SH_target                     String
    | SH_delegate                   String
    | SH_defaultparams              [PR_Attr]

data PR_Attr
    = PR_paramnamed                 String String [FloatType]
    | PR_paramnamedauto             String AutoConstantType [FloatType]
    | PR_paramindexed               Int String [FloatType]
    | PR_paramindexedauto           Int AutoConstantType [FloatType]

-- * Material script top level parser combinators

pMaterialScript :: (GpuProgram p, LinkedGpuProgram lp, Texture t) => AnaParser [Token] Pair Token (Maybe Token) ([Material t lp],[GpuProgramDescriptor p],[GpuProgramDescriptor p])
pMaterialScript = mkMaterialScript <$> pList pMaterialScriptContent

mkMaterialScript :: (Texture t, LinkedGpuProgram lp, GpuProgram p) => [MS_Attr t p lp] -> ([Material t lp],[GpuProgramDescriptor p],[GpuProgramDescriptor p])
mkMaterialScript l = (mats,vertprogs,fragprogs)
  where
    mats = [x | MS_material x <- l]
    vertprogs = [x | MS_vertexprogram x <- l]
    fragprogs = [x | MS_fragmentprogram x <- l]

pMaterialScriptContent :: (GpuProgram p, LinkedGpuProgram lp, Texture t) => AnaParser [Token] Pair Token (Maybe Token) (MS_Attr t p lp)
pMaterialScriptContent =  (MS_material .) . mkMaterial                                          <$= "material" <*> pName <*= "{" <*> pList pMaterialContent <*= "}"
                      <|> ((MS_vertexprogram .) .) . (mkGpuProgramDesc GPT_VERTEX_PROGRAM)      <$= "vertex_program" <*> pName <*> pName <*= "{" <*> pList pProgramContent <*= "}"
                      <|> ((MS_fragmentprogram .) .) . (mkGpuProgramDesc GPT_FRAGMENT_PROGRAM)  <$= "fragment_program" <*> pName <*> pName <*= "{" <*> pList pProgramContent <*= "}"

-- * Material
pMaterialContent :: (LinkedGpuProgram lp, Texture t) => AnaParser [Token] Pair Token (Maybe Token) (M_Attr t lp)
pMaterialContent =  (M_technique .) . mkTechnique   <$= "technique" <*> (pName <|> pSucceed "") <*= "{" <*> pList pTechniqueContent <*= "}"
                <|> M_loddistances                  <$= "lod_distances" <*> pList pFloat
                <|> M_receiveshadows                <$= "receive_shadows" <*> pOnOff
                <|> M_transparencycastsshadows      <$= "transparency_casts_shadows" <*> pOnOff
                <|> M_settexturealias               <$= "set_texture_alias" <*> pName <*> pName

mkMaterial :: (Texture t, LinkedGpuProgram lp) => String -> [M_Attr t lp] -> Material t lp
mkMaterial name l = Material
    { mtName                     = name
--    , mtLodDistances             = def []    [x | M_loddistances x <- l]
    , mtReceiveShadows           = def True  [x | M_receiveshadows x <- l]
    , mtTransparencyCastsShadows = def False [x | M_transparencycastsshadows x <- l]
    --, mtTextureAlias             = [(a,b) | M_settexturealias a b <- l]
    , mtTechniques               = [x | M_technique x <- l]
---------------
    , mtSupportedTechniques      = Nothing
    , mtUserLodValues = []
    , mtLodValues = []
    , mtUnsupportedReasons = ""
    }

-- * Technique
pTechniqueContent :: (LinkedGpuProgram lp, Texture t) => AnaParser [Token] Pair Token (Maybe Token) (T_Attr t lp)
pTechniqueContent =  (T_pass .) . mkPass      <$= "pass" <*> (pName <|> pSucceed "") <*= "{" <*> pList pPassContent <*= "}"
                 <|> T_scheme                 <$= "scheme" <*> pName
                 <|> T_lodindex               <$= "lod_index" <*> pInt
                 <|> T_shadowcastermaterial   <$= "shadow_caster_material" <*> pName
                 <|> T_shadowreceivermaterial <$= "shadow_receiver_material" <*> pName
                 <|> T_gpuvendorrule          <$= "gpu_vendor_rule" <*> pEnum ruleopVals <*> pName
                 <|> T_gpudevicerule          <$= "gpu_device_rule" <*> pEnum ruleopVals <*> pName <*> (True <$= "case_sensitive" <|> pSucceed False)

mkTechnique :: (Texture t, LinkedGpuProgram lp) => String -> [T_Attr t lp] -> Technique t lp
mkTechnique n l = Technique
    -- TODO
    { tchName                   = n
    -- TODO
    , tchSchemeIndex            = 0 --def "Default" [x | T_scheme x <- l]
    , tchLodIndex               = def 0         [x | T_lodindex x <- l]
--    , tchShadowCasterMaterial   = def ""        [x | T_shadowcastermaterial x <- l]
--    , tchShadowReceiverMaterial = def ""        [x | T_shadowreceivermaterial x <- l]
--    , tchGPUVendorRules         = [GPUVendorRule (a,b) | T_gpuvendorrule a b <- l]
--    , tchGPUDeviceNameRules     = [(a,b,c) | T_gpudevicerule a b c <- l]
    , tchPasses                 = [x | T_pass x <- l]
-------------------
    , tchGPUVendorRules = []
    , tchGPUDeviceNameRules = []

    }

-- * Pass
pPassContent :: (Texture t) => AnaParser [Token] Pair Token (Maybe Token) (P_Attr t)
pPassContent =  (P_textureunit .) . mkTextureUnitState  <$= "texture_unit" <*> (pName <|> pSucceed "") <*= "{" <*> pList pTextureUnitContent <*= "}"
            <|> P_vertexprogramref                      <$= "vertex_program_ref" <*> pName <*= "{" <*> pList pParamContent <*= "}"
            <|> P_fragmentprogramref                    <$= "fragment_program_ref" <*> pName <*= "{" <*> pList pParamContent <*= "}"
            <|> P_shadowcastervertexprogramref          <$= "shadow_caster_vertex_program_ref" <* pName <*= "{" <* pList pParamContent <*= "}"
            <|> P_shadowreceiververtexprogramref        <$= "shadow_receiver_vertex_program_ref" <* pName <*= "{" <* pList pParamContent <*= "}"
            <|> P_shadowreceiverfragmentprogramref      <$= "shadow_receiver_fragment_program_ref" <* pName <*= "{" <* pList pParamContent <*= "}"
            <|> P_ambient                               <$= "ambient" <*> pColour 1
            <|> P_diffuse                               <$= "diffuse" <*> pColour 1
            <|> P_specular                              <$= "specular" <*> pColour 0 <*> pFloat
            <|> P_emissive                              <$= "emissive" <*> pColour 0
            <|> P_sceneblendop                          <$= "scene_blend_op" <*> pEnum blendopVals
--            <|> P_sceneblend (convertSBTtoSBF SBT_MODULATE)     <$= "scene_blend" <*= "modulate"
            <|> P_sceneblend . convertSBTtoSBF          <$= "scene_blend" <*> pEnum sceneblendVals
            <|> curry P_sceneblend                      <$= "scene_blend" <*> pEnum blendVals <*> pEnum blendVals
            <|> P_separatesceneblendop                  <$= "separate_scene_blend_op" <*> pEnum blendopVals <*> pEnum blendopVals
            <|> curry P_separatesceneblend              <$= "separate_scene_blend" <*> (convertSBTtoSBF <$> pEnum sceneblendVals) <*> (convertSBTtoSBF <$> pEnum sceneblendVals)
            <|> (\a b c d -> P_separatesceneblend ((a,b),(c,d))) <$= "separate_scene_blend" <*> pEnum blendVals <*> pEnum blendVals <*> pEnum blendVals <*> pEnum blendVals
            <|> P_depthcheck                            <$= "depth_check" <*> pOnOff
            <|> P_depthwrite                            <$= "depth_write" <*> pOnOff
            <|> P_depthfunc                             <$= "depth_func" <*> pEnum cmpfuncVals
            <|> P_depthbias                             <$= "depth_bias" <*> pFloat <*> (pFloat <|> pSucceed 0)
            <|> P_iterationdepthbias                    <$= "iteration_depth_bias" <*> pFloat
            <|> P_alpharejection                        <$= "alpha_rejection" <*> pEnum cmpfuncVals <*> pInt
            <|> P_alphatocoverage                       <$= "alpha_to_coverage" <*> pOnOff
            <|> P_lightscissor                          <$= "light_scissor" <*> pOnOff
            <|> P_lightclipplanes                       <$= "light_clip_planes" <*> pOnOff
            <|> P_illuminationstage                     <$= "illumination_stage" <*> pEnum illumstageVals
            <|> P_normalisenormals                      <$= "normalise_normals" <*> pOnOff
            <|> P_transparentsorting                    <$= "transparent_sorting" <*= "force" <*> pSucceed True <*> pSucceed True
            <|> P_transparentsorting                    <$= "transparent_sorting" <*> pOnOff <*> pSucceed False
            <|> P_cullhardware                          <$= "cull_hardware" <*> pEnum cullhwVals
            <|> P_cullsoftware                          <$= "cull_software" <*> pEnum cullswVals
            <|> P_lighting                              <$= "lighting" <*> pOnOff
            <|> P_shading                               <$= "shading" <*> pEnum shadingVals
            <|> P_polygonmode                           <$= "polygon_mode" <*> pEnum polymodeVals
            <|> P_polygonmodeoverrideable               <$= "polygon_mode_overrideable" <*> pOnOff

            <|> P_fogoverride False                     <$= "fog_override" <*= "false" <*> pSucceed FOG_NONE <*> pSucceed (0,0,0) <*> pSucceed 0 <*> pSucceed 0 <*> pSucceed 0
            <|> P_fogoverride True                      <$= "fog_override" <*= "true" <*> pSucceed FOG_NONE <*> pSucceed (0,0,0) <*> pSucceed 0 <*> pSucceed 0 <*> pSucceed 0
            <|> P_fogoverride True                      <$= "fog_override" <*= "true" <*> (FOG_NONE <$= "none") <*> pSucceed (0,0,0) <*> pSucceed 0 <*> pSucceed 0 <*> pSucceed 0
            <|> P_fogoverride True                      <$= "fog_override" <*= "true" <*> pEnum fogmodeVals <*> pFloat3 <*> pFloat <*> pFloat <*> pFloat

            <|> P_colourwrite                           <$= "colour_write" <*> pOnOff
            <|> P_startlight                            <$= "start_light" <*> pInt
            <|> P_maxlights                             <$= "max_lights" <*> pInt

            -- Format 1: iteration <once | once_per_light> [lightType]
            -- Format 2: iteration <number> [<per_light> [lightType]]
            -- Format 3: iteration <number> [<per_n_lights> <num_lights> [lightType]]
            -- lights of a single type (either 'point', 'directional' or 'spot').
            <|> P_iteration 1 Nothing                   <$= "iteration" <*= "once" <*> (Just <$> pEnum lighttypeVals <|> pSucceed Nothing)
            <|> P_iteration 1 (Just 1)                  <$= "iteration" <*= "once_per_light" <*> (Just <$> pEnum lighttypeVals <|> pSucceed Nothing)
            <|> (\n -> P_iteration n (Just 1))          <$= "iteration" <*> pInt <*= "per_light" <*> (Just <$> pEnum lighttypeVals <|> pSucceed Nothing)
            <|> P_iteration                             <$= "iteration" <*> pInt <*= "per_n_light" <*> (Just <$> pInt) <*> (Just <$> pEnum lighttypeVals <|> pSucceed Nothing)
            <|> P_iteration                             <$= "iteration" <*> pInt <*> pSucceed Nothing <*> pSucceed Nothing

            <|> P_pointsize                             <$= "point_size" <*> pFloat
            <|> P_pointsprites                          <$= "point_sprites" <*> pOnOff
            <|> P_pointsizeattenuation                  <$= "point_size_attenuation" <*> pOnOff <*> (pFloat3 <|> pSucceed (1,0,0))
            <|> P_pointsizemin                          <$= "point_size_min" <*> pFloat
            <|> P_pointsizemax                          <$= "point_size_max" <*> pFloat

mkPass :: (Texture t, LinkedGpuProgram lp) => String -> [P_Attr t] -> Pass t lp
mkPass n l = Pass
    { psName                     = n

    , psAmbient                  = def (1,1,1,1)            $ lefts $ [x | P_ambient x <- l]
    , psDiffuse                  = def (1,1,1,1)            $ lefts $ [x | P_diffuse x <- l]
    , psSpecular                 = def (0,0,0,0)            $ lefts $ [x | P_specular x _ <- l]
    , psEmissive                 = def (0,0,0,0)            $ lefts $ [x | P_emissive x <- l]
    , psShininess                = def 0                    [x | P_specular _ x <- l]

    , psTracking                 = def (TrackVertexColourType False False False False)
                                                            [ TrackVertexColourType
                                                                (null $ lefts $ [x | P_ambient x <- l])
                                                                (null $ lefts $ [x | P_diffuse x <- l])
                                                                (null $ lefts $ [x | P_specular x _ <- l])
                                                                (null $ lefts $ [x | P_emissive x <- l])
                                                            ]

    , psSourceBlendFactor        = def SBF_ONE              $ [x | P_separatesceneblend ((x,_),_) <- l] ++ [x | P_sceneblend (x,_) <- l]
    , psDestBlendFactor          = def SBF_ZERO             $ [x | P_separatesceneblend ((_,x),_) <- l] ++ [x | P_sceneblend (_,x) <- l]
    , psSourceBlendFactorAlpha   = def SBF_ONE              [x | P_separatesceneblend (_,(x,_)) <- l]
    , psDestBlendFactorAlpha     = def SBF_ZERO             [x | P_separatesceneblend (_,(_,x)) <- l]

    , psSeparateBlend            = (not . null)             [() | P_separatesceneblend _ <- l]

    , psBlendOperation           = def SBO_ADD              $ [x | P_separatesceneblendop x _ <- l] ++ [x | P_sceneblendop x <- l]
    , psAlphaBlendOperation      = def SBO_ADD              [x | P_separatesceneblendop _ x <- l]
    , psSeparateBlendOperation   = (not . null)             [() | P_separatesceneblendop _ _ <- l]

    , psDepthCheck               = def True                 [x | P_depthcheck x <- l]
    , psDepthWrite               = def True                 [x | P_depthwrite x <- l]
    , psDepthFunc                = def CMPF_LESS_EQUAL      [x | P_depthfunc x <- l]
    , psDepthBiasConstant        = def 0                    [x | P_depthbias x _ <- l]
    , psDepthBiasSlopeScale      = def 0                    [x | P_depthbias _ x <- l]
    , psDepthBiasPerIteration    = def 0                    [x | P_iterationdepthbias x <- l]

    , psColourWrite              = def True                 [x | P_colourwrite x <- l]

    , psAlphaRejectFunc          = def CMPF_ALWAYS_PASS     [x | P_alpharejection x _ <- l]
    , psAlphaRejectVal           = def 0                    [x | P_alpharejection _ x <- l]
    , psAlphaToCoverageEnabled   = def False                [x | P_alphatocoverage x <- l]


	, psTransparentSorting       = def True                 [x | P_transparentsorting x _ <- l]
    , psTransparentSortingForced = def False                [x | P_transparentsorting _ x <- l]

    , psCullMode                 = def CULL_CLOCKWISE       [x | P_cullhardware x <- l]
    , psManualCullMode           = def MANUAL_CULL_BACK     [x | P_cullsoftware x <- l]

    , psLightingEnabled          = def True                 [x | P_lighting x <- l]
    , psMaxSimultaneousLights    = def 8                    [x | P_maxlights x <- l]
    , psStartLight               = def 0                    [x | P_startlight x <- l]
    , psLightsPerIteration       = def Nothing              [x | P_iteration _ x _ <- l]
    , psOnlyLightType            = def Nothing              [x | P_iteration _ _ x <- l]

    , psShadeOptions             = def SO_GOURAUD           [x | P_shading x <- l]
    , psPolygonMode              = def PM_SOLID             [x | P_polygonmode x <- l]

    , psNormaliseNormals         = def False                [x | P_normalisenormals x <- l]
    , psPolygonModeOverrideable  = def True                 [x | P_polygonmodeoverrideable x <- l]

    , psFogOverride              = def False                [x | P_fogoverride x _ _ _ _ _ <- l]
    , psFogMode                  = def FOG_NONE             [x | P_fogoverride _ x _ _ _ _  <- l]
    , psFogColour                = def (0,0,0,0)            [(r,g,b,1) | P_fogoverride _ _ (r,g,b) _ _ _ <- l]
    , psFogStart                 = def 0                    [x | P_fogoverride _ _ _ _ x _ <- l]
    , psFogEnd                   = def 0                    [x | P_fogoverride _ _ _ _ _ x <- l]
    , psFogDensity               = def 0                    [x | P_fogoverride _ _ _ x _ _ <- l]

    , psTextureUnitStates        = [x | P_textureunit x <- l]

    , psVertexProgramUsage       = def Nothing              [Just $ GpuProgramUsage x | P_vertexprogramref x _ <- l] -- TODO
    , psFragmentProgramUsage     = def Nothing              [Just $ GpuProgramUsage x | P_fragmentprogramref x _ <- l] -- TODO
    , psGeometryProgramUsage     = Nothing  -- TODO
    , psLinkedGpuProgram         = Nothing

    , psPassIterationCount       = def 1                    [x | P_iteration x _ _ <- l]

    , psPointSize                = def 0                    [x | P_pointsize x <- l]
    , psPointMinSize             = def 0                    [x | P_pointsizemin x <- l]
    , psPointMaxSize             = def 0                    [x | P_pointsizemax x <- l]
    , psPointSpritesEnabled      = def False                [x | P_pointsprites x <- l]
    , psPointAttenuationEnabled  = def False                [x | P_pointsizeattenuation x _ <- l]
    , psPointAttenuationCoeffs   = def (0,0,0)              [x | P_pointsizeattenuation _ x <- l]

    , psLightScissoring          = def False                [x | P_lightscissor x <- l]
    , psLightClipPlanes          = def False                [x | P_lightclipplanes x <- l]
    , psIlluminationStage        = def IS_UNKNOWN           [x | P_illuminationstage x <- l]
	}

-- * Texture
pTextureContent :: AnaParser [Token] Pair Token (Maybe Token) TX_Attr
pTextureContent =  TX_type        <$> pEnum textypeVals
               <|> TX_mipmap      <$> (pKey "unlimited" *> pSucceed MIP_UNLIMITED <|> MIP_NUMBER <$> pInt)
               <|> TX_alpha       <$= "alpha"
               <|> TX_pixelformat <$> pEnum pixelformatVals
               <|> TX_gamma       <$= "gamma"

-- * TextureUnit
pTextureUnitContent :: AnaParser [Token] Pair Token (Maybe Token) TU_Attr
pTextureUnitContent =  TU_texturealias      <$= "texture_alias" <*> pName
                    -- Format: texture <texturename> [<type>] [unlimited | numMipMaps] [alpha] [<PixelFormat>] [gamma]
                   <|> mkTU_Texture         <$= "texture" <*> pName <*> pList pTextureContent
                   -- Format1 (short): anim_texture <base_name> <num_frames> <duration>
--                   <|> mkTU_animtexture     <$= "anim_texture" <*> pName <*> pInt <*> pFloat
                   -- Format2 (long): anim_texture <frame1> <frame2> ... <duration>
--                   <|> TU_animtexture       <$= "anim_texture" <*> pList pName <*> pFloat
                   <|> (\a b -> TU_animtexture b a)       <$= "anim_texture" <*> pFloat <*> pList pName

                   -- Format2 (long): cubic_texture <front> <back> <left> <right> <up> <down> separateUV
                   <|> TU_cubictexture      <$= "cubic_texture" <*> pName <*> pName <*> pName <*> pName <*> pName <*> pName <*= "separateUV" <*> pSucceed False
                   -- Format1 (short): cubic_texture <base_name> <combinedUVW|separateUV>
                   <|> mkTU_cubictexture    <$= "cubic_texture" <*> pName <*> (True <$= "combinedUVW" <|> False <$= "separateUV" )

                   <|> TU_bindingtype       <$= "binding_type" <*> pEnum btyVals
                   <|> TU_contenttype       <$= "content_type" <*> pEnum ctyVals
                   <|> TU_texcoordset       <$= "tex_coord_set" <*> pInt

                   -- Extended Format: tex_address_mode <u_mode> <v_mode> [<w_mode>]
                   <|> TU_texaddressmode    <$= "tex_address_mode" <*> pEnum texaddressVals <*> pEnum texaddressVals <*> (pEnum texaddressVals <|> pSucceed TAM_WRAP)
                   -- Simple Format: tex_address_mode <uvw_mode>
                   <|> (\a -> TU_texaddressmode a a a) <$= "tex_address_mode" <*> pEnum texaddressVals

                   <|> TU_texbordercolour   <$= "tex_border_colour" <*> pRGBOrRGBA 1

                   -- Format: filtering <minification> <magnification> <mip>
                   <|> (\a b c -> TU_filtering (a,b,c))  <$= "filtering" <*> pEnum filteringVals <*> pEnum filteringVals <*> pEnum filteringVals
                   -- Format: filtering <none|bilinear|trilinear|anisotropic>
                   <|> TU_filtering         <$= "filtering" <*> pEnum texfilteringVals

                   <|> TU_maxanisotropy     <$= "max_anisotropy" <*> pInt
                   <|> TU_mipmapbias        <$= "mipmap_bias" <*> pFloat
                   <|> TU_colourop          <$= "colour_op" <*> pEnum copVals

                   -- Format: colour_op_ex <operation> <source1> <source2> [<manual_factor>] [<manual_colour1>] [<manual_colour2>]
                   <|> TU_colouropex        <$= "colour_op_ex" <*> pEnum layerblendopexVals <*> pEnum layerblendsrcVals <*> pEnum layerblendsrcVals <*> pFloat <*> pFloat4 <*> pFloat4
                   <|> TU_colouropex        <$= "colour_op_ex" <*> pEnum layerblendopexVals <*> pEnum layerblendsrcVals <*> pEnum layerblendsrcVals <*> pFloat <*> pFloat4 <*> pSucceed (1,1,1,1)
                   <|> TU_colouropex        <$= "colour_op_ex" <*> pEnum layerblendopexVals <*> pEnum layerblendsrcVals <*> pEnum layerblendsrcVals <*> pFloat <*> pSucceed (1,1,1,1) <*> pSucceed (1,1,1,1)
                   <|> TU_colouropex        <$= "colour_op_ex" <*> pEnum layerblendopexVals <*> pEnum layerblendsrcVals <*> pEnum layerblendsrcVals <*> pSucceed 0 <*> pSucceed (1,1,1,1) <*> pSucceed (1,1,1,1)

                   -- Format: colour_op_multipass_fallback <src_factor> <dest_factor>
                   <|> TU_colouropmultipassfallback . convertSBTtoSBF <$= "colour_op_multipass_fallback" <*> pEnum sceneblendVals
                   <|> curry TU_colouropmultipassfallback   <$= "colour_op_multipass_fallback" <*> pEnum blendVals <*> pEnum blendVals

                   <|> TU_alphaopex        <$= "alpha_op_ex" <*> pEnum layerblendopexVals <*> pEnum layerblendsrcVals <*> pEnum layerblendsrcVals <*> pFloat <*> pFloat <*> pFloat
                   <|> TU_alphaopex        <$= "alpha_op_ex" <*> pEnum layerblendopexVals <*> pEnum layerblendsrcVals <*> pEnum layerblendsrcVals <*> pFloat <*> pFloat <*> pSucceed 1
                   <|> TU_alphaopex        <$= "alpha_op_ex" <*> pEnum layerblendopexVals <*> pEnum layerblendsrcVals <*> pEnum layerblendsrcVals <*> pFloat <*> pSucceed 1 <*> pSucceed 1
                   <|> TU_alphaopex        <$= "alpha_op_ex" <*> pEnum layerblendopexVals <*> pEnum layerblendsrcVals <*> pEnum layerblendsrcVals <*> pSucceed 0 <*> pSucceed 1 <*> pSucceed 1

                   -- Format: env_map <off|spherical|planar|cubic_reflection|cubic_normal>
                   <|> TU_envmap            <$= "env_map" <*> pEnum envmapVals
                   <|> TU_scroll            <$= "scroll" <*> pFloat <*> pFloat
                   <|> TU_scrollanim        <$= "scroll_anim" <*> pFloat <*> pFloat
                   <|> TU_rotate            <$= "rotate" <*> pFloat
                   <|> TU_rotateanim        <$= "rotate_anim" <*> pFloat
                   <|> TU_scale             <$= "scale" <*> pFloat <*> pFloat

                   -- Format: wave_xform <xform_type> <wave_type> <base> <frequency> <phase> <amplitude>
                   <|> TU_wavexform         <$= "wave_xform" <*> pEnum xformtypeVals <*> pEnum wavetypeVals <*> pFloat <*> pFloat <*> pFloat <*> pFloat
                   <|> TU_transform         <$= "transform" <*> pFloat4 <*> pFloat4 <*> pFloat4 <*> pFloat4
  where
    mkTU_Texture n l = TU_texture n t m a p g
      where
        t = def TEX_TYPE_2D   [x    | TX_type x <- l]
        m = def MIP_UNLIMITED [x    | TX_mipmap x <- l]
        a = def False         [True | TX_alpha <- l]
        p = def PF_UNKNOWN    [x    | TX_pixelformat x <- l]
        g = def False         [True | TX_gamma <- l]
    f a e = (dropExtensions a) ++ e ++ (takeExtensions a)
    mkTU_cubictexture n True = TU_cubictexture n n n n n n True
    mkTU_cubictexture n False = TU_cubictexture (f n "_fr") (f n "_bk") (f n "_up") (f n "_dn") (f n "_lf") (f n "_rt") False
    -- Format1 (short): anim_texture <base_name> <num_frames> <duration>
    --mkTU_animtexture basename numframes duration = TU_animtexture [f basename $ show i | i <- [0..(numframes-1)]] duration

{-
    -- texture <texturename> [<type>] [unlimited | numMipMaps] [alpha] [<PixelFormat>] [gamma]
    | TU_texture                   String TextureType TextureMipmap Bool PixelFormat Bool
-}
mkTextureUnitState :: (Texture t) => String -> [TU_Attr] -> TextureUnitState t
mkTextureUnitState n l = TextureUnitState
    { tusAnimDuration               = def Nothing           [Just x | TU_animtexture _ x <- l]
    , tusCubic                      = def False           $ [TEX_TYPE_CUBE_MAP==x | TU_texture _ x _ _ _ _ <- l] ++ [True | TU_cubictexture _ _ _ _ _ _ _ <- l]

    , tusTextureType                = def TEX_TYPE_2D     $ [x | TU_texture _ x _ _ _ _ <- l] ++ [TEX_TYPE_CUBE_MAP | TU_cubictexture _ _ _ _ _ _ _ <- l]
    , tusDesiredFormat              = def PF_UNKNOWN        [x | TU_texture _ _ _ _ x _ <- l]
    , tusTextureSrcMipmaps          = def MIP_DEFAULT       [x | TU_texture _ _ x _ _ _ <- l]

    , tusTextureCoordSetIndex       = def 0                 [x | TU_texcoordset x <- l]
    , tusAddressMode                = def (UVWAddressingMode TAM_WRAP TAM_WRAP TAM_WRAP)
                                                            [UVWAddressingMode a b c | TU_texaddressmode a b c <- l]
    , tusBorderColour               = def (0,0,0,1)         [x | TU_texbordercolour x <- l]

    , tusColourBlendMode            = def cblendmode        [LayerBlendModeEx LBT_COLOUR op src1 src2 c1 c2 1 1 f | TU_colouropex op src1 src2 f c1 c2 <- (l ++ colouropex)]
    , tusColourBlendFallbackSrc     = def SBF_DEST_COLOUR   [x | TU_colouropmultipassfallback (x,_) <- (l ++ fallbackop)]
    , tusColourBlendFallbackDest    = def SBF_ZERO          [x | TU_colouropmultipassfallback (_,x) <- (l ++ fallbackop)]

    , tusAlphaBlendMode             = def ablendmode        [LayerBlendModeEx LBT_ALPHA op src1 src2 white white a1 a2 f | TU_alphaopex op src1 src2 f a1 a2 <- l]
    , tusIsAlpha                    = def False             [x | TU_texture _ _ _ x _ _ <- l]
    , tusHwGamma                    = def False             [x | TU_texture _ _ _ _ _ x <- l]

    , tusUMod                       = def 0                 [x | TU_scroll x _ <- l]
    , tusVMod                       = def 0                 [x | TU_scroll _ x <- l]
    , tusUScale                     = def 1                 [x | TU_scale x _ <- l]
    , tusVScale                     = def 1                 [x | TU_scale _ x <- l]
    , tusRotate                     = def 0                 [x | TU_rotate x <- l]

    , tusMinFilter                  = def FO_LINEAR         [x | TU_filtering (x,_,_) <- l]
    , tusMagFilter                  = def FO_LINEAR         [x | TU_filtering (_,x,_) <- l]
    , tusMipFilter                  = def FO_POINT          [x | TU_filtering (_,_,x) <- l]

    , tusMaxAniso                   = def 1                 [x | TU_maxanisotropy x <- l]
    , tusMipmapBias                 = def 0                 [x | TU_mipmapbias x <- l]

    , tusBindingType                = def BT_FRAGMENT       [x | TU_bindingtype x <- l]
    , tusContentType                = def CONTENT_NAMED     [x | TU_contenttype x <- l]


    , tusFrameNames                 = animFrames ++ cubeFrames ++ [n | TU_texture n _ _ _ _ _ <- l]
    , tusFrames                     = Nothing
    , tusName                       = n
    , tusTextureAlias               = def ""                [x | TU_texturealias x <- l]
    , tusEffects                    = [e | Just e <- map mkEffect l]
    }
  where
    white       = (1,1,1,1)
    colourop    = def LBO_MODULATE [x | TU_colourop x <- l]
    animFrames  = concat [x | TU_animtexture x _ <- l]
    cubeFrames  = concat [[a,b,c,d,e,f] | TU_cubictexture a b c d e f _ <- l]
    fallbackop  = case colourop of
        LBO_REPLACE       -> [TU_colouropmultipassfallback (SBF_ONE, SBF_ZERO)]
        LBO_ADD           -> [TU_colouropmultipassfallback (SBF_ONE, SBF_ONE)]
        LBO_MODULATE      -> [TU_colouropmultipassfallback (SBF_DEST_COLOUR, SBF_ZERO)]
        LBO_ALPHA_BLEND   -> [TU_colouropmultipassfallback (SBF_SOURCE_ALPHA, SBF_ONE_MINUS_SOURCE_ALPHA)]
    colouropex  = case colourop of
        LBO_REPLACE       -> [TU_colouropex LBX_SOURCE1               LBS_TEXTURE LBS_CURRENT 0 white white]
        LBO_ADD           -> [TU_colouropex LBX_ADD                   LBS_TEXTURE LBS_CURRENT 0 white white]
        LBO_MODULATE      -> [TU_colouropex LBX_MODULATE              LBS_TEXTURE LBS_CURRENT 0 white white]
        LBO_ALPHA_BLEND   -> [TU_colouropex LBX_BLEND_TEXTURE_ALPHA   LBS_TEXTURE LBS_CURRENT 0 white white]
    cblendmode  = LayerBlendModeEx
        { lbBlendType  = LBT_COLOUR
        , lbOperation  = LBX_MODULATE
        , lbSource1    = LBS_TEXTURE
        , lbSource2    = LBS_CURRENT
        , lbColourArg1 = white
        , lbColourArg2 = white
        , lbAlphaArg1  = 1
        , lbAlphaArg2  = 1
        , lbFactor     = 0
        }
    ablendmode  = LayerBlendModeEx
        { lbBlendType  = LBT_ALPHA
        , lbOperation  = LBX_MODULATE
        , lbSource1    = LBS_TEXTURE
        , lbSource2    = LBS_CURRENT
        , lbColourArg1 = white
        , lbColourArg2 = white
        , lbAlphaArg1  = 1
        , lbAlphaArg2  = 1
        , lbFactor     = 0
        }
    mkEffect e  = case e of
        TU_envmap _   -> Just $ TextureEffect
          { teType        = ET_ENVIRONMENT_MAP
          , teSubType     = 0
          , teArg1        = 0
          , teArg2        = 0
          , teWaveType    = WFT_SINE
          , teBase        = 0
          , teFrequency   = 0
          , tePhase       = 0
          , teAmplitude   = 0
          }
--      TU_scrollanim
--      TU_rotateanim
--      TU_wavexform
--      TU_transform
        _ -> Nothing

{-
    | TU_envmap                    (Maybe EnvMapType)
    | TU_scrollanim                FloatType FloatType
    | TU_rotateanim                FloatType
    | TU_wavexform                 TextureTransformType WaveformType FloatType FloatType FloatType FloatType
    | TU_transform                 FloatType4 FloatType4 FloatType4 FloatType4

    = TextureEffect
    { teType        :: TextureEffectType
    , teSubType     :: Int
    , teArg1        :: FloatType
    , teArg2        :: FloatType
    , teWaveType    :: WaveformType
    , teBase        :: FloatType
    , teFrequency   :: FloatType
    , tePhase       :: FloatType
    , teAmplitude   :: FloatType
    }
-}

-- * Shaders

pProgramContent :: AnaParser [Token] Pair Token (Maybe Token) SH_Attr
pProgramContent =  SH_source                    <$= "source" <*> pName
               <|> SH_attach                    <$= "attach" <*> pList pName
               <|> SH_includesskeletalanimation <$= "includes_skeletal_animation" <*> pBool
               <|> SH_includesmorphanimation    <$= "includes_morph_animation" <*> pBool
               <|> SH_includesposeanimation     <$= "includes_pose_animation" <*> pInt
               <|> SH_usesvertextexturefetch    <$= "uses_vertex_texture_fetch" <*> pBool
               <|> SH_usesadjacencyinformation  <$= "uses_adjacency_information" <*> pBool
               <|> SH_entrypoint                <$= "entry_point" <*> pName
               <|> SH_profiles                  <$= "profiles" <*> pList pName
               <|> SH_target                    <$= "target" <*> pName
               <|> SH_delegate                  <$= "delegate" <*> pName
--               <|> pPreprocessorDefines
               <|> SH_defaultparams             <$= "default_params" <*= "{" <*> pList pParamContent <*= "}"

--pPreprocessorDefines = (\_ d -> []) <$> pKey "preprocessor_defines" <*> pName -- TODO: parse defines correctly not with pName

--format: param_indexed         <index> <type>       <value>
--format: param_indexed_auto    <index> <value_code> <extra_params>
--format: param_named           <name>  <type>       <value>
--format: param_named_auto      <name>  <value_code> <extra_params>
--The value of 'type' can be float4, matrix4x4, float<n>, int4, int<n>

--("matrix4x4", 16, pFloat)
--("float"    , 1 , pFloat)
--("int"      , 1 , pInt)
--[("float" ++ show i,i,pFloat) | i <- [1..32]]
--[("int" ++ show i,i,pInt) | i <- [1..32]]

autoparamVals :: [(String, AutoConstantType)]
autoparamVals = [(n,v) | (v,n,_,_,_) <- autoConstantDictionary]

pParamContent :: AnaParser [Token] Pair Token (Maybe Token) PR_Attr
pParamContent =  PR_paramnamed       <$= "param_named" <*> pName <*> pVarid <*> pList pFloat
             <|> PR_paramnamedauto   <$= "param_named_auto" <*> pName <*> pEnum autoparamVals <*> pList pFloat
             <|> PR_paramindexed     <$= "param_indexed" <*> pInt <*> pVarid <*> pList pFloat
             <|> PR_paramindexedauto <$= "param_indexed_auto" <*> pInt <*> pEnum autoparamVals <*> pList pFloat


mkGpuProgramDesc :: (GpuProgram p) => GpuProgramType -> String -> String -> [SH_Attr] -> GpuProgramDescriptor p
mkGpuProgramDesc t name s l = GpuProgramDescriptor
    { gpdName               = name
    , gpdType               = t
    , gpdFilename           = def ""                [x | SH_source x <- l]
    , gpdSyntaxCode         = s
    , gpdAttach             = def []                [x | SH_attach x <- l]
    , gpdSkeletalAnimation  = def False             [x | SH_includesskeletalanimation x <- l]
    , gpdMorphAnimation     = def False             [x | SH_includesmorphanimation x <- l]
    , gpdPoseAnimation      = def 0                 [x | SH_includesposeanimation x <- l]
    , gpdVertexTextureFetch = def False             [x | SH_usesvertextexturefetch x <- l]
    , gpdNeedsAdjacencyInfo = def False             [x | SH_usesadjacencyinformation x <- l]
--    , gpdDefaultParams      :: GpuProgramParameters -- ^ The default parameters for use with this object
--    , gpdCompileError       = False
    , gpdGpuProgram         = Nothing
    }