Commit before picture change

app/Main.hs

@@ -65,7 +65,7 @@ main = do
                       blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
                       renderTree (_renderData preData) (_cameraRot w) (_cameraZoom w) (_cameraPos w)
                                             (_windowX w,_windowY w) 
-                                            (picToList 1 $ fixedCoordPictures w)
+                                            (picToLTree 1 $ fixedCoordPictures w)
                       endRenderTicks <- SDL.ticks
                       playSoundQueue (_soundData preData) (_soundQueue w)
                       newSoundData <- playAndUpdate (_sounds w) (_soundData preData)

package.yaml

@@ -56,6 +56,7 @@ executables:
     - -O2
     - -rtsopts
     - -with-rtsopts=-N
+    - -flate-dmd-anal
     - -fno-liberate-case 
     - -fno-state-hack
     - -funfolding-use-threshold1000 

shader/wallShadow.geom

@@ -16,14 +16,14 @@ void main()
 //  vec2 posc = vBackPoss[0].xy;
 //  vec2 posd = vBackPoss[0].zw;
 
-  gl_Position = vec4 (posa, 0 , 1);
-  EmitVertex();
-  gl_Position = vec4 (posa + (200 * (posa - lightPos)), 0 , 1);
-  EmitVertex();
   gl_Position = vec4 (posb, 0 , 1);
   EmitVertex();
   gl_Position = vec4 (posb + (200 * (posb - lightPos)), 0 , 1);
   EmitVertex();
+  gl_Position = vec4 (posa, 0 , 1);
+  EmitVertex();
+  gl_Position = vec4 (posa + (200 * (posa - lightPos)), 0 , 1);
+  EmitVertex();
 
   EndPrimitive();
 }

src/Picture/Data.hs

@@ -25,6 +25,18 @@ instance Foldable FTree where
     foldMap g (FLeaf x) = g x
     {-# INLINE foldMap #-}
 
+data LTree a
+    = LBranches [LTree a]
+    | LLeaf a
+instance Foldable LTree where
+    foldMap g (LBranches ts) = mconcat $ map (foldMap g) ts
+    foldMap g (LLeaf a) = g a
+    {-# INLINE foldMap #-}
+instance Functor LTree where
+    fmap f (LBranches ts) = LBranches $ (fmap (fmap f)) ts
+    fmap f (LLeaf x) = LLeaf (f x)
+
+
 flat2 (x,y)     = [x,y]
 flat3 (x,y,z)   = [x,y,z]
 flat4 (x,y,z,w) = [x,y,z,w]

src/Picture/Render.hs

@@ -4,6 +4,8 @@ module Picture.Render
     where
 import Control.Lens
 import Control.Monad
+
+import qualified Control.Applicative as Ap
 --import Control.Monad.Trans.State
 --
 --
@@ -31,6 +33,7 @@ import Data.Foldable
 import Data.List
 import qualified Data.Vector.Storable as V
 import qualified Data.IntMap as IM
+import qualified Data.DList as DL
 
 import Control.DeepSeq
 
@@ -57,6 +60,7 @@ scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2)
 scaleT x (a,b,(o,s)) = (a,b,(o,s*x))
 
 overPos :: (Point3 -> Point3) -> RenderType -> RenderType
+{-# INLINE overPos #-}
 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
@@ -65,6 +69,7 @@ overPos f (RenderArc (a,b,c))  = RenderArc (f a,b,c)
 overPos _ RenderBlank = RenderBlank
 
 overCol :: (Point4 -> Point4) -> RenderType -> RenderType
+{-# INLINE overCol #-}
 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
@@ -102,8 +107,38 @@ charToTuple :: Char -> (Point3,Point4,Point2)
 charToTuple c = ((0,0,0),white,(offset,100))
     where offset = fromIntegral (fromEnum c) - 32
 
+picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
+{-# INLINE picToAlt #-}
+picToAlt x (Polygon i ps) 
+    | i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+    | otherwise = Ap.empty
+picToAlt x (PolygonCol i vs) 
+    | i /= x = Ap.empty 
+    | otherwise = 
+        let (ps,cs) = unzip vs
+        in  Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+picToAlt x (Circle i r) 
+    | i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
+    | otherwise = Ap.empty
+picToAlt x (ThickArc i startA endA rad wdth) 
+    | i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
+    | otherwise = Ap.empty
+picToAlt x (Line i ps) 
+    | i == x = Ap.pure $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
+    | otherwise = Ap.empty
+picToAlt x (Text i s) 
+    | i == x = Ap.pure $ RenderText $ stringToList s
+    | otherwise = Ap.empty
+picToAlt j Blank = Ap.empty
+picToAlt j (Scale x y pic) = fmap (scaleRen x y) $ picToAlt j pic
+picToAlt j (Translate x y pic) = fmap (translateRen x y) $ picToAlt j pic
+picToAlt j (Rotate a pic) = fmap (rotateRen a) $ picToAlt j pic
+picToAlt j (SetDepth a pic) = fmap (setDepthRen a) $ picToAlt j pic
+picToAlt j (Color c pic) = fmap (colorRen c) $ picToAlt j pic
+picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics
+
 picToList :: Int -> Picture -> [RenderType]
---{-# INLINE picToList #-}
+{-# INLINE picToList #-}
 picToList x (Polygon i ps) 
     | i == x = [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black]
     | otherwise = []
@@ -132,40 +167,70 @@ picToList j (SetDepth a pic) = fmap (setDepthRen a) $ picToList j pic
 picToList j (Color c pic) = fmap (colorRen c) $ picToList j pic
 picToList j (Pictures pics) = concatMap (picToList j) pics
 
-picToFTree :: Int -> Picture -> FTree RenderType
+-- picToFTree :: Int -> Picture -> FTree RenderType
 -- {-# INLINE picToFTree #-}
-picToFTree x (Polygon i ps) 
+-- picToFTree x (Polygon i ps) 
-    | i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+--     | i == x = FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-    | otherwise = FLeaf RenderBlank
+--     | otherwise = FLeaf RenderBlank
-picToFTree x (PolygonCol i vs) 
+-- picToFTree x (PolygonCol i vs) 
-    | i /= x = FLeaf RenderBlank
+--     | i /= x = FLeaf RenderBlank
-    | otherwise = 
+--     | otherwise = 
-        let (ps,cs) = unzip vs
+--         let (ps,cs) = unzip vs
-        in  FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+--         in  FLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
-picToFTree x (Circle i r) 
+-- picToFTree x (Circle i r) 
-    | i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
+--     | i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
-    | otherwise = FLeaf RenderBlank
+--     | otherwise = FLeaf RenderBlank
-picToFTree x (ThickArc i startA endA rad wdth) 
+-- picToFTree x (ThickArc i startA endA rad wdth) 
-    | i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
+--     | i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
-    | otherwise = FLeaf RenderBlank
+--     | otherwise = FLeaf RenderBlank
-picToFTree x (Line i ps) 
+-- picToFTree x (Line i ps) 
-    | i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
+--     | i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
-    | otherwise = FLeaf RenderBlank
+--     | otherwise = FLeaf RenderBlank
-picToFTree x (Text i s) 
+-- picToFTree x (Text i s) 
-    | i == x = FLeaf $ RenderText $ stringToList s
+--     | i == x = FLeaf $ RenderText $ stringToList s
-    | otherwise = FLeaf RenderBlank
+--     | otherwise = FLeaf RenderBlank
-picToFTree j Blank = FLeaf RenderBlank
+-- picToFTree j Blank = FLeaf RenderBlank
-picToFTree j (Scale x y pic) = collapseBranch (scaleRen x y) $ picToFTree j pic
+-- picToFTree j (Scale x y pic) = collapseBranch (scaleRen x y) $ picToFTree j pic
-picToFTree j (Translate x y pic) = collapseBranch (translateRen x y) $ picToFTree j pic
+-- picToFTree j (Translate x y pic) = collapseBranch (translateRen x y) $ picToFTree j pic
-picToFTree j (Rotate a pic) = collapseBranch (rotateRen a) $ picToFTree j pic
+-- picToFTree j (Rotate a pic) = collapseBranch (rotateRen a) $ picToFTree j pic
-picToFTree j (SetDepth a pic) = collapseBranch (setDepthRen a) $ picToFTree j pic
+-- picToFTree j (SetDepth a pic) = collapseBranch (setDepthRen a) $ picToFTree j pic
-picToFTree j (Color c pic) = collapseBranch (colorRen c) $ picToFTree j pic
+-- picToFTree j (Color c pic) = collapseBranch (colorRen c) $ picToFTree j pic
-picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
+-- picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
 
 collapseBranch :: (RenderType -> RenderType) -> FTree RenderType -> FTree RenderType
 collapseBranch f (FBranch g t) = FBranch (f . g) t
 collapseBranch f (FBranches ts) = FBranches $ map (collapseBranch f) ts
-collapseBranch f t = FBranch f t
+collapseBranch f (FLeaf x) = FLeaf (f x)
+
+picToLTree :: Int -> Picture -> LTree RenderType
+{-# INLINE picToLTree #-}
+picToLTree x (Polygon i ps) 
+    | i == x = LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+    | otherwise = LLeaf RenderBlank
+picToLTree x (PolygonCol i vs) 
+    | i /= x = LLeaf RenderBlank
+    | otherwise = 
+        let (ps,cs) = unzip vs
+        in  LLeaf $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+picToLTree x (Circle i r) 
+    | i == x = LLeaf $ RenderCirc $ ((0,0,0),black,r)
+    | otherwise = LLeaf RenderBlank
+picToLTree x (ThickArc i startA endA rad wdth) 
+    | i == x = LLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
+    | otherwise = LLeaf RenderBlank
+picToLTree x (Line i ps) 
+    | i == x = LLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
+    | otherwise = LLeaf RenderBlank
+picToLTree x (Text i s) 
+    | i == x = LLeaf $ RenderText $ stringToList s
+    | otherwise = LLeaf RenderBlank
+picToLTree j Blank = LLeaf RenderBlank
+picToLTree j (Scale x y pic) = fmap (scaleRen x y) $ picToLTree j pic
+picToLTree j (Translate x y pic) = fmap (translateRen x y) $ picToLTree j pic
+picToLTree j (Rotate a pic) = fmap (rotateRen a) $ picToLTree j pic
+picToLTree j (SetDepth a pic) = fmap (setDepthRen a) $ picToLTree j pic
+picToLTree j (Color c pic) = fmap (colorRen c) $ picToLTree j pic
+picToLTree j (Pictures pics) = LBranches $ map (picToLTree j) pics
 
 doubleLine :: [Point2] -> [Point2]
 doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
@@ -190,12 +255,15 @@ type TwoPtrs = (Ptr Float,Ptr Float)
 
 pokeThreePtrsWith :: (ThreePtrs -> Int -> RenderType -> IO Int)
     -> ThreePtrs -> F.FoldM IO RenderType Int
+{-# INLINE pokeThreePtrsWith #-}
 pokeThreePtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
 pokeTwoPtrsWith :: (TwoPtrs -> Int -> RenderType -> IO Int)
     -> TwoPtrs -> F.FoldM IO RenderType Int
+{-# INLINE pokeTwoPtrsWith #-}
 pokeTwoPtrsWith  pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
 
 pokeArc:: ThreePtrs -> Int -> RenderType -> IO Int
+{-# INLINE pokeArc #-}
 pokeArc (pa,pb,pc) n (RenderArc (p,c,s))
     | n > 20000 * 2 = return n
     | otherwise = do
@@ -206,15 +274,18 @@ pokeArc (pa,pb,pc) n (RenderArc (p,c,s))
 pokeArc _ n _ = return n
 
 pokeTwoOff :: Ptr Float -> Int -> (Float,Float) -> IO ()
+{-# INLINE pokeTwoOff #-}
 pokeTwoOff ptr n (x,y) = do
     pokeElemOff ptr (2*n+0) x
     pokeElemOff ptr (2*n+1) y
 pokeThreeOff :: Ptr Float -> Int -> (Float,Float,Float) -> IO ()
+{-# INLINE pokeThreeOff #-}
 pokeThreeOff ptr n (x,y,z) = do
     pokeElemOff ptr (3*n+0) x
     pokeElemOff ptr (3*n+1) y
     pokeElemOff ptr (3*n+2) z
 pokeFourOff :: Ptr Float -> Int -> (Float,Float,Float,Float) -> IO ()
+{-# INLINE pokeFourOff #-}
 pokeFourOff ptr n (x,y,z,w) = do
     pokeElemOff ptr (4*n+0) x
     pokeElemOff ptr (4*n+1) y
@@ -223,10 +294,12 @@ pokeFourOff ptr n (x,y,z,w) = do
 
 
 pokeLine :: TwoPtrs -> Int -> RenderType -> IO Int
+{-# INLINE pokeLine #-}
 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
+{-# INLINE pokeLineVert #-}
 pokeLineVert pa pb n (p,c)
     | n > 20000 * 2 = return n
     | otherwise = do
@@ -235,6 +308,7 @@ pokeLineVert pa pb n (p,c)
         return (n+1)
 
 pokeCirc :: ThreePtrs -> Int -> RenderType -> IO Int
+{-# INLINE pokeCirc #-}
 pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s)) 
     | n > 20000 * 2 = return n
     | otherwise = do
@@ -245,10 +319,12 @@ pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s))
 pokeCirc _          n _               = return n
 
 pokeText :: (Ptr Float, Ptr Float, Ptr Float) -> Int -> RenderType -> IO Int
+{-# INLINE pokeText #-}
 pokeText (pa,pb,pc) n  (RenderText vs) = foldM (pokeTextVert pa pb pc) n vs
 pokeText _          n _               = return n
 
 pokeTextVert :: Ptr Float -> Ptr Float -> Ptr Float -> Int -> (Point3, Point4, Point2) -> IO Int
+{-# INLINE pokeTextVert #-}
 pokeTextVert pa pb pc n (p,c,t)
     | n > 20000 * 2 = return n
     | otherwise = do
@@ -258,10 +334,12 @@ pokeTextVert pa pb pc n (p,c,t)
         return (n+1)
 
 pokePoly :: TwoPtrs -> Int -> RenderType -> IO Int
+{-# INLINE pokePoly #-}
 pokePoly (pa,pb) n (RenderPoly vs) = foldM (pokeVert pa pb) n vs
 pokePoly _       n _               = return n
 
 pokeVert :: Ptr Float -> Ptr Float -> Int -> (Point3, Point4) -> IO Int
+{-# INLINE pokeVert #-}
 pokeVert pa pb n (p,c)
     | n > 20000 * 2 = return n
     | otherwise = do
@@ -289,9 +367,11 @@ bindArrayBuffers numVs ps = do
         bufferData ArrayBuffer $= (fromIntegral $ fSize * numVs * i, ptr, StreamDraw)
         
 twoPtrsVAO :: VAO -> (Ptr Float, Ptr Float)
+{-# INLINE twoPtrsVAO #-}
 twoPtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
     (a:b:_) -> (a,b)
 threePtrsVAO :: VAO -> (Ptr Float, Ptr Float,Ptr Float)
+{-# INLINE threePtrsVAO #-}
 threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
     (a:b:c:_) -> (a,b,c)
 
@@ -299,11 +379,9 @@ threePtrsVAO vao = case (\(_,ps,_) -> ps) $ unzip3 $ _vaoBufferTargets vao of
 renderPicture' :: RenderData -> Float -> Float -> (Float,Float) -> (Float,Float) ->
                     [(Point2,Point2)] -> [Point4] -> Picture -> IO (Word32,Word32)
 renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints pic = do
-    ticksAfterL <- SDL.ticks
     startWallTicks <- SDL.ticks
     depthFunc $= Just Lequal
 
-    aticks <- SDL.ticks
 -- calculate world transformation matrix
     let scalMat = Linear.Matrix.transpose $
             V4 (V4 (2*zoom/winx) 0             0 (0::GLfloat))
@@ -339,10 +417,10 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
         uniform (snd shad !! 2) $= rot
         uniform (snd shad !! 3) $= Vector2 tranx trany
         uniform (snd shad !! 4) $= wmata
-    bticks <- SDL.ticks
 
 -- draw lightmap
     bindVertexArrayObject $= Just (_vao $ _wallVAO pdata)
+    wallPokeStart <- SDL.ticks
     let wallPtr = (\(_,x,_) -> x) $ head $ _vaoBufferTargets $ _wallVAO pdata
 --        wallPtr2 = (\(_,x,_) -> x) $ (_vaoBufferTargets $ _wallVAO pdata) !! 1
         foldWalls n ((x,y),(z,w)) = do
@@ -350,6 +428,7 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
 --                pokeFourOff wallPtr2 n (a,b,c,d)
                 return $ n+1
     nWalls <- foldM foldWalls 0 wallPoints 
+    wallPokeEnd <- SDL.ticks
 
     forM_ lightPoints $ \(x,y,r,lum) -> do
         cullFace $= Just Front
@@ -370,18 +449,23 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
         drawArrays Points (fromIntegral 0) (fromIntegral 1)
 --    ticksAfterL <- SDL.ticks
     endWallTicks <- SDL.ticks
+    ticksS <- SDL.ticks
+    ticksAfterL <- SDL.ticks
 -- draw picture
 -- set drawing for on top
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
     clear [DepthBuffer]
 -- draw layer 0
-    ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) (picToFTree 0 pic)
+    ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 0 pic
+                                                        --((picToAlt 0 pic) :: [RenderType])
 -- reset blend so that light map doesn't apply
     blendFunc $= (SrcAlpha,OneMinusSrcAlpha)
-    ticks3 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 1 pic
+    ticks3 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 1 pic
 -- set drawing for on top
+    aticks <- SDL.ticks
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-    ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToFTree 2 pic
+    ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 2 pic
+    bticks <- SDL.ticks
 -- reset uniforms (hacky for now)
     idmat <- (newMatrix RowMajor [1,0,0,0
                                  ,0,1,0,0
@@ -404,7 +488,9 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
         uniform (snd shad !! 3)  $= Vector2 (0::Float) 0
         uniform (snd shad !! 4)  $= idmat
     --return (ticksAfterL, ticks2+ticks3+ticks4, endWallTicks - startWallTicks)
-    return (ticksAfterL, endWallTicks - startWallTicks)
+    ticksE <- SDL.ticks
+    --return (ticksAfterL, ticksE - ticksS)
+    return (ticksAfterL, ticks2 + ticks3 + ticks4)
 
 bufferOffset :: Integral a => a -> Ptr b
 bufferOffset = plusPtr nullPtr . fromIntegral
@@ -427,8 +513,8 @@ renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
                             (twoPtrsVAO $ _lineVAO pdata)
                             (threePtrsVAO $ _arcVAO pdata)
                    ) $ tree
-    pokeEndTicks <-SDL.ticks
 
+    pokeEndTicks <-SDL.ticks
     depthFunc $= Just Less
 
     currentProgram $= Just (fst $ _backShader pdata)