Move towards replacing F.foldM with streaming, using mutable accumulator

src/Picture.hs

@@ -73,19 +73,19 @@ polygon :: [Point2] -> Picture
 {-# INLINE polygon #-}
 polygon ps = map (f . zeroZ) $ polyToTris ps
   where
-    f pos = Verx pos black PolyV 0
+    f pos = Verx pos black PolyV 0 polyNum
 
 polygonZ :: [Point2] -> Float -> Picture
 {-# INLINE polygonZ #-}
 polygonZ ps z = map (f . zeroZ) $ polyToTris ps
   where
-    f pos = Verx pos black (PolyzV z) 0
+    f pos = Verx pos black (PolyzV z) 0 polyzNum
 
 polygonCol :: [(Point2,RGBA)] -> Picture
 {-# INLINE polygonCol #-}
 polygonCol vs = polyToTris $ map f vs
   where
-    f (V2 x y,col) = Verx (V3 x y 0) col PolyV 0
+    f (V2 x y,col) = Verx (V3 x y 0) col PolyV 0 polyNum
 
 poly3 :: [Point3] -> Picture
 {-# INLINE poly3 #-}
@@ -95,7 +95,7 @@ poly3Col :: [(Point3,RGBA)] -> Picture
 {-# INLINE poly3Col #-}
 poly3Col vs = map f $ polyToTris vs
   where
-    f (pos,col) = Verx pos col PolyV 0
+    f (pos,col) = Verx pos col PolyV 0 polyNum
 
 -- note that much of work computing the width of the bezier curve is done here
 bezierQuad :: Color -> Color -> Float -> Float -> Point2 -> Point2 -> Point2 -> Picture
@@ -134,7 +134,7 @@ bezierQuad cola colc ra rc a b c
 bzhelp :: [(Point2, Point4, Point2, Point2)] -> Picture
 bzhelp = map f
   where
-    f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col (BezV (V4 a b c d)) 0
+    f (V2 x y,col,V2 a b,V2 c d) = Verx (V3 x y 0) col (BezV (V4 a b c d)) 0 bezNum
 
 -- given a one and two zeros of a linear function over x and y,
 -- determine the function
@@ -215,7 +215,7 @@ circleSolidCol colC colE r = map f
     ,( (V3 ( r) (-r) (0)), black)
     ]
   where
-    f (pos,col) = Verx pos col EllV 0
+    f (pos,col) = Verx pos col EllV 0 ellNum
 
 circle :: Float -> Picture
 {-# INLINE circle #-}
@@ -225,7 +225,7 @@ text :: String -> Picture
 {-# INLINE text #-}
 text s = map f $ stringToList s
   where
-    f (pos,col,val) = Verx pos col (TextV val) 0
+    f (pos,col,val) = Verx pos col (TextV val) 0 textNum
 
 line :: [Point2] -> Picture
 {-# INLINE line #-}
@@ -306,7 +306,7 @@ thickArcHelp startA endA rad wdth = map f
     (V2 xa ya) = rotateV startA (V2 rad 0)
     (V2 xb yb) = rotateV (0.5 * (startA + endA)) (V2 (rad * sqrt 2) (0))
     (V2 xc yc) = rotateV endA (V2 rad 0)
-    f (pos,col,val) = Verx pos col (ArcV val) 0
+    f (pos,col,val) = Verx pos col (ArcV val) 0 arcNum
 
 withAlpha :: Float -> RGBA -> RGBA
 {-# INLINE withAlpha #-}

src/Picture/Data.hs

@@ -22,6 +22,7 @@ data Verx = Verx
     , _vxCol    :: !Point4
     , _vxType   :: !VertexType
     , _vxLayer  :: !Int
+    , _vxShadNum  :: !ShadNum
     }
 data VertexType
     = PolyV
@@ -31,6 +32,16 @@ data VertexType
     | ArcV      !Point3
     | EllV
 
+newtype ShadNum = ShadNum { _unShadNum :: Int }
+
+polyNum, polyzNum, bezNum, textNum, arcNum, ellNum :: ShadNum
+polyNum     = ShadNum 0
+polyzNum    = ShadNum 1
+bezNum      = ShadNum 2
+textNum     = ShadNum 3
+arcNum      = ShadNum 4
+ellNum      = ShadNum 5
+
 type RGBA  = Point4
 type Color = Point4
 

src/Polyhedra.hs

@@ -88,7 +88,7 @@ polyToPics = map helpPoly3D . _pyFaces
 helpPoly3D :: [(Point3, Point4)] -> [Verx]
 helpPoly3D vs = map f $ polyToTris vs
   where
-    f (pos,col) = Verx pos col PolyV 0
+    f (pos,col) = Verx pos col PolyV 0 polyNum
 
 polysToPic :: [Polyhedra] -> Picture
 polysToPic = pictures . concatMap polyToPics

src/Shader.hs

@@ -23,6 +23,8 @@ import qualified Data.IntMap.Strict as IM
 --import Text.RawString.QQ
 --import Linear.Matrix
 --import Linear.V4
+--import qualified Data.Vector.Unboxed.Mutable as MV
+--import Control.Monad.Primitive
 
 bindArrayBuffers :: Int -> VBO -> IO ()
 bindArrayBuffers numVs theVBO = do

src/Shader/Poke.hs

@@ -27,7 +27,17 @@ import qualified Data.Vector.Unboxed.Mutable as MV
 import Control.Monad.Primitive
 
 pokeVerxs :: PicShads VBO -> [Verx] -> IO (PicShads Int)
-pokeVerxs vbos = F.foldM $ F.FoldM 
+pokeVerxs vbos vxs = do
+    count <- (MV.replicate 6 0 :: IO (MV.MVector (PrimState IO) Int))
+    F.foldM (F.FoldM 
+        (\_ vx -> pokeVerx vbos count vx >> addCountVerx count vx)
+        (return ())
+        (const (vToPicShad count))
+        )
+        vxs
+
+pokeVerxs' :: PicShads VBO -> [Verx] -> IO (PicShads Int)
+pokeVerxs' vbos = F.foldM $ F.FoldM 
     (\count vx -> pokeVerx vbos count vx >> addCountVerx count vx >> return count)
     (MV.replicate 6 0)
     vToPicShad
@@ -84,17 +94,10 @@ poke34 ptr (V3 a b c) (V4 d e f g) = do
 
 addCountVerx :: MV.MVector (PrimState IO) Int -> Verx -> IO ()
 {-# INLINE addCountVerx #-}
-addCountVerx v !Verx{_vxType=theType} = case theType of
+addCountVerx vec vx = MV.unsafeModify vec (+1) (_unShadNum $ _vxShadNum vx)
-    PolyV       -> MV.unsafeModify v (+ 1) 0
-    PolyzV _    -> MV.unsafeModify v (+ 1) 1 
-    BezV _      -> MV.unsafeModify v (+ 1) 2
-    TextV _     -> MV.unsafeModify v (+ 1) 3
-    ArcV _      -> MV.unsafeModify v (+ 1) 4
-    EllV        -> MV.unsafeModify v (+ 1) 5
 
 pokeArrayOff :: Storable a => Ptr a -> Int -> [a] -> IO ()
 --{-# INLINE pokeArrayOff #-}
---pokeArrayOff ptr i = zipWithM_ (pokeElemOff ptr) [i..]
 pokeArrayOff ptr i = pokeArray (plusPtr ptr (floatSize * i))
 
 pokePoint33s :: Ptr Float -> [(Point3,Point3)] -> IO Int
@@ -134,7 +137,7 @@ comLayVerx vbos counts vx = do
     MV.unsafeModify counts (+ 1) vecPos
     return counts
   where
-    vecPos = theLayer * 6 + typeInt theType
+    vecPos = theLayer * 6 + _unShadNum (_vxShadNum vx)
     theLayer = _vxLayer vx
     theType = _vxType vx
     thePos = _vxPos vx
@@ -154,25 +157,6 @@ pokeVerxType thePtr vt = case vt of
                             >> pokeElemOff thePtr 9 z
     _ -> return ()
 
-typeInt :: VertexType -> Int
-typeInt vt = case vt of
-    PolyV       -> 0
-    PolyzV{}    -> 1
-    BezV{}      -> 2
-    TextV{}     -> 3
-    ArcV{}      -> 4
-    EllV        -> 5
-
---intFromType :: PicShads Int -> VertexType -> Int
---{-# INLINE intFromType #-}
---intFromType ps vt = case vt of
---    PolyV       -> _psPoly ps
---    PolyzV{}    -> _psPolyz ps
---    BezV{}      -> _psBez ps
---    TextV{}     -> _psText ps
---    ArcV{}      -> _psArc ps
---    EllV        -> _psEll ps
-
 vboFromType :: PicShads VBO -> VertexType -> VBO
 {-# INLINE vboFromType #-}
 vboFromType ps vt = case vt of