Commit with working graphics but slow, will attempt to change text

src/Picture.hs

@@ -1,5 +1,5 @@
 --{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE Strict #-}
+--{-# LANGUAGE Strict #-}
 module Picture
     ( module Picture.Data
     , polygon
@@ -61,26 +61,36 @@ black = (0,0,0,1)
 polygonD :: Float -> [Point2] -> Picture
 {-# INLINE polygonD #-}
 polygonD d (a:b:c:ps) = blank
-    { _scPosTri = DL.fromList $ map (\(x,y) -> (x,y,d)) tris
+    { _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
-    , _scColTri = DL.fromList $ map (const black) tris
+    , _scColTri = mapVC (const black) tris
     }
     where twoPs = zip (b:c:ps) (c:ps)
-          tris = concatMap (\(x,y)-> [a,x,y]) twoPs
+          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
 polygonD _ _ = blank
 
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
 polygon (a:b:c:ps) = blank
-    { _scPosTri = DL.fromList $ map zeroZ tris
+    { _scPosTri = fmap zeroZ tris
-    , _scColTri = DL.fromList $ map (const black) tris
+    , _scColTri = fmap (const black) tris
     }
     where twoPs = zip (b:c:ps) (c:ps)
-          tris = concatMap (\(x,y)-> [a,x,y]) twoPs
+          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
 polygon _ = blank
 
 color :: RGBA -> Picture -> Picture
 {-# INLINE color #-}
-color c = over scColTri (DL.map $ const c) . over scColChar (DL.map $ const c)
+color c pic@(Scene {_scColTri = colTri,_scColChar= colChar}) =
+    pic {_scColTri  = mapVC (const c) colTri
+        ,_scColChar = mapVC (const c) colChar
+        }
+
+overPos :: (Point3 -> Point3) -> Picture -> Picture
+{-# INLINE overPos #-}
+overPos f pic@(Scene {_scPosTri = posTri,_scPosChar= posChar}) =
+    pic {_scPosTri  = mapVC f posTri
+        ,_scPosChar = mapVC f posChar
+        }
 
 translate3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE translate3 #-}
@@ -88,19 +98,13 @@ translate3 a b (x,y,z) = (x+a,y+b,z)
 
 translate :: Float -> Float -> Picture -> Picture
 {-# INLINE translate #-}
-translate x y = over scPosTri (DL.map $ translate3 x y) . over scPosChar (DL.map $ translate3 x y)
+--translate x y = over scPosTri (mapVC $ translate3 x y) . over scPosChar (mapVC $ translate3 x y)
+translate x y = overPos $ translate3 x y
 
 setDepth :: Float -> Picture -> Picture
-setDepth d = over scPosTri (DL.map $ (\(x,y,z)->(x,y,d)))
+--setDepth d = over scPosTri (mapVC $ (\(x,y,z)->(x,y,d)))
-             . over scPosChar (DL.map $ (\(x,y,z)->(x,y,d)))
+--             . over scPosChar (mapVC $ (\(x,y,z)->(x,y,d)))
-
+setDepth d = overPos $ \(x,y,z) -> (x,y,d)
---overVs' :: (CPoint2 -> CPoint) -> Picture -> Picture
-----{-# INLINE overVs' #-}
---overVs' f !(Scene a b) = let !a' = map f a
---                             !b' = map g b
---                         in  Scene a' b'
---    where g !(x,y,z) = let !(x',y') = f (x,y)
---                       in  (x',y',z)
 
 scale3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE scale3 #-}
@@ -108,7 +112,8 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
 
 scale :: Float -> Float -> Picture -> Picture
 {-# INLINE scale #-}
-scale x y = over scPosTri (DL.map $ scale3 x y) . over scPosChar (DL.map $ scale3 x y)
+--scale x y = over scPosTri (mapVC $ scale3 x y) . over scPosChar (mapVC $ scale3 x y)
+scale x y = overPos $ scale3 x y
 
 rotate3 :: Float -> Point3 -> Point3
 {-# INLINE rotate3 #-}
@@ -117,14 +122,16 @@ rotate3 a (x,y,z) = (x',y',z)
 
 rotate :: Float -> Picture -> Picture
 {-# INLINE rotate #-}
-rotate a = over scPosTri (DL.map $ rotate3 (0 - degToRad a)) 
+--rotate a = over scPosTri (mapVC $ rotate3 (0 - degToRad a)) 
-            . over scPosChar (DL.map $ 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
 rotateRad :: Float -> Picture -> Picture
 {-# INLINE rotateRad #-}
-rotateRad a = over scPosTri (DL.map $ rotate3 a) 
+--rotateRad a = over scPosTri (mapVC $ rotate3 a) 
-            . over scPosChar (DL.map $ rotate3 a)
+--            . over scPosChar (mapVC $ rotate3 a)
+rotateRad a = overPos $ rotate3 a
 
 pictures :: [Picture] -> Picture
 {-# INLINE pictures #-}
@@ -161,17 +168,17 @@ text s = mconcat $ zipWith (\x -> translate x (0-dimText))
 
 charToScene :: Char -> Picture
 charToScene c = Scene
-    {_scPosTri = DL.empty
+    {_scPosTri = mempty
-    ,_scColTri = DL.empty
+    ,_scColTri = mempty
-    ,_scPosChar = DL.fromList [(0.0    ,0.0      ,0)        
+    ,_scPosChar = toVC [(0.0    ,0.0      ,0)        
                   ,(dimText,0.0      ,0)    
                   ,(dimText,dimText*2,0)
                   ,(0.0    ,0.0      ,0)        
                   ,(dimText,dimText*2,0)
                   ,(0.0    ,dimText*2,0)    
                   ]
-    ,_scColChar = DL.fromList $ take 6 $ repeat white
+    ,_scColChar = toVC $ take 6 $ repeat white
-    ,_scTexChar = DL.fromList $ [(s,1) ,(e,1) ,(e,0) ,(s,1) ,(e,0) ,(s,0)]
+    ,_scTexChar = toVC $ [(s,1) ,(e,1) ,(e,0) ,(s,1) ,(e,0) ,(s,0)]
     }
     where x = 1/128
           s = offset * x

src/Picture/Data.hs

@@ -1,9 +1,10 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE Strict #-}
+--{-# LANGUAGE Strict #-}
 module Picture.Data
     where
 import Data.Monoid
 import qualified Data.DList as DL
+import qualified Data.Vector as V
 import Geometry.Data
 
 import Control.Lens
@@ -11,21 +12,41 @@ import Control.Lens
 type RGBA = (Float,Float,Float,Float)
 type Color = (Float,Float,Float,Float)
 
+
+--type VerticesContainer a = DL.DList a
+--toVC = DL.fromList
+--fromVC = DL.toList
+type VerticesContainer a = [a]
+toVC = id
+fromVC = id
+
+mapVC :: (a -> b) -> VerticesContainer a -> VerticesContainer b
+mapVC = fmap
+
+data Shape = Shape
+    { _shPos :: VerticesContainer Point3
+    , _shCol :: VerticesContainer RGBA
+    }
+combineShapes :: Shape -> Shape -> Shape
+combineShapes sa sb = Shape
+    { _shPos  = _shPos  sa <> _shPos sb
+    , _shCol  = _shCol  sa <> _shCol sb
+    }
+
 data Picture = Scene
-    { _scPosTri  :: DL.DList Point3
+    { _scPosTri  :: VerticesContainer Point3
-    , _scColTri  :: DL.DList RGBA
+    , _scColTri  :: VerticesContainer RGBA
-    , _scPosChar :: DL.DList Point3
+    , _scPosChar :: VerticesContainer Point3
-    , _scColChar :: DL.DList RGBA
+    , _scColChar :: VerticesContainer RGBA
-    , _scTexChar :: DL.DList Point2
+    , _scTexChar :: VerticesContainer Point2
     }
 
 blank :: Picture
 {-# INLINE blank #-}
-blank = Scene DL.empty DL.empty DL.empty DL.empty DL.empty 
+blank = Scene mempty mempty mempty mempty mempty 
 
 combineScenes :: Picture -> Picture -> Picture
-{-# SCC combineScenes #-}
+{-# INLINE combineScenes #-}
---{-# INLINE combineScenes #-}
 combineScenes sa sb = Scene
     { _scPosTri  = _scPosTri  sa <> _scPosTri sb
     , _scColTri  = _scColTri  sa <> _scColTri sb

src/Picture/Preload.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE Strict #-}
+--{-# LANGUAGE Strict #-}
 module Picture.Preload
     where
 
@@ -130,9 +130,9 @@ doPreload' = do
     vertexAttribArray (AttribLocation 2) $= Enabled
 
 -- allocate memory for vertex attributes
-    ptrPosVBO <- mallocArray (3*3*5000)
+    ptrPosVBO <- mallocArray (3*3*20000)
-    ptrColVBO <- mallocArray (3*4*5000)
+    ptrColVBO <- mallocArray (3*4*20000)
-    ptrTexVBO <- mallocArray (3*2*5000)
+    ptrTexVBO <- mallocArray (3*2*20000)
 
     return $ PreloadData
         { _charMap      = convertRGBA8 cmap

src/Picture/Render.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE Strict #-}
+--{-# LANGUAGE Strict #-}
 module Picture.Render
     where
 import Control.Lens
@@ -29,63 +29,56 @@ 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)     = DL.fromList [x,y]
+flat2 (x,y)     = toVC [x,y]
-flat3 (x,y,z)   = DL.fromList [x,y,z]
+flat3 (x,y,z)   = toVC [x,y,z]
-flat4 (x,y,z,w) = DL.fromList [x,y,z,w]
+flat4 (x,y,z,w) = toVC [x,y,z,w]
 
-mapFlat :: (NFData b) => (a -> DL.DList b) -> DL.DList a -> [b]
+mapFlat :: (NFData b) => (a -> VerticesContainer b) -> VerticesContainer a -> [b]
-mapFlat f = force . DL.toList . foldMap f
+mapFlat f = fromVC . foldMap f
 
 --marshallVs = V.unsafeWith . V.fromList
 --marshallVs = withArray
 
 renderPicture' :: PreloadData -> Picture -> IO ()
-renderPicture' pdata (Scene posTri' colTri' posChar' colChar' texChar') = do
+renderPicture' pdata (Scene posTri colTri posChar colChar texChar) = do
-    let posTri = DL.toList posTri'
-        colTri = DL.toList colTri'
-        posChar = DL.toList posChar'
-        colChar = DL.toList colChar'
-        texChar = DL.toList texChar'
     currentProgram $= Just (_basicShader pdata)
     bindVertexArrayObject $= Just (_basicVAO pdata)
     bindBuffer ArrayBuffer $= Just (_posVBO pdata)
     let firstIndex = 0
     let vertices :: [Float]
-        vertices = mapFlat flat3 posTri'
+        vertices = mapFlat flat3 posTri
-        numVertices = length vertices
+        numVertices = length posTri
         vertexSize = sizeOf (head vertices)
     pokeArray (_ptrPosVBO pdata) vertices
-    bufferData ArrayBuffer $= (fromIntegral (numVertices * vertexSize), _ptrPosVBO pdata, StreamDraw)
+    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'
+    let colVs = mapFlat flat4 colTri
         colVsize = sizeOf $ head colVs
     pokeArray (_ptrColVBO pdata) colVs
-    bufferData ArrayBuffer $= (fromIntegral (div (4 * numVertices * colVsize) 3), _ptrColVBO pdata, StreamDraw)
+    bufferData ArrayBuffer $= (fromIntegral (4 * numVertices * colVsize), _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' = mapFlat flat3 posChar
---        numVertices' = length vertices'
+        numVertices' = length posChar
---        vertexSize'  = sizeOf $ head vertices'
+        vertexSize'  = sizeOf $ head vertices'
---    withArray vertices' $ \ptr -> do
+    pokeArray (_ptrPosVBO pdata) vertices'
---        bufferData ArrayBuffer $= (fromIntegral (numVertices' * vertexSize'), ptr, StreamDraw)
+    bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), _ptrPosVBO pdata, StreamDraw)
---    bindBuffer ArrayBuffer $= Just (_colVBO pdata)
+    --withArray vertices' $ \ptr -> do
---    let colVsT = mapFlat flat4 colChar'
+    --    bufferData ArrayBuffer $= (fromIntegral (3 * numVertices' * vertexSize'), ptr, StreamDraw)
---        colVsTsize  = sizeOf $ head colVsT
+    bindBuffer ArrayBuffer $= Just (_colVBO pdata)
---    withArrayLen colVsT $ \numV' ptr -> do
+    pokeArray (_ptrColVBO pdata) $ mapFlat flat4 colChar
---        bufferData ArrayBuffer $= (fromIntegral (numVertices' * colVsTsize), ptr, StreamDraw)
+    bufferData ArrayBuffer $= (fromIntegral (4 * numVertices' * vertexSize'), _ptrColVBO pdata, StreamDraw)
---    bindBuffer ArrayBuffer $= Just (_texVBO pdata)
+    bindBuffer ArrayBuffer $= Just (_texVBO pdata)
---    let texVsT = mapFlat flat2 texChar'
+    pokeArray (_ptrTexVBO pdata) $ mapFlat flat2 texChar
---        texVsTsize  = sizeOf $ head texVsT
+    bufferData ArrayBuffer $= (fromIntegral (2 * numVertices' * vertexSize'), _ptrTexVBO pdata, StreamDraw)
---    withArrayLen texVsT $ \numV' ptr -> do
+    drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices')
---        bufferData ArrayBuffer $= (fromIntegral (numVertices' * texVsTsize), ptr, StreamDraw)
---    drawArrays Triangles (fromIntegral firstIndex) (fromIntegral $ numVertices')