Add curvature-coloring.

1 files changed, 20 insertions, 4 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 8df74b3..ea8fbe6 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -60,6 +60,7 @@ import MtlParser (ObjMaterial(..))
 import Matrix
 import PointPrimitiveRing
 import MaskableStream (AttributeKey,(@<-))
+import SmallRing
 
 
 prettyDebug :: GL.DebugMessage -> String
@@ -105,6 +106,7 @@ data State = State
     , stPenDown    :: IORef Bool
     , stPlane      :: IORef (Maybe Plane)
     , stDragPlane  :: IORef (Maybe (Vector Float,Plane))
+    , stRecentPts  :: IORef (Giver (Vector Double))
     }
 
 data Camera = Camera
@@ -229,6 +231,7 @@ uploadState obj glarea storage = do
     dragPlane <- newIORef Nothing
     pendown <- newIORef False
     plane <- newIORef $ Just (xzPlaneVector G.// [(3,-1)])
+    recentPts <- newIORef Give0
 
     let st = State
             { stAnimator     = tm
@@ -242,6 +245,7 @@ uploadState obj glarea storage = do
             , stPenDown      = pendown
             , stPlane        = plane
             , stDragPlane    = dragPlane
+            , stRecentPts    = recentPts
             }
     -- _ <- addAnimation tm (whirlingCamera st)
 
@@ -615,14 +619,23 @@ pushRing w st 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)
+    writeIORef (stRecentPts st) g
+    with3 g $ \a b c -> do
+        let d = det $ fromRows [(b-c),(a-b)]
+        putStrLn $ "d = " ++ show d
+        updateBack (stRingBuffer st) $ \RingPoint{..} -> do
+            rpColor @<- if d<0 then blue else red
     pushBack (stRingBuffer st) $ \RingPoint{..} -> do
         rpPosition @<- d
         rpColor @<- c
     windowInvalidateRect win Nothing False
     return d
 
-yellow = fromList [1,1,0] :: Vector Float
-red    = fromList [1,0,0] :: Vector Float
+red,yellow,blue :: Vector Float
+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
@@ -646,8 +659,11 @@ onEvent w realized ev = do
                 Just InputSourcePen -> do
                     isDown <- readIORef (stPenDown st)
                     when isDown $ do
-                        d <- pushRing w st h k yellow
-                        put (etype,(h,k),d)
+                        -- TODO: Read prior two points and example the angle.
+                        -- If it is small, reclassify the prior point.
+                        d <- pushRing w st h k blue
+                        -- put (etype,(h,k),d)
+                        return ()
                 _ -> do
                     -- put (h,k)
                     updateCameraRotation w st h k