Make pictures directly create render list

app/Main.hs

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

src/Picture.hs

@@ -49,46 +49,35 @@ import Geometry.Data
 import Picture.Data
 
 import Data.Bifunctor
+import Data.List
 import qualified Data.DList as DL
 
 import Graphics.Rendering.OpenGL (lineWidth, ($=))
 
 import Control.Lens
 
+import Control.Applicative
+
 black :: RGBA
 black = (0,0,0,1)
 
---polygonD :: Float -> [Point2] -> Picture
---{-# INLINE polygonD #-}
---polygonD d (a:b:c:ps) = blank
---    { _scPosTri = mapVC (\(x,y) -> (x,y,d)) tris
---    , _scColTri = mapVC (const black) tris
---    }
---    where twoPs = zip (b:c:ps) (c:ps)
---          tris = toVC $ concatMap (\(x,y)-> [a,x,y]) twoPs
---polygonD _ _ = blank
-
 polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
-polygon = Polygon 0
+polygon ps = pure $ (,) 0 $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
 
 polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
-polygonCol = PolygonCol 0
+polygonCol ls = pure $ (,) 0 $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
+    where (ps,cs) = unzip ls
 
---polygon :: [Point2] -> Picture
+polyToTris :: [s] -> [s]
---{-# INLINE polygon #-}
+{-# INLINE polyToTris #-}
---polygon (a:b:c:ps) = NLeaf $ emptyScene
+polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
---    { _scPosTri = fmap zeroZ tris
+polyToTris _ = []
---    , _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
 {-# INLINE color #-}
-color c pic = Color c pic
+color c pic = fmap (second $ colorRen c) pic
 
 translate3 :: Float -> Float -> Point3 -> Point3
 {-# INLINE translate3 #-}
@@ -96,26 +85,14 @@ translate3 a b (x,y,z) = (x+a,y+b,z)
 
 translate :: Float -> Float -> Picture -> Picture
 {-# INLINE translate #-}
-translate x y pic = Translate x y pic
+translate x y pic = fmap (second $ translateRen x y) pic
 
 setDepth :: Float -> Picture -> Picture
 {-# INLINE setDepth #-}
-setDepth d pic = SetDepth d pic
+setDepth d pic = fmap (second $ setDepthRen d) pic
 
 setLayer :: Int -> Picture -> Picture
-setLayer _ Blank = Blank
+setLayer i pic = fmap (first $ const i) pic
-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 #-}
@@ -123,22 +100,23 @@ scale3 a b (x,y,z) = (x*a,y*b,z)
 
 scale :: Float -> Float -> Picture -> Picture
 {-# INLINE scale #-}
-scale x y pic = Scale x y pic
+scale x y pic = fmap (second $ scaleRen x y) pic
 
 rotate3 :: Float -> Point3 -> Point3
 {-# INLINE rotate3 #-}
 rotate3 a (x,y,z) = (x',y',z)
     where (x',y') = rotateV a (x,y)
 
-rotate = Rotate
+rotate :: Float -> Picture -> Picture
 {-# INLINE rotate #-}
+rotate a pic = fmap (second $ rotateRen a) pic
 
 --rotateRad a = Rotate a
 --{-# INLINE rotateRad #-}
 
 pictures :: [Picture] -> Picture
 {-# INLINE pictures #-}
-pictures = Pictures
+pictures = mconcat
 
 
 makeArc :: Float -> (Float,Float) -> [Point2]
@@ -150,7 +128,7 @@ 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 0
+circleSolid r = pure $ (,) 0 $ RenderCirc $ ((0,0,0),black,r)
 
 circle :: Float -> Picture
 {-# INLINE circle #-}
@@ -158,11 +136,27 @@ circle rad = thickArc 0 (2*pi) rad 1
 
 text :: String -> Picture
 {-# INLINE text #-}
-text = Text 1
+text s = pure $ (,) 1 $ RenderText $ stringToList s
+
+stringToList :: String -> [(Point3,Point4,Point2)]
+{-# INLINE stringToList #-}
+stringToList s = zipWith (\x (a,b,c) -> (translate3 x 0 a,b,c))
+                         [0,0.9*dimText..]
+                         $ map charToTuple s
+    where dimText = 100
+
+charToTuple :: Char -> (Point3,Point4,Point2)
+{-# INLINE charToTuple #-}
+charToTuple c = ((0,0,0),white,(offset,100))
+    where offset = fromIntegral (fromEnum c) - 32
 
 line :: [Point2] -> Picture
 {-# INLINE line #-}
-line = Line 0
+line ps = pure $ (,) 0 $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
+
+doubleLine :: [Point2] -> [Point2]
+doubleLine (x:y:xs) = concat $ zipWith (:) (init (x:y:xs)) $ map (\a -> [a]) (y:xs)
+doubleLine _ = []
 
 thickLine :: [Point2] -> Float -> Picture
 {-# INLINE thickLine #-}
@@ -189,7 +183,7 @@ arc startA endA rad = thickArc startA endA rad 1
 
 thickArc :: Float -> Float -> Float -> Float -> Picture
 {-# INLINE thickArc #-}
-thickArc = ThickArc 0
+thickArc startA endA rad wdth = pure $ (,) 0 $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
 --thickArc startA endA rad wdth
 --    = thickLine (makeArc rad (startA,endA)) wdth
 
@@ -234,3 +228,45 @@ bright (r,g,b,a) = (r*1.2,g*1.2,b*1.2,a)
 
 greyN :: Float -> Color
 greyN x = (x,x,x,1)
+
+
+
+scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2)
+{-# INLINE scaleT #-}
+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
+overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
+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
+overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
+overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c)
+overCol _ RenderBlank = RenderBlank
+
+scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
+{-# INLINE scaleRen #-}
+scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT x) vs
+scaleRen x y rt = overPos (scale3 x y) rt
+{-# INLINE translateRen #-}
+translateRen x y = overPos $ translate3 x y
+rotateRen,setDepthRen :: Float -> RenderType -> RenderType
+{-# INLINE rotateRen #-}
+rotateRen a (RenderArc (p,c,(as,ae,r,w))) = overPos (rotate3 a) $ RenderArc (p,c,(f as,f ae,r,w))
+    --where f b = normalizeAngle $ a + b
+    where f b = a + b
+rotateRen a pic = overPos (rotate3 a) pic
+{-# INLINE setDepthRen #-}
+setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
+{-# INLINE colorRen #-}
+colorRen :: RGBA -> RenderType -> RenderType
+colorRen c = overCol $ const c

src/Picture/Data.hs

@@ -52,23 +52,10 @@ data RenderType
     | RenderLine [(Point3,Point4)]
     | RenderBlank
 
-data Picture
+type RenderTypeL = (Int,RenderType)
-    = Blank
-    | 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]
-    | OverPos (Point3 -> Point3) (Float -> Float) Picture
 
+type Picture = [RenderTypeL]
 
 blank :: Picture
 {-# INLINE blank #-}
-blank = Blank
+blank = []

src/Picture/Render.hs

@@ -42,226 +42,238 @@ import qualified SDL as SDL
 white = (1,1,1,1)
 black = (0,0,0,1)
 
-polyToTris :: [s] -> [s]
+--polyToTris :: [s] -> [s]
-{-# INLINE polyToTris #-}
+--{-# INLINE polyToTris #-}
-polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
+--polyToTris (a:b:c:as) = a : intercalate [a] (zipWith (\x y->[x,y]) (init (b:c:as)) (c:as))
-polyToTris _ = []
+--polyToTris _ = []
-
+--
-tripFirst :: (a -> a') -> (a,b,c) -> (a',b,c)
+--tripFirst :: (a -> a') -> (a,b,c) -> (a',b,c)
-{-# INLINE tripFirst #-}
+--{-# INLINE tripFirst #-}
-tripFirst f (x,y,z) = (f x,y,z)
+--tripFirst f (x,y,z) = (f x,y,z)
-
+--
-tripSecond :: (b -> b') -> (a,b,c) -> (a,b',c)
+--tripSecond :: (b -> b') -> (a,b,c) -> (a,b',c)
-{-# INLINE tripSecond #-}
+--{-# INLINE tripSecond #-}
-tripSecond f (x,y,z) = (x,f y,z)
+--tripSecond f (x,y,z) = (x,f y,z)
-
+--
-scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2)
+--scaleT :: Float -> (Point3,Point4,Point2) -> (Point3,Point4,Point2)
-{-# INLINE scaleT #-}
+--{-# INLINE scaleT #-}
-scaleT x (a,b,(o,s)) = (a,b,(o,s*x))
+--scaleT x (a,b,(o,s)) = (a,b,(o,s*x))
-
+--
-overPos :: (Point3 -> Point3) -> RenderType -> RenderType
+--overPos :: (Point3 -> Point3) -> RenderType -> RenderType
-{-# INLINE overPos #-}
+--{-# INLINE overPos #-}
-overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
+--overPos f (RenderPoly vs) = RenderPoly $ map (first $ f) vs
-overPos f (RenderLine vs) = RenderLine $ 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
+--overPos f (RenderText vs) = RenderText $ map (\(a,b,c) -> (f a,b,c)) vs
-overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
+--overPos f (RenderCirc (a,b,c)) = RenderCirc (f a,b,c)
-overPos f (RenderArc (a,b,c))  = RenderArc (f a,b,c)
+--overPos f (RenderArc (a,b,c))  = RenderArc (f a,b,c)
-overPos _ RenderBlank = RenderBlank
+--overPos _ RenderBlank = RenderBlank
-
+--
-overCol :: (Point4 -> Point4) -> RenderType -> RenderType
+--overCol :: (Point4 -> Point4) -> RenderType -> RenderType
-{-# INLINE overCol #-}
+--{-# INLINE overCol #-}
-overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs
+--overCol f (RenderPoly vs) = RenderPoly $ map (second $ f) vs
-overCol f (RenderLine vs) = RenderLine $ 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
+--overCol f (RenderText vs) = RenderText $ map (\(a,b,c) -> (a,f b,c)) vs
-overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
+--overCol f (RenderCirc (a,b,c)) = RenderCirc (a,f b,c)
-overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c)
+--overCol f (RenderArc (a,b,c)) = RenderArc (a,f b,c)
-overCol _ RenderBlank = RenderBlank
+--overCol _ RenderBlank = RenderBlank
-
+--
-scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
+--scaleRen,translateRen :: Float -> Float -> RenderType -> RenderType
-{-# INLINE scaleRen #-}
+--{-# INLINE scaleRen #-}
-scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT x) vs
+--scaleRen x y (RenderText vs) = overPos (scale3 x y) $ RenderText $ map (scaleT x) vs
-scaleRen x y rt = overPos (scale3 x y) rt
+--scaleRen x y rt = overPos (scale3 x y) rt
-{-# INLINE translateRen #-}
+--{-# INLINE translateRen #-}
-translateRen x y = overPos $ translate3 x y
+--translateRen x y = overPos $ translate3 x y
-rotateRen,setDepthRen :: Float -> RenderType -> RenderType
+--rotateRen,setDepthRen :: Float -> RenderType -> RenderType
-{-# INLINE rotateRen #-}
+--{-# INLINE rotateRen #-}
-rotateRen a (RenderArc (p,c,(as,ae,r,w))) = overPos (rotate3 a) $ RenderArc (p,c,(f as,f ae,r,w))
+--rotateRen a (RenderArc (p,c,(as,ae,r,w))) = overPos (rotate3 a) $ RenderArc (p,c,(f as,f ae,r,w))
-    --where f b = normalizeAngle $ a + b
+--    --where f b = normalizeAngle $ a + b
-    where f b = a + b
+--    where f b = a + b
-rotateRen a pic = overPos (rotate3 a) pic
+--rotateRen a pic = overPos (rotate3 a) pic
-{-# INLINE setDepthRen #-}
+--{-# INLINE setDepthRen #-}
-setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
+--setDepthRen d = overPos $ \(x,y,_) -> (x,y,-d)
-{-# INLINE colorRen #-}
+--{-# INLINE colorRen #-}
-colorRen :: RGBA -> RenderType -> RenderType
+--colorRen :: RGBA -> RenderType -> RenderType
-colorRen c = overCol $ const c
+--colorRen c = overCol $ const c
-
+--
-stringToList :: String -> [(Point3,Point4,Point2)]
+--stringToList :: String -> [(Point3,Point4,Point2)]
-{-# INLINE stringToList #-}
+--{-# INLINE stringToList #-}
-stringToList s = zipWith (\x (a,b,c) -> (translate3 x 0 a,b,c))
+--stringToList s = zipWith (\x (a,b,c) -> (translate3 x 0 a,b,c))
-                         [0,0.9*dimText..]
+--                         [0,0.9*dimText..]
-                         $ map charToTuple s
+--                         $ map charToTuple s
-    where dimText = 100
+--    where dimText = 100
-
+--
-charToTuple :: Char -> (Point3,Point4,Point2)
+--charToTuple :: Char -> (Point3,Point4,Point2)
-{-# INLINE charToTuple #-}
+--{-# INLINE charToTuple #-}
-charToTuple c = ((0,0,0),white,(offset,100))
+--charToTuple c = ((0,0,0),white,(offset,100))
-    where offset = fromIntegral (fromEnum c) - 32
+--    where offset = fromIntegral (fromEnum c) - 32
-
+--
-picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
+--picToAlt :: (Ap.Alternative f, Monoid (f RenderType)) => Int -> Picture -> f RenderType
-{-# INLINE picToAlt #-}
+--{-# INLINE picToAlt #-}
-picToAlt x (Polygon i ps) 
+--picToAlt x (Polygon i ps) 
-    | i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
+--    | i == x = Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black
-    | otherwise = Ap.empty
+--    | otherwise = Ap.empty
-picToAlt x (PolygonCol i vs) 
+--picToAlt x (PolygonCol i vs) 
-    | i /= x = Ap.empty 
+--    | 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 #-}
-picToList x (Polygon i ps) 
-    | i == x = [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black]
-    | otherwise = []
-picToList x (PolygonCol i vs) 
-    | i /= x = []
-    | otherwise = 
-        let (ps,cs) = unzip vs
-        in  [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs]
-picToList x (Circle i r) 
-    | i == x = [RenderCirc $ ((0,0,0),black,r)]
-    | otherwise = []
-picToList x (ThickArc i startA endA rad wdth) 
-    | i == x = [RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))]
-    | otherwise = []
-picToList x (Line i ps) 
-    | i == x = [RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white]
-    | otherwise = []
-picToList x (Text i s) 
-    | i == x = [RenderText $ stringToList s]
-    | otherwise = []
-picToList j Blank = []
-picToList j (Scale x y pic) = fmap (scaleRen x y) $ picToList j pic
-picToList j (Translate x y pic) = fmap (translateRen x y) $ picToList j pic
-picToList j (Rotate a pic) = fmap (rotateRen a) $ picToList j pic
-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
--- {-# INLINE picToFTree #-}
--- 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
+--        in  Ap.pure $ RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs
--- picToFTree x (Circle i r) 
+--picToAlt x (Circle i r) 
---     | i == x = FLeaf $ RenderCirc $ ((0,0,0),black,r)
+--    | i == x = Ap.pure $ RenderCirc $ ((0,0,0),black,r)
---     | otherwise = FLeaf RenderBlank
+--    | otherwise = Ap.empty
--- picToFTree x (ThickArc i startA endA rad wdth) 
+--picToAlt x (ThickArc i startA endA rad wdth) 
---     | i == x = FLeaf $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
+--    | i == x = Ap.pure $ RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))
---     | otherwise = FLeaf RenderBlank
+--    | otherwise = Ap.empty
--- picToFTree x (Line i ps) 
+--picToAlt x (Line i ps) 
---     | i == x = FLeaf $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
+--    | i == x = Ap.pure $ RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white
---     | otherwise = FLeaf RenderBlank
+--    | otherwise = Ap.empty
--- picToFTree x (Text i s) 
+--picToAlt x (Text i s) 
---     | i == x = FLeaf $ RenderText $ stringToList s
+--    | i == x = Ap.pure $ RenderText $ stringToList s
---     | otherwise = FLeaf RenderBlank
+--    | otherwise = Ap.empty
--- picToFTree j Blank = FLeaf RenderBlank
+--picToAlt j Blank = Ap.empty
--- picToFTree j (Scale x y pic) = collapseBranch (scaleRen x y) $ picToFTree j pic
+--picToAlt j (Scale x y pic) = fmap (scaleRen x y) $ picToAlt j pic
--- picToFTree j (Translate x y pic) = collapseBranch (translateRen x y) $ picToFTree j pic
+--picToAlt j (Translate x y pic) = fmap (translateRen x y) $ picToAlt j pic
--- picToFTree j (Rotate a pic) = collapseBranch (rotateRen a) $ picToFTree j pic
+--picToAlt j (Rotate a pic) = fmap (rotateRen a) $ picToAlt j pic
--- picToFTree j (SetDepth a pic) = collapseBranch (setDepthRen a) $ picToFTree j pic
+--picToAlt j (SetDepth a pic) = fmap (setDepthRen a) $ picToAlt j pic
--- picToFTree j (Color c pic) = collapseBranch (colorRen c) $ picToFTree j pic
+--picToAlt j (Color c pic) = fmap (colorRen c) $ picToAlt j pic
--- picToFTree j (Pictures pics) = FBranches $ map (picToFTree j) pics
+--picToAlt j (Pictures pics) = mconcat $ fmap (picToAlt j) pics
+--
+--picToList :: Int -> Picture -> [RenderType]
+--{-# INLINE picToList #-}
+--picToList x (Polygon i ps) 
+--    | i == x = [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ repeat black]
+--    | otherwise = []
+--picToList x (PolygonCol i vs) 
+--    | i /= x = []
+--    | otherwise = 
+--        let (ps,cs) = unzip vs
+--        in  [RenderPoly $ zip (map zeroZ $ polyToTris ps) $ polyToTris cs]
+--picToList x (Circle i r) 
+--    | i == x = [RenderCirc $ ((0,0,0),black,r)]
+--    | otherwise = []
+--picToList x (ThickArc i startA endA rad wdth) 
+--    | i == x = [RenderArc $ ((0,0,0),black,(startA,endA,rad,wdth))]
+--    | otherwise = []
+--picToList x (Line i ps) 
+--    | i == x = [RenderLine $ zip (map zeroZ $ doubleLine ps) $ repeat white]
+--    | otherwise = []
+--picToList x (Text i s) 
+--    | i == x = [RenderText $ stringToList s]
+--    | otherwise = []
+--picToList j Blank = []
+--picToList j (Scale x y pic) = fmap (scaleRen x y) $ picToList j pic
+--picToList j (Translate x y pic) = fmap (translateRen x y) $ picToList j pic
+--picToList j (Rotate a pic) = fmap (rotateRen a) $ picToList j pic
+--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
+---- {-# INLINE picToFTree #-}
+---- 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) = collapseBranch (scaleRen 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 (SetDepth a pic) = collapseBranch (setDepthRen a) $ picToFTree j pic
+---- picToFTree j (Color c pic) = collapseBranch (colorRen c) $ picToFTree j pic
+---- 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 (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)
+--doubleLine _ = []
 
-collapseBranch :: (RenderType -> RenderType) -> FTree RenderType -> FTree RenderType
+theFold :: Int 
-collapseBranch f (FBranch g t) = FBranch (f . g) t
+        -> TwoPtrs
-collapseBranch f (FBranches ts) = FBranches $ map (collapseBranch f) ts
-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)
-doubleLine _ = []
-
-theFold :: TwoPtrs
         -> ThreePtrs
         -> ThreePtrs
         -> TwoPtrs
         -> ThreePtrs
-        -> F.FoldM IO RenderType (Int,Int,Int,Int,Int)
+        -> F.FoldM IO (Int,RenderType) (Int,Int,Int,Int,Int)
-theFold pas pbs pcs pds pes 
+theFold i pas pbs pcs pds pes 
    -- = (,,,,) <$> pokeFold pas <*> pokeTextFold pbs <*> pokeCircFold pcs
-    = (,,,,) <$> pokeTwoPtrsWith pokePoly pas 
+    = (,,,,) <$> pokeTwoPtrsWith   (pokePolyN i) pas 
-             <*> pokeThreePtrsWith pokeText pbs 
+             <*> pokeThreePtrsWith (pokeTextN i) pbs 
-             <*> pokeThreePtrsWith pokeCirc pcs
+             <*> pokeThreePtrsWith (pokeCircN i) pcs
-             <*> pokeTwoPtrsWith pokeLine pds
+             <*> pokeTwoPtrsWith   (pokeLineN i) pds
-             <*> pokeThreePtrsWith pokeArc pes
+             <*> pokeThreePtrsWith (pokeArcN  i) pes
 
 type ThreePtrs = (Ptr Float,Ptr Float,Ptr Float)
 type TwoPtrs = (Ptr Float,Ptr Float)
 
-pokeThreePtrsWith :: (ThreePtrs -> Int -> RenderType -> IO Int)
+pokeThreePtrsWith :: (ThreePtrs -> Int -> (Int,RenderType) -> IO Int)
-    -> ThreePtrs -> F.FoldM IO RenderType Int
+    -> ThreePtrs -> F.FoldM IO (Int,RenderType) Int
 {-# INLINE pokeThreePtrsWith #-}
 pokeThreePtrsWith pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
-pokeTwoPtrsWith :: (TwoPtrs -> Int -> RenderType -> IO Int)
+pokeTwoPtrsWith :: (TwoPtrs -> Int -> (Int,RenderType) -> IO Int)
-    -> TwoPtrs -> F.FoldM IO RenderType Int
+    -> TwoPtrs -> F.FoldM IO (Int,RenderType) Int
 {-# INLINE pokeTwoPtrsWith #-}
 pokeTwoPtrsWith  pokeF ptrs = F.FoldM (pokeF ptrs) (return 0) return
 
+pokeArcN :: Int -> ThreePtrs -> Int -> (Int,RenderType) -> IO Int
+{-# INLINE pokeArcN #-}
+pokeArcN i (pa,pb,pc) n (j,RenderArc (p,c,s))
+    | n > 20000 * 2 || i /= j = return n
+    | otherwise = do
+        pokeThreeOff pa n p
+        pokeFourOff  pb n c
+        pokeFourOff  pc n s
+        return $ n + 1
+pokeArcN _ _ n _ = return n
+
 pokeArc:: ThreePtrs -> Int -> RenderType -> IO Int
 {-# INLINE pokeArc #-}
 pokeArc (pa,pb,pc) n (RenderArc (p,c,s))
@@ -293,6 +305,13 @@ pokeFourOff ptr n (x,y,z,w) = do
     pokeElemOff ptr (4*n+3) w
 
 
+pokeLineN :: Int -> TwoPtrs -> Int -> (Int,RenderType) -> IO Int
+{-# INLINE pokeLineN #-}
+pokeLineN i (pa,pb) n (j,RenderLine vs) 
+    | i == j = foldM (pokeLineVert pa pb) n vs
+    | otherwise = return n
+pokeLineN _ _       n _               = return n
+
 pokeLine :: TwoPtrs -> Int -> RenderType -> IO Int
 {-# INLINE pokeLine #-}
 pokeLine (pa,pb) n (RenderLine vs) = foldM (pokeLineVert pa pb) n vs
@@ -307,6 +326,17 @@ pokeLineVert pa pb n (p,c)
         pokeFourOff  pb n c
         return (n+1)
 
+pokeCircN :: Int -> ThreePtrs -> Int -> (Int,RenderType) -> IO Int
+{-# INLINE pokeCircN #-}
+pokeCircN i (pa,pb,pc) n (j,RenderCirc (p,c,s)) 
+    | n > 20000 * 2 || i /= j = return n
+    | otherwise = do
+        pokeThreeOff pa n p
+        pokeFourOff  pb n c
+        pokeElemOff  pc n s
+        return (n+1)
+pokeCircN _ _          n _               = return n
+
 pokeCirc :: ThreePtrs -> Int -> RenderType -> IO Int
 {-# INLINE pokeCirc #-}
 pokeCirc (pa,pb,pc) n (RenderCirc (p,c,s)) 
@@ -323,6 +353,14 @@ pokeText :: (Ptr Float, Ptr Float, Ptr Float) -> Int -> RenderType -> IO Int
 pokeText (pa,pb,pc) n  (RenderText vs) = foldM (pokeTextVert pa pb pc) n vs
 pokeText _          n _               = return n
 
+pokeTextN :: Int -> (Ptr Float, Ptr Float, Ptr Float) -> Int -> (Int,RenderType) -> IO Int
+{-# INLINE pokeTextN #-}
+pokeTextN i (pa,pb,pc) n  (j,RenderText vs) 
+    | i == j    = foldM (pokeTextVert pa pb pc) n vs
+    | otherwise = return n
+pokeTextN i _          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)
@@ -333,6 +371,13 @@ pokeTextVert pa pb pc n (p,c,t)
         pokeTwoOff   pc n t
         return (n+1)
 
+pokePolyN :: Int -> TwoPtrs -> Int -> (Int, RenderType) -> IO Int
+{-# INLINE pokePolyN #-}
+pokePolyN j (pa,pb) n (i,RenderPoly vs) 
+    | i == j    = foldM (pokeVert pa pb) n vs
+    | otherwise = return n
+pokePolyN _ _       n _               = return n
+
 pokePoly :: TwoPtrs -> Int -> RenderType -> IO Int
 {-# INLINE pokePoly #-}
 pokePoly (pa,pb) n (RenderPoly vs) = foldM (pokeVert pa pb) n vs
@@ -456,15 +501,15 @@ renderPicture' pdata rot zoom (tranx,trany) (winx,winy) wallPoints lightPoints p
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
     clear [DepthBuffer]
 -- draw layer 0
-    ticks2 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 0 pic
+    ticks2 <- renderTree 0 pdata rot zoom (tranx,trany) (winx,winy) $ 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) $ picToLTree 1 pic
+    ticks3 <- renderTree 1 pdata rot zoom (tranx,trany) (winx,winy) $ pic
 -- set drawing for on top
     aticks <- SDL.ticks
     blendFuncSeparate    $= ((SrcAlphaSaturate, OneMinusSrcAlpha), (Zero,One))
-    ticks4 <- renderTree pdata rot zoom (tranx,trany) (winx,winy) $ picToLTree 2 pic
+    ticks4 <- renderTree 2 pdata rot zoom (tranx,trany) (winx,winy) $ pic
     bticks <- SDL.ticks
 -- reset uniforms (hacky for now)
     idmat <- (newMatrix RowMajor [1,0,0,0
@@ -499,15 +544,16 @@ bufferOffset = plusPtr nullPtr . fromIntegral
 -- the following code draws a picture tree
 -- it does not set nor change the blend function or depth buffer
 -- nor does it set uniforms
-renderTree :: Foldable f => RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
+renderTree :: Foldable f => Int -> RenderData -> Float -> Float -> (Float,Float) -> (Float,Float)
-                    -> f RenderType -> IO Word32
+                    -> f (Int,RenderType) -> IO Word32
-renderTree pdata rot zoom (tranx,trany) (winx,winy) tree = do
+renderTree i pdata rot zoom (tranx,trany) (winx,winy) tree = do
 
     pokeStartTicks <- SDL.ticks
 -- poke necessary data
     (nTriVs,nTextVs,numCircVs,nLineVs,nArcVs) 
 --        <- F.foldM (theFold (_ptrPosVBO pdata, _ptrColVBO pdata)  
-        <- F.foldM (theFold (twoPtrsVAO $ _triVAO pdata)  
+        <- F.foldM (theFold i
+                            (twoPtrsVAO $ _triVAO pdata)  
                             (threePtrsVAO $ _textVAO pdata)
                             (threePtrsVAO $ _circVAO pdata)
                             (twoPtrsVAO $ _lineVAO pdata)