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)