Allow alternate plane positions.

2 files changed, 66 insertions, 25 deletions

diff --git a/MeshSketch.hs b/MeshSketch.hs
index 95c79af..14039e9 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 (init,(//))
 import Foreign.Marshal.Array
 import Foreign.Storable
 import GI.Gdk
@@ -84,6 +84,7 @@ data State = State
     , stDragFrom   :: IORef (Maybe (Vector Float,Camera))
     , stRingBuffer :: Ring
     , stPenDown    :: IORef Bool
+    , stPlane      :: IORef (Maybe (Vector Float))
     }
 
 data Camera = Camera
@@ -206,6 +207,7 @@ uploadState obj glarea storage = do
 
     drag <- newIORef Nothing
     pendown <- newIORef False
+    plane <- newIORef $ Just (xzPlaneVector G.// [(3,-1)])
 
     let st = State
             { stAnimator     = tm
@@ -217,6 +219,7 @@ uploadState obj glarea storage = do
             , stDragFrom     = drag
             , stRingBuffer   = ring
             , stPenDown      = pendown
+            , stPlane        = plane
             }
     -- _ <- addAnimation tm (whirlingCamera st)
 
@@ -231,6 +234,19 @@ destroyState glarea st = do
 deg30 :: Float
 deg30 = pi/6
 
+ĵ :: Vector Float
+ĵ = fromList [0,1,0]
+
+computePlaneModel :: Vector Float -> Matrix Float
+computePlaneModel plane = if n̂ == ĵ then translate4 p
+                                    else translate4 p <> rotate4 cosθ axis
+ where
+    n̂ = G.init plane
+    c = plane!3
+    p = scale c n̂
+    cosθ = dot n̂ ĵ
+    axis = ĵ `cross` n̂
+
 whirlingCamera :: State -> Animation
 whirlingCamera st = Animation $ \_ t -> do
     let tf = realToFrac t :: Float
@@ -246,9 +262,12 @@ whirlingCamera st = Animation $ \_ t -> do
 setUniforms :: glctx -> GLStorage -> State -> IO ()
 setUniforms gl storage st = do
     (mvp,pos) <- atomicModifyIORef' (stCamera st) viewProjection
+    mplane <- readIORef (stPlane st)
+    let planeModel = maybe (ident 4) computePlaneModel mplane
     LC.updateUniforms storage $ do
       "CameraPosition" @= return (pos :: Vector Float)
       "ViewProjection" @= return (mvp :: Matrix Float)
+      "PlaneModel" @= return planeModel
     updateRingUniforms storage (stRingBuffer st)
 
 data MeshSketch = MeshSketch
@@ -284,6 +303,7 @@ new = do
             "CubeMap"         @: FTextureCube
             "CameraPosition"  @: V3F
             "ViewProjection"  @: M44F
+            "PlaneModel"      @: M44F
             "PointsMax"       @: Int
             "PointsStart"     @: Int
             "diffuseTexture"  @: FTexture2D
@@ -413,6 +433,36 @@ rotate cosθ u = (3><3)
     uy² = uy . uy
     uz² = uz . uz
 
+rotate4 :: ( Floating a
+          , Math.Container Vector a
+          , Indexable (Vector a) a
+          , Normed (Vector a)
+          ) => a -> Vector a -> Matrix a
+rotate4 cosθ u = (4><4)
+  [ cosθ + ux² mcosθ       , (uy.uy)mcosθ - uz sinθ , (ux.uz)mcosθ + uy sinθ , 0
+  , (uy.ux)mcosθ + uz sinθ , cosθ + uy² mcosθ       , (uy.uz)mcosθ - ux sinθ , 0
+  , (uz.ux)mcosθ - uy sinθ , (uz.uy)mcosθ + ux sinθ , cosθ + uz² mcosθ       , 0
+  , 0                      , 0                      , 0                      , 1
+  ]
+ 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
+
+translate4 :: (Storable a, Num a, Indexable c a) => c -> Matrix a
+translate4 p = (4><4)
+    [ 1 , 0 , 0 , p!0
+    , 0 , 1 , 0 , p!1
+    , 0 , 0 , 1 , p!2
+    , 0 , 0 , 0 , 1
+    ]
+
 updateCameraRotation :: IsWidget a => a -> State -> Double -> Double -> IO ()
 updateCameraRotation w st h k = do
     m <- readIORef (stDragFrom st)
@@ -501,7 +551,8 @@ worldCoordinates st h k mplane = do
 
 pushRing :: IsWidget w => w -> State -> Double -> Double -> IO (Vector Float)
 pushRing w st h k = do
-    d <- worldCoordinates st h k (Just xzPlaneVector)
+    plane <- readIORef (stPlane st)
+    d <- worldCoordinates st h k plane
     Just win <- getWidgetWindow w
     pushBack (stRingBuffer st) (d!0) (d!1) (d!2)
     windowInvalidateRect win Nothing False
@@ -521,38 +572,32 @@ onEvent w realized ev = do
     case etype of
 
         EventTypeMotionNotify -> do
+            mev <- get ev #motion
+            h <- get mev #x
+            k <- get mev #y
             case inputSource of
                 Just InputSourcePen -> do
                     isDown <- readIORef (stPenDown st)
                     when isDown $ do
-                        mev <- get ev #motion
-                        h <- get mev #x
-                        k <- get mev #y
                         d <- pushRing w st h k
                         put (etype,(h,k),d)
                 _ -> do
-                    mev <- get ev #motion
-                    h <- get mev #x
-                    k <- get mev #y
                     put (h,k)
                     updateCameraRotation w st h k
                     return ()
 
         EventTypeButtonPress -> do
+            bev <- get ev #button
+            h <- get bev #x
+            k <- get bev #y
             case inputSource of
                 Just InputSourcePen -> do
                     writeIORef (stPenDown st) True
-                    bev <- get ev #button
-                    h <- get bev #x
-                    k <- get bev #y
                     d <- pushRing w st h k
                     Just win <- getWidgetWindow w
                     windowInvalidateRect win Nothing False
                     put (etype,(h,k),d)
                 _ -> do
-                    bev <- get ev #button
-                    h <- get bev #x
-                    k <- get bev #y
                     _ {- d -} <- worldCoordinates st h k Nothing
                     cam <- readIORef (stCamera st)
                     let d = computeDirection cam h k
@@ -561,19 +606,16 @@ onEvent w realized ev = do
                     return ()
 
         EventTypeButtonRelease -> do
+            bev <- get ev #button
+            h <- get bev #x
+            k <- get bev #y
             case inputSource of
                 Just InputSourcePen -> do
                     writeIORef (stPenDown st) False
-                    bev <- get ev #button
-                    h <- get bev #x
-                    k <- get bev #y
                     d <- pushRing w st h k
                     Just win <- getWidgetWindow w
                     windowInvalidateRect win Nothing False
                 _ -> do
-                    bev <- get ev #button
-                    h <- get bev #x
-                    k <- get bev #y
                     updateCameraRotation w st h k
                     sanitizeCamera st
                     writeIORef (stDragFrom st) Nothing
diff --git a/hello_obj2.lc b/hello_obj2.lc
index 629bf59..fdf08d6 100644
--- a/hello_obj2.lc
+++ b/hello_obj2.lc
@@ -20,6 +20,7 @@ makeFrame (cubemap :: TextureCube)
           (prims :: PrimitiveStream Triangle (Vec 4 Float, Vec 3 Float, Vec 3 Float))
           (plane :: PrimitiveStream Triangle ((Vec 4 Float)))
           (points :: PrimitiveStream Point ((Vec 3 Float)))
+          (plane_mat :: Mat 4 4 Float)
 
     = imageFrame (emptyDepthImage 1, emptyColorImage (V4 0 0 0.4 1))
   `overlay`
@@ -38,7 +39,7 @@ makeFrame (cubemap :: TextureCube)
     & accumulateWith (DepthOp Less True, ColorOp NoBlending (V4 True True True True))
   `overlay`
       plane
-    & mapPrimitives (\((p)) -> let p' = coordmap cam p in (p', p%xz))
+    & mapPrimitives (\((p)) -> let p' = coordmap cam $ plane_mat *. p in (p', p%xz))
     & rasterizePrimitives (TriangleCtx CullNone PolygonFill NoOffset LastVertex) ((Smooth))
     & mapFragments (\((uv)) -> let c = mixB zero one (fract uv >= (one *! (0.95::Float)))
                                    r = V4 1 1 1 0 *! (max c%x c%y)
@@ -62,11 +63,9 @@ renderPoints cam points =
     & mapFragments (\((c)) -> ((c)))
     & accumulateWith (DepthOp Always False, ColorOp NoBlending (V4 True True True True))
 
-textureCubeSlot s = TextureCubeSlot s
-
 main :: Output
 main = renderFrame $
-   makeFrame (textureCubeSlot "CubeMap")
+   makeFrame (TextureCubeSlot "CubeMap")
              (fetch "SkyCube" ((Attribute "position")))
              (Uniform "CameraPosition")
              (Uniform "ViewProjection")
@@ -75,4 +74,4 @@ main = renderFrame $
              (fetch "objects" (Attribute "position", Attribute "normal", Attribute "uvw"))
              (fetch "plane"   ((Attribute "position")))
              (fetch "Points" ((Attribute "position")))
-
+             (Uniform "PlaneModel")