Permalink
Browse files

Added beginnings of cleaned-up VSM example.

  • Loading branch information...
1 parent 355feb3 commit 3c0cdc1147cdb163f46e5a024cf67b6a7c6f6ea5 @cobbpg cobbpg committed Oct 7, 2012
@@ -0,0 +1,133 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module GraphicsUtils where
+
+import Data.Bits
+import qualified Data.ByteString.Char8 as SB
+import qualified Data.Trie as T
+import Data.Vect
+import qualified Data.Vector.Storable as V
+import FRP.Elerea.Param
+
+import LC_API
+import LC_Mesh
+
+quad :: Mesh
+quad = Mesh
+ { mAttributes = T.singleton "position" $ A_V2F $ V.fromList [-1 ^ 1, -1 ^ -1, 1 ^ -1, 1 ^ -1, 1 ^ 1, -1 ^ 1]
+ , mPrimitive = P_Triangles
+ , mGPUData = Nothing
+ }
+ where
+ infixr 0 ^
+ (^) = V2
+
+cube :: Mesh
+cube = Mesh
+ { mAttributes = T.fromList [("position", A_V3F vertices), ("normal", A_V3F normals)]
+ , mPrimitive = P_Triangles
+ , mGPUData = Nothing
+ }
+ where
+ quads = [[6, 2, 3, 7], [5, 1, 0, 4], [7, 3, 1, 5], [4, 0, 2, 6], [3, 2, 0, 1], [6, 7, 5, 4]]
+ indices = V.fromList $ concat [[a, b, c, c, d, a] | [d, c, b, a] <- quads]
+ vertices = V.backpermute (V.generate 8 mkVertex) indices
+ normals = V.concatMap (V.replicate 6) (V.generate 6 mkNormal)
+
+ mkVertex n = V3 x y z
+ where
+ x = if testBit n 2 then 1 else -1
+ y = if testBit n 1 then 1 else -1
+ z = if testBit n 0 then 1 else -1
+
+ mkNormal n = fromVec3 (normalize ((v3 &- v2) &^ (v2 &- v1)))
+ where
+ i = n * 6
+ v1 = toVec3 (vertices V.! i)
+ v2 = toVec3 (vertices V.! (i + 1))
+ v3 = toVec3 (vertices V.! (i + 2))
+
+toVec3 :: V3F -> Vec3
+toVec3 (V3 x y z) = Vec3 x y z
+
+fromVec3 :: Vec3 -> V3F
+fromVec3 (Vec3 x y z) = V3 x y z
+
+fromVec4 :: Vec4 -> V4F
+fromVec4 (Vec4 x y z w) = V4 x y z w
+
+fromMat4 :: Mat4 -> M44F
+fromMat4 (Mat4 a b c d) = V4 (fromVec4 a) (fromVec4 b) (fromVec4 c) (fromVec4 d)
+
+v3v4 :: Exp s V3F -> Exp s V4F
+v3v4 v = pack' (V4 x y z (Const 1))
+ where
+ V3 x y z = unpack' v
+
+n3v4 :: Exp s V3F -> Exp s V4F
+n3v4 v = pack' (V4 x y z (Const 0))
+ where
+ V3 x y z = unpack' v
+
+v4v3 :: Exp s V4F -> Exp s V3F
+v4v3 v = pack' (V3 x y z)
+ where
+ V4 x y z _ = unpack' v
+
+floatV :: Float -> Exp V Float
+floatV = Const
+
+floatF :: Float -> Exp F Float
+floatF = Const
+
+intF :: Int32 -> Exp F Int32
+intF = Const
+
+-- | Perspective transformation matrix in row major order.
+perspective :: Float -- ^ Near plane clipping distance (always positive).
+ -> Float -- ^ Far plane clipping distance (always positive).
+ -> Float -- ^ Field of view of the y axis, in radians.
+ -> Float -- ^ Aspect ratio, i.e. screen's width\/height.
+ -> Mat4
+perspective n f fovy aspect = transpose $
+ Mat4 (Vec4 (2*n/(r-l)) 0 (-(r+l)/(r-l)) 0)
+ (Vec4 0 (2*n/(t-b)) ((t+b)/(t-b)) 0)
+ (Vec4 0 0 (-(f+n)/(f-n)) (-2*f*n/(f-n)))
+ (Vec4 0 0 (-1) 0)
+ where
+ t = n*tan(fovy/2)
+ b = -t
+ r = aspect*t
+ l = -r
+
+-- | Pure orientation matrix defined by Euler angles.
+rotationEuler :: Vec3 -> Proj4
+rotationEuler (Vec3 a b c) = orthogonal $ toOrthoUnsafe $ rotMatrixY a .*. rotMatrixX b .*. rotMatrixZ c
+
+-- | Camera transformation matrix.
+lookat :: Vec3 -- ^ Camera position.
+ -> Vec3 -- ^ Target position.
+ -> Vec3 -- ^ Upward direction.
+ -> Proj4
+lookat pos target up = translateBefore4 (neg pos) (orthogonal $ toOrthoUnsafe r)
+ where
+ w = normalize $ pos &- target
+ u = normalize $ up &^ w
+ v = w &^ u
+ r = transpose $ Mat3 u v w
+
+-- | Continuous camera state (rotated with mouse, moved with arrows)
+userCamera :: Vec3 -> Signal Vec2 -> Signal (Bool, Bool, Bool, Bool, Bool) -> SignalGen Float (Signal (Vec3, Vec3, Vec3, Vec2))
+userCamera startPosition mouseDelta directionKeys = transfer2 (startPosition, zero, zero, zero) calcCam mouseDelta directionKeys
+ where
+ d0 = Vec4 0 0 (-1) 1
+ u0 = Vec4 0 1 0 1
+ calcCam dt dm (ka, kw, ks, kd, turbo) (p0, _, _, m) = (p', d, u, m')
+ where
+ f0 c v = if c then v else zero
+ p' = p0 &+ (f0 kw d &- f0 ks d &+ f0 kd v &- f0 ka v) &* (realToFrac dt * if turbo then 5 else 1)
+ m' = dm &+ m
+ rm = fromProjective $ rotationEuler $ extendZero (m' &* 0.01)
+ d = trim (rm *. d0) :: Vec3
+ u = trim (rm *. u0) :: Vec3
+ v = normalize (d &^ u)
@@ -0,0 +1,132 @@
+{-# LANGUAGE OverloadedStrings, PackageImports, TypeOperators #-}
+
+import Control.Applicative hiding (Const)
+import Control.Monad
+import qualified Data.ByteString.Char8 as SB
+import qualified Data.Trie as T
+import Data.Vect
+import Data.Vect.Float.Instances ()
+import FRP.Elerea.Param
+import "GLFW-b" Graphics.UI.GLFW as GLFW
+
+import LC_API
+import LC_Mesh
+
+import Utils
+import GraphicsUtils
+import VSM
+
+main :: IO ()
+main = do
+ let pipeline :: Exp Obj (Image N1 V4F)
+ pipeline = PrjFrameBuffer "outFB" tix0 vsm
+
+ windowSize <- initWindow "LambdaCube 3D Shadow Mapping Demo"
+
+ (duration, renderer) <- measureDuration $ compileRenderer (ScreenOut pipeline)
+ putStrLn $ "Renderer compiled - " ++ show duration
+
+ putStrLn "Renderer uniform slots:"
+ forM_ (T.toList (slotUniform renderer)) $ \(name, slot) -> do
+ putStrLn $ " " ++ SB.unpack name
+ forM_ (T.toList slot) $ \(inputName, inputType) -> do
+ putStrLn $ " " ++ SB.unpack inputName ++ " :: " ++ show inputType
+
+ putStrLn "Renderer stream slots:"
+ forM_ (T.toList (slotStream renderer)) $ \(name, (primitive, attributes)) -> do
+ putStrLn $ " " ++ SB.unpack name ++ " - " ++ show primitive
+ forM_ (T.toList attributes) $ \(attributeName, attributeType) -> do
+ putStrLn $ " " ++ SB.unpack attributeName ++ " :: " ++ show attributeType
+
+ quadMesh <- compileMesh quad
+ addMesh renderer "postSlot" quadMesh []
+
+ cubeMesh <- compileMesh cube
+
+ (duration, cubeObjects) <- measureDuration $ replicateM 6 $ addMesh renderer "geometrySlot" cubeMesh ["modelMatrix"]
+ putStrLn $ "Cube meshes added - " ++ show duration
+
+ let objectSlots = map objectUniformSetter cubeObjects
+ sceneSlots = uniformSetter renderer
+
+ draw _ = do
+ render renderer
+ swapBuffers
+
+ sceneSignal <- start $ do
+ thread <- scene (setScreenSize renderer) sceneSlots objectSlots windowSize
+ return $ draw <$> thread
+ driveNetwork sceneSignal readInput
+
+ dispose renderer
+ putStrLn "Renderer destroyed."
+
+ closeWindow
+
+scene setSize sceneSlots (planeSlot:cubeSlots) windowSize = do
+ time <- stateful 0 (+)
+
+ fpsTracking <- stateful (0, 0, Nothing) $ \dt (time, count, _) ->
+ let time' = time + dt
+ done = time > 5
+ in if done
+ then (0, 0, Just (count / time'))
+ else (time', count + 1, Nothing)
+
+ mousePosition <- effectful $ do
+ (x, y) <- getMousePosition
+ return $ Vec2 (fromIntegral x) (fromIntegral y)
+ fblrPress <- effectful $ (,,,,)
+ <$> keyIsPressed KeyLeft
+ <*> keyIsPressed KeyUp
+ <*> keyIsPressed KeyDown
+ <*> keyIsPressed KeyRight
+ <*> keyIsPressed KeyRightShift
+
+ mousePosition' <- delay zero mousePosition
+ camera <- userCamera (Vec3 (-4) 0 0) (mousePosition - mousePosition') fblrPress
+
+ let setCameraMatrix = uniformM44F "cameraMatrix" sceneSlots . fromMat4
+ setLightMatrix = uniformM44F "lightMatrix" sceneSlots . fromMat4
+ setLightPosition = uniformV3F "lightPosition" sceneSlots . fromVec3
+ setPlaneModelMatrix = uniformM44F "modelMatrix" planeSlot . fromMat4
+ setCubeModelMatrices = [uniformM44F "modelMatrix" cubeSlot . fromMat4 | cubeSlot <- cubeSlots]
+
+ setupRendering (_, _, fps) (windowWidth, windowHeight) (cameraPosition, cameraDirection, cameraUp, _) time = do
+ let aspect = fromIntegral windowWidth / fromIntegral windowHeight
+
+ cameraView = fromProjective (lookat cameraPosition (cameraPosition &+ cameraDirection) cameraUp)
+ cameraProjection = perspective 0.1 50 (pi/2) aspect
+
+ lightPosition = Vec3 (5 * sin time) 2 10
+ lightDirection = Vec3 0 (-0.2) (-1)
+ lightUp = Vec3 0 1 0
+
+ lightView = fromProjective (lookat lightPosition (lightPosition &+ lightDirection) lightUp)
+ lightProjection = perspective 0.1 100 (pi/2) aspect
+
+ case fps of
+ Just value -> putStrLn $ "FPS: " ++ show value
+ Nothing -> return ()
+
+ setCameraMatrix (cameraView .*. cameraProjection)
+ setLightMatrix (lightView .*. lightProjection)
+ setLightPosition lightPosition
+
+ setPlaneModelMatrix (fromProjective $ scaling (Vec3 12 12 1) .*. translation (Vec3 0 (-2) (-12)))
+ forM_ (zip setCubeModelMatrices [0..]) $ \(setCubeModelMatrix, i) -> do
+ let t = i * 2 * pi / 5
+ s = (t + 2) * 0.3
+ trans = scaling (Vec3 s s s) .*. rotationEuler (Vec3 0 0 s) .*. translation (Vec3 (t * 0.3) (sin t * 4) (cos t * 4))
+ setCubeModelMatrix (fromProjective trans)
+ setSize (fromIntegral windowWidth) (fromIntegral windowHeight)
+
+ effectful4 setupRendering fpsTracking windowSize camera time
+
+readInput :: IO (Maybe Float)
+readInput = do
+ t <- getTime
+ resetTime
+
+ k <- keyIsPressed KeyEsc
+ return $ if k then Nothing else Just (realToFrac t)
@@ -0,0 +1,51 @@
+{-# LANGUAGE PackageImports #-}
+
+module Utils where
+
+import Control.Monad
+import Data.Time.Clock
+import "GLFW-b" Graphics.UI.GLFW as GLFW
+import Graphics.Rendering.OpenGL.Raw.Core32 (glViewport)
+import FRP.Elerea.Param
+
+measureDuration :: IO a -> IO (NominalDiffTime, a)
+measureDuration action = do
+ startTime <- getCurrentTime
+ result <- action
+ endTime <- getCurrentTime
+ return (diffUTCTime endTime startTime, result)
+
+initWindow :: String -> IO (Signal (Int, Int))
+initWindow title = do
+ initialize
+ openWindow defaultDisplayOptions
+ { displayOptions_numRedBits = 8
+ , displayOptions_numGreenBits = 8
+ , displayOptions_numBlueBits = 8
+ , displayOptions_numAlphaBits = 8
+ , displayOptions_numDepthBits = 24
+ , displayOptions_width = 800
+ , displayOptions_height = 600
+ , displayOptions_windowIsResizable = True
+ , displayOptions_openGLVersion = (3,2)
+ , displayOptions_openGLProfile = CoreProfile
+-- , displayOptions_openGLForwardCompatible = True
+-- , displayOptions_displayMode = Fullscreen
+ }
+ setWindowTitle title
+
+ (windowSize, windowSizeSink) <- external (0, 0)
+ setWindowSizeCallback $ \w h -> do
+ glViewport 0 0 (fromIntegral w) (fromIntegral h)
+ windowSizeSink (fromIntegral w, fromIntegral h)
+
+ return windowSize
+
+driveNetwork :: (p -> IO (IO a)) -> IO (Maybe p) -> IO ()
+driveNetwork network driver = do
+ dt <- driver
+ case dt of
+ Just dt -> do
+ join (network dt)
+ driveNetwork network driver
+ Nothing -> return ()
Oops, something went wrong.

0 comments on commit 3c0cdc1

Please sign in to comment.