Started FitCurves module.

3 files changed, 74 insertions, 41 deletions

diff --git a/FitCurves.hs b/FitCurves.hs
new file mode 100644
index 0000000..8c73cfb
--- /dev/null
+++ b/FitCurves.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE RecordWildCards, DataKinds, DeriveDataTypeable #-}
+module FitCurves where
+
+import Control.Monad
+import Data.Data
+import Data.Int
+import Data.IORef
+import qualified Data.Vector.Storable.Mutable as MV
+import Foreign.Ptr
+import Foreign.Storable
+import GHC.Exts (RealWorld)
+import Numeric.LinearAlgebra as Math hiding ((<>))
+
+import Bezier
+import Camera
+import qualified GPURing as GPU
+import LambdaCube.GL.Input.Type
+import MaskableStream
+import RingBuffer
+import qualified VectorRing as Vector
+         ;import VectorRing (Point)
+import LambdaCube.GL.HMatrix ()
+
+
+data RingPoint = RingPoint
+    { rpPosition :: AttributeKey (GLVector 3 Float)
+    , rpColor :: AttributeKey (GLVector 3 Float)
+    }
+    deriving Data
+
+
+white,red,yellow,blue :: Vector Float
+white  = fromList [1,1,1]
+yellow = fromList [1,1,0]
+blue   = fromList [0,0,1]
+red    = fromList [1,0,0]
+
+fitCurve1 :: Camera
+             -> Maybe Plane
+             -> (Int32 -> [(Int32, Int32)])
+             -> Int
+             -> TargetBuffer (GPU.Update RingPoint)
+             -> MV.MVector RealWorld Vector.Point
+             -> IO (Maybe Int)
+fitCurve1 cam plane mask max_curve_pts buf dta = do
+    return Nothing -- TODO
diff --git a/MeshSketch.hs b/MeshSketch.hs
index 1019d72..14b3ebc 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -68,7 +68,8 @@ import RingBuffer
 import MaskableStream (AttributeKey,(@<-))
 import SmallRing
 import Camera
-
+import FitCurves
+import Bezier
 
 prettyDebug :: GL.DebugMessage -> String
 prettyDebug (GL.DebugMessage src typ (GL.DebugMessageID mid) severity msg) = unwords ws
@@ -89,13 +90,6 @@ setupGLDebugging = do
     GL.debugMessageControl (GL.MessageGroup Nothing Nothing Nothing) GL.$= GL.Enabled
     GL.debugMessageCallback GL.$= Just pdebug
 
-type Plane = Vector Float
-
-data RingPoint = RingPoint
-    { rpPosition :: AttributeKey (GLVector 3 Float)
-    , rpColor :: AttributeKey (GLVector 3 Float)
-    }
-    deriving Data
 
 ringPointAttr :: String -> String
 ringPointAttr ('r':'p':c:cs) = toLower c : cs
@@ -237,12 +231,6 @@ destroyState glarea st = do
     -- widgetRemoveTickCallback glarea (stTickCallback st)
     return ()
 
-deg30 :: Float
-deg30 = pi/6
-
-ĵ :: Vector Float
-ĵ = fromList [0,1,0]
-
 computePlaneModel :: Vector Float -> Matrix Float
 computePlaneModel plane = if n̂ == ĵ then translate4 p
                                     else translate4 p <> rotate4 cosθ axis
@@ -258,7 +246,7 @@ whirlingCamera st = Animation $ \_ t -> do
     let tf = realToFrac t :: Float
         rot = rotMatrixZ (-tf/2) <> rotMatrixX (-tf/pi)
     modifyIORef (stCamera st) $ \cam -> cam
-                            { camUp            = fromList [0,1,0] <# rot
+                            { camUp            = ĵ <# rot
                             , camDirection     = (scale (1/camDistance cam) $ fromList [-2,-2,-10]) <# rot
                             , camWorldToScreen = Nothing
                             , camScreenToWorld = Nothing
@@ -571,25 +559,28 @@ worldCoordinates :: State -> Double -> Double -> Maybe (Vector Float) -> IO (Vec
 worldCoordinates st h k mplane = do
     pv <- atomicModifyIORef' (stCamera st) projectionView
     cam <- readIORef (stCamera st)
-    let q0 = fromList [ 2 * realToFrac h/camWidth cam - 1
-                      , 1 - 2 * realToFrac k/camHeight cam
-                      , 1
-                      , 1
-                      ] :: Vector Float
-        q1 = pv #> q0
-        q2 = scale (1 /(q1!3)) $ G.init q1
-        p = camPos cam
-        d = q2 - p
-        d̂ = unit d
-    return $ case mplane of
-        -- Write on the plane.
-        Just plane -> let n̂ = G.init plane
-                          c = plane!3
-                          a = (c - dot p n̂) / dot d̂ n̂
-                       in p + scale a d̂
-
-        -- Write on the camDistance sphere.
-        Nothing    -> p + scale (camDistance cam) d̂
+    return $ camWorldCoordinates cam h k mplane
+
+fitCurves :: State -> IO ()
+fitCurves st = do
+    _ <- atomicModifyIORef' (stCamera st) projectionView
+    cam <- readIORef (stCamera st)
+    plane <- readIORef (stPlane st)
+    mask <- ringMask (stDataRing st)
+    let max_curve_pts = ringCapacity (stRingBuffer st)
+        buf = rBuffer (stRingBuffer st)
+        dta = stDataPoints st
+    -- dta_cnt <- readIORef (rSize $ stDataRing st)
+    -- when (dta_cnt > 4) $ do
+    -- when (idx > 0) $
+    midx <- fitCurve1 cam plane mask max_curve_pts buf dta
+    forM_ midx $ \idx -> do
+        putStrLn $ "idx = " ++ show idx
+        -- syncBuffer buf $ \cnt -> [(0,max cnt $ fromIntegral idx)]
+        writeIORef (rBack $ stRingBuffer st) idx
+        writeIORef (rSize $ stRingBuffer st) idx
+        syncRing (stRingBuffer st)
+
 
 pushRing :: IsWidget w => w -> State
                             -> Bool -- ^ True when press/release.
@@ -647,14 +638,9 @@ pushRing w st endpt h k c = do
     else do
         fromMaybe withEndpt $ take3 withTriple g
     windowInvalidateRect win Nothing False
+    fitCurves st
     return d
 
-white,red,yellow,blue :: Vector Float
-white  = fromList [1,1,1]
-yellow = fromList [1,1,0]
-blue   = fromList [0,0,1]
-red    = fromList [1,0,0]
-
 onEvent :: IsWidget w => w -> Realized -> Event -> IO Bool
 onEvent w realized ev = do
     msrc <- eventGetSourceDevice ev
@@ -710,6 +696,7 @@ onEvent w realized ev = do
                     writeIORef (stAngle st) 0
                     writeIORef (stRecentPts st) Give0
                     clearRing (stRingBuffer st)
+                    clearRing (stDataRing st)
                     d <- pushRing w st True h k red
                     Just win <- getWidgetWindow w
                     windowInvalidateRect win Nothing False
diff --git a/lambda-gtk.cabal b/lambda-gtk.cabal
index a0c9fc3..86269e5 100644
--- a/lambda-gtk.cabal
+++ b/lambda-gtk.cabal
@@ -50,7 +50,7 @@ executable meshsketch
   other-modules:       InfinitePlane LambdaCubeWidget GLWidget LambdaCube.Gtk TimeKeeper
                        LoadMesh MtlParser Matrix LambdaCube.GL.HMatrix
                        Animator MeshSketch CubeMap AttributeData GPURing MaskableStream
-                       RingBuffer SmallRing VectorRing Camera
+                       RingBuffer SmallRing VectorRing Camera Bezier FitCurves
   extensions:          NondecreasingIndentation
   other-extensions:    OverloadedLabels, OverloadedLists, OverloadedStrings
   build-depends:       base, containers >=0.5 && <0.6, bytestring >=0.10 && <0.11,