From f13eedc6482098581c359518e5db1dc7ec572eaf Mon Sep 17 00:00:00 2001 From: Joe Crayne Date: Mon, 3 Jun 2019 19:16:56 -0400 Subject: Factor Camera module out of MeshSketch. --- Camera.hs | 79 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ MeshSketch.hs | 48 +--------------------------------- lambda-gtk.cabal | 2 +- 3 files changed, 81 insertions(+), 48 deletions(-) create mode 100644 Camera.hs 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, -- cgit v1.2.3