path: root/testdata/Graphics.lc

module Graphics where

import Material hiding (Blending)
import SampleMaterial

--texture' _ _ = V4 0.0 0.0 0.0 0.0 --PrimTexture
texture' = texture2D

singT = id

-- specialized snoc
v3v4 :: Vec 3 Float -> Vec 4 Float
v3v4 v = V4 v%x v%y v%z 1.0

v4v3 :: Vec 4 Float -> Vec 3 Float
v4v3 v = V3 v%x v%y v%z

-- specialized snoc
snoc :: Vec 3 Float -> Float -> Vec 4 Float
snoc v s = V4 v%x v%y v%z s

snoc' :: Vec 3 Float -> Float -> Vec 4 Float
snoc' v s = V4 v%x v%y v%z s

drop4 :: Vec 4 Float -> Vec 3 Float
drop4 v = V3 v%x v%y v%z

drop3 :: Vec 3 Float -> Vec 2 Float
drop3 v = V2 v%x v%y

mkRasterContext :: CommonAttrs -> RasterContext a Triangle
mkRasterContext ca = TriangleCtx cull PolygonFill offset LastVertex
  where
    offset  = if caPolygonOffset ca then Offset (-1) (-2) else NoOffset
    cull = case caCull ca of
        CT_FrontSided   -> CullFront
        CT_BackSided    -> CullBack
        CT_TwoSided     -> CullNone

mkaccumulationContext :: StageAttrs -> (FragmentOperation Depth, FragmentOperation (Color (Vec 4 Float)))
mkaccumulationContext sa = (DepthOp depthFunc depthWrite, ColorOp blend (one :: Vec 4 Bool))
  where
    depthWrite  = saDepthWrite sa
    depthFunc   = case saDepthFunc sa of
        D_Equal     -> Equal
        D_Lequal    -> Lequal
    cvt b = case b of
        B_DstAlpha          -> DstAlpha
        B_DstColor          -> DstColor
        B_One               -> OneBF
        B_OneMinusDstAlpha  -> OneMinusDstAlpha
        B_OneMinusDstColor  -> OneMinusDstColor
        B_OneMinusSrcAlpha  -> OneMinusSrcAlpha
        B_OneMinusSrcColor  -> OneMinusSrcColor
        B_SrcAlpha          -> SrcAlpha
        B_SrcAlphaSaturate  -> SrcAlphaSaturate
        B_SrcColor          -> SrcColor
        B_Zero              -> ZeroBF
    blend       = case saBlend sa of
        Nothing     -> NoBlending
        Just (src,dst)  -> Blend (FuncAdd,FuncAdd) ((srcF,dstF),(srcF,dstF)) one
          where
            srcF    = cvt src
            dstF    = cvt dst

mkWave' :: Float -> Wave -> Float
mkWave' off (Wave wFunc base amplitude phase freq) = base +! (a *! amplitude)
  where
    time        = Uniform "time" :: Float
    u           = off +! phase +! (freq *! time)
    uv          = V2 u 0
    name        = case wFunc of
        WT_Sin              -> "SinTable"
        WT_Triangle         -> "TriangleTable"
        WT_Square           -> "SquareTable"
        WT_Sawtooth         -> "SawToothTable"
        WT_InverseSawtooth  -> "InverseSawToothTable"
        WT_Noise            -> "Noise"
    sampler     = Sampler LinearFilter Repeat (Texture2DSlot name) -- (Texture2D (Float RGBA) n1)
    v           = (texture' sampler uv)%x
    a           = (v *! 2) -! 1

mkWave :: Wave -> Float
mkWave = mkWave' 0

mkColor :: CommonAttrs -> StageAttrs -> Vec 4 Float -> Vec 4 Float      -- V frequency
mkColor ca sa = \rgbaV ->
  let
    entityRGB       = Uniform "entityRGB" :: Vec 3 Float
    entityAlpha     = Uniform "entityAlpha" :: Float
    identityLight'  = Uniform "identityLight" :: Float
    --red             = V3 1 0 0
    white'          = V3 1 1 1.0
    rV  = rgbaV%r
    gV  = rgbaV%g
    bV  = rgbaV%b
    aV  = rgbaV%a
    rgb' :: Vec 3 Float
    rgb' = case saRGBGen sa of
        RGB_Wave w              -> let c = mkWave w in V3 c c c :: Vec 3 Float
        RGB_Const r g b         -> V3 r g b
        RGB_Identity            -> one
        RGB_IdentityLighting    -> V3 identityLight' identityLight' identityLight'
        RGB_Entity              -> entityRGB
        RGB_OneMinusEntity      -> one - entityRGB
        RGB_ExactVertex         -> V3 rV gV bV
        RGB_Vertex              -> (V3 rV gV bV) *! identityLight'
        RGB_LightingDiffuse     -> white' -- TODO
        {-  input:
                entity: ambientLight
                        directedLight
                        lightDir
                model:  position
                        normal
        -}
        RGB_OneMinusVertex      -> one - ((V3 rV gV bV) *! identityLight')

    alpha = case saAlphaGen sa of
        A_Wave w            -> let a = mkWave w in clamp a 0 1
        A_Const a           -> a
        A_Portal            -> 1 -- TODO
        A_Identity          -> 1
        A_Entity            -> entityAlpha
        A_OneMinusEntity    -> 1 -! entityAlpha
        A_Vertex            -> aV
        A_LightingSpecular  -> 1 -- TODO
        {-  input:
                model:  position
                        normal
                user:   viewOrigin
        -}
        A_OneMinusVertex    -> 1 -! aV
  in snoc' rgb' alpha

mkDeform :: Vec 2 Float -> Vec 3 Float -> Vec 3 Float -> Deform {-CPU-} -> Vec 3 Float
mkDeform uv normal pos = \d -> case d of
    D_Move v w   -> pos + (v *! mkWave w)
    D_Wave spread w -- todo @(Wave _ _ _ _ f)
        -> if (\(Wave _ _ _ _ f) -> f) w < 0.000001 then pos + (normal *! mkWave w)
           else
            let off         = (pos%x +! pos%y +! pos%z) *! spread
            in pos + (normal *! mkWave' off w)
{- todo
        | f < 0.000001  -> pos + (normal *! mkWave w)
        | otherwise     ->
            let off         = (pos%x +! pos%y +! pos%z) *! spread
            in pos + (normal *! mkWave' off w)
-}
    D_Bulge w h s   -> let time     = Uniform "time" :: Float
                           now      = time *! s
                           off      = (uv%x *! w) +! now
                       in pos + (normal *! sin off *! h)
    _ -> pos

{-
data TCMod
    = TM_EntityTranslate
-}
mkTCMod :: Vec 3 Float -> Vec 2 Float -> TCMod -> Vec 2 Float
mkTCMod pos uv = \m -> {- trace (show m) $ -} case m of
    TM_Scroll su sv -> uv + ((V2 su sv :: Vec 2 Float) *! (Uniform "time" :: Float))
    TM_Scale su sv  -> uv * (V2 su sv :: Vec 2 Float)
    TM_Stretch w    -> let p    = 1 /! mkWave w 
                           v0_5 = 0.5
                           off  = v0_5 -! (v0_5 *! p)
                       in (uv *! p) +! off
    TM_Rotate speed -> let time = Uniform "time" :: Float
                           fi   = (-speed *! pi /! 180) *! time
                           s    = sin fi
                           ms   = s *! (-1)
                           c    = cos fi
                           mA   = V2 c s
                           mB   = V2 ms c
                           m'   = M22F mA mB
                           v0_5 = 0.5
                           off  = V2 (v0_5 -! (v0_5 *! c) +! (v0_5 *! s)) (v0_5 -! (v0_5 *! s) -! (v0_5 *! c))
                       in (m' *. uv) + off
    TM_Transform m00 m01 m10 m11 t0 t1  -> let u   = uv%x
                                               v   = uv%y
                                               u'       = (u *! m00) +! (v *! m10) +! t0
                                               v'       = (u *! m01) +! (v *! m11) +! t1
                                           in V2 u' v'
    TM_Turb base amp phase freq ->  let u = uv%x
                                        v = uv%y
                                        x = pos%x
                                        y = pos%y
                                        z = pos%z
                                        time        = Uniform "time" :: Float
                                        now         = phase +! time *! freq
                                        offU        = (2 *! pi) *! (((x +! z) *! (0.125 /! 128)) +! now)
                                        offV        = (2 *! pi) *! ((y *! (0.125 /! 128)) +! now)
                                    in uv + (sin (V2 offU offV) *! amp)
    _ -> uv

mkTexCoord :: Vec 3 Float -> Vec 3 Float -> StageAttrs -> Vec 2 Float -> Vec 2 Float -> Vec 2 Float
mkTexCoord pos normal = \sa -> \uvD uvL -> let

    uv = case saTCGen sa of
        TG_Base         -> uvD
        TG_Lightmap     -> uvL
        TG_Environment  ->  let viewOrigin  = Uniform "viewOrigin" :: Vec 3 Float
                                viewer      = normalize (viewOrigin - pos)
                                d           = normal `PrimDot` viewer
                                reflected   = (normal *! (2 *! d)) - viewer
                                y = reflected%y
                                z = reflected%z
                                v0_5        = 0.5
                            in V2 (v0_5 +! (y *! v0_5)) (v0_5 -! (z *! v0_5))
        TG_Vector (V3 sx sy sz) (V3 tx ty tz)       -> let s    = V3 sx sy sz :: Vec 3 Float
                                                           t    = V3 tx ty tz :: Vec 3 Float
                                                       in V2 (pos `PrimDot` s) (pos `PrimDot` t)
    in foldl' (mkTCMod pos) uv (saTCMod sa)

--mkVertexShader :: CommonAttrs -> StageAttrs -> (Vec 3 Float,Vec 3 Float,Vec 2 Float,Vec 2 Float,Vec 4 Float) -> VertexOut (Vec 2 Float,Vec 4 Float)
mkVertexShader ca sa = \(p,n,d,l,c) ->
  let
        worldMat    = Uniform "worldMat" :: Mat 4 4 Float
        viewMat     = Uniform "viewMat" :: Mat 4 4 Float
        viewProj    = Uniform "viewProj" :: Mat 4 4 Float
        pos         = foldl' (mkDeform d n) p (caDeformVertexes ca)
        screenPos   = viewProj *. (worldMat *. snoc pos 1)
        norm        = drop4 (viewMat *. (worldMat *. snoc n 0))
        uv          = mkTexCoord pos n sa d l
        color       = mkColor ca sa c
  in (screenPos, uv, color)

--saTxName sa = saTextureUniform sa
saTextureUniform' (StageAttrs _ _ _ _ _ _ _ _ _ _ a) = a

mkFragmentShader :: StageAttrs -> (Vec 2 Float,Vec 4 Float) -> ((Vec 4 Float))
mkFragmentShader sa{- @(StageAttrs _ _ _ _ _ _ _ _ _ _ texName)-} = \(uv,rgba) ->
  let
    texName   = saTextureUniform' sa
    texColor em name = texture2D (Sampler LinearFilter em (Texture2DSlot name)) uv
    color       = case saTexture sa of
        ST_WhiteImage   -> rgba
        ST_Lightmap     -> rgba * texColor ClampToEdge "LightMap"
        ST_Map _        -> rgba * texColor Repeat texName
        ST_ClampMap _   -> rgba * texColor ClampToEdge texName
        ST_AnimMap _ _  -> rgba * texColor Repeat texName
  in ((color))

mkFilterFunction :: StageAttrs -> Maybe ((Vec 2 Float,Vec 4 Float) -> Bool)
mkFilterFunction sa = case saAlphaFunc sa of
    Nothing -> Nothing
    Just f  -> Just (\(uv,rgba) ->
        let
            texName = saTextureUniform' sa
            stageTex    = saTexture sa
            texColor em name = texture' sampler uv
              where
                sampler     = Sampler LinearFilter em (Texture2DSlot name) -- (Texture2D (Float RGBA) n1)
            color       = case stageTex of
                ST_WhiteImage   -> rgba
                ST_Lightmap     -> rgba * texColor ClampToEdge "LightMap"
                ST_Map _        -> rgba * texColor Repeat  texName
                ST_ClampMap _   -> rgba * texColor ClampToEdge texName
                ST_AnimMap _ _  -> rgba * texColor Repeat texName
            -- TODO: V4 _ _ _ a  = color
            a = color%a
        in case {- trace ("alpha filter: " ++ show f) -} f of
            A_Gt0   -> a > 0
            A_Lt128 -> a < 0.5
            A_Ge128 -> a >= 0.5
        )

maybe a b Nothing = a
maybe a b (Just x) = b x

type FB = FrameBuffer 1 '[ 'Depth, 'Color (Vec 4 Float)]

mkStage :: String -> CommonAttrs -> FB -> StageAttrs -> FB
mkStage name ca prevFB sa = Accumulate aCtx (mapFragments fSh (maybe id filterFragments fFun (rasterizePrimitives rCtx (Smooth, Smooth) (mapPrimitives vSh input)))) prevFB
  where
    input   =  fetch name ( Attribute "position"   :: Vec 3 Float
                          , Attribute "normal"     :: Vec 3 Float
                          , Attribute "diffuseUV"  :: Vec 2 Float
                          , Attribute "lightmapUV" :: Vec 2 Float
                          , Attribute "color"      :: Vec 4 Float
                          )
    rCtx    = mkRasterContext ca
    aCtx    = mkaccumulationContext sa
    vSh     = mkVertexShader ca sa
    fSh     = mkFragmentShader sa
    fFun    = mkFilterFunction sa

mkShader :: FB -> (String,CommonAttrs) -> FB
mkShader fb (name,ca) = foldl' (mkStage name ca) fb (caStages ca)

errorShaderFill :: FB -> FB
errorShaderFill fb = accumulate fragCtx frag rast fb
  where
    worldMat = Uniform "worldMat" :: Mat 4 4 Float
    viewProj = Uniform "viewProj" :: Mat 4 4 Float

--    vert :: (Vec 3 Float,Vec 4 Float) -> VertexOut (Vec 4 Float)
    vert (p,c) = (v4, c')
      where
        v4    = viewProj *. (worldMat *. snoc p 1)
        c'          = V4 c%r c%g c%b 0.5

    blend   = Blend (FuncAdd,Min) ((OneBF, OneBF), (OneBF, OneBF)) one
    fragCtx = accumulationContext (DepthOp Less False, ColorOp blend (one :: Vec 4 Bool))
    rastCtx = TriangleCtx CullNone PolygonFill NoOffset LastVertex
    input   = fetch "missing shader" (Attribute "position" :: Vec 3 Float, Attribute "color" :: Vec 4 Float)
    prims   = mapPrimitives vert input
    rast    = rasterizePrimitives rastCtx ((Smooth)) prims

--    frag :: Vec 4 Float -> (Depth, Color (Vec 4 Float))
    frag = \((v)) -> ((v))

errorShader :: FB -> FB
errorShader fb = accumulate fragCtx frag rast (errorShaderFill fb)
  where
    viewProj = Uniform "viewProj" :: Mat 4 4 Float
    worldMat = Uniform "worldMat" :: Mat 4 4 Float

--    vert :: (Vec 3 Float,Vec 4 Float) -> VertexOut (Vec 4 Float)
    vert (p,c) = (v4, c)
      where
        v4    = viewProj *. (worldMat *. snoc p 1)

    offset  = NoOffset--Offset (0) (-10)
    fragCtx = accumulationContext (DepthOp Lequal True, ColorOp NoBlending (one :: Vec 4 Bool))
    rastCtx = TriangleCtx CullNone (PolygonLine 1) offset LastVertex
    input   = fetch "missing shader" (Attribute "position" :: Vec 3 Float, Attribute "color" :: Vec 4 Float)
    prims   = mapPrimitives vert input
    rast    = rasterizePrimitives rastCtx ((Smooth)) prims

--    frag :: Vec 4 Float -> (Depth, Color (Vec 4 Float))
    frag = \((v)) -> ((V4 (1 - v%r) (1 - v%g) (1 - v%b) 1))

q3GFX :: [(String,CommonAttrs)] -> FB
q3GFX shl = {-blurVH $ PrjFrameBuffer "" tix0 $ -}errorShader (foldl' mkShader clear ordered)
  where
    ordered = sortBy (\(_,a) (_,b) -> caSort a `compare` caSort b) shl
    clear   = FrameBuffer (depthImage1 1000, colorImage1 (zero :: Vec 4 Float))

--main :: Output
main = ScreenOut (q3GFX sampleMaterial)