Refactor vao preload
This commit is contained in:
+6
-75
@@ -14,24 +14,6 @@ import Control.Lens
|
||||
type RGBA = (Float,Float,Float,Float)
|
||||
type Color = (Float,Float,Float,Float)
|
||||
|
||||
|
||||
--type VerticesContainer a = Se.Seq a
|
||||
--toVC = Se.fromList
|
||||
--fromVC :: VerticesContainer a -> [a]
|
||||
--fromVC = F.toList
|
||||
--type VerticesContainer a = DL.DList a
|
||||
--toVC = DL.fromList
|
||||
--fromVC = DL.toList
|
||||
type VerticesContainer a = [a]
|
||||
toVC = id
|
||||
fromVC = id
|
||||
{-# INLINE toVC #-}
|
||||
{-# INLINE fromVC #-}
|
||||
{-# INLINE mapVC #-}
|
||||
|
||||
mapVC :: (a -> b) -> VerticesContainer a -> VerticesContainer b
|
||||
mapVC = fmap
|
||||
|
||||
data FTree a
|
||||
= FBranch (a -> a) (FTree a)
|
||||
| FBranches [FTree a]
|
||||
@@ -43,33 +25,6 @@ instance Foldable FTree where
|
||||
foldMap g (FLeaf x) = g x
|
||||
{-# INLINE foldMap #-}
|
||||
|
||||
--reduceShapeTree :: (Shape -> Shape) -> ShapeTree -> [Shape]
|
||||
--reduceShapeTree
|
||||
-- (TransformShape f xs) = map (f . reduceShapeTree) xs
|
||||
--reduceShapeTree
|
||||
-- (Leaf s) = [s]
|
||||
|
||||
-- data ShapeTree
|
||||
-- = TransformShape (Shape -> Shape) [ShapeTree]
|
||||
-- | Leaf Shape
|
||||
--
|
||||
-- data Shape
|
||||
-- = Shape
|
||||
-- { _shPos :: VerticesContainer Point3
|
||||
-- , _shCol :: VerticesContainer RGBA
|
||||
-- }
|
||||
-- | TextShape
|
||||
-- { _shPos :: VerticesContainer Point3
|
||||
-- , _shCol :: VerticesContainer RGBA
|
||||
-- , _shTex :: VerticesContainer Point2
|
||||
-- }
|
||||
--
|
||||
--combineShapes :: Shape -> Shape -> Shape
|
||||
--combineShapes sa sb = Shape
|
||||
-- { _shPos = _shPos sa <> _shPos sb
|
||||
-- , _shCol = _shCol sa <> _shCol sb
|
||||
-- }
|
||||
|
||||
flat2 (x,y) = [x,y]
|
||||
flat3 (x,y,z) = [x,y,z]
|
||||
flat4 (x,y,z,w) = [x,y,z,w]
|
||||
@@ -80,49 +35,25 @@ flat4 (x,y,z,w) = [x,y,z,w]
|
||||
data RenderType
|
||||
= RenderPoly [(Point3,Point4)]
|
||||
| RenderText [(Point3,Point4,Point2)]
|
||||
| RenderCirc (Point3,Point4,Float)
|
||||
| RenderArc (Point3,Point4,Point4)
|
||||
| RenderLine [(Point3,Point4)]
|
||||
| RenderBlank
|
||||
|
||||
data Picture
|
||||
= Blank
|
||||
| Text String
|
||||
| Polygon [Point2]
|
||||
| PolygonCol [(Point2,RGBA)]
|
||||
| Circle Float
|
||||
| Scale Float Float Picture
|
||||
| Translate Float Float Picture
|
||||
| Rotate Float Picture
|
||||
| SetDepth Float Picture
|
||||
| Color RGBA Picture
|
||||
| Pictures [Picture]
|
||||
|
||||
data Scene = Scene
|
||||
{ _scPosTri :: VerticesContainer Point3
|
||||
, _scColTri :: VerticesContainer RGBA
|
||||
, _scPosChar :: VerticesContainer Point3
|
||||
, _scColChar :: VerticesContainer RGBA
|
||||
, _scTexChar :: VerticesContainer Point2
|
||||
}
|
||||
|
||||
emptyScene :: Scene
|
||||
{-# INLINE emptyScene #-}
|
||||
emptyScene = Scene mempty mempty mempty mempty mempty
|
||||
| Line [Point2]
|
||||
|
||||
blank :: Picture
|
||||
{-# INLINE blank #-}
|
||||
blank = Blank
|
||||
|
||||
combineScenes :: Scene -> Scene -> Scene
|
||||
{-# INLINE combineScenes #-}
|
||||
combineScenes sa sb = Scene
|
||||
{ _scPosTri = _scPosTri sa <> _scPosTri sb
|
||||
, _scColTri = _scColTri sa <> _scColTri sb
|
||||
, _scPosChar = _scPosChar sa <> _scPosChar sb
|
||||
, _scColChar = _scColChar sa <> _scColChar sb
|
||||
, _scTexChar = _scTexChar sa <> _scTexChar sb
|
||||
}
|
||||
|
||||
instance Semigroup Scene where
|
||||
(<>) = combineScenes
|
||||
instance Monoid Scene where
|
||||
mempty = emptyScene
|
||||
--mappend = combineScenes
|
||||
|
||||
makeLenses ''Scene
|
||||
|
||||
+94
-55
@@ -10,6 +10,7 @@ import qualified Graphics.Rendering.OpenGL as GL
|
||||
import qualified Data.Vector.Storable as V
|
||||
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
|
||||
import Foreign
|
||||
|
||||
@@ -20,19 +21,55 @@ data PreloadData = PreloadData
|
||||
-- , _textures :: [Image PixelRGBA8]
|
||||
, _basicShader :: Program
|
||||
, _textShader :: Program
|
||||
, _circShader :: Program
|
||||
, _arcShader :: Program
|
||||
, _lineShader :: Program
|
||||
, _fadeCircleShader :: Program
|
||||
, _basicVAO :: VertexArrayObject
|
||||
, _textVAO :: VertexArrayObject
|
||||
, _circVAO :: VertexArrayObject
|
||||
, _arcVAO :: VertexArrayObject
|
||||
, _posVBO :: BufferObject
|
||||
, _colVBO :: BufferObject
|
||||
, _texVBO :: BufferObject
|
||||
, _ptrPosVBO :: Ptr Float
|
||||
, _ptrColVBO :: Ptr Float
|
||||
, _ptrTexVBO :: Ptr Float
|
||||
, _ptrCharPos :: Ptr Float
|
||||
, _ptrCharCol :: Ptr Float
|
||||
, _ptrCharTex :: Ptr Float
|
||||
, _ptrCircPos :: Ptr Float
|
||||
, _ptrCircCol :: Ptr Float
|
||||
, _ptrCircSca :: Ptr Float
|
||||
, _ptrArcPos :: Ptr Float
|
||||
, _ptrArcCol :: Ptr Float
|
||||
, _ptrArcSca :: Ptr Float
|
||||
, _ptrLinePos :: Ptr Float
|
||||
, _ptrLineCol :: Ptr Float
|
||||
, _uniWinSize :: UniformLocation
|
||||
, _csZoomUni :: UniformLocation
|
||||
, _asWinUni :: UniformLocation
|
||||
, _asZoomUni :: UniformLocation
|
||||
}
|
||||
|
||||
makeLenses ''PreloadData
|
||||
|
||||
floatSize = sizeOf (0.5 :: GLfloat)
|
||||
|
||||
setupVAO :: [(BufferObject,GLuint,Int)] -> IO VertexArrayObject
|
||||
setupVAO ps = do
|
||||
theVAO <- genObjectName
|
||||
bindVertexArrayObject $= Just theVAO
|
||||
forM_ ps $ \(vbo,aloc,i) -> do
|
||||
bindBuffer ArrayBuffer $= Just vbo
|
||||
vertexAttribPointer (AttribLocation aloc) $=
|
||||
( ToFloat
|
||||
, VertexArrayDescriptor (fromIntegral i)
|
||||
Float
|
||||
(fromIntegral $ floatSize * i)
|
||||
(bufferOffset 0)
|
||||
)
|
||||
vertexAttribArray (AttribLocation aloc) $= Enabled
|
||||
return theVAO
|
||||
|
||||
loadTextures :: IO [Image PixelRGBA8]
|
||||
loadTextures = do
|
||||
@@ -53,8 +90,16 @@ doPreload' = do
|
||||
-- compile shader programs
|
||||
bs <- makeBasicShader
|
||||
ts <- makeTextureShader
|
||||
cs <- makeCircleShader
|
||||
as <- makeArcShader
|
||||
fcs <- makeFadeShader
|
||||
|
||||
winSizeUni <- GL.uniformLocation cs "winSize"
|
||||
zoomUni <- GL.uniformLocation cs "zoom"
|
||||
asWinSizeUniLoc <- GL.uniformLocation as "winSize"
|
||||
asZoomUniLoc <- GL.uniformLocation as "zoom"
|
||||
-- get uniform locations
|
||||
|
||||
--setup vbos
|
||||
--need to be bound before assigning the vertex attribute pointers
|
||||
posVBO <- genObjectName
|
||||
@@ -76,81 +121,75 @@ doPreload' = do
|
||||
generateMipmap' Texture2D
|
||||
textureFilter Texture2D $= ((Linear',Just Linear') , Nearest)
|
||||
|
||||
let vertexSize = sizeOf (0.5 :: GLfloat)
|
||||
firstIndex = 0
|
||||
|
||||
-- setup VAOs: basic vao
|
||||
basicVAO <- genObjectName
|
||||
bindVertexArrayObject $= Just basicVAO
|
||||
|
||||
-- let posAttrib = AttribLocation 0
|
||||
-- colAttrib = AttribLocation 1
|
||||
bindBuffer ArrayBuffer $= Just posVBO
|
||||
vertexAttribPointer (AttribLocation 0) $=
|
||||
( ToFloat
|
||||
, VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3)
|
||||
(bufferOffset (firstIndex * vertexSize))
|
||||
)
|
||||
vertexAttribArray (AttribLocation 0) $= Enabled
|
||||
|
||||
bindBuffer ArrayBuffer $= Just colVBO
|
||||
vertexAttribPointer (AttribLocation 1) $=
|
||||
( ToFloat
|
||||
, VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4)
|
||||
(bufferOffset (firstIndex * vertexSize) )
|
||||
)
|
||||
vertexAttribArray (AttribLocation 1) $= Enabled
|
||||
|
||||
-- setup second vao
|
||||
textVAO <- genObjectName
|
||||
bindVertexArrayObject $= Just textVAO
|
||||
|
||||
bindBuffer ArrayBuffer $= Just posVBO
|
||||
vertexAttribPointer (AttribLocation 0) $=
|
||||
( ToFloat
|
||||
, VertexArrayDescriptor 3 Float (fromIntegral $ vertexSize * 3)
|
||||
(bufferOffset (firstIndex * vertexSize))
|
||||
)
|
||||
vertexAttribArray (AttribLocation 0) $= Enabled
|
||||
|
||||
bindBuffer ArrayBuffer $= Just colVBO
|
||||
vertexAttribPointer (AttribLocation 1) $=
|
||||
( ToFloat
|
||||
, VertexArrayDescriptor 4 Float (fromIntegral $ vertexSize * 4)
|
||||
(bufferOffset (firstIndex * vertexSize) )
|
||||
)
|
||||
vertexAttribArray (AttribLocation 1) $= Enabled
|
||||
|
||||
bindBuffer ArrayBuffer $= Just texVBO
|
||||
vertexAttribPointer (AttribLocation 2) $=
|
||||
( ToFloat
|
||||
, VertexArrayDescriptor 2 Float (fromIntegral $ vertexSize * 2)
|
||||
(bufferOffset (firstIndex * vertexSize) )
|
||||
)
|
||||
vertexAttribArray (AttribLocation 2) $= Enabled
|
||||
basicVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4)]
|
||||
textVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,2)]
|
||||
circVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,1)]
|
||||
arcVAO <- setupVAO [(posVBO,0,3),(colVBO,1,4),(texVBO,2,3)]
|
||||
|
||||
-- allocate memory for vertex attributes
|
||||
-- for triangles
|
||||
ptrPosVBO <- mallocArray (3*3*20000)
|
||||
ptrColVBO <- mallocArray (3*4*20000)
|
||||
ptrTexVBO <- mallocArray (3*2*20000)
|
||||
-- for characters
|
||||
ptrCharPos <- mallocArray (3*20000)
|
||||
ptrCharCol <- mallocArray (4*20000)
|
||||
ptrCharTex <- mallocArray (2*20000)
|
||||
-- for circles
|
||||
ptrCircPos <- mallocArray (3*20000)
|
||||
ptrCircCol <- mallocArray (4*20000)
|
||||
ptrCircSca <- mallocArray (2*20000)
|
||||
-- for lines
|
||||
ptrLinePos <- mallocArray (3*20000)
|
||||
ptrLineCol <- mallocArray (4*20000)
|
||||
-- for arcs
|
||||
ptrArcPos <- mallocArray (3*20000)
|
||||
ptrArcCol <- mallocArray (4*20000)
|
||||
ptrArcSca <- mallocArray (3*20000)
|
||||
|
||||
return $ PreloadData
|
||||
{ _charMap = convertRGBA8 cmap
|
||||
, _basicShader = bs
|
||||
, _textShader = ts
|
||||
, _circShader = cs
|
||||
, _arcShader = as
|
||||
, _fadeCircleShader = fcs
|
||||
, _basicVAO = basicVAO
|
||||
, _textVAO = textVAO
|
||||
, _circVAO = circVAO
|
||||
, _arcVAO = arcVAO
|
||||
, _posVBO = posVBO
|
||||
, _colVBO = colVBO
|
||||
, _texVBO = texVBO
|
||||
, _ptrPosVBO = ptrPosVBO
|
||||
, _ptrColVBO = ptrColVBO
|
||||
, _ptrTexVBO = ptrTexVBO
|
||||
, _ptrCharPos = ptrCharPos
|
||||
, _ptrCharCol = ptrCharCol
|
||||
, _ptrCharTex = ptrCharTex
|
||||
, _ptrCircPos = ptrCircPos
|
||||
, _ptrCircCol = ptrCircCol
|
||||
, _ptrCircSca = ptrCircSca
|
||||
, _ptrArcPos = ptrArcPos
|
||||
, _ptrArcCol = ptrArcCol
|
||||
, _ptrArcSca = ptrArcSca
|
||||
, _ptrLinePos = ptrLinePos
|
||||
, _ptrLineCol = ptrLineCol
|
||||
, _uniWinSize = winSizeUni
|
||||
, _csZoomUni = zoomUni
|
||||
, _asWinUni = asWinSizeUniLoc
|
||||
, _asZoomUni = asZoomUniLoc
|
||||
}
|
||||
|
||||
cleanUpPreload :: PreloadData -> IO ()
|
||||
cleanUpPreload pd = do
|
||||
free (_ptrPosVBO pd)
|
||||
free (_ptrColVBO pd)
|
||||
free (_ptrTexVBO pd)
|
||||
free (_ptrCharPos pd)
|
||||
free (_ptrCharCol pd)
|
||||
free (_ptrCharTex pd)
|
||||
free (_ptrCircPos pd)
|
||||
free (_ptrCircCol pd)
|
||||
free (_ptrCircSca pd)
|
||||
free (_ptrArcPos pd)
|
||||
free (_ptrArcCol pd)
|
||||
free (_ptrArcSca pd)
|
||||
|
||||
+140
-116
@@ -6,6 +6,8 @@ import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.State
|
||||
|
||||
import qualified Control.Foldl as F
|
||||
|
||||
import Data.Bifunctor
|
||||
|
||||
import Picture
|
||||
@@ -18,7 +20,7 @@ import Foreign
|
||||
|
||||
import Codec.Picture
|
||||
|
||||
import Graphics.Rendering.OpenGL hiding (get,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
|
||||
import Graphics.Rendering.OpenGL hiding (Line,get,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
|
||||
import qualified Graphics.Rendering.OpenGL as GL
|
||||
|
||||
import Data.Foldable
|
||||
@@ -36,27 +38,11 @@ toVec2 (x,y) = Vector2 x y
|
||||
toVec3 (x,y,z) = Vector3 x y z
|
||||
toVec4 (x,y,z,w) = Vector4 x y z w
|
||||
|
||||
mapFlat :: (NFData b) => (a -> VerticesContainer b) -> VerticesContainer a -> [b]
|
||||
mapFlat f = fromVC . foldMap f
|
||||
|
||||
polyToTris :: [s] -> [s]
|
||||
{-# INLINE polyToTris #-}
|
||||
polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
|
||||
polyToTris _ = []
|
||||
|
||||
data Tx a = Tx [Tx a] | Lx a
|
||||
|
||||
deriving instance Foldable Tx
|
||||
|
||||
stateBump :: [Int] -> () -> State Int [Int]
|
||||
stateBump xs _ = do
|
||||
s <- get
|
||||
modify (+1)
|
||||
return (s:xs)
|
||||
|
||||
redT :: Foldable t => t () -> [Int]
|
||||
redT x = evalState (foldM stateBump [] x) 0
|
||||
|
||||
tripFirst :: (a -> a') -> (a,b,c) -> (a',b,c)
|
||||
{-# INLINE tripFirst #-}
|
||||
tripFirst f (x,y,z) = (f x,y,z)
|
||||
@@ -66,42 +52,57 @@ tripSecond :: (b -> b') -> (a,b,c) -> (a,b',c)
|
||||
tripSecond f (x,y,z) = (x,f y,z)
|
||||
|
||||
scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2)
|
||||
{-# INLINE scaleT #-}
|
||||
scaleT x (a,b,(o,s)) = (a,b,(o,s*x))
|
||||
|
||||
overPos :: (Point3 -> Point3) -> RenderType -> RenderType
|
||||
overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
|
||||
overPos f (RenderLine vs) = RenderLine $ map (first $ f) vs
|
||||
overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
|
||||
overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
|
||||
overPos _ RenderBlank = RenderBlank
|
||||
|
||||
overCol :: (Point4 -> Point4) -> RenderType -> RenderType
|
||||
overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs
|
||||
overCol f (RenderLine vs) = RenderLine $ map (second $ f) vs
|
||||
overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
|
||||
overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
|
||||
overCol _ RenderBlank = RenderBlank
|
||||
|
||||
scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
|
||||
scaleRen x y (RenderPoly xs) = RenderPoly $ map (first $ scale3 x y) xs
|
||||
scaleRen x y (RenderText xs) = RenderText $ map (tripFirst (scale3 x y ) . scaleT x) xs
|
||||
--scaleRen x y (RenderText xs) = RenderText $ map (\(a,b,c) -> (a,b, (0,0.2))) xs
|
||||
scaleRen x y rt = rt
|
||||
translateRen x y (RenderPoly xs) = RenderPoly $ map (first $ translate3 x y) xs
|
||||
translateRen x y (RenderText xs) = RenderText $ map (tripFirst $ translate3 x y) xs
|
||||
--translateRen x y (RenderText xs) = RenderText $ map (tripFirst $ const (0.2,0.2,0)) xs
|
||||
translateRen x y rt = rt
|
||||
{-# INLINE scaleRen #-}
|
||||
scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT x) vs
|
||||
scaleRen x y (RenderCirc (a,b,c)) = overPos (scale3 x y) $ RenderCirc (a,b,c)
|
||||
scaleRen x y rt = overPos (scale3 x y) rt
|
||||
{-# INLINE translateRen #-}
|
||||
translateRen x y = overPos $ translate3 x y
|
||||
rotateRen,setDepthRen :: Float -> RenderType -> RenderType
|
||||
rotateRen a (RenderPoly xs) = RenderPoly $ map (first $ rotate3 a) xs
|
||||
rotateRen a (RenderText xs) = RenderText $ map (tripFirst $ rotate3 a) xs
|
||||
rotateRen a rt = rt
|
||||
setDepthRen a (RenderPoly xs) = RenderPoly $ map (first $ (\(x,y,_) -> (x,y,a))) xs
|
||||
setDepthRen a (RenderText xs) = RenderText $ map (tripFirst $ (\(x,y,_) -> (x,y,a))) xs
|
||||
setDepthRen a rt = rt
|
||||
{-# INLINE rotateRen #-}
|
||||
rotateRen a = overPos $ rotate3 a
|
||||
{-# INLINE setDepthRen #-}
|
||||
setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
|
||||
{-# INLINE colorRen #-}
|
||||
colorRen :: RGBA -> RenderType -> RenderType
|
||||
colorRen c (RenderPoly xs) = RenderPoly $ map (second $ const c) xs
|
||||
colorRen c (RenderText xs) = RenderText $ map (tripSecond $ const c) xs
|
||||
colorRen c rt = rt
|
||||
colorRen c = overCol $ const c
|
||||
|
||||
stringToList :: String -> [(Point3,Point4,Point2)]
|
||||
stringToList s = zipWith (\x (a,b,c) -> (translate3 x (0-dimText) a,b,c))
|
||||
{-# INLINE stringToList #-}
|
||||
stringToList s = zipWith (\x (a,b,c) -> (translate3 x 0 a,b,c))
|
||||
[0,0.9*dimText..]
|
||||
$ map charToTuple s
|
||||
where dimText = 100
|
||||
|
||||
charToTuple :: Char -> (Point3,Point4,Point2)
|
||||
{-# INLINE charToTuple #-}
|
||||
charToTuple c = ((0,0,0),white,(offset,100))
|
||||
where offset = fromIntegral (fromEnum c) - 32
|
||||
|
||||
picToFTree :: Picture -> FTree RenderType
|
||||
{-# INLINE picToFTree #-}
|
||||
picToFTree (Polygon ps) = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
picToFTree (PolygonCol vs) = let (ps,cs) = unzip vs
|
||||
in FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
picToFTree (Circle r) = FLeaf $ RenderCirc $ ((0.5,0,0),red,r)
|
||||
picToFTree Blank = FLeaf $ RenderBlank
|
||||
picToFTree (Text s) = FLeaf $ RenderText $ stringToList s
|
||||
picToFTree (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree pic
|
||||
@@ -110,10 +111,75 @@ picToFTree (Rotate a pic) = FBranch (rotateRen a) $ picToFTree pic
|
||||
picToFTree (SetDepth a pic) = FBranch (setDepthRen a) $ picToFTree pic
|
||||
picToFTree (Color c pic) = FBranch (colorRen c) $ picToFTree pic
|
||||
picToFTree (Pictures pics) = FBranches $ map picToFTree pics
|
||||
picToFTree (Line ps) = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat black
|
||||
|
||||
pokeTexts :: Ptr Float -> Ptr Float -> Ptr Float -> FTree RenderType -> IO Int
|
||||
pokeTexts = go 0
|
||||
where go n pa pb pc t = foldM (pokeText pa pb pc) n t
|
||||
doubleLine :: [Point2] -> [Point2]
|
||||
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
|
||||
doubleLine _ = []
|
||||
|
||||
pokeFold :: (Ptr Float, Ptr Float) -> F.FoldM IO RenderType Int
|
||||
pokeFold (pa,pb) = F.FoldM
|
||||
(pokePoly pa pb)
|
||||
(return 0)
|
||||
return
|
||||
pokeTextFold :: (Ptr Float, Ptr Float,Ptr Float) -> F.FoldM IO RenderType Int
|
||||
pokeTextFold (pa,pb,pc) = F.FoldM
|
||||
(pokeText pa pb pc)
|
||||
(return 0)
|
||||
return
|
||||
pokeCircFold :: (Ptr Float, Ptr Float,Ptr Float) -> F.FoldM IO RenderType Int
|
||||
pokeCircFold (pa,pb,pc) = F.FoldM
|
||||
(pokeCirc pa pb pc)
|
||||
(return 0)
|
||||
return
|
||||
|
||||
theFold :: (Ptr Float,Ptr Float)
|
||||
-> (Ptr Float,Ptr Float,Ptr Float)
|
||||
-> (Ptr Float,Ptr Float,Ptr Float)
|
||||
-> (Ptr Float,Ptr Float)
|
||||
-> F.FoldM IO RenderType (Int,Int,Int,Int)
|
||||
theFold pas pbs pcs pds = (,,,) <$> pokeFold pas <*> pokeTextFold pbs <*> pokeCircFold pcs
|
||||
<*> pokeLineFold pds
|
||||
|
||||
pokeLineFold :: (Ptr Float, Ptr Float) -> F.FoldM IO RenderType Int
|
||||
pokeLineFold (pa,pb) = F.FoldM
|
||||
(pokeLine pa pb)
|
||||
(return 0)
|
||||
return
|
||||
pokeLine :: Ptr Float -> Ptr Float -> Int -> RenderType -> IO Int
|
||||
pokeLine pa pb n (RenderLine vs) = foldM (pokeLineVert pa pb) n vs
|
||||
pokeLine _ _ n _ = return n
|
||||
|
||||
pokeLineVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
|
||||
pokeLineVert pa pb n ((x,y,z),(r,g,b,a))
|
||||
| n > 20000 * 2 = return n
|
||||
| otherwise = do
|
||||
pokeElemOff pa (3*n+0) x
|
||||
pokeElemOff pa (3*n+1) y
|
||||
pokeElemOff pa (3*n+2) z
|
||||
pokeElemOff pb (4*n+0) r
|
||||
pokeElemOff pb (4*n+1) g
|
||||
pokeElemOff pb (4*n+2) b
|
||||
pokeElemOff pb (4*n+3) a
|
||||
return (n+1)
|
||||
|
||||
pokeCirc :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> RenderType -> IO Int
|
||||
pokeCirc pa pb pc n (RenderCirc vs) = pokeCircVert pa pb pc n vs
|
||||
pokeCirc _ _ _ n _ = return n
|
||||
|
||||
pokeCircVert :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> (Point3, Point4, Float) -> IO Int
|
||||
pokeCircVert pa pb pc n ((x,y,z),(r,g,b,a),s)
|
||||
| n > 20000 * 2 = return n
|
||||
| otherwise = do
|
||||
pokeElemOff pa (3*n+0) x
|
||||
pokeElemOff pa (3*n+1) y
|
||||
pokeElemOff pa (3*n+2) z
|
||||
pokeElemOff pb (4*n+0) r
|
||||
pokeElemOff pb (4*n+1) g
|
||||
pokeElemOff pb (4*n+2) b
|
||||
pokeElemOff pb (4*n+3) a
|
||||
pokeElemOff pc n s
|
||||
return (n+1)
|
||||
|
||||
pokeText :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> RenderType -> IO Int
|
||||
pokeText pa pb pc n (RenderText vs) = foldM (pokeTextVert pa pb pc) n vs
|
||||
@@ -155,33 +221,6 @@ pokeVert pa pb n ((x,y,z),(r,g,b,a))
|
||||
pokeElemOff pb (4*n+3) a
|
||||
return (n+1)
|
||||
|
||||
|
||||
|
||||
reducePicture :: Picture -> (DL.DList Float,DL.DList Float)
|
||||
{-# INLINE reducePicture #-}
|
||||
reducePicture = reducePicture' black id
|
||||
where
|
||||
reducePicture' :: RGBA -> (Point3 -> Point3) -> Picture -> (DL.DList Float,DL.DList Float)
|
||||
reducePicture' col tran Blank = (DL.empty,DL.empty)
|
||||
reducePicture' col tran (Text _) = (DL.empty,DL.empty)
|
||||
reducePicture' col tran (Polygon ps)
|
||||
= ( DL.fromList $ concatMap (flat3 . tran . zeroZ) (polyToTris ps)
|
||||
, DL.fromList $ concatMap (flat4 . const col) (polyToTris ps)
|
||||
)
|
||||
reducePicture' col tran (Scale x y pic)
|
||||
= reducePicture' col (tran . scale3 x y) pic
|
||||
reducePicture' col tran (Translate x y pic)
|
||||
= reducePicture' col (tran . translate3 x y) pic
|
||||
reducePicture' col tran (Rotate a pic)
|
||||
= reducePicture' col (tran . rotate3 a) pic
|
||||
reducePicture' col tran (SetDepth a pic)
|
||||
= reducePicture' col (tran . \(x,y,z) -> (x,y,a)) pic
|
||||
reducePicture' col tran (Color c pic)
|
||||
= reducePicture' c tran pic
|
||||
reducePicture' col tran (Pictures pics)
|
||||
= foldr com (DL.empty,DL.empty) $ map (reducePicture' col tran) pics
|
||||
where com (xs,ys) (xs',ys') = (xs <> xs', ys <> ys')
|
||||
|
||||
translate3 :: Float -> Float -> Point3 -> Point3
|
||||
{-# INLINE translate3 #-}
|
||||
translate3 a b (x,y,z) = (x+a,y+b,z)
|
||||
@@ -193,72 +232,57 @@ rotate3 :: Float -> Point3 -> Point3
|
||||
rotate3 a (x,y,z) = (x',y',z)
|
||||
where (x',y') = rotateV a (x,y)
|
||||
|
||||
renderPicture' :: PreloadData -> Picture -> IO ()
|
||||
renderPicture' pdata pic = do
|
||||
renderPicture' :: PreloadData -> Float -> (Float,Float) -> Picture -> IO ()
|
||||
renderPicture' pdata zoom (winx,winy) pic = do
|
||||
let firstIndex = 0
|
||||
fSize = sizeOf (0::Float)
|
||||
|
||||
(nTriVs,numVert',numCircVs,nLineVs)
|
||||
<- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
|
||||
(_ptrCharPos pdata, _ptrCharCol pdata, _ptrCharTex pdata)
|
||||
(_ptrCircPos pdata, _ptrCircCol pdata, _ptrCircSca pdata)
|
||||
(_ptrLinePos pdata, _ptrLineCol pdata)
|
||||
) $ picToFTree pic
|
||||
|
||||
depthFunc $= Just Less
|
||||
-- draw triangles
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
numVert <- pokePic (_ptrPosVBO pdata) (_ptrColVBO pdata) $ picToFTree pic
|
||||
bindVertexArrayObject $= Just (_basicVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 3, _ptrPosVBO pdata, StreamDraw)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * nTriVs * 3, _ptrPosVBO pdata, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 4, _ptrColVBO pdata, StreamDraw)
|
||||
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVert)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * nTriVs * 4, _ptrColVBO pdata, StreamDraw)
|
||||
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ nTriVs)
|
||||
-- draw lines, don't need to change the program or vaos, just need to bind the
|
||||
-- vbos and draw
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * nLineVs * 3, _ptrLinePos pdata, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * nLineVs * 4, _ptrLineCol pdata, StreamDraw)
|
||||
drawArrays Lines (fromIntegral firstIndex) (fromIntegral $ nLineVs)
|
||||
-- draw circles
|
||||
currentProgram $= Just (_circShader pdata)
|
||||
uniform (_uniWinSize pdata) $= Vector2 winx winy
|
||||
uniform (_csZoomUni pdata) $= zoom
|
||||
bindVertexArrayObject $= Just (_circVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *3, _ptrCircPos pdata, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *4, _ptrCircCol pdata, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_texVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *1, _ptrCircSca pdata, StreamDraw)
|
||||
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numCircVs)
|
||||
|
||||
currentProgram $= Just (_textShader pdata)
|
||||
numVert' <- pokeTexts (_ptrPosVBO pdata) (_ptrColVBO pdata) (_ptrTexVBO pdata) $ picToFTree pic
|
||||
bindVertexArrayObject $= Just (_textVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *3, _ptrPosVBO pdata, StreamDraw)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *3, _ptrCharPos pdata, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *4, _ptrColVBO pdata, StreamDraw)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *4, _ptrCharCol pdata, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_texVBO pdata)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *2, _ptrTexVBO pdata, StreamDraw)
|
||||
bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert' *2, _ptrCharTex pdata, StreamDraw)
|
||||
drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVert')
|
||||
|
||||
renderPicture :: PreloadData -> Picture -> IO ()
|
||||
renderPicture pdata pic = do
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
bindVertexArrayObject $= Just (_basicVAO pdata)
|
||||
bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
let firstIndex = 0
|
||||
let (vs,cs) = reducePicture pic
|
||||
vertices :: [Float]
|
||||
vertices = DL.toList vs
|
||||
numVertices = length vertices
|
||||
vertexSize = sizeOf (head vertices)
|
||||
pokeArray (_ptrPosVBO pdata) vertices
|
||||
bufferData ArrayBuffer $= (fromIntegral (length vertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
|
||||
-- marshallVs vertices $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
|
||||
bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
let colVs = DL.toList cs
|
||||
pokeArray (_ptrColVBO pdata) colVs
|
||||
bufferData ArrayBuffer $= (fromIntegral (length colVs * vertexSize), _ptrColVBO pdata, StreamDraw)
|
||||
-- marshallVs colVs $ \ptr -> do
|
||||
-- bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
|
||||
drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices)
|
||||
|
||||
---- currentProgram $= Just (_textShader pdata)
|
||||
---- bindVertexArrayObject $= Just (_textVAO pdata)
|
||||
---- bindBuffer ArrayBuffer $= Just (_posVBO pdata)
|
||||
---- let vertices' = concatMap flat3 posChar
|
||||
---- numVertices' = length posChar
|
||||
---- vertexSize' = sizeOf $ head vertices'
|
||||
---- pokeArray (_ptrPosVBO pdata) vertices'
|
||||
---- bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), _ptrPosVBO pdata, StreamDraw)
|
||||
---- --withArray vertices' $ \ptr -> do
|
||||
---- -- bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), ptr, StreamDraw)
|
||||
---- bindBuffer ArrayBuffer $= Just (_colVBO pdata)
|
||||
---- pokeArray (_ptrColVBO pdata) $ concatMap flat4 colChar
|
||||
---- bufferData ArrayBuffer $= (fromIntegral (4 * numVertices' * vertexSize'), _ptrColVBO pdata, StreamDraw)
|
||||
---- bindBuffer ArrayBuffer $= Just (_texVBO pdata)
|
||||
---- pokeArray (_ptrTexVBO pdata) $ concatMap flat2 texChar
|
||||
---- bufferData ArrayBuffer $= (fromIntegral (2 * numVertices' * vertexSize'), _ptrTexVBO pdata, StreamDraw)
|
||||
---- drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVertices')
|
||||
|
||||
|
||||
|
||||
bufferOffset :: Integral a => a -> Ptr b
|
||||
|
||||
Reference in New Issue
Block a user