{-# 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 [] [unlimited | numMipMaps] [alpha] [] [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 [lightType] -- Format 2: iteration [ [lightType]] -- Format 3: iteration [ [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 [] [unlimited | numMipMaps] [alpha] [] [gamma] <|> mkTU_Texture <$= "texture" <*> pName <*> pList pTextureContent -- Format1 (short): anim_texture -- <|> mkTU_animtexture <$= "anim_texture" <*> pName <*> pInt <*> pFloat -- Format2 (long): anim_texture ... -- <|> TU_animtexture <$= "anim_texture" <*> pList pName <*> pFloat <|> (\a b -> TU_animtexture b a) <$= "anim_texture" <*> pFloat <*> pList pName -- Format2 (long): cubic_texture separateUV <|> TU_cubictexture <$= "cubic_texture" <*> pName <*> pName <*> pName <*> pName <*> pName <*> pName <*= "separateUV" <*> pSucceed False -- Format1 (short): cubic_texture <|> 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 [] <|> TU_texaddressmode <$= "tex_address_mode" <*> pEnum texaddressVals <*> pEnum texaddressVals <*> (pEnum texaddressVals <|> pSucceed TAM_WRAP) -- Simple Format: tex_address_mode <|> (\a -> TU_texaddressmode a a a) <$= "tex_address_mode" <*> pEnum texaddressVals <|> TU_texbordercolour <$= "tex_border_colour" <*> pRGBOrRGBA 1 -- Format: filtering <|> (\a b c -> TU_filtering (a,b,c)) <$= "filtering" <*> pEnum filteringVals <*> pEnum filteringVals <*> pEnum filteringVals -- Format: filtering <|> 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 [] [] [] <|> 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 <|> 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 <|> 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 <|> 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 --mkTU_animtexture basename numframes duration = TU_animtexture [f basename $ show i | i <- [0..(numframes-1)]] duration {- -- texture [] [unlimited | numMipMaps] [alpha] [] [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 --format: param_indexed_auto --format: param_named --format: param_named_auto --The value of 'type' can be float4, matrix4x4, float, int4, int --("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 }