Reduce rendertype down to vertex information
This commit is contained in:
+6
-6
@@ -54,12 +54,12 @@ doSideEffects preData w = do
|
||||
|
||||
endTicks <- SDL.ticks
|
||||
let lastFrameTicks = _frameTimer preData
|
||||
when (_displaySecondsPerFrame $ _debugFlags w) $ void $ renderFoldable
|
||||
(_renderData preData)
|
||||
(map snd $ setDepth (-1)
|
||||
. translate (-0.5) (-0.8) . scale 0.0005 0.0005
|
||||
. text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
|
||||
)
|
||||
-- FIXME when (_displaySecondsPerFrame $ _debugFlags w) $ void $ renderFoldable
|
||||
-- FIXME (_renderData preData)
|
||||
-- FIXME (map snd $ setDepth (-1)
|
||||
-- FIXME . translate (-0.5) (-0.8) . scale 0.0005 0.0005
|
||||
-- FIXME . text $ "ms/frame " ++ show (endTicks - lastFrameTicks)
|
||||
-- FIXME )
|
||||
foldr (=<<) (return (preData & soundData . playingSounds .~ newPlayingSounds
|
||||
& frameTimer .~ endTicks)) (_doneSideEffects w)
|
||||
|
||||
|
||||
@@ -21,7 +21,7 @@ data RenderData = RenderData
|
||||
, _colorBlurShader :: FullShader
|
||||
, _barrelShader :: FullShader
|
||||
, _grayscaleShader :: FullShader
|
||||
, _pictureShaders :: [FullShader]
|
||||
, _pictureShaders :: [VShader]
|
||||
, _fbo2 :: (FramebufferObject, TextureObject)
|
||||
, _fbo3 :: (FramebufferObject, TextureObject)
|
||||
, _fboFourth1 :: (FramebufferObject, TextureObject)
|
||||
|
||||
+2
-2
@@ -79,7 +79,7 @@ doDrawing pdata w = do
|
||||
else renderBlankWalls pdata nWalls
|
||||
--_ <- renderFoldable pdata $ (picToAlt (Just 0) (polysToPic $ foregroundPics w) :: [RenderType])
|
||||
--_ <- renderFoldable pdata $ (picToAlt (Just 0) pic :: [RenderType])
|
||||
_ <- renderFoldable pdata $ map snd (polysToPic $ foregroundPics w)
|
||||
-- FIXME _ <- renderFoldable pdata $ map snd (polysToPic $ foregroundPics w)
|
||||
|
||||
--_ <- renderFoldable pdata $ map snd $ filter ((==0).fst) pic
|
||||
vnums <- pokeBindFoldableLayer pdata $ pic
|
||||
@@ -175,7 +175,7 @@ doDrawing pdata w = do
|
||||
depthMask $= Disabled
|
||||
blend $= Enabled
|
||||
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
||||
_ <- renderFoldable pdata $ map snd (fixedCoordPictures w)
|
||||
-- FIXME _ <- renderFoldable pdata $ map snd (fixedCoordPictures w)
|
||||
depthMask $= Enabled
|
||||
|
||||
eTicks <- SDL.ticks
|
||||
|
||||
+13
-14
@@ -18,20 +18,19 @@ import Polyhedra.Data
|
||||
import Control.Lens
|
||||
import Data.Maybe
|
||||
import Data.List (partition)
|
||||
import qualified Data.IntMap.Strict as IM
|
||||
import qualified Data.IntMap.Lazy as IM
|
||||
|
||||
worldPictures :: World -> Picture
|
||||
worldPictures w = pictures $ concat
|
||||
[ IM.elems $ _decorations w
|
||||
, map (dbArg _pjDraw) . IM.elems $ _projectiles w
|
||||
, map drawItem . IM.elems $ _floorItems w
|
||||
, map (crDraw w) . IM.elems $ _creatures w
|
||||
, map clDraw . reverse $ _clouds w
|
||||
, map ppDraw . IM.elems $ _pressPlates w
|
||||
, map btDraw (IM.elems (_buttons w))
|
||||
, map (dbArg _ptDraw) $ _particles w
|
||||
, map drawWallFloor (wallFloorsToDraw w)
|
||||
, testPic w
|
||||
worldPictures w =
|
||||
concat (IM.elems $ _decorations w) ++ testPic w ++ concat
|
||||
[ concatMap (dbArg _pjDraw) . IM.elems $ _projectiles w
|
||||
, concatMap drawItem . IM.elems $ _floorItems w
|
||||
, concatMap (crDraw w) . IM.elems $ _creatures w
|
||||
, concatMap clDraw . reverse $ _clouds w
|
||||
, concatMap ppDraw . IM.elems $ _pressPlates w
|
||||
, concatMap btDraw (IM.elems (_buttons w))
|
||||
, concatMap (dbArg _ptDraw) $ _particles w
|
||||
, concatMap drawWallFloor (wallFloorsToDraw w)
|
||||
]
|
||||
foregroundPics :: World -> [Polyhedra]
|
||||
foregroundPics = _foregroundDecorations
|
||||
@@ -53,8 +52,8 @@ customMouseCursor w =
|
||||
. color white
|
||||
$ pictures [ line [(-5,0),(5,0)] , line [(0,-5),(0,5)] ]
|
||||
|
||||
testPic :: World -> [Picture]
|
||||
testPic _ = [blank]
|
||||
testPic :: World -> Picture
|
||||
testPic _ = blank
|
||||
-- [ setDepth (-1) . translate 0 0.8
|
||||
-- . scale 0.001 0.001 . text . show $ _crMvDir $ you w
|
||||
-- ]
|
||||
|
||||
+39
-63
@@ -59,7 +59,7 @@ import Data.List
|
||||
import Data.Bifunctor
|
||||
--import qualified Data.DList as DL
|
||||
--import Graphics.Rendering.OpenGL (lineWidth, ($=))
|
||||
--import Control.Lens
|
||||
import Control.Lens
|
||||
|
||||
black :: RGBA
|
||||
black = (0,0,0,1)
|
||||
@@ -69,17 +69,21 @@ zl rt = [(0,rt)]
|
||||
|
||||
polygon :: [Point2] -> Picture
|
||||
{-# INLINE polygon #-}
|
||||
polygon ps = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
polygon ps = map (f . zeroZ) $ polyToTris ps
|
||||
where
|
||||
f pos = Verx pos black PolyV 0
|
||||
|
||||
polygonZ :: [Point2] -> Float -> Picture
|
||||
{-# INLINE polygonZ #-}
|
||||
polygonZ ps z = zl $ RenderPolyZ $ zip3 (map zeroZ $ polyToTris ps) (repeat black) (repeat z)
|
||||
polygonZ ps z = map (f . zeroZ) $ polyToTris ps
|
||||
where
|
||||
f pos = Verx pos black (PolyzV z) 0
|
||||
|
||||
polygonCol :: [(Point2,RGBA)] -> Picture
|
||||
{-# INLINE polygonCol #-}
|
||||
polygonCol vs = zl $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
where
|
||||
(ps,cs) = unzip vs
|
||||
polygonCol vs = map f $ polyToTris vs
|
||||
where
|
||||
f ((x,y),col) = Verx (x,y,0) col PolyV 0
|
||||
|
||||
poly3 :: [Point3] -> Picture
|
||||
{-# INLINE poly3 #-}
|
||||
@@ -87,7 +91,9 @@ poly3 = poly3Col . map (, black)
|
||||
|
||||
poly3Col :: [(Point3,RGBA)] -> Picture
|
||||
{-# INLINE poly3Col #-}
|
||||
poly3Col vs = zl $ RenderPoly $ polyToTris vs
|
||||
poly3Col vs = map f $ polyToTris vs
|
||||
where
|
||||
f (pos,col) = Verx pos col PolyV 0
|
||||
|
||||
-- note that much of work computing the width of the bezier curve is done here
|
||||
bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
|
||||
@@ -124,12 +130,10 @@ bezierQuad cola colc ra rc a b c
|
||||
fa' = extrapolate aIn cIn bIn
|
||||
fc' = extrapolate cIn aIn bIn
|
||||
|
||||
bzhelp :: [(Point2, Point4, (Float, Float), (Float, Float))] -> [(Int, RenderType)]
|
||||
bzhelp vs = zl $ RenderBezQ $ zip3 (map zeroZ ps) cols rs
|
||||
where
|
||||
(ps,cols,offps,rads) = unzip4 vs
|
||||
rs = zipWith (\(x,y) (z,w) -> (x,y,z,w)) offps rads
|
||||
|
||||
bzhelp :: [(Point2, Point4, (Float, Float), (Float, Float))] -> Picture
|
||||
bzhelp = map f
|
||||
where
|
||||
f ((x,y),col,(a,b),(c,d)) = Verx (x,y,0) col (BezV (a,b,c,d)) 0
|
||||
|
||||
-- given a one and two zeros of a linear function over x and y,
|
||||
-- determine the function
|
||||
@@ -148,8 +152,7 @@ extrapolate (ox,oy) (ax,ay) (bx,by) (x,y) =
|
||||
|
||||
color :: RGBA -> Picture -> Picture
|
||||
{-# INLINE color #-}
|
||||
--color c = map $ second $ overCol (const c)
|
||||
color c = map $ overCol' (const c)
|
||||
color c = map $ overCol (const c)
|
||||
|
||||
translate3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE translate3 #-}
|
||||
@@ -158,21 +161,23 @@ translate3 a b (x,y,z) = (x+a,y+b,z)
|
||||
translate :: Float -> Float -> Picture -> Picture
|
||||
--{-# INLINE translate #-}
|
||||
--translate x y = map $ second $ overPos (translate3 x y)
|
||||
translate x y = map $ overPos' (translate3 x y)
|
||||
translate x y = map $ overPos (translate3 x y)
|
||||
|
||||
setDepth :: Float -> Picture -> Picture
|
||||
--{-# INLINE setDepth #-}
|
||||
--setDepth d = map $ second $ overPos (\(x,y,_) -> (x,y,d))
|
||||
setDepth d = map $ overPos' (\(x,y,_) -> (x,y,d))
|
||||
setDepth d = map $ overPos (\(x,y,_) -> (x,y,d))
|
||||
|
||||
addDepth :: Float -> Picture -> Picture
|
||||
--{-# INLINE addDepth #-}
|
||||
--addDepth d = map $ second $ overPos (\(x,y,z) -> (x,y,z+d))
|
||||
addDepth d = map $ overPos' (\(x,y,z) -> (x,y,z+d))
|
||||
addDepth d = map $ overPos (\(x,y,z) -> (x,y,z+d))
|
||||
|
||||
setLayer :: Int -> Picture -> Picture
|
||||
{-# INLINE setLayer #-}
|
||||
setLayer = map . first . const
|
||||
setLayer i = map $ f
|
||||
where
|
||||
f v = v {_vxLayer = i}
|
||||
|
||||
scale3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE scale3 #-}
|
||||
@@ -181,12 +186,11 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
|
||||
scale :: Float -> Float -> Picture -> Picture
|
||||
--{-# INLINE scale #-}
|
||||
--scale x y = map . second . overPos $ scale3 x y
|
||||
scale x y = map $ overPos' $ scale3 x y
|
||||
scale x y = map $ overPos $ scale3 x y
|
||||
|
||||
rotate :: Float -> Picture -> Picture
|
||||
--{-# INLINE rotate #-}
|
||||
--rotate a = map . second . overPos $ rotate3 a
|
||||
rotate a = map $ overPos' $ rotate3 a
|
||||
rotate a = map $ overPos $ rotate3 a
|
||||
|
||||
pictures :: [Picture] -> Picture
|
||||
{-# INLINE pictures #-}
|
||||
@@ -205,11 +209,13 @@ circleSolid = circleSolidCol white white
|
||||
|
||||
circleSolidCol :: Color -> Color -> Float -> Picture
|
||||
{-# INLINE circleSolidCol #-}
|
||||
circleSolidCol colC colE r = zl $ RenderEllipse
|
||||
circleSolidCol colC colE r = map f
|
||||
[( (-r, r,0), colC)
|
||||
,( (-r,-r,0), colE)
|
||||
,( ( r,-r,0), black)
|
||||
]
|
||||
where
|
||||
f (pos,col) = Verx pos col EllV 0
|
||||
|
||||
circle :: Float -> Picture
|
||||
{-# INLINE circle #-}
|
||||
@@ -217,7 +223,9 @@ circle rad = thickArc 0 (2*pi) rad 1
|
||||
|
||||
text :: String -> Picture
|
||||
{-# INLINE text #-}
|
||||
text s = zl $ RenderText $ stringToList s
|
||||
text s = map f $ stringToList s
|
||||
where
|
||||
f (pos,col,val) = Verx pos col (TextV val) 0
|
||||
|
||||
line :: [Point2] -> Picture
|
||||
{-# INLINE line #-}
|
||||
@@ -286,8 +294,8 @@ thickArc startA endA rad wdth
|
||||
r = rad + 0.5 * wdth
|
||||
w = 1 - wdth / r
|
||||
|
||||
thickArcHelp :: Float -> Float -> Float -> Float -> [(Int, RenderType)]
|
||||
thickArcHelp startA endA rad wdth = zl $ RenderArc
|
||||
thickArcHelp :: Float -> Float -> Float -> Float -> [Verx]
|
||||
thickArcHelp startA endA rad wdth = map f
|
||||
[( (0,0,0),black,(0,0,wdth))
|
||||
,((xa,ya,0),black,(1,0,wdth))
|
||||
,((xb,yb,0),black,(1,1,wdth))
|
||||
@@ -299,6 +307,7 @@ thickArcHelp startA endA rad wdth = zl $ RenderArc
|
||||
(xa,ya) = rotateV startA (rad,0)
|
||||
(xb,yb) = rotateV (0.5 * (startA + endA)) (rad * sqrt 2,0)
|
||||
(xc,yc) = rotateV endA (rad,0)
|
||||
f (pos,col,val) = Verx pos col (ArcV val) 0
|
||||
|
||||
withAlpha :: Float -> RGBA -> RGBA
|
||||
{-# INLINE withAlpha #-}
|
||||
@@ -342,45 +351,12 @@ bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
|
||||
greyN :: Float -> Color
|
||||
greyN x = (x,x,x,1)
|
||||
|
||||
overPos' :: (Point3 -> Point3) -> (Int,RenderType) -> (Int,RenderType)
|
||||
--{-# INLINE overPos' #-}
|
||||
overPos' f (i,RenderPoly vs) = (i, RenderPoly $ map (first f) vs )
|
||||
overPos' f (i,RenderText vs) = (i, RenderText $ map (\(a,b,c) -> (f a,b,c)) vs )
|
||||
overPos' f (i,RenderBezQ vs) = (i, RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs )
|
||||
overPos' f (i,RenderEllipse vs) = (i, RenderEllipse $ map (first f) vs )
|
||||
overPos' f (i,RenderArc vs) = (i, RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs )
|
||||
overPos' f (i,RenderPolyZ vs) = (i, RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs )
|
||||
overPos' _ rt = rt
|
||||
|
||||
overPos :: (Point3 -> Point3) -> RenderType -> RenderType
|
||||
overPos :: (Point3 -> Point3) -> Verx -> Verx
|
||||
{-# INLINE overPos #-}
|
||||
overPos f (RenderPoly vs) = RenderPoly $ map (first f) vs
|
||||
overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
|
||||
overPos f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (f a,b,c)) vs
|
||||
overPos f (RenderEllipse vs) = RenderEllipse $ map (first f) vs
|
||||
overPos f (RenderArc vs) = RenderArc $ map (\(a,b,c) -> (f a,b,c)) vs
|
||||
overPos f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (f a,b,c)) vs
|
||||
overPos _ rt = rt
|
||||
overPos = over vxPos
|
||||
|
||||
overCol' :: (Point4 -> Point4) -> (Int,RenderType) -> (Int,RenderType)
|
||||
--{-# INLINE overCol #-}
|
||||
overCol' f (i,(RenderPoly vs) ) = (i,RenderPoly $ map (second f) vs )
|
||||
overCol' f (i,(RenderEllipse vs)) = (i,RenderEllipse $ map (second f) vs )
|
||||
overCol' f (i,(RenderText vs) ) = (i,RenderText $ map (\(a,b,c) -> (a,f b,c)) vs )
|
||||
overCol' f (i,(RenderBezQ vs) ) = (i,RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs )
|
||||
overCol' f (i,(RenderArc vs) ) = (i,RenderArc $ map (\(a,b,c) -> (a,f b,c)) vs )
|
||||
overCol' f (i,(RenderPolyZ vs) ) = (i,RenderPolyZ $ map (\(a,b,c) -> (a,f b,c)) vs )
|
||||
overCol' _ _ = undefined
|
||||
|
||||
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
|
||||
--{-# INLINE overCol #-}
|
||||
overCol f (RenderPoly vs) = RenderPoly $ map (second f) vs
|
||||
overCol f (RenderEllipse vs) = RenderEllipse $ map (second f) vs
|
||||
overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
|
||||
overCol f (RenderBezQ vs) = RenderBezQ $ map (\(a,b,c) -> (a,f b,c)) vs
|
||||
overCol f (RenderArc vs) = RenderArc $ map (\(a,b,c) -> (a,f b,c)) vs
|
||||
overCol f (RenderPolyZ vs) = RenderPolyZ $ map (\(a,b,c) -> (a,f b,c)) vs
|
||||
overCol _ _ = undefined
|
||||
overCol :: (Point4 -> Point4) -> Verx -> Verx
|
||||
overCol = over vxCol
|
||||
|
||||
-- no premature optimisation, consider changing to use texture arrays
|
||||
stringToList :: String -> [(Point3,Point4,Point2)]
|
||||
|
||||
+26
-22
@@ -1,4 +1,4 @@
|
||||
--{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
--{-# LANGUAGE Strict #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
module Picture.Data
|
||||
@@ -15,17 +15,31 @@ import Data.Foldable
|
||||
--import qualified Data.Sequence as Se
|
||||
--import qualified Data.DList as DL
|
||||
--import qualified Data.Vector as V
|
||||
--import Control.Lens
|
||||
import Control.Lens
|
||||
--import Control.Monad
|
||||
|
||||
data Verx = Verx
|
||||
{ _vxPos :: Point3
|
||||
, _vxCol :: Point4
|
||||
, _vxType :: VertexType
|
||||
, _vxLayer :: Int
|
||||
}
|
||||
data VertexType
|
||||
= PolyV
|
||||
| PolyzV Float
|
||||
| BezV Point4
|
||||
| TextV Point2
|
||||
| ArcV Point3
|
||||
| EllV
|
||||
|
||||
data RenderType
|
||||
= RenderPoly [(Point3,Point4)]
|
||||
| RenderPolyZ [(Point3,Point4,Float)]
|
||||
| RenderBezQ [(Point3,Point4,Point4)]
|
||||
| RenderText [(Point3,Point4,Point2)]
|
||||
| RenderArc [(Point3,Point4,Point3)]
|
||||
| RenderEllipse [(Point3,Point4)]
|
||||
| Render3 [Point3]
|
||||
-- -= RenderPoly [(Point3,Point4)]
|
||||
-- -| RenderPolyZ [(Point3,Point4,Float)]
|
||||
-- -| RenderBezQ [(Point3,Point4,Point4)]
|
||||
-- -| RenderText [(Point3,Point4,Point2)]
|
||||
-- -| RenderArc [(Point3,Point4,Point3)]
|
||||
-- -| RenderEllipse [(Point3,Point4)]
|
||||
= Render3 [Point3]
|
||||
| Render1111 {_unRender1111 :: (Float,Float,Float,Float)}
|
||||
| Render22 {_unRender22 :: (Point2,Point2)}
|
||||
| Render2221 {_unRender2221 :: (Point2,Point2,Point2,Float)}
|
||||
@@ -99,20 +113,10 @@ flat4 (x,y,z,w) = [x,y,z,w]
|
||||
{-# INLINE flat3 #-}
|
||||
{-# INLINE flat4 #-}
|
||||
|
||||
type Picture = [(Int,RenderType)]
|
||||
-- = Blank
|
||||
-- | Text String
|
||||
-- | Polygon [Point2]
|
||||
-- | PolygonZ [Point2] Float
|
||||
-- | BezierQuad [(Point2,RGBA,Point2,Point2)]
|
||||
-- | PolygonCol [(Point2,RGBA)]
|
||||
-- | Poly3D [(Point3,RGBA)]
|
||||
-- | Circle RGBA RGBA Float
|
||||
-- | ThickArc Float Float Float Float
|
||||
-- | Pictures [Picture]
|
||||
-- | OverPic (Point3 -> Point3) (Point4 -> Point4) Picture
|
||||
-- | OnLayer Int Picture
|
||||
type Picture = [Verx]
|
||||
|
||||
blank :: Picture
|
||||
{-# INLINE blank #-}
|
||||
blank = []
|
||||
|
||||
makeLenses ''Verx
|
||||
|
||||
+3
-4
@@ -85,11 +85,10 @@ boxABC a b c =
|
||||
polyToPics :: Polyhedra -> [Picture]
|
||||
polyToPics = map helpPoly3D . _pyFaces
|
||||
|
||||
helpPoly3D :: [(Point3, Point4)] -> [(Int, RenderType)]
|
||||
helpPoly3D vs = zl $ RenderPoly $ polyToTris vs
|
||||
helpPoly3D :: [(Point3, Point4)] -> [Verx]
|
||||
helpPoly3D vs = map f $ polyToTris vs
|
||||
where
|
||||
zl :: RenderType -> [(Int,RenderType)]
|
||||
zl rt = [(0,rt)]
|
||||
f (pos,col) = Verx pos col PolyV 0
|
||||
|
||||
polysToPic :: [Polyhedra] -> Picture
|
||||
polysToPic = pictures . concatMap polyToPics
|
||||
|
||||
+22
-34
@@ -63,14 +63,14 @@ preloadRender = do
|
||||
<- makeShader "lighting/lineShadow" [vert,geom,frag] [3] ELinesAdjacency poke3
|
||||
>>= addUniforms ["lightPos"]
|
||||
-- 2D draw shaders
|
||||
bslist <- makeShader "twoD/basic" [vert,frag] [3,4] ETriangles pokeTriStrat
|
||||
aslist <- makeShader "twoD/arc" [vert,frag] [3,4,3] ETriangles pokeArcStrat
|
||||
eslist <- makeShader "twoD/ellipse" [vert,geom,frag] [3,4] ETriangles pokeEllStrat
|
||||
bezierQuadShader <- makeShader "twoD/bezierQuad" [vert,frag] [3,4,4] ETriangleStrip pokeBezQStrat
|
||||
cslist <- makeShader "twoD/character" [vert,frag] [3,4,2] ETriangles pokeCharStrat
|
||||
>>= addTextureNoFilter "data/texture/charMap.png"
|
||||
bslist <- makeVShader "twoD/basic" [vert,frag] [3,4] ETriangles isPolyV
|
||||
aslist <- makeVShader "twoD/arc" [vert,frag] [3,4,3] ETriangles isArcV
|
||||
eslist <- makeVShader "twoD/ellipse" [vert,geom,frag] [3,4] ETriangles isEllV
|
||||
bezierQuadShader <- makeVShader "twoD/bezierQuad" [vert,frag] [3,4,4] ETriangleStrip isBezV
|
||||
cslist <- makeVShader "twoD/character" [vert,frag] [3,4,2] ETriangles isTextV
|
||||
>>= vaddTextureNoFilter "data/texture/charMap.png"
|
||||
-- this should really be a 2d texture array
|
||||
basicTweakZShad <- makeShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles pokeTriTweakZ
|
||||
basicTweakZShad <- makeVShader "twoD/basicTweakZ" [vert,frag] [4,4] ETriangles isPolyzV
|
||||
-- fullscreen shaders
|
||||
fullscreenAlphaHalveShad <- makeShaderSized "fullscreen/alphaHalve" [vert,frag] [2] 4 ETriangleStrip $
|
||||
const cornerListNoCoord
|
||||
@@ -208,36 +208,11 @@ minMagFilter = ((Nearest,Nothing),Nearest)
|
||||
|
||||
cleanUpRenderPreload :: RenderData -> IO ()
|
||||
cleanUpRenderPreload pd = do
|
||||
mapM_ freeShaderPointers $ _pictureShaders pd
|
||||
-- TODO fix this
|
||||
--mapM_ freeShaderPointers $ _pictureShaders pd
|
||||
freeShaderPointers $ _lightingOccludeShader pd
|
||||
freeShaderPointers $ _fullscreenShader pd
|
||||
|
||||
--{-# INLINE pokeBezQStrat #-}
|
||||
pokeBezQStrat :: RenderType -> [[Float]]
|
||||
pokeBezQStrat (RenderBezQ vs) = fmap
|
||||
(\((x,y,z),(r,g,b,a),(s,t,u,v)) -> [x,y,z,r,g,b,a,s,t,u,v])
|
||||
vs
|
||||
pokeBezQStrat _ = []
|
||||
|
||||
|
||||
pokeTriTweakZ :: RenderType -> [[Float]]
|
||||
pokeTriTweakZ (RenderPolyZ vs) = fmap (\(p,co,z) -> flat3 p ++ [z] ++ flat4 co) vs
|
||||
pokeTriTweakZ _ = []
|
||||
|
||||
--{-# INLINE pokeTriStrat #-}
|
||||
pokeTriStrat,pokeCharStrat,pokeArcStrat,pokeEllStrat :: RenderType -> [[Float]]
|
||||
pokeTriStrat (RenderPoly vs) = fmap (\(p,co) -> flat3 p ++ flat4 co) vs
|
||||
pokeTriStrat _ = []
|
||||
|
||||
pokeCharStrat (RenderText vs) = fmap (\(a,b,c) -> concat [flat3 a, flat4 b, flat2 c]) vs
|
||||
pokeCharStrat _ = []
|
||||
|
||||
pokeArcStrat (RenderArc vs) = fmap (\(a,b,c) -> concat [flat3 a, flat4 b, flat3 c]) vs
|
||||
pokeArcStrat _ = []
|
||||
|
||||
pokeEllStrat (RenderEllipse vs) = fmap (\((x,y,z),(r,g,b,a)) -> [x,y,z,r,g,b,a]) vs
|
||||
pokeEllStrat _ = []
|
||||
|
||||
vert, geom, frag :: ShaderType
|
||||
vert = VertexShader
|
||||
geom = GeometryShader
|
||||
@@ -262,3 +237,16 @@ pokeWPColStrat _ = undefined
|
||||
poke33 :: RenderType -> [[Float]]
|
||||
poke33 Render3x3{_unRender3x3=((x,y,z),(a,b,c))} = [[x,y,z,a,b,c]]
|
||||
poke33 _ = undefined
|
||||
|
||||
isPolyV PolyV = True
|
||||
isPolyV _ = False
|
||||
isArcV (ArcV _) = True
|
||||
isArcV _ = False
|
||||
isEllV EllV = True
|
||||
isEllV _ = False
|
||||
isTextV (TextV _) = True
|
||||
isTextV _ = False
|
||||
isBezV (BezV _) = True
|
||||
isBezV _ = False
|
||||
isPolyzV (PolyzV _) = True
|
||||
isPolyzV _ = False
|
||||
|
||||
+24
-24
@@ -155,8 +155,8 @@ renderShader shad dat = do
|
||||
pokeBindFoldableLayer
|
||||
:: Foldable f
|
||||
=> RenderData
|
||||
-> f (Int,RenderType)
|
||||
-> IO (IM.IntMap [(FullShader,Int)])
|
||||
-> f Verx
|
||||
-> IO (IM.IntMap [(VShader,Int)])
|
||||
pokeBindFoldableLayer pdata m = do
|
||||
let slist = (,) <$> [0..6] <*> _pictureShaders pdata
|
||||
|
||||
@@ -164,28 +164,28 @@ pokeBindFoldableLayer pdata m = do
|
||||
bindShaderLayer slist is
|
||||
return $ IM.fromListWith (++) $ zipWith (\(i,fs) n -> (i,[(fs,n)])) slist is
|
||||
|
||||
renderFoldable
|
||||
:: Foldable f
|
||||
=> RenderData
|
||||
-> f RenderType
|
||||
-> IO Word32
|
||||
renderFoldable pdata struct = do
|
||||
pokeStartTicks <- SDL.ticks
|
||||
|
||||
let slist = _pictureShaders pdata
|
||||
|
||||
-- poke data, returns list buffer sizes for each shader
|
||||
is <- F.foldM (traverse pokeShader slist) struct
|
||||
|
||||
-- the idea of binding many buffers at once, rather than interweaving with draw
|
||||
-- calls, is to prevent opengl from waiting for a draw call to finish
|
||||
-- before it performs another state change
|
||||
bindShaderBuffers slist is
|
||||
|
||||
zipWithM_ drawShader slist is
|
||||
|
||||
pokeEndTicks <- SDL.ticks
|
||||
return $ pokeEndTicks - pokeStartTicks
|
||||
--renderFoldable
|
||||
-- :: Foldable f
|
||||
-- => RenderData
|
||||
-- -> f RenderType
|
||||
-- -> IO Word32
|
||||
--renderFoldable pdata struct = do
|
||||
-- pokeStartTicks <- SDL.ticks
|
||||
--
|
||||
-- let slist = _pictureShaders pdata
|
||||
--
|
||||
---- poke data, returns list buffer sizes for each shader
|
||||
-- is <- F.foldM (traverse pokeShader slist) struct
|
||||
--
|
||||
---- the idea of binding many buffers at once, rather than interweaving with draw
|
||||
---- calls, is to prevent opengl from waiting for a draw call to finish
|
||||
---- before it performs another state change
|
||||
-- bindShaderBuffers slist is
|
||||
--
|
||||
-- zipWithM_ drawShader slist is
|
||||
--
|
||||
-- pokeEndTicks <- SDL.ticks
|
||||
-- return $ pokeEndTicks - pokeStartTicks
|
||||
------------------------------end renderFoldable
|
||||
|
||||
pokeTwoOff
|
||||
|
||||
+7
-7
@@ -42,26 +42,26 @@ bindArrayBuffersLayer numVs lay theVBO = do
|
||||
where
|
||||
stride = sum $ _vboAttribSizes theVBO
|
||||
|
||||
bindShaderLayer :: [(Int,FullShader)] -> [Int] -> IO ()
|
||||
bindShaderLayer :: [(Int,VShader)] -> [Int] -> IO ()
|
||||
bindShaderLayer = zipWithM_ f
|
||||
where
|
||||
f (l,fs) i = bindArrayBuffersLayer i l $ _vaoVBO $ _shaderVAO fs
|
||||
f (l,fs) i = bindArrayBuffersLayer i l $ _vaoVBO $ _vshaderVAO fs
|
||||
|
||||
bindShaderBuffers :: [FullShader] -> [Int] -> IO ()
|
||||
bindShaderBuffers = zipWithM_ f
|
||||
where
|
||||
f fs i = bindArrayBuffers i $ _vaoVBO $ _shaderVAO fs
|
||||
|
||||
drawShaderLay :: Int -> FullShader -> Int -> IO ()
|
||||
drawShaderLay :: Int -> VShader -> Int -> IO ()
|
||||
{-# INLINE drawShaderLay #-}
|
||||
drawShaderLay l fs i = do
|
||||
currentProgram $= Just (_shaderProgram fs)
|
||||
bindVertexArrayObject $= Just (_vao $ _shaderVAO fs)
|
||||
case _shaderTexture fs of
|
||||
currentProgram $= Just (_vshaderProgram fs)
|
||||
bindVertexArrayObject $= Just (_vao $ _vshaderVAO fs)
|
||||
case _vshaderTexture fs of
|
||||
Just ShaderTexture{_textureObject = txo}
|
||||
-> textureBinding Texture2D $= Just txo
|
||||
_ -> return ()
|
||||
glDrawArrays (marshalEPrimitiveMode $ _shaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i)
|
||||
glDrawArrays (marshalEPrimitiveMode $ _vshaderDrawPrimitive fs) (fromIntegral $ l*numSubElements) (fromIntegral i)
|
||||
|
||||
drawShader :: FullShader -> Int -> IO ()
|
||||
{-# INLINE drawShader #-}
|
||||
|
||||
@@ -1,6 +1,7 @@
|
||||
module Shader.AuxAddition
|
||||
( addTexture
|
||||
, addTextureNoFilter
|
||||
, vaddTextureNoFilter
|
||||
, addTextureArray
|
||||
, addUniforms
|
||||
) where
|
||||
@@ -34,6 +35,21 @@ addTexture texturePath shad = do
|
||||
generateMipmap' Texture2D
|
||||
return $ shad & shaderTexture ?~ ShaderTexture {_textureObject = textureOb}
|
||||
|
||||
vaddTextureNoFilter :: String -> VShader -> IO VShader
|
||||
vaddTextureNoFilter texturePath shad = do
|
||||
Right cmap <- readImage texturePath
|
||||
let tex = convertRGBA8 cmap
|
||||
textureOb <- genObjectName
|
||||
textureBinding Texture2D $= Just textureOb
|
||||
textureFilter Texture2D $= ((Nearest,Nothing) , Nearest)
|
||||
let texData = V.toList $ imageData tex
|
||||
wtex = fromIntegral $ imageWidth tex
|
||||
htex = fromIntegral $ imageHeight tex
|
||||
glTexStorage2D GL_TEXTURE_2D 1 GL_RGBA8 wtex htex
|
||||
withArray texData $ \ptr -> do
|
||||
glTexSubImage2D GL_TEXTURE_2D 0 0 0 wtex htex GL_RGBA GL_UNSIGNED_BYTE ptr
|
||||
return $ shad & vshaderTexture ?~ ShaderTexture {_textureObject = textureOb}
|
||||
|
||||
addTextureNoFilter :: String -> FullShader -> IO FullShader
|
||||
addTextureNoFilter texturePath shad = do
|
||||
Right cmap <- readImage texturePath
|
||||
|
||||
@@ -1,5 +1,6 @@
|
||||
module Shader.Compile
|
||||
( makeShader
|
||||
, makeVShader
|
||||
, makeShaderSized
|
||||
, makeShaderUsingShaderVAO
|
||||
, makeSourcedShader
|
||||
@@ -16,6 +17,29 @@ import Control.Monad
|
||||
--import Control.Lens
|
||||
import Graphics.Rendering.OpenGL hiding (Point,translate,scale,imageHeight)
|
||||
|
||||
{- |
|
||||
Compiles a vertex shader found within the shader directory.
|
||||
The shader is made up of files begining with the inputted string with extensions .vert, .geom etc.
|
||||
-}
|
||||
makeVShader
|
||||
:: String -- ^ First part of the name of the shader
|
||||
-> [ShaderType] -- ^ Filetype extensions
|
||||
-> [Int] -- ^ The input vertex sizes
|
||||
-> EPrimitiveMode
|
||||
-> (VertexType -> Bool)
|
||||
-> IO VShader
|
||||
makeVShader s shaderlist sizes renStrat vtest = do
|
||||
prog <- makeSourcedShader s shaderlist
|
||||
vaob <- setupVAO sizes
|
||||
return $ VShader
|
||||
{ _vshaderProgram = prog
|
||||
, _vshaderVAO = vaob
|
||||
, _vshaderTexture = Nothing
|
||||
, _vshaderCustomUnis = []
|
||||
, _vshaderPokeTest = vtest
|
||||
, _vshaderDrawPrimitive = renStrat
|
||||
}
|
||||
|
||||
-- | Takes the VAO and poke strategy from another shader
|
||||
makeShaderUsingShaderVAO
|
||||
:: String -- ^ First part of the name of the shader
|
||||
|
||||
@@ -6,6 +6,7 @@ module Shader.Data
|
||||
( VAO (..)
|
||||
, VBO (..)
|
||||
, FullShader (..)
|
||||
, VShader (..)
|
||||
, ShaderTexture (..)
|
||||
, EPrimitiveMode (..)
|
||||
-- | Lens functions
|
||||
@@ -19,6 +20,13 @@ module Shader.Data
|
||||
, shaderTexture
|
||||
, shaderCustomUnis
|
||||
|
||||
, vshaderProgram
|
||||
, vshaderVAO
|
||||
, vshaderDrawPrimitive
|
||||
, vshaderTexture
|
||||
, vshaderCustomUnis
|
||||
, vshaderPokeTest
|
||||
|
||||
-- , textureObject
|
||||
) where
|
||||
import Picture.Data
|
||||
@@ -42,6 +50,14 @@ data VBO = VBO
|
||||
, _vboPointer :: Ptr Float
|
||||
, _vboAttribSizes :: [Int] -- ^ It is not clear to me if this is necessary to store or not
|
||||
}
|
||||
data VShader = VShader
|
||||
{ _vshaderProgram :: Program
|
||||
, _vshaderVAO :: VAO
|
||||
, _vshaderDrawPrimitive :: EPrimitiveMode
|
||||
, _vshaderTexture :: Maybe ShaderTexture
|
||||
, _vshaderCustomUnis :: [UniformLocation]
|
||||
, _vshaderPokeTest :: VertexType -> Bool
|
||||
}
|
||||
|
||||
{- | Datatype containing the necessary information for a single shader. -}
|
||||
data FullShader = FullShader
|
||||
@@ -72,3 +88,4 @@ data EPrimitiveMode
|
||||
|
||||
makeLenses ''VAO
|
||||
makeLenses ''FullShader
|
||||
makeLenses ''VShader
|
||||
|
||||
+25
-12
@@ -19,13 +19,6 @@ pokeShader fs = F.FoldM (pokeVertices fls ptr stride) (return 0) return
|
||||
stride = sum $ _vboAttribSizes theVBO
|
||||
fls = _shaderPokeStrategy fs
|
||||
|
||||
pokeShaderLayer :: (Int,FullShader) -> F.FoldM IO (Int,RenderType) Int
|
||||
pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff fls ptr stride l) (return 0) return
|
||||
where
|
||||
theVBO = _vaoVBO $ _shaderVAO fs
|
||||
ptr = _vboPointer theVBO
|
||||
stride = sum $ _vboAttribSizes theVBO
|
||||
fls = _shaderPokeStrategy fs
|
||||
|
||||
|
||||
pokeVertices
|
||||
@@ -37,17 +30,37 @@ pokeVertices
|
||||
-> IO Int
|
||||
pokeVertices toFs ptr stride n rt = foldM (pokeVertex ptr stride) n (toFs rt)
|
||||
|
||||
pokeShaderLayer :: (Int,VShader) -> F.FoldM IO Verx Int
|
||||
pokeShaderLayer (l,fs) = F.FoldM (pokeVerticesOff ptr (_vshaderPokeTest fs) stride l) (return 0) return
|
||||
where
|
||||
theVBO = _vaoVBO $ _vshaderVAO fs
|
||||
ptr = _vboPointer theVBO
|
||||
stride = sum $ _vboAttribSizes theVBO
|
||||
|
||||
pokeVerticesOff
|
||||
:: (RenderType -> [[Float]])
|
||||
-> Ptr Float
|
||||
:: Ptr Float
|
||||
-> (VertexType -> Bool)
|
||||
-> Int -- ^ stride
|
||||
-> Int -- ^ offset
|
||||
-> Int -- ^ number of vertices already poked
|
||||
-> (Int,RenderType)
|
||||
-> Verx
|
||||
-> IO Int
|
||||
pokeVerticesOff toFs ptr stride offset n (i,rt)
|
||||
| offset == i = foldM (pokeVertexOff ptr stride offset) n (toFs rt)
|
||||
pokeVerticesOff ptr vtest stride offset n vx
|
||||
| offset == i && typetest = do
|
||||
foldM (pokeVertexOff ptr stride offset) n (toFls vx)
|
||||
| otherwise = return n
|
||||
where
|
||||
i = _vxLayer vx
|
||||
typetest = vtest (_vxType vx)
|
||||
|
||||
toFls :: Verx -> [[Float]]
|
||||
toFls vx = [flat3 (_vxPos vx) ++ flat4 (_vxCol vx) ++ f (_vxType vx)]
|
||||
where
|
||||
f (PolyzV x) = [x]
|
||||
f (BezV x) = flat4 x
|
||||
f (TextV x) = flat2 x
|
||||
f (ArcV x) = flat3 x
|
||||
f _ = []
|
||||
|
||||
pokeVertexOff :: Ptr Float -> Int -> Int -> Int -> [Float] -> IO Int
|
||||
pokeVertexOff ptr stride offset n fs = do
|
||||
|
||||
Reference in New Issue
Block a user