Factor Camera module out of MeshSketch.

3 files changed, 81 insertions, 48 deletions

diff --git a/Camera.hs b/Camera.hs
new file mode 100644
index 0000000..6bf4dd8
--- /dev/null
+++ b/Camera.hs
@@ -0,0 +1,79 @@
+module Camera where
+
+import qualified Data.Vector.Generic as G
+import Numeric.LinearAlgebra as Math hiding ((<>))
+
+import Matrix
+import LambdaCube.GL.HMatrix ()
+
+data Camera = Camera
+    { camHeightAngle   :: Float
+    , camTarget        :: Vector Float -- 3-vector
+    , camDirection     :: Vector Float -- 3-vector
+    , camDistance      :: Float
+    , camWidth         :: Float
+    , camHeight        :: Float
+    , camUp            :: Vector Float -- 3-vector
+    , camWorldToScreen :: Maybe (Matrix Float) -- 4×4
+    , camScreenToWorld :: Maybe (Matrix Float) -- 4×4
+    }
+
+-- | Compute the height of a pixel at the given 3d point.
+pixelDelta :: Camera -> Vector Float -> Float
+pixelDelta cam x = realToFrac $ frustumHeight eyeToPoint / realToFrac (camHeight cam)
+ where
+    eyeToPoint = norm_2 (x - camPos cam)
+    frustumHeight d = 2 * d * tan (realToFrac $ camHeightAngle cam / 2)
+
+camPos :: Camera -> Vector Float
+camPos c = camTarget c - scale (camDistance c) (camDirection c)
+
+camWorldCoordinates :: Camera -> Double -> Double -> Maybe (Vector Float) -> Vector Float
+camWorldCoordinates cam h k mplane = case mplane of
+        -- Write on the plane.
+        Just plane -> let n̂ = G.init plane
+                          c = plane!3
+                          a = (c - dot p n̂) / dot d̂ n̂
+                       in p + scale a d̂
+
+        -- Write on the camDistance sphere.
+        Nothing    -> p + scale (camDistance cam) d̂
+ where
+    q0 = fromList [ 2 * realToFrac h/camWidth cam - 1
+                  , 1 - 2 * realToFrac k/camHeight cam
+                  , 1
+                  , 1
+                  ] :: Vector Float
+    pv = snd $ projectionView cam
+    q1 = pv #> q0
+    q2 = scale (1 /(q1!3)) $ G.init q1
+    p = camPos cam
+    d = q2 - p
+    d̂ = unit d
+
+projectionView :: Camera -> (Camera,Matrix Float)
+projectionView c
+    | Just m <- camScreenToWorld c = (c,m)
+    | Just w <- camWorldToScreen c = projectionView c{ camScreenToWorld = Just $ invFloat w }
+    | otherwise                    = projectionView $ fst $ viewProjection c
+
+viewProjection :: Camera -> (Camera,(Matrix Float,Vector Float))
+viewProjection c
+    | Just m <- camWorldToScreen c = (c,(m,pos))
+    | otherwise                    = (c { camWorldToScreen = Just m' }, (m',pos))
+ where
+    m' = proj <> cam
+    cam = lookat pos (camTarget c) (camUp c)
+    pos = camPos c
+    proj = perspective 0.1 100 (camHeightAngle c) (camWidth c / camHeight c)
+
+invFloat :: Matrix Float -> Matrix Float
+invFloat m = realToFracMatrix $ inv (realToFracMatrix m :: Matrix Double)
+
+realToFracMatrix :: (Real a, Fractional t, Element t, Element a) => Matrix a -> Matrix t
+realToFracMatrix m = fromLists $ map realToFrac <$> toLists m
+
+unit :: (Linear t c, Fractional t, Normed (c t)) => c t -> c t
+unit v = scale (1/realToFrac (norm_2 v)) v
+
+
diff --git a/MeshSketch.hs b/MeshSketch.hs
index c63420e..1019d72 100644
--- a/MeshSketch.hs
+++ b/MeshSketch.hs
@@ -67,6 +67,7 @@ import qualified VectorRing as Vector
 import RingBuffer
 import MaskableStream (AttributeKey,(@<-))
 import SmallRing
+import Camera
 
 
 prettyDebug :: GL.DebugMessage -> String
@@ -118,21 +119,6 @@ data State = State
     , stAngle      :: IORef Int
     }
 
-data Camera = Camera
-    { camHeightAngle   :: Float
-    , camTarget        :: Vector Float -- 3-vector
-    , camDirection     :: Vector Float -- 3-vector
-    , camDistance      :: Float
-    , camWidth         :: Float
-    , camHeight        :: Float
-    , camUp            :: Vector Float -- 3-vector
-    , camWorldToScreen :: Maybe (Matrix Float) -- 4×4
-    , camScreenToWorld :: Maybe (Matrix Float) -- 4×4
-    }
-
-camPos :: Camera -> Vector Float
-camPos c = camTarget c - scale (camDistance c) (camDirection c)
-
 initCamera :: Camera
 initCamera = Camera
     { camHeightAngle = pi/6
@@ -147,16 +133,6 @@ initCamera = Camera
     }
     where d = realToFrac $ norm_2 $ fromList [2::Float,2,10]
 
-viewProjection :: Camera -> (Camera,(Matrix Float,Vector Float))
-viewProjection c
-    | Just m <- camWorldToScreen c = (c,(m,pos))
-    | otherwise                    = (c { camWorldToScreen = Just m' }, (m',pos))
- where
-    m' = proj <> cam
-    cam = lookat pos (camTarget c) (camUp c)
-    pos = camPos c
-    proj = perspective 0.1 100 (camHeightAngle c) (camWidth c / camHeight c)
-
 realToFracVector :: ( Real a
                     , Fractional b
                     , Storable a
@@ -164,18 +140,6 @@ realToFracVector :: ( Real a
                     ) => Vector a -> Vector b
 realToFracVector v = Math.fromList $ map realToFrac $ Math.toList v
 
-realToFracMatrix :: (Real a, Fractional t, Element t, Element a) => Matrix a -> Matrix t
-realToFracMatrix m = fromLists $ map realToFrac <$> toLists m
-
-invFloat :: Matrix Float -> Matrix Float
-invFloat m = realToFracMatrix $ inv (realToFracMatrix m :: Matrix Double)
-
-projectionView :: Camera -> (Camera,Matrix Float)
-projectionView c
-    | Just m <- camScreenToWorld c = (c,m)
-    | Just w <- camWorldToScreen c = projectionView c{ camScreenToWorld = Just $ invFloat w }
-    | otherwise                    = projectionView $ fst $ viewProjection c
-
 addOBJToObjectArray :: GLStorage -> String -> [(GPUMesh, Maybe Text)] -> Map Text (ObjMaterial,TextureData) -> IO [LC.Object]
 addOBJToObjectArray storage slotName objMesh mtlLib = forM objMesh $ \(mesh,mat) -> do
   obj <- LC.addMeshToObjectArray storage slotName ["diffuseTexture","diffuseColor"] mesh
@@ -468,16 +432,6 @@ 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
-
--- | Compute the height of a pixel at the given 3d point.
-pixelDelta :: Camera -> Vector Float -> Float
-pixelDelta cam x = realToFrac $ frustumHeight eyeToPoint / realToFrac (camHeight cam)
- where
-    eyeToPoint = norm_2 (x - camPos cam)
-    frustumHeight d = 2 * d * tan (realToFrac $ camHeightAngle cam / 2)
-
 -- 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
diff --git a/lambda-gtk.cabal b/lambda-gtk.cabal
index e7e6859..a0c9fc3 100644
--- a/lambda-gtk.cabal
+++ b/lambda-gtk.cabal
@@ -50,7 +50,7 @@ executable meshsketch
   other-modules:       InfinitePlane LambdaCubeWidget GLWidget LambdaCube.Gtk TimeKeeper
                        LoadMesh MtlParser Matrix LambdaCube.GL.HMatrix
                        Animator MeshSketch CubeMap AttributeData GPURing MaskableStream
-                       RingBuffer SmallRing VectorRing
+                       RingBuffer SmallRing VectorRing Camera
   extensions:          NondecreasingIndentation
   other-extensions:    OverloadedLabels, OverloadedLists, OverloadedStrings
   build-depends:       base, containers >=0.5 && <0.6, bytestring >=0.10 && <0.11,