Add curvature-coloring.

3 files changed, 65 insertions, 5 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
diff --git a/PointPrimitiveRing.hs b/PointPrimitiveRing.hs
index 3647d4a..c458421 100644
--- a/PointPrimitiveRing.hs
+++ b/PointPrimitiveRing.hs
@@ -81,7 +81,7 @@ updateRingCommands r = do
                 front | front > cnt -> [(front - cnt,size)]
                       | otherwise   -> [(0,back), (front,cnt - front)]
     updateCommands (rStorage r) (rObject r) mask
-    readIORef (objCommands $ rObject r) >>= mapM_ print
+    -- readIORef (objCommands $ rObject r) >>= mapM_ print
     return ()
 
 pushBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO ()
@@ -93,5 +93,10 @@ pushBack r attrs = do
     when (sz < ringCapacity r) $ writeIORef (rSize r) (sz + 1)
     updateRingCommands r
 
+updateBack :: Ring keys -> (keys -> Writer [DSum AttributeKey GLUniformValue] a) -> IO ()
+updateBack r attrs = do
+    back <- readIORef $ rBack r
+    updateAttributes (mod (back - 1) (ringCapacity r)) $ attrs (rKeys r)
+
 updateRingUniforms :: GLStorage -> Ring keys -> IO ()
 updateRingUniforms _ _ = return ()
diff --git a/SmallRing.hs b/SmallRing.hs
new file mode 100644
index 0000000..d792899
--- /dev/null
+++ b/SmallRing.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE RankNTypes #-}
+module SmallRing where
+
+import Data.Ratio
+
+odds :: (Integral i, Num a) => i -> [a]
+odds x = [ 1 + 2 * fromIntegral n | n <- [0..x] ]
+
+pts :: (Fractional a, Integral b) => b -> [a]
+pts i = let d = 2^i in [ k / d | k <- odds (2^(i-1) - 1) ]
+
+fractions :: Fractional b => [b]
+fractions = concatMap pts [1..]
+
+vis :: Int -> Ratio Int -> [Char]
+vis w α = let i = numerator α
+              n = denominator α
+              x = (w * i) `div` n
+           in replicate (x-1) '.' ++ "x" ++ replicate (w-max x 1) '.' ++ show α
+
+data Giver a
+    = Give0
+    | Give1 (forall b. (a -> b) -> b)
+    | Give2 (forall b. (a -> a -> b) -> b)
+    | Give3 (forall b. (a -> a -> a -> b) -> b)
+
+pushFront :: a -> Giver a -> Giver a
+pushFront a Give0     = Give1 ($ a)
+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
+
+take3 :: (a -> a -> a -> b) -> Giver a -> Maybe b
+take3 f (Give3 g) = Just (g f)
+take3 _ _         = Nothing
+
+with3 :: Applicative f => Giver a -> (a -> a -> a -> f ()) -> f ()
+with3 (Give3 g) f = g f
+with3 _ _         = pure ()