From b3d7ec251055a24d289d7e197d5d06bed30d79f2 Mon Sep 17 00:00:00 2001
From: Joe Crayne <joe@jerkface.net>
Date: Thu, 30 May 2019 04:23:50 -0400
Subject: Added (non-gpu) vector of points for fitting curve.

---
 MeshSketch.hs | 23 ++++++++++++++++++-----
 VectorRing.hs | 39 +++++++++++++++++++++++++++++----------
 2 files changed, 47 insertions(+), 15 deletions(-)

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 89f6581..02c813d 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -12,6 +12,7 @@ module MeshSketch where
 import Codec.Picture             as Juicy
 import Control.Concurrent
 import Control.Monad
+import Data.Bool
 import Data.Data
 import Data.Word
 import Data.Function ((&))
@@ -24,8 +25,10 @@ import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import qualified Data.Vector     as V
 import qualified Data.Vector.Generic as G
+import qualified Data.Vector.Storable.Mutable as MV
 import Foreign.Marshal.Array
 import Foreign.Storable
+import GHC.Exts (RealWorld)
 import GI.Gdk
 import GI.GObject.Functions (signalHandlerDisconnect)
 import GI.Gdk.Objects
@@ -105,6 +108,8 @@ data State = State
     , stSkybox     :: IORef Int
     , stSkyTexture :: IORef TextureCubeData
     , stDragFrom   :: IORef (Maybe (Vector Float,Camera))
+    , stDataPoints :: MV.MVector RealWorld Vector.Point
+    , stDataRing   :: RingBuffer Vector.Point
     , stRingBuffer :: RingBuffer (GPU.Update RingPoint)
     , stPenDown    :: IORef Bool
     , stPlane      :: IORef (Maybe Plane)
@@ -206,7 +211,10 @@ uploadState obj glarea storage = do
     -- grid plane
     uploadMeshToGPU xzplane >>= addMeshToObjectArray storage "plane" []
 
-    ring <- newRing 100 (GPU.new storage ringPointAttr 100)
+    let bufsize = 100
+    v <- MV.unsafeNew bufsize
+    pts <- newRing bufsize (Vector.new v)
+    ring <- newRing bufsize (GPU.new storage ringPointAttr bufsize)
 
     -- setup FrameClock
     w <- toWidget glarea
@@ -246,6 +254,8 @@ uploadState obj glarea storage = do
             , stSkybox       = skybox
             , stSkyTexture   = skytex
             , stDragFrom     = drag
+            , stDataPoints   = v
+            , stDataRing     = pts
             , stRingBuffer   = ring
             , stPenDown      = pendown
             , stPlane        = plane
@@ -647,6 +657,7 @@ pushRing w st endpt h k c = do
             let isSpecial = x<0.3 -- || δ<0.5
             go <- if (m /= n || isSpecial) then do
                         bb <- worldCoordinates st (b!0) (b!1) plane
+                        updateBack (stDataRing st) (Vector.Point (b!0) (b!1))
                         updateBack (stRingBuffer st) $ \RingPoint{..} -> do
                             rpPosition @<- bb
                             rpColor @<- if isSpecial then yellow
@@ -654,22 +665,24 @@ pushRing w st endpt h k c = do
                         writeIORef (stAngle st) n
                         -- sz <- readIORef (rSize $ stRingBuffer st)
                         -- putStrLn $ "pushBack" ++ show (sz,isSpecial,dt)
-                        return pushBack
+                        return True
                   else do
                     -- sz <- readIORef (rSize $ stRingBuffer st)
                     -- putStrLn $ "updateBack " ++ show sz
-                    return updateBack
+                    return False
             aa <- worldCoordinates st (a!0) (a!1) plane
-            go (stRingBuffer st) $ \RingPoint{..} -> do
+            bool updateBack pushBack go (stDataRing st) (Vector.Point (a!0) (a!1))
+            bool updateBack pushBack go (stRingBuffer st) $ \RingPoint{..} -> do
                 rpPosition @<- aa
                 rpColor    @<- yellow
         withEndpt = do
+            pushBack (stDataRing st) (Vector.Point h k)
             pushBack (stRingBuffer st) $ \RingPoint{..} -> do
                 rpPosition @<- d
                 rpColor @<- yellow -- white
     if endpt then do
         withEndpt
-        -- putStrLn $ "EndPoint: " ++ show d
+        -- putStrLn $ "EndVector.Point: " ++ show d
     else do
         fromMaybe withEndpt $ take3 withTriple g
     windowInvalidateRect win Nothing False
diff --git a/VectorRing.hs b/VectorRing.hs
index 2ddac72..4362fa7 100644
--- a/VectorRing.hs
+++ b/VectorRing.hs
@@ -1,17 +1,36 @@
 module VectorRing where
 
-import Data.Vector.Unboxed.Mutable
+import Data.Vector.Storable.Mutable
 import RingBuffer
 
+import Foreign.Ptr
+import Foreign.ForeignPtr
+import Foreign.Storable
+import GHC.Exts (RealWorld)
+
+data Point = Point
+    { pointX :: Double
+    , pointY :: Double
+    }
+ deriving (Eq,Ord,Show)
+
+instance Storable Point where
+    sizeOf _ = 2 * sizeOf (0::Double)
+    alignment _ = alignment (0::Double)
+    peek ptr = Point <$> peek (castPtr ptr) <*> peekElemOff (castPtr ptr) 1
+    poke ptr (Point x y) = do poke (castPtr ptr) x
+                              pokeElemOff (castPtr ptr) 1 y
+
 -- | Typical usage:
 --
--- > ringBuffer <- newRing capacity (VectorRing.new capacity)
-new :: Unbox a => Int -> IO (TargetBuffer a)
-new sz = do
-    v <- unsafeNew sz
-    return () :: IO ()
-    return TargetBuffer
-        { syncBuffer   = \_ -> return ()
-        , updateBuffer = \i u -> write v i u
-        }
+-- > v <- unsafeNew capacity
+-- > ringBuffer <- newRing capacity (VectorRing.new v)
+new :: Storable a => MVector RealWorld a -> IO (TargetBuffer a)
+new v = return TargetBuffer
+            { syncBuffer   = \_ -> return ()
+            , updateBuffer = \i u -> write v i u
+            }
 
+withData :: Storable a => MVector RealWorld a -> (Int -> Ptr a -> IO b) -> IO b
+withData v f = let (fptr,len) = unsafeToForeignPtr0 v
+               in withForeignPtr fptr $ f len
-- 
cgit v1.2.3