Avoid adding redundant points to ring buffer.

3 files changed, 61 insertions, 19 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 7cda3fc..6475d27 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -6,6 +6,7 @@
 {-# LANGUAGE OverloadedLabels   #-}
 {-# LANGUAGE OverloadedStrings  #-}
 {-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE NondecreasingIndentation #-}
 module MeshSketch where
 
 import Codec.Picture             as Juicy
@@ -107,6 +108,7 @@ data State = State
     , stPlane      :: IORef (Maybe Plane)
     , stDragPlane  :: IORef (Maybe (Vector Float,Plane))
     , stRecentPts  :: IORef (Giver (Vector Double))
+    , stAngle      :: IORef Int
     }
 
 data Camera = Camera
@@ -232,6 +234,7 @@ uploadState obj glarea storage = do
     pendown <- newIORef False
     plane <- newIORef $ Just (xzPlaneVector G.// [(3,-1)])
     recentPts <- newIORef Give0
+    angle <- newIORef 0
 
     let st = State
             { stAnimator     = tm
@@ -246,6 +249,7 @@ uploadState obj glarea storage = do
             , stPlane        = plane
             , stDragPlane    = dragPlane
             , stRecentPts    = recentPts
+            , stAngle        = angle
             }
     -- _ <- addAnimation tm (whirlingCamera st)
 
@@ -614,30 +618,54 @@ worldCoordinates st h k mplane = do
         -- Write on the camDistance sphere.
         Nothing    -> p + scale (camDistance cam) d̂
 
-pushRing :: IsWidget w => w -> State -> Double -> Double -> Vector Float -> IO (Vector Float)
-pushRing w st h k c = do
+pushRing :: IsWidget w => w -> State -> Bool -> 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
     Just win <- getWidgetWindow w
-    g <- pushFront (fromList [h,k]) <$> readIORef (stRecentPts st)
+    mf <- front <$> readIORef (stRecentPts st)
+    let hk = fromList [h,k]
+        chk :: Vector Double -> IO (Vector Float) -> IO (Vector Float)
+        chk stored act = if endpt || norm_2 (hk - stored) >= 2 then act else return d
+    maybe id chk mf $ do
+    g <- pushFront hk <$> readIORef (stRecentPts st)
     writeIORef (stRecentPts st) g
-    with3 g $ \a b c -> do
+    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-c
+            v̂ = unit $ b-cc
             δ = norm_1 $ (a-b)^2
-            d = det $ fromRows [û,v̂]
+            dt = det $ fromRows [û,v̂]
             x = dot û v̂
-        putStrLn $ "(d,x) = " ++ show (d,x)
+            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 d<0 then blue else red
-    pushBack (stRingBuffer st) $ \RingPoint{..} -> do
-        rpPosition @<- d
-        rpColor @<- c
-    windowInvalidateRect win Nothing False
+                                            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
+            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
     return d
 
-red,yellow,blue :: Vector Float
+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]
@@ -649,7 +677,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
@@ -664,9 +692,7 @@ onEvent w realized ev = do
                 Just InputSourcePen -> do
                     isDown <- readIORef (stPenDown st)
                     when isDown $ do
-                        -- TODO: Read prior two points and example the angle.
-                        -- If it is small, reclassify the prior point.
-                        d <- pushRing w st h k blue
+                        d <- pushRing w st False h k blue
                         -- put (etype,(h,k),d)
                         return ()
                 _ -> do
@@ -694,8 +720,12 @@ onEvent w realized ev = do
             if h < realToFrac (camWidth cam) * 0.9 then
               case inputSource of
                 Just InputSourcePen -> do
+                    putStrLn "Pen Down!"
                     writeIORef (stPenDown st) True
-                    d <- pushRing w st h k red
+                    writeIORef (stAngle st) 0
+                    writeIORef (stRecentPts st) Give0
+                    clearRing (stRingBuffer st)
+                    d <- pushRing w st True h k red
                     Just win <- getWidgetWindow w
                     windowInvalidateRect win Nothing False
                     put (etype,(h,k),d)
@@ -722,7 +752,7 @@ onEvent w realized ev = do
               Nothing -> case inputSource of
                 Just InputSourcePen -> do
                     writeIORef (stPenDown st) False
-                    d <- pushRing w st h k red
+                    d <- pushRing w st True h k red
                     Just win <- getWidgetWindow w
                     windowInvalidateRect win Nothing False
                 _ -> do
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs
index c458421..54405e4 100644
--- a/PointPrimitiveRing.hs
+++ b/PointPrimitiveRing.hs
@@ -70,6 +70,12 @@ newRing storage sz toAttr = fix $ \retProxy -> do
     updateRingCommands r
     return r
 
+clearRing :: Ring keys -> IO ()
+clearRing r = do
+    writeIORef (rBack r) 0
+    writeIORef (rSize r) 0
+    updateRingCommands r
+
 updateRingCommands :: Ring keys -> IO ()
 updateRingCommands r = do
     back <- fromIntegral <$> readIORef (rBack r)
diff --git a/SmallRing.hs b/SmallRing.hs
index d792899..f710393 100644
--- a/SmallRing.hs
+++ b/SmallRing.hs
@@ -30,6 +30,12 @@ pushFront a (Give1 f) = Give2 (\g -> f (g a))
 pushFront a (Give2 f) = Give3 (\g -> f (g a))
 pushFront a (Give3 f) = f $ \b c _ -> Give3 $ \g -> g a b c
 
+front :: Giver a -> Maybe a
+front Give0     = Nothing
+front (Give1 f) = f Just
+front (Give2 g) = g (\x _ -> Just x)
+front (Give3 h) = h (\x _ _ -> Just x)
+
 take3 :: (a -> a -> a -> b) -> Giver a -> Maybe b
 take3 f (Give3 g) = Just (g f)
 take3 _ _         = Nothing