meshsketch: drag background.

1 files changed, 121 insertions, 6 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 6d7e757..c88da0c 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -53,6 +53,7 @@ data State = State
     , stSkyboxes   :: Skyboxes
     , stSkybox     :: IORef Int
     , stSkyTexture :: IORef TextureData
+    , stDragFrom   :: IORef (Maybe (Vector Float,Camera))
     }
 
 data Camera = Camera
@@ -140,6 +141,8 @@ uploadState obj glarea storage = do
     mi <- LC.uploadMeshToGPU cubeMesh
     LC.addMeshToObjectArray storage "SkyCube" [] mi
 
+    drag <- newIORef Nothing
+
     let st = State
             { stAnimator     = tm
             , stCamera       = cam
@@ -147,8 +150,9 @@ uploadState obj glarea storage = do
             , stSkyboxes     = skyboxes
             , stSkybox       = skybox
             , stSkyTexture   = skytex
+            , stDragFrom     = drag
             }
-    _ <- addAnimation tm (whirlingCamera st)
+    -- _ <- addAnimation tm (whirlingCamera st)
 
     return st
 
@@ -164,7 +168,7 @@ deg30 = pi/6
 whirlingCamera :: State -> Animation
 whirlingCamera st = Animation $ \_ t -> do
     let tf = realToFrac t :: Float
-        rot = rotMatrixZ (-tf) <> rotMatrixX (-tf)
+        rot = rotMatrixZ (-tf/2) <> rotMatrixX (-tf/pi)
     modifyIORef (stCamera st) $ \cam -> cam
                             { camUp            = rot #> fromList [0,1,0]
                             , camDirection     = (scale (1/camDistance cam) $ fromList [-2,-2,-10]) <# rot
@@ -285,10 +289,79 @@ onResize glarea realized w h = do
         modifyIORef' (stCamera $ stState realized)
                   $ \c -> c { camWidth  = fromIntegral wd
                             , camHeight = fromIntegral ht
+                            , camWorldToScreen = Nothing
+                            , camScreenToWorld = Nothing
                             }
         LC.setScreenSize (stStorage realized) wd ht)
 
-onEvent :: w -> Realized -> Event -> IO Bool
+computeDirection :: Camera -> Double -> Double -> Vector Float
+computeDirection cam h k =
+    let d̂ = camDirection cam -- forward
+        û = camUp cam        -- upward
+        r̂ = d̂ `cross` û      -- rightward
+        xr = realToFrac h - (camWidth cam / 2)
+        xu = (camHeight cam / 2) - realToFrac k
+        xd = (camHeight cam / 2) / tan (camHeightAngle cam / 2)
+    in scale xr r̂ + scale xu û + scale xd d̂
+
+rotate :: Float -> Vector Float -> Matrix Float
+rotate cosθ u = (3><3)
+  [ cosθ + ux² mcosθ       , (uy.uy)mcosθ - uz sinθ , (ux.uz)mcosθ + uy sinθ
+  , (uy.ux)mcosθ + uz sinθ , cosθ + uy² mcosθ       , (uy.uz)mcosθ - ux sinθ
+  , (uz.ux)mcosθ - uy sinθ , (uz.uy)mcosθ + ux sinθ , cosθ + uz² mcosθ
+  ]
+ where
+    sinθ = sqrt (1 - cosθ * cosθ)
+    mcosθ = 1 - cosθ
+    û = scale (1/realToFrac (norm_2 u)) u
+    ux a = (û!0) * a
+    uy a = (û!1) * a
+    uz a = (û!2) * a
+    ux² = ux . ux
+    uy² = uy . uy
+    uz² = uz . uz
+
+updateCameraRotation w st h k = do
+    m <- readIORef (stDragFrom st)
+    forM_ m $ \(df,cam) -> do
+        let d̂ = camDirection cam -- forward
+            û = camUp cam        -- upward
+            r̂ = d̂ `cross` û      -- rightward
+            -- fr = df `dot` r̂
+            -- fu = df `dot` û
+            -- fd = df `dot` d̂
+            dt = computeDirection cam h k
+            -- tr = dt `dot` r̂
+            -- tu = dt `dot` û
+            -- td = dt `dot` d̂
+            cosθ = dot df dt / realToFrac (norm_2 df) / realToFrac (norm_2 dt)
+            axis = df `cross` dt
+            cam' = cam
+                    { camDirection     = d̂ <# rotate cosθ axis
+                    , camWorldToScreen = Nothing
+                    , camScreenToWorld = Nothing
+                    }
+        writeIORef (stCamera st) cam'
+        mwin <- widgetGetWindow w
+        forM_ mwin $ \win ->
+            windowInvalidateRect win Nothing False
+
+sanitizeCamera st = do
+    modifyIORef (stCamera st) $ \cam ->
+        let d = camDirection cam
+            dd = norm_2 d
+            e = scale (realToFrac $ 1/dd) d
+            d̂ = if any isNaN (toList e)
+                    then fromList [0,0,-1]
+                    else e
+        in cam
+            { camDirection = d̂
+            , camWorldToScreen = Nothing
+            , camScreenToWorld = Nothing
+            }
+
+
+onEvent :: IsWidget w => w -> Realized -> Event -> IO Bool
 onEvent w realized ev = do
     let st = stState realized
     msrc <- eventGetSourceDevice ev
@@ -298,15 +371,54 @@ onEvent w realized ev = do
     etype <- get ev #type
     -- putStrLn $ "onEvent! " ++ show (etype,inputSource)
     let put x = putStrLn (show inputSource ++ " " ++ show x)
+    let st = stState realized
     case etype of
 
         EventTypeMotionNotify -> do
             mev <- get ev #motion
-            x <- get mev #x
-            y <- get mev #y
-            put (x,y)
+            h <- get mev #x
+            k <- get mev #y
+            {-
+            cam <- readIORef (stCamera st)
+            {-
+            let o = fromList [ camWidth cam / 2, camHeight cam / 2 ]
+                r = camHeight cam / (2 * sin (camHeight cam / 2))
+
+                c = fromList [realToFrac h, realToFrac k]  - o :: Vector Float
+                d = realToFrac $ norm_2 c
+                τ = asin (d / r) -- angle from center
+                axis = fromList [c!1, - (c!0)] :: Vector Float
+            -}
+            let d̂ = camDirection cam -- forward
+                û = camUp cam        -- upward
+                r̂ = d̂ `cross` û      -- rightward
+                x_r = realToFrac h - (camWidth cam / 2)
+                x_u = (camHeight cam / 2) - realToFrac k
+                x_d = (camHeight cam / 2) / tan (camHeightAngle cam / 2)
+                x = fromList [x_r,x_u,x_d]
+            -}
+
+            updateCameraRotation w st h k
             return ()
 
+        EventTypeButtonPress -> do
+            bev <- get ev #button
+            h <- get bev #x
+            k <- get bev #y
+            cam <- readIORef (stCamera st)
+            let d = computeDirection cam h k
+            writeIORef (stDragFrom st) $ Just (d,cam)
+            put (etype,(h,k),d)
+            return ()
+
+        EventTypeButtonRelease -> do
+            bev <- get ev #button
+            h <- get bev #x
+            k <- get bev #y
+            updateCameraRotation w st h k
+            sanitizeCamera st
+            writeIORef (stDragFrom st) Nothing
+
         EventTypeScroll -> do
             sev <- get ev #scroll
             d <- get sev #direction
@@ -320,6 +432,9 @@ onEvent w realized ev = do
                     , camWorldToScreen = Nothing
                     , camScreenToWorld = Nothing
                     }
+                mwin <- widgetGetWindow w
+                forM_ mwin $ \win ->
+                    windowInvalidateRect win Nothing False
             put d
             return ()