From 62395f38bcc9f9047e99ab3848dbddb02314fa10 Mon Sep 17 00:00:00 2001
From: jgk <justin.g.kruger@gmail.com>
Date: Mon, 9 Aug 2021 01:58:36 +0200
Subject: [PATCH] Proof of mutable vector vertex offset storage concept

---
 package.yaml       |  1 +
 src/Shader/Data.hs | 10 +++++++
 src/Shader/Poke.hs | 71 ++++++++++++++++++++++++++++++++++++++++++++--
 3 files changed, 79 insertions(+), 3 deletions(-)

diff --git a/package.yaml b/package.yaml
index aeb0ca773..4a6c710a7 100644
--- a/package.yaml
+++ b/package.yaml
@@ -48,6 +48,7 @@ dependencies:
 - directory
 - QuickCheck
 - extra
+- primitive
   #- streaming
 
 library:
diff --git a/src/Shader/Data.hs b/src/Shader/Data.hs
index 12e963165..6cdc8989f 100644
--- a/src/Shader/Data.hs
+++ b/src/Shader/Data.hs
@@ -128,6 +128,16 @@ instance Foldable PicShads where
         , _psEll   = theEll  
         }
         = f thePoly . f thePolyz . f theBez . f theText . f theArc $ f theEll x
+instance Traversable PicShads where
+    {-# INLINE traverse #-}
+    traverse f PicShads
+        { _psPoly   = x0 
+        , _psPolyz  = x1
+        , _psBez    = x2 
+        , _psText   = x3 
+        , _psArc    = x4 
+        , _psEll    = x5 
+        } = PicShads <$> f x0 <*> f x1 <*> f x2 <*> f x3 <*> f x4 <*> f x5
 
 
 {- | Datatype containing the necessary information for a single shader.  -}
diff --git a/src/Shader/Poke.hs b/src/Shader/Poke.hs
index f240e5fec..4a3db2e64 100644
--- a/src/Shader/Poke.hs
+++ b/src/Shader/Poke.hs
@@ -19,16 +19,35 @@ import Geometry.Data
 --import Data.Maybe
 --import Data.List
 import Foreign
---import Control.Monad
+import Control.Monad
 import qualified Control.Foldl as F
 import qualified Data.IntMap.Strict as IM
 import Control.Lens
+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'' :: PicShads VBO -> [Verx] -> IO (PicShads Int)
+pokeVerxs'' vbos = F.foldM $ F.FoldM 
     (\count vx -> pokeVerx vbos count vx >> return (addCountVerx count vx))
     (pure $ pure 0)
     return
+
+pokeVerxs' :: PicShads VBO -> [Verx] -> IO (MV.MVector (PrimState IO) Int)
+pokeVerxs' vbos = F.foldM $ F.FoldM 
+    (\count vx -> pokeVerx' vbos count vx >> addCountVerx' count vx >> return count)
+    (MV.replicate 6 0)
+    return
+
+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
+
+vToPicShad :: MV.MVector (PrimState IO) Int -> IO (PicShads Int)
+vToPicShad mv = do
+    mapM (MV.read mv) $ PicShads 0 1 2 3 4 5
+
 --pokeVerxs vbos vxs0 = go vxs0 (pure 0)
 --  where
 --    go [] !count = return count
@@ -63,6 +82,42 @@ pokeVerx vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case t
         thePtr = plusPtr (_vboPtr $ _psArc vbos) (_psArc offsets * 10 * floatSize)
     EllV            -> poke34 (plusPtr (_vboPtr $ _psEll vbos) (_psEll offsets * 7 * floatSize)) thePos theCol
 
+pokeVerx' :: PicShads VBO -> MV.MVector (PrimState IO) Int -> Verx -> IO ()
+{-# INLINE pokeVerx' #-}
+pokeVerx' vbos offsets Verx{_vxPos=thePos,_vxCol=theCol,_vxType=theType} = case theType of
+    PolyV -> do
+        typeOff <- MV.read offsets 0
+        poke34 (plusPtr (_vboPtr $ _psPoly vbos) (typeOff * 7 * floatSize)) thePos theCol
+    PolyzV x -> do
+        typeOff <- MV.read offsets 1
+        let thePtr = plusPtr (_vboPtr $ _psPolyz vbos) (typeOff * 8 * floatSize)
+        poke34 thePtr thePos theCol
+        pokeElemOff thePtr 7 x
+    BezV (V4 x y z w)  -> do
+        typeOff <- MV.read offsets 2
+        let thePtr = plusPtr (_vboPtr $ _psBez vbos)  (typeOff * 11 * floatSize)
+        poke34 thePtr thePos theCol
+        pokeElemOff thePtr 7 x
+        pokeElemOff thePtr 8 y
+        pokeElemOff thePtr 9 z
+        pokeElemOff thePtr 10 w
+    TextV (V2 x y)     -> do
+        typeOff <- MV.read offsets 3
+        let thePtr = plusPtr (_vboPtr $ _psText vbos) (typeOff * 9 * floatSize)
+        poke34 thePtr thePos theCol
+        pokeElemOff thePtr 7 x
+        pokeElemOff thePtr 8 y
+    ArcV (V3 x y z)    -> do
+        typeOff <- MV.read offsets 4
+        let thePtr = plusPtr (_vboPtr $ _psArc vbos) (typeOff * 10 * floatSize)
+        poke34 thePtr thePos theCol
+        pokeElemOff thePtr 7 x
+        pokeElemOff thePtr 8 y
+        pokeElemOff thePtr 9 z
+    EllV            -> do
+        typeOff <- MV.read offsets 5
+        poke34 (plusPtr (_vboPtr $ _psEll vbos) (typeOff * 7 * floatSize)) thePos theCol
+
 poke34 :: Ptr Float -> Point3 -> Point4 -> IO ()
 {-# INLINE poke34 #-}
 poke34 ptr (V3 a b c) (V4 d e f g) = do
@@ -91,6 +146,16 @@ addCountVerx !ps@PicShads
     ArcV _      -> ps {_psArc  = sArc  + 1}
     EllV        -> ps {_psEll  = sEll  + 1}
 
+addCountVerx' :: MV.MVector (PrimState IO) Int -> Verx -> IO ()
+{-# INLINE addCountVerx' #-}
+addCountVerx' v !Verx{_vxType=theType} = case theType of
+    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..]