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
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)
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
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
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
| P_shadowreceiververtexprogramref
| P_shadowreceiverfragmentprogramref
| 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)
| P_pointsize FloatType
| P_pointsprites Bool
| P_pointsizeattenuation Bool FloatType3
| P_pointsizemin FloatType
| P_pointsizemax FloatType
data TU_Attr
= TU_texturealias String
| 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
data TX_Attr
= TX_type TextureType
| TX_mipmap TextureMipmap
| TX_alpha
| TX_pixelformat PixelFormat
| TX_gamma
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]
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 <*= "}"
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
, mtReceiveShadows = def True [x | M_receiveshadows x <- l]
, mtTransparencyCastsShadows = def False [x | M_transparencycastsshadows x <- l]
, mtTechniques = [x | M_technique x <- l]
, mtSupportedTechniques = Nothing
, mtUserLodValues = []
, mtLodValues = []
, mtUnsupportedReasons = ""
}
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
{ tchName = n
, tchSchemeIndex = 0
, tchLodIndex = def 0 [x | T_lodindex x <- l]
, tchPasses = [x | T_pass x <- l]
, tchGPUVendorRules = []
, tchGPUDeviceNameRules = []
}
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 <$= "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
<|> 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]
, psFragmentProgramUsage = def Nothing [Just $ GpuProgramUsage x | P_fragmentprogramref x _ <- l]
, psGeometryProgramUsage = Nothing
, 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]
}
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"
pTextureUnitContent :: AnaParser [Token] Pair Token (Maybe Token) TU_Attr
pTextureUnitContent = TU_texturealias <$= "texture_alias" <*> pName
<|> mkTU_Texture <$= "texture" <*> pName <*> pList pTextureContent
<|> (\a b -> TU_animtexture b a) <$= "anim_texture" <*> pFloat <*> pList pName
<|> TU_cubictexture <$= "cubic_texture" <*> pName <*> pName <*> pName <*> pName <*> pName <*> pName <*= "separateUV" <*> pSucceed False
<|> 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
<|> TU_texaddressmode <$= "tex_address_mode" <*> pEnum texaddressVals <*> pEnum texaddressVals <*> (pEnum texaddressVals <|> pSucceed TAM_WRAP)
<|> (\a -> TU_texaddressmode a a a) <$= "tex_address_mode" <*> pEnum texaddressVals
<|> TU_texbordercolour <$= "tex_border_colour" <*> pRGBOrRGBA 1
<|> (\a b c -> TU_filtering (a,b,c)) <$= "filtering" <*> pEnum filteringVals <*> pEnum filteringVals <*> pEnum filteringVals
<|> TU_filtering <$= "filtering" <*> pEnum texfilteringVals
<|> TU_maxanisotropy <$= "max_anisotropy" <*> pInt
<|> TU_mipmapbias <$= "mipmap_bias" <*> pFloat
<|> TU_colourop <$= "colour_op" <*> pEnum copVals
<|> 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)
<|> 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
<|> 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
<|> 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
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
}
_ -> Nothing
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
<|> SH_defaultparams <$= "default_params" <*= "{" <*> pList pParamContent <*= "}"
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]
, gpdGpuProgram = Nothing
}