Faster feedback for pen drawing.

1 files changed, 44 insertions, 34 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 8660119..89f6581 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -59,7 +59,8 @@ import LoadMesh
 import InfinitePlane
 import MtlParser (ObjMaterial(..))
 import Matrix
-import GPURing as GPU
+import qualified GPURing as GPU
+import qualified VectorRing as Vector
 import RingBuffer
 import MaskableStream (AttributeKey,(@<-))
 import SmallRing
@@ -619,7 +620,9 @@ worldCoordinates st h k mplane = do
         -- Write on the camDistance sphere.
         Nothing    -> p + scale (camDistance cam) d̂
 
-pushRing :: IsWidget w => w -> State -> Bool -> Double -> Double -> Vector Float -> IO (Vector Float)
+pushRing :: IsWidget w => w -> State
+                            -> Bool -- ^ True when press/release.
+                            -> Double -> Double -> Vector Float -> IO (Vector Float)
 pushRing w st endpt h k c = do
     plane <- readIORef (stPlane st)
     d <- worldCoordinates st h k plane
@@ -631,38 +634,45 @@ pushRing w st endpt h k c = do
     maybe id chk mf $ do
     g <- pushFront hk <$> readIORef (stRecentPts st)
     writeIORef (stRecentPts st) g
-    if endpt then do
-        pushBack (stRingBuffer st) $ \RingPoint{..} -> do
-            rpColor @<- yellow -- white
-            rpPosition @<- d
-        windowInvalidateRect win Nothing False
-        putStrLn $ "EndPoint: " ++ show d
-    else with3 g $ \a b cc -> do
-        let û = unit $ a-b
-            v̂ = unit $ b-cc
-            δ = norm_1 $ (a-b)^2
-            dt = det $ fromRows [û,v̂]
-            x = dot û v̂
-            uv = û + v̂
-            θ = atan2 (uv!0) (uv!1)
-            n = round $ θ/(pi/6)
-        {-
-        putStrLn $ "(dt,x) = " ++ show (dt,x)
-        updateBack (stRingBuffer st) $ \RingPoint{..} -> do
-            rpColor @<- if x < 0.3 || δ<0.5 then yellow
-                                            else if dt<0 then blue else red
-        -}
-        m <- readIORef (stAngle st)
-        let isSpecial = x<0.3 -- || δ<0.5
-        when (m /= n || isSpecial) $ do
-            bb <- worldCoordinates st (b!0) (b!1) plane
+    let withTriple a b cc = do
+            let û = unit $ a-b
+                v̂ = unit $ b-cc
+                δ = norm_1 $ (a-b)^2
+                dt = det $ fromRows [û,v̂]
+                x = dot û v̂
+                uv = û + v̂
+                θ = atan2 (uv!0) (uv!1)
+                n = round $ θ/(pi/6)
+            m <- readIORef (stAngle st)
+            let isSpecial = x<0.3 -- || δ<0.5
+            go <- if (m /= n || isSpecial) then do
+                        bb <- worldCoordinates st (b!0) (b!1) plane
+                        updateBack (stRingBuffer st) $ \RingPoint{..} -> do
+                            rpPosition @<- bb
+                            rpColor @<- if isSpecial then yellow
+                                                     else if dt<0 then blue else red
+                        writeIORef (stAngle st) n
+                        -- sz <- readIORef (rSize $ stRingBuffer st)
+                        -- putStrLn $ "pushBack" ++ show (sz,isSpecial,dt)
+                        return pushBack
+                  else do
+                    -- sz <- readIORef (rSize $ stRingBuffer st)
+                    -- putStrLn $ "updateBack " ++ show sz
+                    return updateBack
+            aa <- worldCoordinates st (a!0) (a!1) plane
+            go (stRingBuffer st) $ \RingPoint{..} -> do
+                rpPosition @<- aa
+                rpColor    @<- yellow
+        withEndpt = do
             pushBack (stRingBuffer st) $ \RingPoint{..} -> do
-                rpPosition @<- bb
-                rpColor @<- if isSpecial then yellow
-                                         else if dt<0 then blue else red
-            windowInvalidateRect win Nothing False
-            putStrLn $ "point: " ++ show bb
-            writeIORef (stAngle st) n
+                rpPosition @<- d
+                rpColor @<- yellow -- white
+    if endpt then do
+        withEndpt
+        -- putStrLn $ "EndPoint: " ++ show d
+    else do
+        fromMaybe withEndpt $ take3 withTriple g
+    windowInvalidateRect win Nothing False
     return d
 
 white,red,yellow,blue :: Vector Float
@@ -678,7 +688,7 @@ onEvent w realized ev = do
         src <- get src #inputSource
         return src
     etype <- get ev #type
-    putStrLn $ "onEvent! " ++ show (etype,inputSource)
+    -- putStrLn $ "onEvent! " ++ show (etype,inputSource)
     let put x = putStrLn (show inputSource ++ " " ++ show x)
         st = stState realized
     case etype of