Add layered drawing of pictures
This commit is contained in:
+6
-6
@@ -42,18 +42,18 @@ data RenderType
|
||||
|
||||
data Picture
|
||||
= Blank
|
||||
| Text String
|
||||
| Polygon [Point2]
|
||||
| PolygonCol [(Point2,RGBA)]
|
||||
| Circle Float
|
||||
| ThickArc Float Float Float Float
|
||||
| Text Int String
|
||||
| Polygon Int [Point2]
|
||||
| PolygonCol Int [(Point2,RGBA)]
|
||||
| Circle Int Float
|
||||
| ThickArc Int Float Float Float Float
|
||||
| Line Int [Point2]
|
||||
| Scale Float Float Picture
|
||||
| Translate Float Float Picture
|
||||
| Rotate Float Picture
|
||||
| SetDepth Float Picture
|
||||
| Color RGBA Picture
|
||||
| Pictures [Picture]
|
||||
| Line [Point2]
|
||||
|
||||
blank :: Picture
|
||||
{-# INLINE blank #-}
|
||||
|
||||
+116
-75
@@ -26,7 +26,7 @@ import qualified Graphics.Rendering.OpenGL as GL
|
||||
import Data.Foldable
|
||||
import Data.List
|
||||
import qualified Data.Vector.Storable as V
|
||||
import qualified Data.DList as DL
|
||||
import qualified Data.IntMap as IM
|
||||
|
||||
import Control.DeepSeq
|
||||
|
||||
@@ -93,23 +93,54 @@ charToTuple :: Char -> (Point3,Point4,Point2)
|
||||
charToTuple c = ((0,0,0),white,(offset,100))
|
||||
where offset = fromIntegral (fromEnum c) - 32
|
||||
|
||||
picToFTree :: Picture -> FTree RenderType
|
||||
--picToFTree :: Picture -> IM.IntMap (FTree RenderType)
|
||||
--{-# INLINE picToFTree #-}
|
||||
--picToFTree (Polygon i ps) = IM.singleton i $ FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
--picToFTree (PolygonCol i vs)
|
||||
-- = let (ps,cs) = unzip vs
|
||||
-- in IM.singleton i $ FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
--picToFTree (Circle i r) = IM.singleton i $ FLeaf $ RenderCirc $ ((0,0,0),black,r)
|
||||
--picToFTree (ThickArc i startA endA rad wdth)
|
||||
-- = IM.singleton i $ FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
--picToFTree Blank = IM.singleton 0 $ FLeaf $ RenderBlank
|
||||
--picToFTree (Line i ps) = IM.singleton 0 $ FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat black
|
||||
--picToFTree (Text i s) = IM.singleton i $ FLeaf $ RenderText $ stringToList s
|
||||
--picToFTree (Scale x y pic) = fmap (FBranch (scaleRen x y)) $ picToFTree pic
|
||||
--picToFTree (Translate x y pic) = fmap (FBranch (translateRen x y)) $ picToFTree pic
|
||||
--picToFTree (Rotate a pic) = fmap (FBranch (rotateRen a)) $ picToFTree pic
|
||||
--picToFTree (SetDepth a pic) = fmap (FBranch (setDepthRen a)) $ picToFTree pic
|
||||
--picToFTree (Color c pic) = fmap (FBranch (colorRen c)) $ picToFTree pic
|
||||
--picToFTree (Pictures pics) = fmap FBranches $ IM.unionsWith (++) $ map (fmap return . picToFTree) pics
|
||||
|
||||
picToFTree :: Int -> 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,0,0),black,r)
|
||||
picToFTree (ThickArc startA endA rad wdth)
|
||||
= FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
picToFTree Blank = FLeaf $ RenderBlank
|
||||
picToFTree (Text s) = FLeaf $ RenderText $ stringToList s
|
||||
picToFTree (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree pic
|
||||
picToFTree (Translate x y pic) = FBranch (translateRen x y) $ picToFTree pic
|
||||
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
|
||||
picToFTree x (Polygon i ps)
|
||||
| i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
|
||||
| otherwise = FLeaf RenderBlank
|
||||
picToFTree x (PolygonCol i vs)
|
||||
| i /= x = FLeaf RenderBlank
|
||||
| otherwise =
|
||||
let (ps,cs) = unzip vs
|
||||
in FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
|
||||
picToFTree x (Circle i r)
|
||||
| i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
|
||||
| otherwise = FLeaf RenderBlank
|
||||
picToFTree x (ThickArc i startA endA rad wdth)
|
||||
| i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
|
||||
| otherwise = FLeaf RenderBlank
|
||||
picToFTree x (Line i ps)
|
||||
| i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
|
||||
| otherwise = FLeaf RenderBlank
|
||||
picToFTree x (Text i s)
|
||||
| i == x = FLeaf $ RenderText $ stringToList s
|
||||
| otherwise = FLeaf RenderBlank
|
||||
picToFTree j Blank = FLeaf RenderBlank
|
||||
picToFTree j (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree j pic
|
||||
picToFTree j (Translate x y pic) = FBranch (translateRen x y) $ picToFTree j pic
|
||||
picToFTree j (Rotate a pic) = FBranch (rotateRen a) $ picToFTree j pic
|
||||
picToFTree j (SetDepth a pic) = FBranch (setDepthRen a) $ picToFTree j pic
|
||||
picToFTree j (Color c pic) = FBranch (colorRen c) $ picToFTree j pic
|
||||
picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
|
||||
|
||||
doubleLine :: [Point2] -> [Point2]
|
||||
doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
|
||||
@@ -281,73 +312,83 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
|
||||
blendFuncSeparate $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
|
||||
clear [DepthBuffer]
|
||||
|
||||
-- poke necessary data
|
||||
(nTriVs,nTextVs,numCircVs,nLineVs,nArcVs)
|
||||
-- <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
|
||||
<- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)
|
||||
(threePtrsVAO $ _textVAO pdata)
|
||||
(threePtrsVAO $ _circVAO pdata)
|
||||
(twoPtrsVAO $ _lineVAO pdata)
|
||||
(threePtrsVAO $ _arcVAO pdata)
|
||||
) $ picToFTree pic
|
||||
-- draw layer 0
|
||||
renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToFTree 0 pic)
|
||||
|
||||
depthFunc $= Just Less
|
||||
|
||||
currentProgram $= Just (_backShader pdata)
|
||||
bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
|
||||
let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
|
||||
backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _backVAO pdata) !! 1
|
||||
pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
|
||||
pokeTwoOff backPtr2 0 (winx,winy)
|
||||
bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
|
||||
textureBinding Texture2D $= Just (_textures pdata !! 1)
|
||||
drawArrays Points (fromIntegral 0) (fromIntegral 1)
|
||||
|
||||
-- draw triangles
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
|
||||
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
|
||||
drawArrays Triangles 0 (fromIntegral $ nTriVs)
|
||||
-- draw circles
|
||||
currentProgram $= Just (_circShader pdata)
|
||||
uniform (_uniWinSize pdata) $= Vector2 winx winy
|
||||
uniform (_csZoomUni pdata) $= zoom
|
||||
bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
|
||||
bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata
|
||||
drawArrays Points 0 (fromIntegral $ numCircVs)
|
||||
-- draw arcs
|
||||
currentProgram $= Just (_arcShader pdata)
|
||||
uniform (_asWinUni pdata) $= Vector2 winx winy
|
||||
uniform (_asZoomUni pdata) $= zoom
|
||||
bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
|
||||
bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
|
||||
drawArrays Points 0 (fromIntegral $ nArcVs)
|
||||
renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 1 pic
|
||||
|
||||
-- reset blend so that light map doesn't apply
|
||||
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
||||
|
||||
-- draw lines
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
|
||||
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
|
||||
drawArrays Lines 0 (fromIntegral $ nLineVs)
|
||||
-- draw text
|
||||
currentProgram $= Just (_textShader pdata)
|
||||
bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
|
||||
bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
|
||||
textureBinding Texture2D $= Just (_textures pdata !! 0)
|
||||
drawArrays Points 0 (fromIntegral $ nTextVs)
|
||||
renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 2 pic
|
||||
--
|
||||
---- poke necessary data
|
||||
-- (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs)
|
||||
---- <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)
|
||||
-- <- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)
|
||||
-- (threePtrsVAO $ _textVAO pdata)
|
||||
-- (threePtrsVAO $ _circVAO pdata)
|
||||
-- (twoPtrsVAO $ _lineVAO pdata)
|
||||
-- (threePtrsVAO $ _arcVAO pdata)
|
||||
-- ) $ (picToFTree 0 pic)
|
||||
--
|
||||
-- depthFunc $= Just Less
|
||||
--
|
||||
-- currentProgram $= Just (_backShader pdata)
|
||||
-- bindVertexArrayObject $= Just (_vao $ _backVAO pdata)
|
||||
-- let backPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _backVAO pdata
|
||||
-- backPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _backVAO pdata) !! 1
|
||||
-- pokeFourOff backPtr 0 (tranx,trany,rot,zoom)
|
||||
-- pokeTwoOff backPtr2 0 (winx,winy)
|
||||
-- bindArrayBuffers 1 $ _vaoBufferTargets $ _backVAO pdata
|
||||
-- textureBinding Texture2D $= Just (_textures pdata !! 1)
|
||||
-- drawArrays Points (fromIntegral 0) (fromIntegral 1)
|
||||
--
|
||||
---- draw triangles
|
||||
-- currentProgram $= Just (_basicShader pdata)
|
||||
-- bindVertexArrayObject $= Just (_vao $ _triVAO pdata)
|
||||
-- bindArrayBuffers nTriVs $ _vaoBufferTargets $ _triVAO pdata
|
||||
-- drawArrays Triangles 0 (fromIntegral $ nTriVs)
|
||||
---- draw circles
|
||||
-- currentProgram $= Just (_circShader pdata)
|
||||
-- uniform (_uniWinSize pdata) $= Vector2 winx winy
|
||||
-- uniform (_csZoomUni pdata) $= zoom
|
||||
-- bindVertexArrayObject $= Just (_vao $ _circVAO pdata)
|
||||
-- bindArrayBuffers numCircVs $ _vaoBufferTargets $ _circVAO pdata
|
||||
-- drawArrays Points 0 (fromIntegral $ numCircVs)
|
||||
---- draw arcs
|
||||
-- currentProgram $= Just (_arcShader pdata)
|
||||
-- uniform (_asWinUni pdata) $= Vector2 winx winy
|
||||
-- uniform (_asZoomUni pdata) $= zoom
|
||||
-- bindVertexArrayObject $= Just (_vao $ _arcVAO pdata)
|
||||
-- bindArrayBuffers nArcVs $ _vaoBufferTargets $ _arcVAO pdata
|
||||
-- drawArrays Points 0 (fromIntegral $ nArcVs)
|
||||
--
|
||||
---- reset blend so that light map doesn't apply
|
||||
-- blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
||||
--
|
||||
---- draw lines
|
||||
-- currentProgram $= Just (_basicShader pdata)
|
||||
-- bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
|
||||
-- bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
|
||||
-- drawArrays Lines 0 (fromIntegral $ nLineVs)
|
||||
---- draw text
|
||||
-- currentProgram $= Just (_textShader pdata)
|
||||
-- bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
|
||||
-- bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
|
||||
-- textureBinding Texture2D $= Just (_textures pdata !! 0)
|
||||
-- drawArrays Points 0 (fromIntegral $ nTextVs)
|
||||
|
||||
|
||||
bufferOffset :: Integral a => a -> Ptr b
|
||||
bufferOffset = plusPtr nullPtr . fromIntegral
|
||||
|
||||
|
||||
-- the following code draws a picture
|
||||
-- the following code draws a picture tree
|
||||
-- it does not set nor change the blend function or depth buffer
|
||||
renderPicture :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
|
||||
-> Picture -> IO ()
|
||||
renderPicture pdata rot zoom (tranx,trany) (winx,winy) pic = do
|
||||
renderTree :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
|
||||
-> FTree RenderType -> IO ()
|
||||
renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
|
||||
|
||||
-- poke necessary data
|
||||
(nTriVs,nTextVs,numCircVs,nLineVs,nArcVs)
|
||||
@@ -357,7 +398,7 @@ renderPicture pdata rot zoom (tranx,trany) (winx,winy) pic = do
|
||||
(threePtrsVAO $ _circVAO pdata)
|
||||
(twoPtrsVAO $ _lineVAO pdata)
|
||||
(threePtrsVAO $ _arcVAO pdata)
|
||||
) $ picToFTree pic
|
||||
) $ tree
|
||||
|
||||
depthFunc $= Just Less
|
||||
|
||||
@@ -392,12 +433,12 @@ renderPicture pdata rot zoom (tranx,trany) (winx,winy) pic = do
|
||||
drawArrays Points 0 (fromIntegral $ nArcVs)
|
||||
|
||||
-- reset blend so that light map doesn't apply
|
||||
blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
||||
-- blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
|
||||
|
||||
-- draw lines
|
||||
currentProgram $= Just (_basicShader pdata)
|
||||
bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
|
||||
bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
|
||||
bindArrayBuffers nLineVs $ _vaoBufferTargets $ _lineVAO pdata
|
||||
drawArrays Lines 0 (fromIntegral $ nLineVs)
|
||||
-- draw text
|
||||
currentProgram $= Just (_textShader pdata)
|
||||
|
||||
Reference in New Issue
Block a user