Control to move draw-plane up and down.

1 files changed, 62 insertions, 19 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 14039e9..5ada40e 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -17,7 +17,7 @@ import Data.Text (Text)
 import Data.Map.Strict (Map)
 import qualified Data.Map.Strict as Map
 import qualified Data.Vector     as V
-import qualified Data.Vector.Generic as G (init,(//))
+import qualified Data.Vector.Generic as G
 import Foreign.Marshal.Array
 import Foreign.Storable
 import GI.Gdk
@@ -72,6 +72,7 @@ setupGLDebugging = do
     GL.debugMessageControl (GL.MessageGroup Nothing Nothing Nothing) GL.$= GL.Enabled
     GL.debugMessageCallback GL.$= Just pdebug
 
+type Plane = Vector Float
 
 -- State created by uploadState.
 data State = State
@@ -84,7 +85,8 @@ data State = State
     , stDragFrom   :: IORef (Maybe (Vector Float,Camera))
     , stRingBuffer :: Ring
     , stPenDown    :: IORef Bool
-    , stPlane      :: IORef (Maybe (Vector Float))
+    , stPlane      :: IORef (Maybe Plane)
+    , stDragPlane  :: IORef (Maybe (Vector Float,Plane))
     }
 
 data Camera = Camera
@@ -206,6 +208,7 @@ uploadState obj glarea storage = do
     LC.addMeshToObjectArray storage "SkyCube" [] mi
 
     drag <- newIORef Nothing
+    dragPlane <- newIORef Nothing
     pendown <- newIORef False
     plane <- newIORef $ Just (xzPlaneVector G.// [(3,-1)])
 
@@ -220,6 +223,7 @@ uploadState obj glarea storage = do
             , stRingBuffer   = ring
             , stPenDown      = pendown
             , stPlane        = plane
+            , stDragPlane    = dragPlane
             }
     -- _ <- addAnimation tm (whirlingCamera st)
 
@@ -388,6 +392,9 @@ onResize glarea realized w h = do
                             }
         LC.setScreenSize (stStorage realized) wd ht
 
+unit :: (Linear t c, Fractional t, Normed (c t)) => c t -> c t
+unit v = scale (1/realToFrac (norm_2 v)) v
+
 -- This computes a point in world coordinates on the view screen if
 -- we assume the camera is located at the origin.
 computeDirection :: Camera -> Double -> Double -> Vector Float
@@ -399,9 +406,11 @@ computeDirection cam h k | Just pv <- camScreenToWorld cam  =
                       ] :: Vector Float
         d1 = pv #> d0
         d2 = scale (1 /(d1!3)) $ G.init d1
+        {-
         p = camPos cam
         d3 = d2 - p
-        d4 = scale (1/realToFrac (norm_2 d3)) d3
+        d4 = unit d3
+        -}
     in d2
 computeDirection cam h k =
     let d̂ = camDirection cam -- forward
@@ -425,7 +434,7 @@ rotate cosθ u = (3><3)
  where
     sinθ = sqrt (1 - cosθ * cosθ)
     mcosθ = 1 - cosθ
-    û = scale (1/realToFrac (norm_2 u)) u
+    û = unit u
     ux a = (û!0) * a
     uy a = (û!1) * a
     uz a = (û!2) * a
@@ -447,7 +456,7 @@ rotate4 cosθ u = (4><4)
  where
     sinθ = sqrt (1 - cosθ * cosθ)
     mcosθ = 1 - cosθ
-    û = scale (1/realToFrac (norm_2 u)) u
+    û = unit u
     ux a = (û!0) * a
     uy a = (û!1) * a
     uz a = (û!2) * a
@@ -507,16 +516,12 @@ sanitizeCamera st = do
     modifyIORef (stCamera st) $ \cam ->
         let d = camDirection cam
             u = camUp cam
-            dd = norm_2 d
-            uu = norm_2 u
-            e = scale (realToFrac $ 1/dd) d
-            d̂ = if any isNaN (toList e)
-                    then fromList [0,0,-1]
-                    else e
-            f = scale (realToFrac $ 1/uu) u
-            û = if any isNaN (toList f)
-                    then fromList [0,1,0]
-                    else f
+            d̂ = case unit d of
+                dd | any isNaN (toList dd) -> fromList [0,0,-1]
+                   | otherwise             -> dd
+            û = case unit u of
+                uu | any isNaN (toList uu) -> fromList [0,1,0]
+                   | otherwise             -> uu
         in cam
             { camDirection = d̂
             , camUp        = û
@@ -538,7 +543,7 @@ worldCoordinates st h k mplane = do
         q2 = scale (1 /(q1!3)) $ G.init q1
         p = camPos cam
         d = q2 - p
-        d̂ = scale (1/realToFrac (norm_2 d)) d
+        d̂ = unit d
     return $ case mplane of
         -- Write on the plane.
         Just plane -> let n̂ = G.init plane
@@ -575,7 +580,9 @@ onEvent w realized ev = do
             mev <- get ev #motion
             h <- get mev #x
             k <- get mev #y
-            case inputSource of
+            pd <- readIORef (stDragPlane st)
+            case pd of
+              Nothing -> case inputSource of
                 Just InputSourcePen -> do
                     isDown <- readIORef (stPenDown st)
                     when isDown $ do
@@ -585,12 +592,26 @@ onEvent w realized ev = do
                     put (h,k)
                     updateCameraRotation w st h k
                     return ()
+              Just (from,plane) -> do
+                -- doDragPlane
+                pos <- camPos <$> readIORef (stCamera st)
+                n <- subtract pos <$> worldCoordinates st h k Nothing
+                let n̂ = unit n
+                p <- worldCoordinates st h k (Just $ n̂ `G.snoc` (from `dot` n̂))
+                let δ = dot (p - from) (G.init plane)
+                writeIORef (stPlane st) $ Just $ plane G.// [(3,δ + plane!3)]
+                mwin <- widgetGetWindow w
+                forM_ mwin $ \win -> windowInvalidateRect win Nothing False
+                putStrLn ("drag-plane " ++ show (δ,p))
+                -- end doDragPlane
 
         EventTypeButtonPress -> do
             bev <- get ev #button
             h <- get bev #x
             k <- get bev #y
-            case inputSource of
+            cam <- readIORef (stCamera st)
+            if h < realToFrac (camWidth cam) * 0.9 then
+              case inputSource of
                 Just InputSourcePen -> do
                     writeIORef (stPenDown st) True
                     d <- pushRing w st h k
@@ -604,12 +625,20 @@ onEvent w realized ev = do
                     writeIORef (stDragFrom st) $ Just (d,cam)
                     put (etype,(h,k),d)
                     return ()
+            else do
+                mplane <- readIORef (stPlane st)
+                forM_ mplane $ \plane -> do
+                    p <- worldCoordinates st h k mplane
+                    writeIORef (stDragPlane st) $ Just (p,plane)
+                    putStrLn $ "Start plane drag: " ++ show p
 
         EventTypeButtonRelease -> do
             bev <- get ev #button
             h <- get bev #x
             k <- get bev #y
-            case inputSource of
+            pd <- readIORef (stDragPlane st)
+            case pd of
+              Nothing -> case inputSource of
                 Just InputSourcePen -> do
                     writeIORef (stPenDown st) False
                     d <- pushRing w st h k
@@ -619,6 +648,20 @@ onEvent w realized ev = do
                     updateCameraRotation w st h k
                     sanitizeCamera st
                     writeIORef (stDragFrom st) Nothing
+              Just (from,plane) -> do
+                writeIORef (stDragPlane st) Nothing
+                -- doDragPlane
+                pos <- camPos <$> readIORef (stCamera st)
+                n <- subtract pos <$> worldCoordinates st h k Nothing
+                let n̂ = unit n
+                p <- worldCoordinates st h k (Just $ n̂ `G.snoc` (from `dot` n̂))
+                let δ = dot (p - from) (G.init plane)
+                writeIORef (stPlane st) $ Just $ plane G.// [(3,δ + plane!3)]
+                mwin <- widgetGetWindow w
+                forM_ mwin $ \win -> windowInvalidateRect win Nothing False
+                putStrLn ("drag-plane " ++ show (δ,p))
+                -- end doDragPlane
+
 
         EventTypeScroll -> do
             sev <- get ev #scroll