Improve speed of polygon rendering by folding tree type

app/Main.hs

@@ -27,7 +27,7 @@ import System.Random
 
 import qualified SDL as SDL
 import qualified SDL.Mixer as Mix
-import Graphics.Rendering.OpenGL hiding (color,scale)
+import Graphics.Rendering.OpenGL hiding (color,scale,translate,rotate)
 --Mix.openAudio Mix.defaultAudio 256 >> 
 
 initWorld = initialWorld 
@@ -37,7 +37,7 @@ initWorld = initialWorld
     }
 
 pps = [(0,0),(50,0),(0,25)]
-ppt = [(0,0),(-50,0),(20,25)]
+ppt = [(0,0),(-0.50,0),(0.20,0.25)]
 
 main :: IO ()
 main = do
@@ -50,6 +50,7 @@ main = do
         (initializeWorld $ generateFromTree lev1 $ initWorld)
         (-- \((bs:fs:ts:_),tes) w -> --do render setparams w egFade
          \preData w -> --do render setparams w egFade
+                      --renderPicture' preData (polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)])
                       renderPicture' preData (draw blank w)
 --            renderPicture' preData 
 --                          (pictures [scale 0.5 0.9 $ polygon [(0,0),(0,-0.5),(-0.5,-0.5),(-0.5,0.0)]

package.yaml

@@ -40,6 +40,7 @@ dependencies:
 - vector
 - dlist
 - deepseq
+- transformers
 
 library:
   source-dirs: src

src/Dodge/Critters.hs

@@ -261,10 +261,10 @@ explosiveBarrel = basicCreature
 
 equipOnTop :: (Creature -> Picture) -> Creature -> Drawing
 --equipOnTop f cr = onLayer CrLayer $ pictures $ fst (drawEquipment cr) ++ [f cr] ++ snd (drawEquipment cr)
-equipOnTop f cr = onLayer CrLayer (f cr) <> drawEquipment cr
+equipOnTop f cr = pictures [onLayer CrLayer (f cr) , drawEquipment cr]
 
 drawEquipment :: Creature -> Drawing
-drawEquipment cr = mconcat $ map f $ IM.toList (_crInv cr)
+drawEquipment cr = pictures $ map f $ IM.toList (_crInv cr)
     where f (i,it) = case it ^? itEquipPict of
                         Just g -> g cr i
                         _      -> blank
@@ -388,7 +388,7 @@ sizeEnemy col cr
 sizeColEnemy r col = pictures [color col $ circleSolid r, circLine r]
 
 basicCrPict :: Color -> Creature -> Drawing
-basicCrPict col cr = onLayer CrLayer naked <> drawEquipment cr
+basicCrPict col cr = pictures [ onLayer CrLayer naked , drawEquipment cr]
     where naked | pdam > 200      = color red $ circleSolid $ _crRad cr
                 | pdam > 100      = color white $ circleSolid $ _crRad cr
                 | mod pdam 2 == 1 = color white $ circleSolid $ _crRad cr

src/Dodge/Rendering.hs

@@ -78,72 +78,78 @@ draw'' b w-- | (Char 'm') `S.member` _keys w
           drawNode (i,x) = color yellow $ uncurry translate x $ scale 0.05 0.05 $ text $ show i
 
 collectDrawings :: World -> Picture
-collectDrawings w = screenShift (decPicts <> ppPicts <> itFloorPicts 
+collectDrawings w = pictures 
-                                <> crPicts
+             [screenShift $
-                                <> clPicts
+                        pictures $ concat
-                                <> buttonPicts <> ptPicts 
+                                 [ decPicts 
-                                <> ptPicts'
+                                 , ppPicts 
-                                <> afterPtPicts'
+                                 , itFloorPicts 
-                                <> wlPicts
+                                 , crPicts
-                                <> wallShadows
+                                 , clPicts
-                                <> smokeShadows
+                                 , buttonPicts 
-                                )
+                                 , ptPicts 
-                                <> onLayer LabelLayer
+                                 , ptPicts'
-                                        (itLabels <> ppLabels <> btLabels)
+                                 , afterPtPicts'
-                                <> hudDrawings w
+                                 , wlPicts
-                                <> onLayer MenuLayer menuScreen
+                                 , wallShadows
+                                 , smokeShadows
+                                 ]
+             , onLayer LabelLayer $ pictures [itLabels, ppLabels, btLabels]
+             , hudDrawings w
+             , onLayer MenuLayer menuScreen
+             ]
 --                                <> [onLayer GloomLayer $ theLighting w]
     where
           screenShift = scale zoom zoom . rotate (radToDeg (_cameraRot w) )
                                             . uncurry translate ((0,0) -.- _cameraPos w)
           zoom     = _cameraZoom w
-          decPicts :: Picture
+          decPicts      = IM.elems $ _decorations w
-          decPicts      = mconcat $ IM.elems $ _decorations w
+          ptPicts       = map _ptPict (IM.elems (_particles w))
-          ptPicts       = mconcat $ map _ptPict (IM.elems (_particles w))
+          ptPicts'      = map _ptPict' $ _particles' w
-          ptPicts'      = mconcat $ map _ptPict' $ _particles' w
+          afterPtPicts' = map _ptPict' $ _afterParticles' w
-          afterPtPicts' = mconcat $ map _ptPict' $ _afterParticles' w
+          buttonPicts   = map btDraw (IM.elems (_buttons w))
-          buttonPicts   = mconcat $ map btDraw (IM.elems (_buttons w))
+          ppPicts       = map ppDraw (IM.elems (_pressPlates w))
-          ppPicts       = mconcat $ map ppDraw (IM.elems (_pressPlates w))
+          crPicts       = map crDraw $ IM.elems $ _creatures w
-          crPicts :: Picture
+          clPicts       = map clDraw $ IM.elems $ _clouds w
-          crPicts       = mconcat $ map crDraw $ IM.elems $ _creatures w
+          wallShadows   = map (drawWallShadow w) $ wallShadowsToDraw w
-          clPicts       = mconcat $ map clDraw $ IM.elems $ _clouds w
+          smokeShadows  = map (drawSmokeShadow w) $ _smoke w
-          wallShadows   = mconcat $ map (drawWallShadow w) $ wallShadowsToDraw w
+          wlPicts       = map drawWall (wallsToDraw w)
-          smokeShadows  = mconcat $ map (drawSmokeShadow w) $ _smoke w
+          itFloorPicts  = map (drawItem) (IM.elems (_floorItems w))
-          wlPicts       = mconcat $ map drawWall (wallsToDraw w)
           yourPos = _crPos $ you w
           yourRot = _crDir $ you w
           yourRad = _crRad $ you w
          -- itFloorPicts = zipWith (uncurry translate) (map _flItPos (IM.elems (_floorItems w)))
          --                                       (map (_itFloorPict . _flIt) (IM.elems (_floorItems w)))
-          itFloorPicts = mconcat $ map (drawItem) (IM.elems (_floorItems w))
+          itLabels     = pictures $ map (drawItemName w) (IM.elems (_floorItems w))
-          itLabels     = mconcat $ map (drawItemName w) (IM.elems (_floorItems w))
+          ppLabels     = pictures $ map (drawPPText w) (IM.elems (_pressPlates w))
-          ppLabels     = mconcat $ map (drawPPText w) (IM.elems (_pressPlates w))
+          btLabels     = pictures $ map (drawButText w) (IM.elems (_buttons w))
-          btLabels     = mconcat $ map (drawButText w) (IM.elems (_buttons w))
           menuScreen :: Picture
           menuScreen = case _menuState w of
                         InGame -> blank 
                         LevelMenu x -> 
-                            mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
+                            pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
                             ,tst (-100) 100 0.4 ("LEVEL "++show x)
-                            ] <> controlsList
+                            ,controlsList
-                        PauseMenu   -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
+                            ]
+                        PauseMenu   -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
                                     ,tst (-100) 100 0.4 "PAUSED"
                                     ,tst (-100) 50 0.2 "n - new level"
                                     ,tst (-100) 0 0.2 "r - restart"
-                                    ] <> controlsList
+                                    , controlsList
-                        GameOverMenu -> mconcat [color (withAlpha 0.5 black) $ polygon $ screenBox w
+                                    ]
+                        GameOverMenu -> pictures [color (withAlpha 0.5 black) $ polygon $ screenBox w
                                     ,tst (-100) 100 0.4 "GAME OVER"
                                     ,tst (-100) 50 0.2 "n - new level"
                                     ,tst (-100) 0 0.2 "r - restart"
+                                    ,controlsList
                                     ]
-                                    <> controlsList
                 where tst x y sc t = translate x y $ scale sc sc $ color white $ text t
 
 hudDrawings :: World -> Picture
 hudDrawings w = (onLayer InvLayer) 
-                        $ displayInv 0 w
+                        $ pictures
-                               <> mconcat
+                          [ displayInv 0 w
-                          [ dShadCol white $ displayHP 0 w
+                          , dShadCol white $ displayHP 0 w
                           , dShadCol (itCol (yourItem w)) 
                                 $ drawCursor w, translate (-390) 20 
                                 $ scale 0.05 0.05 $ dShadCol white $ text (_testString w)
@@ -169,7 +175,7 @@ drawCursor w = translate (105-halfWidth w)
     where iPos = _crInvSel $ _creatures w IM.! _yourID w
 
 
-controlsList = mconcat [tst (-250) (-130) 0.15 "controls:"
+controlsList = pictures [tst (-250) (-130) 0.15 "controls:"
                ,tst (-150) (-130) 0.15 "wasd"
                ,tst  0   (-130) 0.15 "movement"
                ,tst (-150) (-160) 0.15 "[rmb]"
@@ -215,20 +221,18 @@ wallsToDraw w = filter isVisible $ IM.elems $ wallsOnScreen w
 wallsOnScreen :: World -> IM.IntMap Wall
 wallsOnScreen w = wallsNearZones (zoneOfScreen w) w
 
-drawSmokeShadow :: World -> Smoke -> Drawing
+drawSmokeShadow :: World -> Smoke -> Picture
 drawSmokeShadow w sm@(Smoke {_smPos = p, _smRad = r', _smColor = c, _smPs = ps, _smTime = t}) 
-    = (
+    = pictures
-        onLayerL [74,0] $ color col $
+        [ onLayerL [74,0] $ color col $
                              pictures [uncurry translate p $ circle r'
                                      ,line $ (\(x,y) -> [x,y]) $ smokePerpLine (_cameraPos w) p sm
                                      ,line [_cameraPos w, mouseWorldPos w]
                                      ,trap' p
                                      ]
-        )
+        , onLayerL [74] $ color (withAlpha 0.1 c) $ pictures
-        <>
-       (onLayerL [74] $ color (withAlpha 0.1 c) $ pictures
                $ concatMap (f . (+.+ p)) p's
-       ) 
+        ]
     where
         r = r'/2
         col | smokeLOS (_cameraPos w) (mouseWorldPos w) w = red
@@ -363,7 +367,7 @@ linePointsBetween p p' | d > 99 = map (\m -> p +.+ fromIntegral m *.* p'') [0..n
           p'' = (1/fromIntegral n) *.* (p' -.- p)
 
 displayInv :: Int -> World -> Picture
-displayInv n w = mconcat $ zipWith (translate (10-halfWidth w)) 
+displayInv n w = pictures $ zipWith (translate (10-halfWidth w)) 
                          (map (\x-> halfHeight w-(25*(fromIntegral x+1))) ns) $ map dItem' is
      where (ns,is) = unzip $ IM.toList $ _crInv $ _creatures w IM.! n
 

src/Dodge/Weapons.hs

@@ -1018,7 +1018,7 @@ moveFlame rotd w pt =
                 damcr cr p = over (creatures . ix (_crID cr) . crState . crDamage) 
                                   ((:) $ Flaming (div time 10) sp p ep)
                 hiteff = _btHitEffect' pt pt
-                thepic p' =  pic p' <> piu p' <> pi2 p' <> glow p'
+                thepic p' = pictures [ pic p' , piu p' , pi2 p' , glow p' ]
                 pic p' = onLayerL [levLayer UPtLayer,6] $ uncurry translate (prot3 p')
                                               $ rotate (90 + (negate $ radToDeg $ argV rotd))
                                               $ scale scaleChange 1
@@ -2055,10 +2055,12 @@ moveTeslaArc p d i w =
                             $ set randGen g
                             $ createSpark 8 nc q2 (argV sv + d1) Nothing
                             $ foldr damCrs w hitCrs
-     where pic = (onLayer PtLayer $ color (f2 nc) $ line ps')
+     where pic = pictures 
-                    <> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps')
+                    [ onLayer PtLayer $ color (f2 nc) $ line ps'
-                    <> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps')
+                    , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 20 ps'
-                    <> (onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps')
+                    , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 25 ps'
+                    , onLayer UPtLayer $ color (withAlpha 0.02 cyan) $ lineOfThickness 30 ps'
+                    ]
            ps' = lightningMids d pers ps
            ps = take 15 $ p : map f (crsLightChain p d 0 w)
            f (E3x1 cr) = _crPos cr

src/Dodge/WorldActions.hs

@@ -403,7 +403,7 @@ flareRad rad rays col ax ay p
 flashRadAt :: Float -> Color -> Float -> Point2 -> Particle'
 flashRadAt rad col alphax (x,y) =
     Particle' 
-        { _ptPict' = mconcat $
+        { _ptPict' = pictures $
                          map (\i -> onLayerL [levLayer PtLayer]
                                         $ color (withAlpha alphax col) $ translate x y $ circleSolid i
                          )
@@ -414,7 +414,7 @@ flashRadAt rad col alphax (x,y) =
 flashColAt :: Color -> Float -> Point2 -> Particle'
 flashColAt col alphax (x,y) =
     Particle' 
-        { _ptPict' = mconcat $
+        { _ptPict' = pictures $
                          map (\i -> onLayerL [levLayer PtLayer] 
                                     $ color (withAlpha alphax col) $ translate x y $ circleSolid i
                          )
@@ -500,7 +500,7 @@ muzFlareAt p = over particles' ((:) (muzzleFlareAt p))
 muzzleFlareAt :: Point2 -> Particle'
 muzzleFlareAt (x,y) =
     Particle' 
-        { _ptPict' = mconcat 
+        { _ptPict' = pictures 
                         $ map (\i -> onLayer PtLayer $ color (withAlpha 0.02 white) $ translate x y $ circleSolid i
                          )
                          [20,25,30,35,40,45,50]
@@ -748,7 +748,7 @@ moveFlamelet levelInt rot w pt =
                 sc = (*) 2 $ log $ 1 + fromIntegral time / 20
                 s1 = (*) 2 $ log $ 2 + fromIntegral time / 40
                 s2 = 0.5 * (sc + s1)
-                thepicture = pic <> piu <> pi2 <> glow
+                thepicture = pictures [pic , piu , pi2 , glow]
                 pi2 = onLayerL [levelInt,2] $ uncurry translate ep
                            $ color (mixColors (fromIntegral (max 0 (time-2))) (10-fromIntegral time) 
                                               orange                          (dark red)
@@ -839,14 +839,16 @@ moveSmoke'' scal time p vel w pt
           pic = onLayerL [levLayer PtLayer - 1] 
                     $ uncurry translate pNew 
                     $ color (greyN 0.5) $ circleSolid $ (21 - fromIntegral time) * scal
-          pi1 = (onLayerL [levLayer PtLayer]
+          pi1 = pictures 
+                  [(onLayerL [levLayer PtLayer]
                     $ uncurry translate pNew 
                     $ color (withAlpha (0.3 * (1 + fromIntegral time /50)) (greyN 0.5)) 
                     $ circleSolid $ 21 * scal)
-                <> (onLayerL [levLayer BgLayer+1]
+                  , (onLayerL [levLayer BgLayer+1]
                     $ uncurry translate pNew 
                     $ color (withAlpha (1 + fromIntegral time /50) (greyN 0.5)) 
                     $ circleSolid $ 21 * scal)
+                  ]
 
 makeColorSmokeAt :: Color -> Point2 -> Float -> Int -> Point2 -> World -> World
 makeColorSmokeAt col vel scal time p w = over particles (IM.insert n smP) w

src/Geometry.hs

@@ -13,6 +13,7 @@ import Data.Maybe
 import Control.Applicative
 
 zeroZ :: Point2 -> Point3
+{-# INLINE zeroZ #-}
 zeroZ (x,y) = (x,y,0)
 
 infixl 6 +.+, -.-

src/Picture.hs

@@ -16,7 +16,6 @@ module Picture
     , rotate
     , rotateRad
     , scale
-    , blank
     , color
     , withAlpha
     , greyN
@@ -51,41 +50,48 @@ import Picture.Data
 import Data.Bifunctor
 import qualified Data.DList as DL
 
-import Graphics.Rendering.OpenGL (lineWidth, ($=),PrimitiveMode (..))
+import Graphics.Rendering.OpenGL (lineWidth, ($=))
 
 import Control.Lens
 
 black :: RGBA
 black = (0,0,0,1)
 
-polygonD :: Float -> [Point2] -> Picture
+--polygonD :: Float -> [Point2] -> Picture
-{-# INLINE polygonD #-}
+--{-# INLINE polygonD #-}
-polygonD d (a:b:c:ps) = blank
+--polygonD d (a:b:c:ps) = blank
-    { _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
+--    { _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
-    , _scColTri = mapVC (const black) tris
+--    , _scColTri = mapVC (const black) tris
-    }
+--    }
-    where twoPs = zip (b:c:ps) (c:ps)
+--    where twoPs = zip (b:c:ps) (c:ps)
-          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
+--          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
-polygonD _ _ = blank
+--polygonD _ _ = blank
 
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
-polygon (a:b:c:ps) = blank
+polygon = Polygon
-    { _scPosTri = fmap zeroZ tris
-    , _scColTri = fmap (const black) tris
-    }
-    where twoPs = zip (b:c:ps) (c:ps)
-          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
-polygon _ = blank
 
-color :: RGBA -> Picture -> Picture
+--polygon :: [Point2] -> Picture
-{-# INLINE color #-}
+--{-# INLINE polygon #-}
-color c pic@(Scene {_scColTri = colTri,_scColChar= colChar}) =
+--polygon (a:b:c:ps) = NLeaf $ emptyScene
+--    { _scPosTri = fmap zeroZ tris
+--    , _scColTri = fmap (const black) tris
+--    }
+--    where twoPs = zip (b:c:ps) (c:ps)
+--          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
+--polygon _ = blank
+
+color' :: RGBA -> Scene -> Scene
+{-# INLINE color' #-}
+color' c pic@(Scene {_scColTri = colTri,_scColChar= colChar}) =
     pic {_scColTri  = mapVC (const c) colTri
         ,_scColChar = mapVC (const c) colChar
         }
+color :: RGBA -> Picture -> Picture
+{-# INLINE color #-}
+color c pic = Color c pic
 
-overPos :: (Point3 -> Point3) -> Picture -> Picture
+overPos :: (Point3 -> Point3) -> Scene -> Scene
 {-# INLINE overPos #-}
 overPos f pic@(Scene {_scPosTri = posTri,_scPosChar= posChar}) =
     pic {_scPosTri  = mapVC f posTri
@@ -96,56 +102,77 @@ translate3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE translate3 #-}
 translate3 a b (x,y,z) = (x+a,y+b,z)
 
+translate' :: Float -> Float -> Scene -> Scene
+{-# INLINE translate' #-}
+--translate x y = over scPosTri (mapVC $ translate3 x y) . over scPosChar (mapVC $ translate3 x y)
+translate' x y = overPos $ translate3 x y
+
 translate :: Float -> Float -> Picture -> Picture
 {-# INLINE translate #-}
---translate x y = over scPosTri (mapVC $ translate3 x y) . over scPosChar (mapVC $ translate3 x y)
+translate x y pic = Translate x y pic
-translate x y = overPos $ translate3 x y
+
+setDepth' :: Float -> Scene -> Scene
+{-# INLINE setDepth' #-}
+setDepth' d = overPos $ \(x,y,z) -> (x,y,d)
 
 setDepth :: Float -> Picture -> Picture
---setDepth d = over scPosTri (mapVC $ (\(x,y,z)->(x,y,d)))
+{-# INLINE setDepth #-}
---             . over scPosChar (mapVC $ (\(x,y,z)->(x,y,d)))
+setDepth d pic = SetDepth d pic
-setDepth d = overPos $ \(x,y,z) -> (x,y,d)
 
 scale3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE scale3 #-}
 scale3 a b (x,y,z) = (x*a,y*b,z)
 
+scale' :: Float -> Float -> Scene -> Scene
+{-# INLINE scale' #-}
+--scale x y = over scPosTri (mapVC $ scale3 x y) . over scPosChar (mapVC $ scale3 x y)
+scale' x y pic = overPos (scale3 x y) $ over scTexChar (fmap (second (*x))) pic
+
 scale :: Float -> Float -> Picture -> Picture
 {-# INLINE scale #-}
---scale x y = over scPosTri (mapVC $ scale3 x y) . over scPosChar (mapVC $ scale3 x y)
+scale x y pic = Scale x y pic
-scale x y pic = overPos (scale3 x y) $ over scTexChar (fmap (second (*x))) pic
 
 rotate3 :: Float -> Point3 -> Point3
 {-# INLINE rotate3 #-}
 rotate3 a (x,y,z) = (x',y',z)
     where (x',y') = rotateV a (x,y)
 
-rotate :: Float -> Picture -> Picture
+rotate' :: Float -> Scene -> Scene
-{-# INLINE rotate #-}
+{-# INLINE rotate' #-}
---rotate a = over scPosTri (mapVC $ rotate3 (0 - degToRad a)) 
+rotate' a = overPos $ rotate3 $ 0 - degToRad a
---            . over scPosChar (mapVC $ rotate3 (0 - degToRad a))
-rotate a = overPos $ rotate3 $ 0 - degToRad a
 
---  -- this rotation uses radians, and is anticlockwise
+--rotate :: Float -> Picture -> Picture
-rotateRad :: Float -> Picture -> Picture
+--{-# INLINE rotate #-}
+--rotate a pic = NBranch (rotate' a) pic
+--
+----  -- this rotation uses radians, and is anticlockwise
+--rotateRad' :: Float -> Scene -> Scene
+--{-# INLINE rotateRad' #-}
+--rotateRad' a = overPos $ rotate3 a
+--
+--rotateRad :: Float -> Picture -> Picture
+--{-# INLINE rotateRad #-}
+--rotateRad a pic = NBranch (rotateRad' a) pic
+
+rotate a = rotateRad (0 - degToRad a)
+{-# INLINE rotate #-}
+
+rotateRad a = Rotate a
 {-# INLINE rotateRad #-}
---rotateRad a = over scPosTri (mapVC $ rotate3 a) 
---            . over scPosChar (mapVC $ rotate3 a)
-rotateRad a = overPos $ rotate3 a
 
 pictures :: [Picture] -> Picture
 {-# INLINE pictures #-}
-pictures = mconcat
+pictures = Pictures
 
 
 makeArc :: Float -> (Float,Float) -> [Point2]
 {-# INLINE makeArc #-}
 makeArc rad (a,b) = zipWith rotateV as $ repeat (0,rad)
     where as = [a,a+step.. b]
-          step = pi * 0.1
+          step = pi * 0.2
 
-circleSolidD :: Float -> Float -> Picture
+--circleSolidD :: Float -> Float -> Picture
-circleSolidD d r = polygonD d $ makeArc r (0,2*pi)
+--circleSolidD d r = polygonD d $ makeArc r (0,2*pi)
 
 circleSolid :: Float -> Picture
 {-# INLINE circleSolid #-}
@@ -162,21 +189,25 @@ circle rad = line $ makeArc rad (0,2*pi)
 
 text :: String -> Picture
 {-# INLINE text #-}
-text s = mconcat $ zipWith (\x -> translate x (0-dimText)) 
+text = Text
-                           [0,0.9*dimText..] 
-                           (map charToScene s)
 
-charToScene :: Char -> Picture
+----text :: String -> Picture
-charToScene c = Scene
+----{-# INLINE text #-}
-    {_scPosTri = mempty
+----text s = pictures $  zipWith (\x -> translate x (0-dimText)) 
-    ,_scColTri = mempty
+----                           [0,0.9*dimText..] 
-    ,_scPosChar = toVC [(0.0,0.0,0)]
+----                           (map charToScene s)
-    ,_scColChar = toVC [white]
+----
-    ,_scTexChar = toVC [(offset,100)]
+----charToScene :: Char -> Picture
-    }
+----charToScene c = NLeaf $ Scene
-    where x = 1/128
+----    {_scPosTri = mempty
-          s = offset * x
+----    ,_scColTri = mempty
-          offset = fromIntegral (fromEnum c) - 32
+----    ,_scPosChar = toVC [(0.0,0.0,0)]
+----    ,_scColChar = toVC [white]
+----    ,_scTexChar = toVC [(offset,100)]
+----    }
+----    where x = 1/128
+----          s = offset * x
+----          offset = fromIntegral (fromEnum c) - 32
 --charToScene :: Char -> Picture
 --charToScene c = Scene
 --    {_scPosTri = mempty
@@ -265,3 +296,9 @@ bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
 
 greyN :: Float -> Color
 greyN x = (x,x,x,1)
+
+
+--zeroZ :: Point2 -> Point3
+--{-# INLINE zeroZ #-}
+--zeroZ (x,y) = (x,y,0)
+

src/Picture/Data.hs

@@ -15,34 +15,33 @@ type RGBA = (Float,Float,Float,Float)
 type Color = (Float,Float,Float,Float)
 
 
-type VerticesContainer a = Se.Seq a
+--type VerticesContainer a = Se.Seq a
-toVC = Se.fromList
+--toVC = Se.fromList
-fromVC :: VerticesContainer a -> [a]
+--fromVC :: VerticesContainer a -> [a]
-fromVC = F.toList
+--fromVC = F.toList
 --type VerticesContainer a = DL.DList a
 --toVC = DL.fromList
 --fromVC = DL.toList
---type VerticesContainer a = [a]
+type VerticesContainer a = [a]
---toVC = id
+toVC = id
---fromVC = id
+fromVC = id
+{-# INLINE toVC #-}
+{-# INLINE fromVC #-}
+{-# INLINE mapVC #-}
 
 mapVC :: (a -> b) -> VerticesContainer a -> VerticesContainer b
 mapVC = fmap
 
-data NTree a b
+data FTree a
-    = NBranch a [NTree a b]
+    = FBranch (a -> a) (FTree a)
-    | NLeaf b
+    | FBranches [FTree a]
+    | FLeaf a
 
-reduceNTree :: NTree (a -> a) a -> NTree () a
+instance Foldable FTree where
-reduceNTree = reduceNTree' id
+    foldMap g (FBranch f t) = foldMap (g . f) t
-    where 
+    foldMap g (FBranches ts) = mconcat $ map (foldMap g) ts
-        reduceNTree' :: (b -> b) -> NTree (b -> b) b -> NTree () b
+    foldMap g (FLeaf x) = g x
-        reduceNTree' f (NBranch g xs) = NBranch () $ map (reduceNTree' (f . g)) xs
+    {-# INLINE foldMap #-}
-        reduceNTree' f (NLeaf x) = NLeaf $ f x
-
-concatLeaves :: NTree a b -> DL.DList b
-concatLeaves (NLeaf x) = DL.singleton x
-concatLeaves (NBranch _ xs) = mconcat (map concatLeaves xs)
 
 --reduceShapeTree :: (Shape -> Shape) -> ShapeTree -> [Shape]
 --reduceShapeTree
@@ -50,27 +49,51 @@ concatLeaves (NBranch _ xs) = mconcat (map concatLeaves xs)
 --reduceShapeTree
 --    (Leaf s) = [s]
 
-data ShapeTree 
+--  data ShapeTree 
-    = TransformShape (Shape -> Shape) [ShapeTree]
+--      = TransformShape (Shape -> Shape) [ShapeTree]
-    | Leaf Shape
+--      | Leaf Shape
-
+--  
-data Shape 
+--  data Shape 
-    = Shape 
+--      = Shape 
-        { _shPos :: VerticesContainer Point3
+--          { _shPos :: VerticesContainer Point3
-        , _shCol :: VerticesContainer RGBA
+--          , _shCol :: VerticesContainer RGBA
-        }
+--          }
-    | TextShape
+--      | TextShape
-        { _shPos :: VerticesContainer Point3
+--          { _shPos :: VerticesContainer Point3
-        , _shCol :: VerticesContainer RGBA
+--          , _shCol :: VerticesContainer RGBA
-        , _shTex :: VerticesContainer Point2
+--          , _shTex :: VerticesContainer Point2
-        }
+--          }
+--
 --combineShapes :: Shape -> Shape -> Shape
 --combineShapes sa sb = Shape
 --    { _shPos  = _shPos  sa <> _shPos sb
 --    , _shCol  = _shCol  sa <> _shCol sb
 --    }
 
-data Picture = Scene
+flat2 (x,y)     = [x,y]
+flat3 (x,y,z)   = [x,y,z]
+flat4 (x,y,z,w) = [x,y,z,w]
+{-# INLINE flat2 #-}
+{-# INLINE flat3 #-}
+{-# INLINE flat4 #-}
+
+data RenderType
+    = RenderPoly [(Point3,Point4)]
+    | RenderText [(Point3,Point4,Point2)]
+    | RenderBlank
+
+data Picture
+    = Blank
+    | Text String
+    | Polygon [Point2]
+    | 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
@@ -78,11 +101,15 @@ data Picture = Scene
     , _scTexChar :: VerticesContainer Point2
     }
 
+emptyScene :: Scene
+{-# INLINE emptyScene #-}
+emptyScene = Scene mempty mempty mempty mempty mempty
+
 blank :: Picture
 {-# INLINE blank #-}
-blank = Scene mempty mempty mempty mempty mempty 
+blank = Blank
 
-combineScenes :: Picture -> Picture -> Picture
+combineScenes :: Scene -> Scene -> Scene
 {-# INLINE combineScenes #-}
 combineScenes sa sb = Scene
     { _scPosTri  = _scPosTri  sa <> _scPosTri sb
@@ -92,10 +119,10 @@ combineScenes sa sb = Scene
     , _scTexChar = _scTexChar sa <> _scTexChar sb
     }
 
-instance Semigroup Picture where
+instance Semigroup Scene where
     (<>) = combineScenes
-instance Monoid Picture where
+instance Monoid Scene where
-    mempty = blank
+    mempty = emptyScene
     --mappend = combineScenes
 
-makeLenses ''Picture
+makeLenses ''Scene

src/Picture/Render.hs

@@ -1,7 +1,13 @@
 --{-# LANGUAGE Strict #-}
+{-# LANGUAGE DeriveFoldable, StandaloneDeriving #-}
 module Picture.Render
     where
 import Control.Lens
+import Control.Monad
+import Control.Monad.Trans.State
+
+import Data.Bifunctor
+
 import Picture
 import Geometry
 
@@ -12,10 +18,11 @@ import Foreign
 
 import Codec.Picture
 
-import Graphics.Rendering.OpenGL hiding (translate,scale,imageHeight,imageWidth)
+import Graphics.Rendering.OpenGL hiding (get,translate,scale,imageHeight,imageWidth,Polygon,Color,T)
 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
 
@@ -29,61 +36,157 @@ toVec2 (x,y) = Vector2 x y
 toVec3 (x,y,z) = Vector3 x y z
 toVec4 (x,y,z,w) = Vector4 x y z w
 
-flat2 (x,y)     = toVC [x,y]
-flat3 (x,y,z)   = toVC [x,y,z]
-flat4 (x,y,z,w) = toVC [x,y,z,w]
-
 mapFlat :: (NFData b) => (a -> VerticesContainer b) -> VerticesContainer a -> [b]
 mapFlat f = fromVC . foldMap f
 
---marshallVs = V.unsafeWith . V.fromList
+polyToTris :: [s] -> [s]
---marshallVs = withArray
+{-# 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
+
+picToFTree :: Picture -> FTree [(Point3,Point4)]
+{-# INLINE picToFTree #-}
+picToFTree (Polygon ps) = FLeaf $ zip (map zeroZ $ polyToTris ps) $ repeat black
+picToFTree Blank    = FLeaf $ []
+picToFTree (Text _) = FLeaf $ []
+picToFTree (Scale x y pic) = FBranch (map $ first $ scale3 x y) $ picToFTree pic
+picToFTree (Translate x y pic) = FBranch (map $ first $ translate3 x y) $ picToFTree pic
+picToFTree (Rotate a pic) = FBranch (map $ first $ rotate3 a) $ picToFTree pic
+picToFTree (SetDepth a pic) = FBranch (map $ first $ (\(x,y,_) -> (x,y,a))) $ picToFTree pic
+picToFTree (Color c pic) = FBranch (map $ second $ const c) $ picToFTree pic
+picToFTree (Pictures pics) = FBranches $ map picToFTree pics
+
+pokePic :: Ptr Float -> Ptr Float -> FTree [(Point3,Point4)] -> IO Int
+pokePic = go 0
+    where go n pa pb t = foldM (pokePoly pa pb) n t
+
+pokePoly :: Ptr Float -> Ptr Float -> Int -> [(Point3,Point4)] -> IO Int
+pokePoly pa pb n vs = foldM (pokeVert pa pb) n vs
+
+pokeVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
+pokeVert 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)
+
+
+
+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)
+scale3 :: Float -> Float -> Point3 -> Point3
+{-# INLINE scale3 #-}
+scale3 a b (x,y,z) = (x*a,y*b,z)
+rotate3 :: Float -> Point3 -> Point3
+{-# INLINE rotate3 #-}
+rotate3 a (x,y,z) = (x',y',z)
+    where (x',y') = rotateV a (x,y)
 
 renderPicture' :: PreloadData -> Picture -> IO ()
-renderPicture' pdata (Scene posTri colTri posChar colChar texChar) = do
+renderPicture' pdata pic = do
     currentProgram $= Just (_basicShader pdata)
     bindVertexArrayObject $= Just (_basicVAO pdata)
     bindBuffer ArrayBuffer $= Just (_posVBO pdata)
     let firstIndex = 0
-    let vertices :: [Float]
+        fSize = sizeOf (0::Float)
-        vertices = mapFlat flat3 posTri
+    numVert <- pokePic (_ptrPosVBO pdata) (_ptrColVBO pdata) $ picToFTree pic
-        numVertices = length posTri
+    bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 3, _ptrPosVBO pdata, StreamDraw)
-        vertexSize = sizeOf (head vertices)
-    pokeArray (_ptrPosVBO pdata) vertices
-    bufferData ArrayBuffer $= (fromIntegral (3 * numVertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
 --    marshallVs vertices $ \ptr -> do
 --        bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), ptr, StreamDraw)
     bindBuffer ArrayBuffer $= Just (_colVBO pdata)
-    let colVs = mapFlat flat4 colTri
+    bufferData ArrayBuffer $= (fromIntegral $ fSize * numVert * 4, _ptrColVBO pdata, StreamDraw)
-        colVsize = sizeOf $ head colVs
+--    marshallVs colVs $ \ptr -> do
+--        bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), ptr, StreamDraw)
+    drawArrays Triangles (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 (4 * numVertices * colVsize), _ptrColVBO pdata, StreamDraw)
+    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)
+----    currentProgram $= Just (_textShader pdata)
-    bindVertexArrayObject $= Just (_textVAO pdata)
+----    bindVertexArrayObject $= Just (_textVAO pdata)
-    bindBuffer ArrayBuffer $= Just (_posVBO pdata)
+----    bindBuffer ArrayBuffer $= Just (_posVBO pdata)
-    let vertices' = mapFlat flat3 posChar
+----    let vertices' = concatMap flat3 posChar
-        numVertices' = length posChar
+----        numVertices' = length posChar
-        vertexSize'  = sizeOf $ head vertices'
+----        vertexSize'  = sizeOf $ head vertices'
-    pokeArray (_ptrPosVBO pdata) vertices'
+----    pokeArray (_ptrPosVBO pdata) vertices'
-    bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), _ptrPosVBO pdata, StreamDraw)
+----    bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), _ptrPosVBO pdata, StreamDraw)
-    --withArray vertices' $ \ptr -> do
+----    --withArray vertices' $ \ptr -> do
-    --    bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), ptr, StreamDraw)
+----    --    bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), ptr, StreamDraw)
-    bindBuffer ArrayBuffer $= Just (_colVBO pdata)
+----    bindBuffer ArrayBuffer $= Just (_colVBO pdata)
-    pokeArray (_ptrColVBO pdata) $ mapFlat flat4 colChar
+----    pokeArray (_ptrColVBO pdata) $ concatMap flat4 colChar
-    bufferData ArrayBuffer $= (fromIntegral (4 * numVertices' * vertexSize'), _ptrColVBO pdata, StreamDraw)
+----    bufferData ArrayBuffer $= (fromIntegral (4 * numVertices' * vertexSize'), _ptrColVBO pdata, StreamDraw)
-    bindBuffer ArrayBuffer $= Just (_texVBO pdata)
+----    bindBuffer ArrayBuffer $= Just (_texVBO pdata)
-    pokeArray (_ptrTexVBO pdata) $ mapFlat flat2 texChar
+----    pokeArray (_ptrTexVBO pdata) $ concatMap flat2 texChar
-    bufferData ArrayBuffer $= (fromIntegral (2 * numVertices' * vertexSize'), _ptrTexVBO pdata, StreamDraw)
+----    bufferData ArrayBuffer $= (fromIntegral (2 * numVertices' * vertexSize'), _ptrTexVBO pdata, StreamDraw)
-    drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVertices')
+----    drawArrays Points (fromIntegral firstIndex) (fromIntegral $ numVertices')
 
 
 
 bufferOffset :: Integral a => a -> Ptr b
 bufferOffset = plusPtr nullPtr . fromIntegral
 
-zeroZ :: Point2 -> Point3
-zeroZ (x,y) = (x,y,0)