Add layered drawing of pictures

src/Dodge/Rendering.hs

@@ -151,8 +151,10 @@ hudDrawings w = (onLayer InvLayer)
                         $ pictures
                           [ displayInv 0 w
                           , dShadCol white $ displayHP 0 w
-                          , dShadCol (itCol (yourItem w)) 
+                          , --color (itCol (yourItem w)) 
-                                $ drawCursor w, translate (-390) 20 
+                            color white
+                                $ drawCursor w
+                          , translate (-390) 20 
                                 $ scale 0.05 0.05 $ dShadCol white $ text (_testString w)
                           ]
     where itCol = fromMaybe (greyN 0.5) . (^? itInvColor)
@@ -171,8 +173,7 @@ drawCursor :: World -> Picture
 drawCursor w = translate (105-halfWidth w) 
                          (halfHeight w - (25* (fromIntegral iPos)) - 20
                          )
-                -- $ rectangleWire 200 25
+                 $ setLayer 2
-                 $ color white
                  $ line [(200,12.5),(-100,12.5),(-100,-12.5),(200,-12.5)]
     where iPos = _crInvSel $ _creatures w IM.! _yourID w
 

src/Picture.hs

@@ -40,6 +40,7 @@ module Picture
     , mixColors
     , zeroZ
     , setDepth
+    , setLayer
     )
     where
 import Geometry
@@ -69,11 +70,11 @@ black = (0,0,0,1)
 
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
-polygon = Polygon
+polygon = Polygon 0
 
 polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
-polygonCol = PolygonCol
+polygonCol = PolygonCol 0
 
 --polygon :: [Point2] -> Picture
 --{-# INLINE polygon #-}
@@ -101,6 +102,21 @@ setDepth :: Float -> Picture -> Picture
 {-# INLINE setDepth #-}
 setDepth d pic = SetDepth d pic
 
+setLayer :: Int -> Picture -> Picture
+setLayer _ Blank = Blank
+setLayer i (Polygon _ ps) = Polygon i ps
+setLayer i (PolygonCol _ ps) = PolygonCol i ps
+setLayer i (Circle _ x) = Circle i x
+setLayer i (ThickArc _ a b r w) = ThickArc i a b r w
+setLayer i (Line _ x) = Line i x
+setLayer i (Scale x y p) = Scale x y $ setLayer i p
+setLayer i (Translate x y p) = Translate x y $ setLayer i p
+setLayer i (Rotate x p) = Rotate x $ setLayer i p
+setLayer i (SetDepth x p) = SetDepth x $ setLayer i p
+setLayer i (Color x p) = Color x $ setLayer i p
+setLayer i (Pictures p) = Pictures $ map (setLayer i) p
+
+
 scale3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE scale3 #-}
 scale3 a b (x,y,z) = (x*a,y*b,z)
@@ -134,19 +150,19 @@ makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
 circleSolid :: Float -> Picture
 {-# INLINE circleSolid #-}
 --circleSolid rad = polygon $ makeArc rad (0,2*pi)
-circleSolid = Circle
+circleSolid = Circle 0
 
 circle :: Float -> Picture
 {-# INLINE circle #-}
-circle rad = line $ makeArc rad (0,2*pi)
+circle rad = thickArc 0 (2*pi) rad 1
 
 text :: String -> Picture
 {-# INLINE text #-}
-text = Text
+text = Text 2
 
 line :: [Point2] -> Picture
 {-# INLINE line #-}
-line = Line
+line = Line 0
 
 thickLine :: [Point2] -> Float -> Picture
 {-# INLINE thickLine #-}
@@ -173,7 +189,7 @@ arc startA endA rad = thickArc startA endA rad 1
 
 thickArc :: Float -> Float -> Float -> Float -> Picture
 {-# INLINE thickArc #-}
-thickArc = ThickArc
+thickArc = ThickArc 0
 --thickArc startA endA rad wdth
 --    = thickLine (makeArc rad (startA,endA)) wdth
 

src/Picture/Data.hs

@@ -42,18 +42,18 @@ data RenderType
 
 data Picture
     = Blank
-    | Text String
+    | Text Int String
-    | Polygon [Point2]
+    | Polygon Int [Point2]
-    | PolygonCol [(Point2,RGBA)]
+    | PolygonCol Int [(Point2,RGBA)]
-    | Circle Float
+    | Circle Int Float
-    | ThickArc Float Float Float 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 #-}

src/Picture/Render.hs

@@ -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 x (Polygon i ps) 
-picToFTree (PolygonCol vs) = let (ps,cs) = unzip vs
+    | 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 (Circle r)   = FLeaf $ RenderCirc $ ((0,0,0),black,r)
+picToFTree x (Circle i r) 
-picToFTree (ThickArc startA endA rad wdth) 
+    | i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
-    = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
+    | otherwise = FLeaf RenderBlank
-picToFTree Blank    = FLeaf $ RenderBlank
+picToFTree x (ThickArc i startA endA rad wdth) 
-picToFTree (Text s) = FLeaf $ RenderText $ stringToList s
+    | i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
-picToFTree (Scale x y pic) = FBranch (scaleRen x y) $ picToFTree pic
+    | otherwise = FLeaf RenderBlank
-picToFTree (Translate x y pic) = FBranch (translateRen x y) $ picToFTree pic
+picToFTree x (Line i ps) 
-picToFTree (Rotate a pic) = FBranch (rotateRen a) $ picToFTree pic
+    | i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
-picToFTree (SetDepth a pic) = FBranch (setDepthRen a) $ picToFTree pic
+    | otherwise = FLeaf RenderBlank
-picToFTree (Color c pic) = FBranch (colorRen c) $ picToFTree pic
+picToFTree x (Text i s) 
-picToFTree (Pictures pics) = FBranches $ map picToFTree pics
+    | i == x = FLeaf $ RenderText $ stringToList s
-picToFTree (Line ps) = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat black
+    | 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
+-- draw layer 0
-    (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs) 
+    renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToFTree 0 pic)
---        <- 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
 
-    depthFunc $= Just Less
+    renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 1 pic
-
-    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
+    renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 2 pic
-    currentProgram $= Just (_basicShader pdata)
+--
-    bindVertexArrayObject $= Just (_vao $ _lineVAO pdata)
+---- poke necessary data
-    bindArrayBuffers nTriVs $ _vaoBufferTargets $ _lineVAO pdata
+--    (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs) 
-    drawArrays Lines 0 (fromIntegral $ nLineVs)
+----        <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)  
--- draw text
+--        <- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)  
-    currentProgram $= Just (_textShader pdata)
+--                            (threePtrsVAO $ _textVAO pdata)
-    bindVertexArrayObject $= Just (_vao $ _textVAO pdata)
+--                            (threePtrsVAO $ _circVAO pdata)
-    bindArrayBuffers nTextVs $ _vaoBufferTargets $ _textVAO pdata
+--                            (twoPtrsVAO $ _lineVAO pdata)
-    textureBinding Texture2D $= Just (_textures pdata !! 0)
+--                            (threePtrsVAO $ _arcVAO pdata)
-    drawArrays Points 0 (fromIntegral $ nTextVs)
+--                   ) $ (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)
+renderTree :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
-                    -> Picture -> IO ()
+                    -> FTree RenderType -> IO ()
-renderPicture pdata rot zoom (tranx,trany) (winx,winy) pic = do
+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)