{-# LANGUAGE NoMonomorphismRestriction #-}
module Graphics.LambdaCube.Loader.CompositorScript (parseCompositor) where

import UU.Parsing
import UU.Scanner

import Data.Either
import Data.Maybe
import qualified Data.IntMap as IntMap

import Graphics.LambdaCube.Common
import Graphics.LambdaCube.Compositor
import Graphics.LambdaCube.GpuProgram
import Graphics.LambdaCube.Loader.Generated.CompositorScriptScanner
import Graphics.LambdaCube.Loader.ParserUtil
import Graphics.LambdaCube.PixelFormat
import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.Texture
import Graphics.LambdaCube.Types

parseCompositor :: (LinkedGpuProgram lp, Texture t) => String -> String -> IO (Maybe [Compositor t lp])
parseCompositor file txt = case parseTokens pCompositorScript (tokenize file txt) of
    Left errs -> do
        mapM_ (\m -> putStrLn $ "parseCompositor " ++ 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, LinkedGpuProgram lp) => CS_Attr t lp
    = CS_compositor     (Compositor t lp)

data (Texture t, LinkedGpuProgram lp) => C_Attr t lp
    = C_technique       (CompositionTechnique t lp)

data (Texture t, LinkedGpuProgram lp) => T_Attr t lp
    = T_target          (CompositionTargetPass t lp)
    | T_targetoutput    (CompositionTargetPass t lp)
    | T_texture         String (Either Int FloatType) (Either Int FloatType) [PixelFormat] Bool

data (Texture t, LinkedGpuProgram lp) => TR_Attr t lp
    = TR_input          InputMode
    | TR_onlyinitial    Bool
    | TR_visibilitymask Int
    | TR_lodbias        FloatType
    | TR_shadows        Bool
    | TR_materialscheme String
    | TR_pass           (CompositionPass t lp)

data P_Attr
    = P_material         String
    | P_input            Int String Int
    | P_identifier       Int
    | P_firstrenderqueue Int
    | P_lastrenderqueue  Int
    | P_buffers          [String]
    | P_colourvalue      ColourValue
    | P_depthvalue       FloatType
    | P_stencilvalue     Int
    | P_check            Bool
    | P_compfunc         CompareFunction
    | P_refvalue         Int
    | P_mask             Int
    | P_failop           StencilOperation
    | P_depthfailop      StencilOperation
    | P_passop           StencilOperation
    | P_twosided         Bool

-- * Compositor parser combinators

pCompositorScript :: (Texture t, LinkedGpuProgram lp) => AnaParser [Token] Pair Token (Maybe Token) [Compositor t lp]
pCompositorScript = mkCompositorScript <$> pList pCompositorScriptContent

mkCompositorScript :: (LinkedGpuProgram lp, Texture t) => [CS_Attr t lp] -> [Compositor t lp]
mkCompositorScript l = [x | CS_compositor x <- l]

pCompositorScriptContent :: (LinkedGpuProgram lp, Texture t) => AnaParser [Token] Pair Token (Maybe Token)  (CS_Attr t lp)
pCompositorScriptContent = pCompositor

-- * Compositor

pCompositor :: (LinkedGpuProgram lp, Texture t) => AnaParser [Token] Pair Token (Maybe Token) (CS_Attr t lp)
pCompositor = (CS_compositor .) . mkCompositor <$= "compositor" <*> pName <*= "{" <*> pList pCompositorContent <*= "}"

pCompositorContent :: (LinkedGpuProgram lp, Texture t) => AnaParser [Token] Pair Token (Maybe Token) (C_Attr t lp)
pCompositorContent = pTechnique

mkCompositor :: (Texture t, LinkedGpuProgram lp) => String -> [C_Attr t lp] -> Compositor t lp
mkCompositor name l = Compositor
    { cmpName                   = name
    , cmpTechniques             = [x | C_technique x <- l]
    , cmpSupportedTechniques    = Nothing
	}

-- * Technique

pTechnique :: (LinkedGpuProgram lp, Texture t) => AnaParser [Token] Pair Token (Maybe Token) (C_Attr t lp)
pTechnique = C_technique . mkTechnique <$= "technique" <*= "{" <*> pList pTechniqueContent <*= "}"

pTechniqueContent :: (LinkedGpuProgram lp, Texture t) => AnaParser [Token] Pair Token (Maybe Token) (T_Attr t lp)
pTechniqueContent =  T_texture         <$= "texture" <*> pName <*> pTexWidth <*> pTexHeight <*> pList (pEnum compositorPixelFormatVals) <*> (True <$= "shared" <|> pSucceed False)
                 <|> pTarget
                 <|> pTargetOutput

pTexWidth :: AnaParser [Token] Pair Token (Maybe Token) (Either Int FloatType)
pTexWidth =  Left       <$> pInt
         <|> Right 1    <$= "target_width"
         <|> Right      <$= "target_width_scaled" <*> pFloat

pTexHeight :: AnaParser [Token] Pair Token (Maybe Token) (Either Int FloatType)
pTexHeight =  Left      <$> pInt
          <|> Right 1   <$= "target_height"
          <|> Right     <$= "target_height_scaled" <*> pFloat

mkTechnique :: (Texture t, LinkedGpuProgram lp) => [T_Attr t lp] -> CompositionTechnique t lp
mkTechnique l = CompositionTechnique
    { ctTextureDefinitions  = [mkTextureDefinition n w h p s | T_texture n w h p s <- l]
    , ctTargetPasses        = [x | T_target x <- l]
    , ctOutputTarget        = head [x | T_targetoutput x <- l]
    , ctSchemeName          = "" -- TODO
    }
  where
    mkTextureDefinition n w h p s = TextureDefinition
        { tdName            = n
        , tdWidth           = listToMaybe $ map fromIntegral $ lefts [w]
        , tdHeight          = listToMaybe $ map fromIntegral $ lefts [h]
        , tdWidthFactor     = def 1 $ rights [w]
        , tdHeightFactor    = def 1 $ rights [h]
        , tdFormatList      = p
        , tdFsaa            = False
        , tdHwGammaWrite    = False
        , tdShared          = s
        , tdTexture         = Nothing
        }

-- * Target

pTargetOutput :: (LinkedGpuProgram lp, Texture t) => AnaParser [Token] Pair Token (Maybe Token) (T_Attr t lp)
pTargetOutput = T_targetoutput . (mkTarget "output") <$= "target_output" <*= "{" <*> pList pTargetContent <*= "}"

pTarget :: (LinkedGpuProgram lp, Texture t) => AnaParser [Token] Pair Token (Maybe Token) (T_Attr t lp)
pTarget = (T_target .) . mkTarget       <$= "target" <*> pName <*= "{" <*> pList pTargetContent <*= "}"

pTargetContent :: (Texture t, LinkedGpuProgram lp) => AnaParser [Token] Pair Token (Maybe Token) (TR_Attr t lp)
pTargetContent =  TR_input          <$= "input" <*> pEnum inputVals
              <|> TR_onlyinitial    <$= "only_initial" <*> pOnOff
              <|> TR_visibilitymask <$= "visibbility_mask" <*> pInt
              <|> TR_lodbias        <$= "lod_bias" <*> pFloat
              <|> TR_materialscheme <$= "material_scheme" <*> pName
              <|> TR_shadows        <$= "shadows" <*> pOnOff
              <|> pPass

mkTarget :: (Texture t, LinkedGpuProgram lp) => String -> [TR_Attr t lp] -> CompositionTargetPass t lp
mkTarget n l = CompositionTargetPass
    { ctpInputMode      = def IM_NONE       [x | TR_input x <- l]
    , ctpOutputName     = n
    , ctpOutput         = Nothing
    , ctpPasses         = [x | TR_pass x <- l]
    , ctpOnlyInitial    = def False         [x | TR_onlyinitial x <- l]
    , ctpVisibilityMask = def 4294967295    [fromIntegral x | TR_visibilitymask x <- l]
    , ctpLodBias        = def 1             [x | TR_lodbias x <- l]
    , ctpMaterialScheme = def ""            [x | TR_materialscheme x <- l]
    , ctpShadowsEnabled = def True          [x | TR_shadows x <- l]
    }

-- * Pass

pPass :: (Texture t, LinkedGpuProgram lp) => AnaParser [Token] Pair Token (Maybe Token) (TR_Attr t lp)
pPass =  TR_pass . (mkPass PT_RENDERQUAD)   <$= "pass" <*= "render_quad" <*= "{" <*> pList pPassRQContent <*= "}"
     <|> TR_pass . (mkPass PT_CLEAR)        <$= "pass" <*= "clear" <*= "{" <*> pList pPassCContent <*= "}"
     <|> TR_pass . (mkPass PT_STENCIL)      <$= "pass" <*= "stencil" <*= "{" <*> pList pPassSContent <*= "}"
     <|> TR_pass . (mkPass PT_RENDERSCENE)  <$= "pass" <*= "render_scene" <*= "{" <*> pList pPassRSContent <*= "}"

pIdentifier :: AnaParser [Token] Pair Token (Maybe Token) P_Attr
pIdentifier = P_identifier <$= "identifier" <*> pInt

pPassRQContent :: AnaParser [Token] Pair Token (Maybe Token) P_Attr
pPassRQContent = pIdentifier
              <|> P_material <$= "material" <*> pName
              <|> P_input    <$= "input" <*> pInt <*> pName <*> (pInt <|> pSucceed 0)

pPassRSContent :: AnaParser [Token] Pair Token (Maybe Token) P_Attr
pPassRSContent =  pIdentifier
              <|> P_firstrenderqueue <$= "first_render_queue" <*> pInt
              <|> P_lastrenderqueue  <$= "last_render_queue" <*> pInt

pPassCContent :: AnaParser [Token] Pair Token (Maybe Token) P_Attr
pPassCContent =  pIdentifier
             <|> P_buffers      <$= "buffers" <*> pList (pKey "colour" <|> pKey "depth" <|> pKey "stencil")
             <|> P_colourvalue  <$= "colour_value" <*> pRGBA
             <|> P_depthvalue   <$= "depth_value" <*> pFloat
             <|> P_stencilvalue <$= "stencil_value" <*> pInt

pPassSContent :: AnaParser [Token] Pair Token (Maybe Token) P_Attr
pPassSContent = pIdentifier
             <|> P_check       <$= "check" <*> pOnOff
             <|> P_compfunc    <$= "comp_func" <*> pEnum cmpfuncVals
             <|> P_refvalue    <$= "ref_value" <*> pInt
             <|> P_mask        <$= "mask" <*> pInt
             <|> P_failop      <$= "fail_op" <*> pEnum stencilopVals
             <|> P_depthfailop <$= "depth_fail_op" <*> pEnum stencilopVals
             <|> P_passop      <$= "pass_op" <*> pEnum stencilopVals
             <|> P_twosided    <$= "two_sided" <*> pOnOff

mkPass :: (LinkedGpuProgram lp, Texture t) => PassType -> [P_Attr] -> CompositionPass t lp
mkPass t l = CompositionPass
    { cpType                        = t
    , cpIdentifier                  = def 0             [fromIntegral x | P_identifier x <- l]
    , cpMaterialName                = def ""            [x | P_material x <- l]
    , cpMaterial                    = Nothing
    , cpFirstRenderQueue            = def 5             [x | P_firstrenderqueue x <- l]
    , cpLastRenderQueue             = def 95            [x | P_lastrenderqueue x <- l]
    , cpClearBuffers                = def (True,True,False) [(elem "colour" x, elem "depth" x, elem "stencil" x) | P_buffers x <- l]
    , cpClearColour                 = def (0,0,0,0)     [x | P_colourvalue x <- l]
    , cpClearDepth                  = def 0             [x | P_depthvalue x <- l]
    , cpClearStencil                = def 0             [fromIntegral x | P_stencilvalue x <- l]
    , cpInputs                      = IntMap.fromList   [(i,InputTex n mi) | P_input i n mi <- l]
    , cpStencilCheck                = def False         [x | P_check x <- l]
    , cpStencilFunc                 = def CMPF_LESS     [x | P_compfunc x <- l]
    , cpStencilRefValue             = def 0             [fromIntegral x | P_refvalue x <- l]
    , cpStencilMask                 = def 0xFFFFFFFF    [fromIntegral x | P_mask x <- l]
    , cpStencilFailOp               = def SOP_KEEP      [x | P_failop x <- l]
    , cpStencilDepthFailOp          = def SOP_KEEP      [x | P_depthfailop x <- l]
    , cpStencilPassOp               = def SOP_KEEP      [x | P_passop x <- l]
    , cpStencilTwoSidedOperation    = def False         [x | P_twosided x <- l]
--    , cpQuadCornerModified          :: Bool             -- ^ true if quad should not cover whole screen
--    , cpQuadLeft                    :: FloatType        -- ^ quad positions in normalised coordinates [-1;1]x[-1;1] (in case of PT_RENDERQUAD)
--    , cpQuadTop                     :: FloatType
--    , cpQuadRight                   :: FloatType
--    , cpQuadBottom                  :: FloatType
--    , cpQuadFarCorners              :: Bool
--    , cpQuadFarCornersViewSpace     :: Bool
    }

{-
mkPassS l =
    (def Nothing [Just x | P_identifier x <- l],
    CompositionStencilPass
    { stCheck       = def False [x | P_check x <- l]
    , stCompFunc    = def CMPF_LESS [x | P_compfunc x <- l]
    , stRefValue    = def 0 [x | P_refvalue x <- l]
    , stMask        = def 4294967295 [x | P_mask x <- l]
    , stFailOp      = def SOP_KEEP [x | P_failop x <- l]
    , stDepthFailOp = def SOP_KEEP [x | P_depthfailop x <- l]
    , stPassOp      = def SOP_KEEP [x | P_passop x <- l]
    , stTwoSided    = def False [x | P_twosided x <- l]
    })
mkPassRQ l =
    (def Nothing [Just x | P_identifier x <- l],
    CompositionRenderQuadPass
    { rqMaterial = def "" [x | P_material x <- l]
    , rqInput    = def (0,"",0) [(a,b,c) | P_input a b c <- l]
    })

mkPassC l =
    (def Nothing [Just x | P_identifier x <- l],
    CompositionClearPass
    { clBuffers      = def (True,True,False) [(elem "colour" x, elem "depth" x, elem "stencil" x) | P_buffers x <- l]
    , clColourValue  = def (0,0,0,0) [x | P_colourvalue x <- l]
    , clDepthValue   = def 0 [x | P_depthvalue x <- l]
    , clStencilValue = def 0 [x | P_stencilvalue x <- l]
    })

mkPassRS l =
    (def Nothing [Just x | P_identifier x <- l],
    CompositionRenderScenePass
    { rsFirstRenderQueue = def 5 [x | P_firstrenderqueue x <- l]
    , rsLastRenderQueue  = def 95 [x | P_lastrenderqueue x <- l]
    })

-}