lambdacube-samples (empty) → 0.1.0
raw patch · 11 files changed
+2178/−0 lines, 11 filesdep +GLFW-bdep +OpenGLRawdep +basesetup-changedbinary-added
Dependencies added: GLFW-b, OpenGLRaw, base, bullet, bytestring, bytestring-trie, elerea, lambdacube-core, mtl, stb-image, time, vect, vector
Files
- BulletExample.hs +644/−0
- Common/GraphicsUtils.hs +255/−0
- Common/Utils.hs +60/−0
- ConvolutionFilter.hs +228/−0
- CubeMap.hs +271/−0
- Hello.hs +228/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- ShadowMapping.hs +379/−0
- hello.png binary
- lambdacube-samples.cabal +81/−0
+ BulletExample.hs view
@@ -0,0 +1,644 @@+{-# LANGUAGE OverloadedStrings, TypeOperators, NoMonomorphismRestriction, ExistentialQuantification, PackageImports, DoRec, ParallelListComp, DataKinds #-}++{-++Notes:++* btCollisionShape can be handled as an immutable, shareable object,+ so functions creating any of its descendants don't have to be in IO++* access to all constants would be nice (e.g. no activation states available)++* the physics world could be just as well made accessible from a monad as the LC world++* how to check if a boxed pointer is null?++-}++import Control.Applicative+import Control.Arrow (first)+import Control.Monad+import Control.Monad.Fix+import Control.Monad.Trans+import Data.Bits+import qualified Data.ByteString.Char8 as B+import Data.IORef+import Data.Maybe+import Data.List+import qualified Data.Trie as T+import Data.Vect+import Data.Vector ((!))+import qualified Data.Vector as V +import Foreign hiding (unsafePerformIO)+import FRP.Elerea.Simple+import "GLFW-b" Graphics.UI.GLFW+import Physics.Bullet.Raw+import Physics.Bullet.Raw.Class+import Physics.Bullet.Raw.Types+import Physics.Bullet.Raw.Utils+import System.IO.Unsafe+import Unsafe.Coerce++import LC_API hiding (Transform)+import qualified LC_API as LC+import LC_Mesh++import Common.Utils+import Common.GraphicsUtils++data CameraInfo = CameraInfo+ { cameraPosition :: Vec3+ , targetPosition :: Vec3+ , upwardDirection :: Vec3+ }++cameraView (CameraInfo cameraPos targetPos upwardDir) = lookat cameraPos targetPos upwardDir+ +cameraInfo = CameraInfo (Vec3 0 20 30) (Vec3 0 0 0) (Vec3 0 1 0)++farPlane = 5000++fieldOfView = pi / 2++floorSize = Vec3 100.0 1.0 100.0++brickSize = Vec3 5.0 2.0 10.0++ghostRadius = 5++capsuleBoxSize radius height = Vec3 radius (height/2+radius) radius++pi2 = pi*0.5++pi4 = pi*0.25++scaleTransPos m (Transform rot pos) = Transform rot (pos &* m)++--ragdollPartConfig :: [(String, (Float, Float, Transform))]+ragdollPartConfig = map (scalePart 5)+ [ ("Pelvis", (0.15, 0.20, Transform idmtx (Vec3 0 1 0)))+ , ("Spine", (0.15, 0.28, Transform idmtx (Vec3 0 1.2 0)))+ , ("Head", (0.10, 0.05, Transform idmtx (Vec3 0 1.6 0)))+ , ("LeftUpperLeg", (0.07, 0.45, Transform idmtx (Vec3 (-0.18) 0.65 0)))+ , ("LeftLowerLeg", (0.05, 0.37, Transform idmtx (Vec3 (-0.18) 0.2 0)))+ , ("RightUpperLeg", (0.07, 0.45, Transform idmtx (Vec3 0.18 0.65 0)))+ , ("RightLowerLeg", (0.05, 0.37, Transform idmtx (Vec3 0.18 0.2 0)))+ , ("LeftUpperArm", (0.05, 0.33, Transform (rotMatrixZ pi2) (Vec3 (-0.35) 1.45 0)))+ , ("LeftLowerArm", (0.04, 0.25, Transform (rotMatrixZ pi2) (Vec3 (-0.7) 1.45 0)))+ , ("RightUpperArm", (0.05, 0.33, Transform (rotMatrixZ (-pi/2)) (Vec3 0.35 1.45 0)))+ , ("RightLowerArm", (0.04, 0.25, Transform (rotMatrixZ (-pi/2)) (Vec3 0.7 1.45 0)))+ ]+ where+ scalePart m (name, (radius, height, trans)) = (name, (radius*m, height*m, scaleTransPos m trans))++ragdollConstraintConfig = map (scaleConstraint 5)+ [ HingeConstraint "Pelvis" "Spine" (Transform (rotMatrixY pi2) (Vec3 0 0.15 0)) (Transform (rotMatrixY pi2) (Vec3 0 (-0.15) 0)) (-pi4) pi2+ , ConeTwistConstraint "Spine" "Head" (Transform (rotMatrixZ pi2) (Vec3 0 0.3 0)) (Transform (rotMatrixZ pi2) (Vec3 0 (-0.14) 0)) pi4 pi4 pi2+ , hipConstraint "LeftUpperLeg" (-1)+ , kneeConstraint "LeftUpperLeg" "LeftLowerLeg"+ , hipConstraint "RightUpperLeg" 1+ , kneeConstraint "RightUpperLeg" "RightLowerLeg"+ , shoulderConstraint "LeftUpperArm" (-1)+ , elbowConstraint "LeftUpperArm" "LeftLowerArm"+ , shoulderConstraint "RightUpperArm" 1+ , elbowConstraint "RightUpperArm" "RightLowerArm"+ ]+ where+ hipConstraint upperLeg sign = ConeTwistConstraint "Pelvis" upperLeg (Transform (rotMatrixZ (sign*pi4)) (Vec3 (sign*0.18) (-0.1) 0)) (Transform (rotMatrixZ (sign*pi4)) (Vec3 0 0.225 0)) pi4 pi4 0+ kneeConstraint upperLeg lowerLeg = HingeConstraint upperLeg lowerLeg (Transform (rotMatrixY pi2) (Vec3 0 (-0.225) 0)) (Transform (rotMatrixY pi2) (Vec3 0 0.185 0)) 0 pi2+ shoulderConstraint upperArm sign = ConeTwistConstraint "Spine" upperArm (Transform (rotMatrixZ (pi2-sign*pi2)) (Vec3 (sign*0.2) 0.15 0)) (Transform (rotMatrixZ pi2) (Vec3 0 (-0.18) 0)) pi2 pi2 0+ elbowConstraint upperArm lowerArm = HingeConstraint upperArm lowerArm (Transform (rotMatrixY pi2) (Vec3 0 0.18 0)) (Transform (rotMatrixY pi2) (Vec3 0 (-0.14) 0)) 0 pi2+ scaleConstraint m c = case c of+ HingeConstraint name1 name2 trans1 trans2 low high -> HingeConstraint name1 name2 (sc trans1) (sc trans2) low high+ ConeTwistConstraint name1 name2 trans1 trans2 swingSpan1 swingSpan2 twistSpan -> ConeTwistConstraint name1 name2 (sc trans1) (sc trans2) swingSpan1 swingSpan2 twistSpan+ where+ sc = scaleTransPos m+ +-- This is missing a lot of stuff (including other constructors?), it should be handled by attributes+data BulletConstraint+ = HingeConstraint String String Transform Transform Float Float+ | ConeTwistConstraint String String Transform Transform Float Float Float++-- Capsules only...+complexBody dynamicsWorld offset parts constraints = do+ bodies <- forM parts $ \(name, (radius, height, Transform rot pos)) -> do+ body <- snd <$> localCreateRigidBodyM dynamicsWorld 1 (Transform rot (pos &+ offset)) (capsuleShape radius height)+ return (name, body)+ let body name = snd (fromJust (find ((==name) . fst) bodies))+ forM_ constraints $ \ctr -> case ctr of+ HingeConstraint name1 name2 trans1 trans2 low high -> do+ hinge <- btHingeConstraint2 (body name1) (body name2) trans1 trans2 False+ btHingeConstraint_setLimit hinge low high 0.9 0.3 1+ --set hinge [lowerLimit? := low, upperLimit? := high, limitSoftness := 0.9, biasFactor := 0.3, relaxationFactor := 1]+ btDynamicsWorld_addConstraint dynamicsWorld hinge True+ ConeTwistConstraint name1 name2 trans1 trans2 swSpan1 swSpan2 twSpan -> do+ coneTwist <- btConeTwistConstraint0 (body name1) (body name2) trans1 trans2+ --set coneTwist [swingSpan1 := swSpan1, swingSpan2 := swSpan2, twistSpan := twSpan, limitSoftness := 1, biasFactor := 0.3, relaxationFactor := 1]+ btConeTwistConstraint_setLimit1 coneTwist swSpan1 swSpan2 twSpan 1 0.3 1+ btDynamicsWorld_addConstraint dynamicsWorld coneTwist True+ return bodies ++-- Attribute system in the footsteps of gtk2hs (glib)++infixr 0 :=, :~, :<++data Attr o a = forall x . Attr !(o -> IO a) !(o -> a -> IO x)++data AttrOp o = forall a . Attr o a := a+ | forall a . Attr o a :~ (a -> a)+ | forall a . Attr o a :!= IO a+ | forall a . Attr o a :!~ (a -> IO a)+ | forall a . Attr o a :< Signal (Maybe a)+ +set :: o -> [AttrOp o] -> IO o+set obj attrs = (>> return obj) $ forM_ attrs $ \op -> case op of+ Attr _ setter := x -> setter obj x >> return ()+ Attr getter setter :~ f -> getter obj >>= setter obj . f >> return ()+ Attr _ setter :!= x -> x >>= setter obj >> return ()+ Attr getter setter :!~ f -> getter obj >>= f >>= setter obj >> return ()+ _ :< _ -> error "Signals not supported in IO"++get :: o -> Attr o a -> IO a+get obj (Attr getter _) = getter obj ++make :: IO o -> [AttrOp o] -> IO o+make act flags = do+ obj <- act+ set obj flags+ return obj++set' :: o -> [AttrOp o] -> SignalGen (Signal ())+set' obj as = go as (return ())+ where+ go [] sig = return sig+ go (a:as) sig = case a of+ Attr getter setter := x -> execute (setter obj x >> return ()) >> go as sig+ Attr getter setter :~ f -> execute (getter obj >>= setter obj . f >> return ()) >> go as sig+ Attr getter setter :!= x -> execute (x >>= setter obj >> return ()) >> go as sig+ Attr getter setter :!~ f -> execute (getter obj >>= f >>= setter obj >> return ()) >> go as sig+ Attr getter setter :< s -> do + dummy <- flip effectful1 s $ \mx -> case mx of+ Nothing -> return ()+ Just x -> setter obj x >> return ()+ go as (liftA2 const sig dummy)++make' :: IO o -> [AttrOp o] -> SignalGen (Signal o)+make' act flags = do+ obj <- execute act+ dummy <- set' obj flags+ return (liftA2 const (return obj) dummy)++-- Test attributes++collisionFlags :: BtCollisionObjectClass o => Attr o Int+collisionFlags = Attr btCollisionObject_getCollisionFlags btCollisionObject_setCollisionFlags++-- coercion needed to generalise concrete type into a vague type class (should be safe)+collisionShape :: (BtCollisionObjectClass o, BtCollisionShapeClass cs) => Attr o cs+collisionShape = Attr (unsafeCoerce . btCollisionObject_getCollisionShape) btCollisionObject_setCollisionShape++worldTransform :: BtCollisionObjectClass o => Attr o Transform+worldTransform = Attr btCollisionObject_getWorldTransform btCollisionObject_setWorldTransform++deactivationTime :: BtCollisionObjectClass o => Attr o Float+deactivationTime = Attr btCollisionObject_getDeactivationTime btCollisionObject_setDeactivationTime++-- note the inconsistent naming convention...+pivotA :: BtPoint2PointConstraintClass o => Attr o Vec3+pivotA = Attr btPoint2PointConstraint_getPivotInA btPoint2PointConstraint_setPivotA++pivotB :: BtPoint2PointConstraintClass o => Attr o Vec3+pivotB = Attr btPoint2PointConstraint_getPivotInB btPoint2PointConstraint_setPivotB++-- it would be great if all the constraints provided a similar facility+setting :: BtPoint2PointConstraintClass o => Attr o BtConstraintSetting+setting = Attr btPoint2PointConstraint_m_setting_get btPoint2PointConstraint_m_setting_set++impulseClamp :: BtConstraintSettingClass o => Attr o Float+impulseClamp = Attr btConstraintSetting_m_impulseClamp_get btConstraintSetting_m_impulseClamp_set++tau :: BtConstraintSettingClass o => Attr o Float+tau = Attr btConstraintSetting_m_tau_get btConstraintSetting_m_tau_set++damping :: BtConstraintSettingClass o => Attr o Float+damping = Attr btConstraintSetting_m_damping_get btConstraintSetting_m_damping_set++-- Collision tracking example++extractManifold :: BtPersistentManifold -> IO (BtCollisionObject,BtCollisionObject,[(Float,Vec3,Vec3,Vec3)])+extractManifold manifold = do+ b0 <- mkBtCollisionObject =<< btPersistentManifold_getBody0 manifold+ b1 <- mkBtCollisionObject =<< btPersistentManifold_getBody1 manifold+ cpn <- btPersistentManifold_getNumContacts manifold+ l <- forM [0..cpn-1] $ \p -> do+ pt <- btPersistentManifold_getContactPoint manifold p+ (,,,) <$>+ btManifoldPoint_getDistance pt <*> btManifoldPoint_getPositionWorldOnA pt <*> + btManifoldPoint_getPositionWorldOnB pt <*> btManifoldPoint_m_normalWorldOnB_get pt+ return (b0,b1,l)++collectManifolds :: BtCollisionWorldClass cw => cw -> BtPairCachingGhostObject -> IO [BtPersistentManifold]+collectManifolds dynamicsWorld ghostObject = do+ let notNull a = btToPtr a /= nullPtr+ manifoldArray <- btAlignedObjectArray_btPersistentManifold_ptr_+ pairArray <- btHashedOverlappingPairCache_getOverlappingPairArray =<< btPairCachingGhostObject_getOverlappingPairCache ghostObject+ numPairs <- btAlignedObjectArray_btBroadphasePair__size pairArray+ l <- forM [0..numPairs-1] $ \i -> do+ btAlignedObjectArray_btPersistentManifold_ptr__clear manifoldArray+ pair <- btAlignedObjectArray_btBroadphasePair__at pairArray i+ pProxy0 <- btBroadphasePair_m_pProxy0_get pair+ pProxy1 <- btBroadphasePair_m_pProxy1_get pair+ collisionPair <- (\a -> btOverlappingPairCache_findPair a pProxy0 pProxy1) =<< btCollisionWorld_getPairCache dynamicsWorld+ case notNull collisionPair of+ False -> return []+ True -> do+ alg <- btBroadphasePair_m_algorithm_get collisionPair+ when (notNull alg) $ btCollisionAlgorithm_getAllContactManifolds alg manifoldArray+ n <- btAlignedObjectArray_btPersistentManifold_ptr__size manifoldArray+ forM [0..n-1] $ \j -> btAlignedObjectArray_btPersistentManifold_ptr__at manifoldArray j+ --btAlignedObjectArray_btPersistentManifold_ptr__free manifoldArray+ return $ concat l++rigidBodyProj4 :: BtRigidBody -> IO Proj4+rigidBodyProj4 rigidBody = do+ motionState <- btRigidBody_getMotionState rigidBody+ t <- btMotionState_getWorldTransform motionState idTransform+ return (transformToProj4 t)++proj4ToTransform :: Proj4 -> Transform+proj4ToTransform p = Transform (Mat3 (Vec3 a1 a2 a3) (Vec3 b1 b2 b3) (Vec3 c1 c2 c3)) (Vec3 p1 p2 p3)+ where+ Mat4 (Vec4 a1 b1 c1 _) (Vec4 a2 b2 c2 _) (Vec4 a3 b3 c3 _) (Vec4 p1 p2 p3 _) = fromProjective p++transformToProj4 :: Transform -> Proj4+transformToProj4 t = toProjectiveUnsafe $ Mat4 (Vec4 a1 b1 c1 0) (Vec4 a2 b2 c2 0) (Vec4 a3 b3 c3 0) (Vec4 p1 p2 p3 1)+ where+ Transform (Mat3 (Vec3 a1 a2 a3) (Vec3 b1 b2 b3) (Vec3 c1 c2 c3)) (Vec3 p1 p2 p3) = t++main' = do+ dynamicsWorld <- simpleBtDiscreteDynamicsWorldM++ -- setup+ ghostPairCallback <- btGhostPairCallback+ pairCache <- btCollisionWorld_getPairCache dynamicsWorld+ btOverlappingPairCache_setInternalGhostPairCallback pairCache ghostPairCallback++ ghostObject <- btPairCachingGhostObject++ sphere <- btSphereShape 5+ print sphere+ print (btToPtr ghostObject < btToPtr sphere)+ btCollisionObject_setCollisionShape ghostObject sphere+ btCollisionObject_setWorldTransform ghostObject $ Transform idmtx $ Vec3 0 5 0+ btCollisionWorld_addCollisionObject dynamicsWorld ghostObject 1 (-1)++ (_,b) <- localCreateRigidBodyM dynamicsWorld 1 (Transform idmtx $ Vec3 0 6 0) sphere+ print (ghostObject,b)++ print =<< mapM extractManifold =<< collectManifolds dynamicsWorld ghostObject++ -- ray test+ let from = Vec3 0 100 0+ to = Vec3 0 (-100) 0+ rayResult <- btCollisionWorld_AllHitsRayResultCallback from to+ btCollisionWorld_rayTest dynamicsWorld from to rayResult+ l <- btCollisionWorld_AllHitsRayResultCallback_m_hitPointWorld_get rayResult+ -- m_collisionObjects: btAlignedObjectArray<btCollisionObject*>+ -- btAlignedObjectArray_btCollisionObject_ptr__at+ n <- btAlignedObjectArray_btVector3__size l+ hitPoints <- forM [0..n-1] $ \i -> btAlignedObjectArray_btVector3__at l i+ print ("ray test",hitPoints)++ -- ghost object collision test+ btDynamicsWorld_stepSimulation dynamicsWorld 0.01 10 (1 / 200)+ print =<< (mapM extractManifold =<< collectManifolds dynamicsWorld ghostObject)+ btDynamicsWorld_stepSimulation dynamicsWorld 10 10 (1 / 200)+ print =<< (mapM extractManifold =<< collectManifolds dynamicsWorld ghostObject)++sphereShape = unsafePerformIO . btSphereShape++boxShape = unsafePerformIO . btBoxShape++capsuleShape r h = unsafePerformIO (btCapsuleShape1 r h)++bodyTransformation = effectful1 rigidBodyProj4++boolToMaybe val bool = if bool then Just val else Nothing++main = do+ (windowSize, mousePosition, mousePress) <- initCommon "LambdaCube-Bullet test"++ dynamicsWorld <- simpleBtDiscreteDynamicsWorldM+ ghostPairCallback <- btGhostPairCallback+ pairCache <- btCollisionWorld_getPairCache dynamicsWorld+ btOverlappingPairCache_setInternalGhostPairCallback pairCache ghostPairCallback+ + let stepPhysics dt = btDynamicsWorld_stepSimulation dynamicsWorld dt 50 0.005+ collisionInfo gobj = mapM extractManifold =<< collectManifolds dynamicsWorld gobj+ bodyInCollision body = not . null . filter (involves body)+ where+ involves b (b1,b2,_) = b == unsafeCoerce b1 || b == unsafeCoerce b2++ let pipeline :: Exp Obj (Image 1 V4F)+ pipeline = PrjFrameBuffer "outFB" tix0 translucentShading --simpleShading+ + (duration, renderer) <- measureDuration $ compileRenderer (ScreenOut pipeline)+ putStrLn $ "Renderer compiled - " ++ show duration+ + let setters = uniformSetter renderer+ lightPositionSetter = uniformV3F "lightPosition" setters . fromVec3++ lightPositionSetter (Vec3 10 10 10)+ + let createObject name mesh colour = do+ let (slotName, uniformName) = case colour of + Left _ -> ("solidGeometry", "solidColour")+ Right _ -> ("translucentGeometry", "alphaColour")++ compiledMesh <- compileMesh mesh+ object <- addMesh renderer slotName compiledMesh [uniformName, "modelMatrix"]+ let objectSetters = objectUniformSetter object+ modelMatrixSetter = uniformM44F "modelMatrix" objectSetters . fromMat4+ + modelMatrixSetter idmtx+ case colour of+ Left rgb -> uniformV3F uniformName objectSetters (fromVec3 rgb)+ Right rgba -> uniformV4F uniformName objectSetters (fromVec4 rgba)+ return (name, modelMatrixSetter)++ ghostSetter <- createObject "Ghost" (sphere 5 10) (Right (Vec4 0.3 0.9 0.9 0.7))+ floorSetter <- createObject "Floor" (box floorSize) (Left (Vec3 0.7 0.7 0.7))+ brickSetter <- createObject "Brick" (box brickSize) (Left (Vec3 1.0 0.0 0.0))+ hitSetter <- createObject "Hit" (sphere 0.5 5) (Right (Vec4 1.0 1.0 1.0 0.7))++ ragdollSetters <- forM ragdollPartConfig $ \(name, (radius, height, trans)) -> do+ ragdollSetter@(_, setTrans) <- createObject name (capsule radius height 10) (Left (Vec3 1.0 0.9 0.6))+ setTrans (fromProjective (transformToProj4 trans))+ return ragdollSetter++ let updateTransforms transforms = forM_ transforms $ \(name, trans) -> do+ let Just setter = T.lookup (B.pack name) setters+ setter (fromProjective trans)+ setters = T.fromList (map (first B.pack) namedSetters) + where+ namedSetters = ghostSetter : floorSetter : brickSetter : hitSetter : ragdollSetters++ smp <- start $ do+ ragdollBodies <- execute $ do+ floor <- localCreateRigidBodyM dynamicsWorld 0 (Transform idmtx 0) (boxShape floorSize)+ complexBody dynamicsWorld (Vec3 1 5 10) ragdollPartConfig ragdollConstraintConfig++ querySpace <- execute $ do+ ghostObject <- make btPairCachingGhostObject+ [ collisionFlags :~ (.|. e_btCollisionObject_CollisionFlags_CF_NO_CONTACT_RESPONSE)+ , collisionShape := sphereShape ghostRadius+ , worldTransform := Transform idmtx 0+ ]+ btCollisionWorld_addCollisionObject dynamicsWorld ghostObject 1 (-1)+ return ghostObject++ collisions <- effectful $ collisionInfo querySpace++ let initBrickTrans = Transform idmtx (Vec3 2 20 (-3))+ brick <- do+ rec brick <- make' (snd <$> localCreateRigidBodyM dynamicsWorld 1 initBrickTrans (boxShape brickSize))+ [worldTransform :< boolToMaybe initBrickTrans . bodyInCollision brickBody <$> collisions]+ brickBody <- snapshot brick+ return brick+ + brickTrans <- bodyTransformation brick+ + (hitPosition, hitPositionSink) <- execute $ external Nothing+ + dummy <- pickConstraint dynamicsWorld windowSize (pure cameraInfo) mousePress mousePosition hitPositionSink++ return $ updateScene renderer updateTransforms stepPhysics ragdollBodies <$> windowSize <*> hitPosition <*> (const <$> brickTrans <*> dummy)+ + fix $ \loop -> do+ join smp+ esc <- keyIsPressed KeyEsc+ when (not esc) loop+ + dispose renderer+ putStrLn "Renderer destroyed."++ closeWindow++updateScene :: Renderer -> ([(String, Proj4)] -> IO ()) -> (Float -> IO Int) -> [(String, BtRigidBody)] -> Vec2 -> Maybe Vec3 -> Proj4 -> IO ()+updateScene renderer updateTransforms stepPhysics ragdollBodies (Vec2 w h) hitPosition brickTrans = do+ ragdollTransforms <- forM ragdollBodies $ \(name, body) -> do+ proj <- rigidBodyProj4 body+ return (name, proj)+ + let aspect = w / h+ cameraProjection = perspective 0.1 farPlane fieldOfView aspect+ cameraSetter = uniformM44F "cameraMatrix" (uniformSetter renderer) . fromMat4+ setScreenSize renderer (floor w) (floor h)+ cameraSetter $ fromProjective (cameraView cameraInfo) .*. cameraProjection++ updateTransforms $+ ("Brick", brickTrans) :+ ("Hit", translation (fromMaybe (Vec3 0 10000 0) hitPosition)) :+ ragdollTransforms+ + dt <- getTime+ resetTime+ stepPhysics (realToFrac dt)+ + render renderer+ swapBuffers++-- Picking++pickConstraint dynamicsWorld windowSize cameraInfo mouseButton mousePos hitPositionSink = do+ press <- edge mouseButton+ release <- edge (not <$> mouseButton)+ pick <- generator $ makePick <$> press <*> windowSize <*> cameraInfo <*> mousePos+ + -- We're going to all this trouble just to keep a reference to the+ -- constraint signal: we sample it in every frame even though it+ -- is constant+ releaseInfo <- do+ rec sig <- delay Nothing $ do+ released <- release+ newPick <- pick+ currentPick <- sig+ case (released, newPick, currentPick) of+ (True, _, _) -> return Nothing+ (_, Just (constraintSignal, body), _) -> do+ constraint <- constraintSignal+ return $ Just (constraint, body, constraintSignal)+ (_, _, Just (_, body, constraintSignal)) -> do+ constraint <- constraintSignal+ return $ Just (constraint, body, constraintSignal)+ _ -> return Nothing ++ return sig+ + effectful2 stopPicking release releaseInfo+ where+ edge sig = do+ sig' <- delay False sig+ return $ do+ cur <- sig+ prev <- sig'+ return $ not prev && cur + + stopPicking True (Just (constraint, body, _)) = releasePick dynamicsWorld body constraint+ stopPicking _ _ = return ()+ + makePick press windowSizeCur cameraInfoCur mousePosCur = case press of+ False -> return Nothing+ True -> do+ pickInfo <- execute $ pickBody dynamicsWorld windowSizeCur cameraInfoCur mousePosCur hitPositionSink+ case pickInfo of+ Nothing -> return Nothing+ Just (body, hitPosition, distance) -> do+ constraint <- createPick dynamicsWorld body hitPosition distance windowSize cameraInfo mousePos+ return $ Just (constraint, body)+ +-- body picked, ray hit position, and distance from the camera at the time of picking (to be kept while moving)+--pickBody :: BtCollisionWorldClass bc => bc -> Vec2 -> CameraInfo -> Vec2-> (Maybe Vec3 -> IO ()) -> IO (Maybe (BtRigidBody, Vec3, Float))+pickBody dynamicsWorld windowSize cameraInfo mousePos hitPositionSink = do+ let rayFrom = cameraPosition cameraInfo+ rayTo = rayTarget windowSize cameraInfo mousePos+ rayResult <- btCollisionWorld_ClosestRayResultCallback rayFrom rayTo+ btCollisionWorld_rayTest dynamicsWorld rayFrom rayTo rayResult+ hasHit <- btCollisionWorld_RayResultCallback_hasHit rayResult+ + case hasHit of+ False -> do+ hitPositionSink Nothing+ return Nothing+ True -> do+ collisionObj <- btCollisionWorld_RayResultCallback_m_collisionObject_get rayResult+ isNotPickable <- btCollisionObject_isStaticOrKinematicObject collisionObj+ hitPositionSink =<< Just <$> btCollisionWorld_ClosestRayResultCallback_m_hitPointWorld_get rayResult+ internalType <- btCollisionObject_getInternalType collisionObj+ case isNotPickable || internalType /= e_btCollisionObject_CollisionObjectTypes_CO_RIGID_BODY of+ True -> return Nothing+ False -> do+ btCollisionObject_setActivationState collisionObj 4 -- DISABLE_DEACTIVATION+ hitPosition <- btCollisionWorld_ClosestRayResultCallback_m_hitPointWorld_get rayResult+ body <- btRigidBody_upcast collisionObj -- this is null if the internal type is not CO_RIGID_BODY+ return $ Just (body, hitPosition, len (hitPosition &- rayFrom))++createPick :: (BtDynamicsWorldClass bc, BtRigidBodyClass b)+ => bc -> b -> Vec3 -> Float -> Signal Vec2 -> Signal CameraInfo -> Signal Vec2 -> SignalGen (Signal BtPoint2PointConstraint)+createPick dynamicsWorld body hitPosition distance windowSize cameraInfo mousePos = do+ make' (createPickConstraint dynamicsWorld body hitPosition)+ [ setting :!~ flip set [impulseClamp := 30, tau := 0.001]+ , pivotB :< pivotPosition <$> windowSize <*> cameraInfo <*> mousePos+ ]+ where+ createPickConstraint dynamicsWorld body hitPosition = do+ bodyProj <- transformToProj4 <$> btRigidBody_getCenterOfMassTransform body+ let localPivot = trim ((extendWith 1 hitPosition :: Vec4) .* fromProjective (inverse bodyProj))+ pickConstraint <- btPoint2PointConstraint1 body localPivot+ btDynamicsWorld_addConstraint dynamicsWorld pickConstraint True+ return pickConstraint+ + pivotPosition windowSize cameraInfo mousePos = Just (rayFrom &+ (normalize (rayTo &- rayFrom) &* distance))+ where+ rayFrom = cameraPosition cameraInfo+ rayTo = rayTarget windowSize cameraInfo mousePos++releasePick dynamicsWorld body constraint = do+ btDynamicsWorld_removeConstraint dynamicsWorld constraint+ btCollisionObject_forceActivationState body 1 -- ACTIVE_TAG+ btCollisionObject_setDeactivationTime body 0++rayTarget :: Vec2 -> CameraInfo -> Vec2 -> Vec3+rayTarget (Vec2 windowW windowH) (CameraInfo cameraPos targetPos cameraUp) (Vec2 windowX windowY) =+ rayCenter &- (horizontal &* (aspect*(0.5-windowX/windowW))) &+ (vertical &* (0.5-windowY/windowH))+ where+ aspect = windowW / windowH+ tanFov = tan (fieldOfView * sqrt 0.5)++ rayForward = normalize (targetPos &- cameraPos) &* farPlane+ horizontal = normalize (rayForward &^ cameraUp) &* (farPlane*tanFov)+ vertical = normalize (horizontal &^ rayForward) &* (farPlane*tanFov)+ + rayCenter = cameraPos &+ rayForward++simpleShading :: Exp Obj (FrameBuffer 1 (Float, V4F))+simpleShading = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) clearBuf+ where+ accCtx = AccumulationContext Nothing (DepthOp Less True :. ColorOp NoBlending (one' :: V4B) :. ZT)+ clearBuf = FrameBuffer (DepthImage n1 1000 :. ColorImage n1 (V4 0 0 0 1) :. ZT)+ prims = LC.Transform vert (Fetch "solidGeometry" Triangles (IV3F "position", IV3F "normal"))+ + cameraMatrix = Uni (IM44F "cameraMatrix")+ modelMatrix = Uni (IM44F "modelMatrix")+ lightPosition = Uni (IV3F "lightPosition")+ colour = Uni (IV3F "solidColour")++ vert :: Exp V (V3F, V3F) -> VertexOut () (V3F, V3F)+ vert attr = VertexOut viewPos (floatV 1) ZT (Smooth (v4v3 worldPos) :. Smooth worldNormal :. ZT)+ where+ worldPos = modelMatrix @*. v3v4 localPos+ viewPos = cameraMatrix @*. worldPos+ worldNormal = normalize' (v4v3 (modelMatrix @*. n3v4 localNormal))+ (localPos, localNormal) = untup2 attr+ + frag :: Exp F (V3F, V3F) -> FragmentOut (Depth Float :+: Color V4F :+: ZZ)+ frag attr = FragmentOutRastDepth (v3v4 (colour @* light) :. ZT)+ where+ light = max' (floatF 0) (dot' worldNormal (normalize' (lightPosition @- worldPos)))+ (worldPos, worldNormal) = untup2 attr++translucentShading :: Exp Obj (FrameBuffer 1 (Float, V4F))+translucentShading = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) simpleShading+ where+ accCtx = AccumulationContext Nothing (DepthOp Less True :. ColorOp blending (one' :: V4B) :. ZT)+ blending = Blend (FuncAdd, FuncAdd) ((SrcAlpha, OneMinusSrcAlpha), (SrcAlpha, OneMinusSrcAlpha)) zero'+ prims = LC.Transform vert (Fetch "translucentGeometry" Triangles (IV3F "position", IV3F "normal"))+ + cameraMatrix = Uni (IM44F "cameraMatrix")+ modelMatrix = Uni (IM44F "modelMatrix")+ lightPosition = Uni (IV3F "lightPosition")+ colour = Uni (IV4F "alphaColour")++ vert :: Exp V (V3F, V3F) -> VertexOut () (V3F, V3F)+ vert attr = VertexOut viewPos (floatV 1) ZT (Smooth (v4v3 worldPos) :. Smooth worldNormal :. ZT)+ where+ worldPos = modelMatrix @*. v3v4 localPos+ viewPos = cameraMatrix @*. worldPos+ worldNormal = normalize' (v4v3 (modelMatrix @*. n3v4 localNormal))+ (localPos, localNormal) = untup2 attr+ + frag :: Exp F (V3F, V3F) -> FragmentOut (Depth Float :+: Color V4F :+: ZZ)+ frag attr = FragmentOutRastDepth (finalColour :. ZT)+ where+ V4 r g b a = unpack' colour+ finalColour = pack' (V4 (r @* light) (g @* light) (b @* light) a)+ light = max' (floatF 0) (dot' worldNormal (normalize' (lightPosition @- worldPos)))+ (worldPos, worldNormal) = untup2 attr++initCommon :: String -> IO (Signal Vec2, Signal Vec2, Signal Bool)+initCommon title = do+ initialize+ openWindow defaultDisplayOptions+ { displayOptions_numRedBits = 8+ , displayOptions_numGreenBits = 8+ , displayOptions_numBlueBits = 8+ , displayOptions_numAlphaBits = 8+ , displayOptions_numDepthBits = 24+ , displayOptions_width = 1280+ , displayOptions_height = 720+ , displayOptions_windowIsResizable = True+ , displayOptions_openGLVersion = (3,2)+ , displayOptions_openGLProfile = CoreProfile+ }+ setWindowTitle title++ (windowSize, windowSizeSink) <- external (Vec2 0 0)+ setWindowSizeCallback $ \w h -> windowSizeSink (Vec2 (fromIntegral w) (fromIntegral h))+ + (mousePosition, mousePositionSink) <- external (Vec2 0 0)+ setMousePositionCallback $ \x y -> mousePositionSink (Vec2 (fromIntegral x) (fromIntegral y))+ + (mousePress, mousePressSink) <- external False+ setMouseButtonCallback $ \b p -> when (b == MouseButton0) $ mousePressSink p+ + return (windowSize, mousePosition, mousePress)
+ Common/GraphicsUtils.hs view
@@ -0,0 +1,255 @@+{-# LANGUAGE OverloadedStrings, NamedFieldPuns, ParallelListComp, DataKinds #-}++module Common.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++complexMesh :: [(Proj4, Mesh)] -> Mesh+complexMesh parts = Mesh+ { mAttributes = T.fromList [("position", A_V3F vertices), ("normal", A_V3F normals)]+ , mPrimitive = P_Triangles+ , mGPUData = Nothing+ }+ where+ vertices = V.concat partVertices+ normals = V.concat partNormals+ + (partVertices, partNormals) = unzip [(getV3F trans "position" attr 1, getV3F (transpose (inverse trans)) "normal" attr 0) |+ (trans, mesh) <- parts, let attr = mAttributes (unrollIndices mesh)]+ getV3F trans name attributes w = V.map transform vector+ where+ transform v = fromVec3 (trim ((extendWith w (toVec3 v) :: Vec4) .* fromProjective trans))+ Just (A_V3F vector) = T.lookup name attributes++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 :: Float -> Mesh+cube size = box (Vec3 size size size) ++box :: Vec3 -> Mesh+box (Vec3 scaleX scaleY scaleZ) = addFlatNormals $ Mesh+ { mAttributes = T.singleton "position" (A_V3F vertices)+ , 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+ + mkVertex n = V3 x y z+ where+ x = if testBit n 2 then scaleX else -scaleX+ y = if testBit n 1 then scaleY else -scaleY+ z = if testBit n 0 then scaleZ else -scaleZ++capsule :: Float -> Float -> Int -> Mesh+capsule radius height n = complexMesh+ [ (idmtx, cylinderLateralArea height' radius (n * 2))+ , (translation (Vec3 0 (-height') 0), halfSphere radius n)+ , (scaling (Vec3 (-1) (-1) 1) .*. translation (Vec3 0 height' 0), halfSphere radius n)+ ]+ where+ height' = height / 2++halfSphere :: Float -> Int -> Mesh+halfSphere radius n = Mesh+ { mAttributes = T.fromList [("position", A_V3F vertices), ("normal", A_V3F normals)]+ , mPrimitive = P_TrianglesI indices+ , mGPUData = Nothing+ }+ where+ m = pi / fromIntegral n+ vertices = V.map (\(V3 x y z) -> V3 (radius * x) (radius * y) (radius * z)) normals+ normals = V.fromList [V3 (sin a * cos b) (cos a) (sin a * sin b) | i <- [0..n], j <- [0..2 * n - 1],+ let a = fromIntegral i * m * 0.5 + 0.5 * pi, let b = fromIntegral j * m]+ indices = V.fromList $ concat [[ix i j, ix i' j, ix i' j', ix i' j', ix i j', ix i j] | i <- [0..n - 1], j <- [0..2 * n - 1],+ let i' = i + 1, let j' = (j + 1) `mod` (2 * n)]+ ix i j = fromIntegral (i * 2 * n + j)++sphere :: Float -> Int -> Mesh+sphere radius n = Mesh+ { mAttributes = T.fromList [("position", A_V3F vertices), ("normal", A_V3F normals)]+ , mPrimitive = P_TrianglesI indices+ , mGPUData = Nothing+ }+ where+ m = pi / fromIntegral n+ vertices = V.map (\(V3 x y z) -> V3 (radius * x) (radius * y) (radius * z)) normals+ normals = V.fromList [V3 (sin a * cos b) (cos a) (sin a * sin b) | i <- [0..n], j <- [0..2 * n - 1],+ let a = fromIntegral i * m, let b = fromIntegral j * m]+ indices = V.fromList $ concat [[ix i j, ix i' j, ix i' j', ix i' j', ix i j', ix i j] | i <- [0..n - 1], j <- [0..2 * n - 1],+ let i' = i + 1, let j' = (j + 1) `mod` (2 * n)]+ ix i j = fromIntegral (i * 2 * n + j)++cylinder :: Float -> Float -> Int -> Mesh+cylinder height radius n = complexMesh+ [ (idmtx, cylinderLateralArea height radius n)+ , (translation (Vec3 0 height 0), regularPolygon radius n)+ , (scaling (Vec3 1 (-1) 1) .*. translation (Vec3 0 (-height) 0), regularPolygon radius n)+ ]++regularPolygon :: Float -> Int -> Mesh+regularPolygon radius n = Mesh+ { mAttributes = T.fromList [("position", A_V3F vertices), ("normal", A_V3F normals)]+ , mPrimitive = P_TrianglesI indices+ , mGPUData = Nothing+ }+ where+ vertices = V.cons (V3 0 0 0) (V.generate n mkVertex)+ normals = V.replicate (n + 1) (V3 0 1 0)+ indices = V.map fromIntegral . V.fromList $ concat [[0, i, i `mod` n + 1] | i <- [1..n]]+ mkVertex i = V3 (radius * cos t) 0 (radius * sin t)+ where+ t = fromIntegral i * 2 * pi / fromIntegral n++cylinderLateralArea :: Float -> Float -> Int -> Mesh+cylinderLateralArea height radius n = Mesh+ { mAttributes = T.fromList [("position", A_V3F vertices), ("normal", A_V3F normals)]+ , mPrimitive = P_TrianglesI indices+ , mGPUData = Nothing+ }+ where+ ts = V.generate n (\t -> fromIntegral t * 2 * pi / fromIntegral n)+ ts' = ts V.++ ts+ xs = V.map cos ts'+ ys = V.replicate n height V.++ V.replicate n (-height)+ zs = V.map sin ts'+ is = [t `mod` n | t <- [0..n]]+ vertices = V.zipWith3 (\x y z -> V3 (radius*x) y (radius*z)) xs ys zs+ normals = V.zipWith3 V3 xs (V.replicate (n*2) 0) zs+ indices = V.fromList (map fromIntegral (concat [[i,i+n,i'+n,i'+n,i',i] | i <- is | i' <- tail is]))++addFlatNormals :: Mesh -> Mesh+addFlatNormals mesh@Mesh { mAttributes, mPrimitive = P_Triangles } =+ mesh { mAttributes = T.insert "normal" (A_V3F normals) mAttributes } + where+ Just (A_V3F positions) = T.lookup "position" mAttributes+ normals = V.concatMap mkNormal (V.generate (V.length positions `div` 3) id)+ mkNormal i = V.replicate 3 (fromVec3 (normalize ((p3 &- p2) &^ (p2 &- p1))))+ where+ p1 = toVec3 (positions V.! (i*3))+ p2 = toVec3 (positions V.! (i*3 + 1))+ p3 = toVec3 (positions V.! (i*3 + 2))+addFlatNormals mesh@Mesh { mPrimitive = P_TrianglesI indices } = addFlatNormals (unrollIndices mesh)+addFlatNormals _ = error "addFlatNormals: unsupported primitive type"++unrollIndices :: Mesh -> Mesh+unrollIndices mesh@Mesh { mAttributes, mPrimitive = P_Triangles } = mesh+unrollIndices mesh@Mesh { mAttributes, mPrimitive = P_TrianglesI indices } =+ mesh { mAttributes = fmap (unrollAttribute indices') mAttributes, mPrimitive = P_Triangles }+ where+ indices' = V.map fromIntegral indices+unrollIndices _ = error "unrollIndices: unsupported primitive type"++unrollAttribute :: V.Vector Int -> MeshAttribute -> MeshAttribute+unrollAttribute indices attribute = case attribute of+ A_V3F vs -> A_V3F (V.backpermute vs indices)+ _ -> error "unrollAttribute: unsupported attribute type"++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++floatG :: Float -> Exp G Float+floatG = Const++intF :: Int32 -> Exp F Int32+intF = Const++intG :: Int32 -> Exp G Int32+intG = 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)
+ Common/Utils.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE PackageImports #-}++module Common.Utils where++import Control.Applicative+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 -> Int -> Int -> IO (Signal (Int, Int))+initWindow title width height = do+ initialize+ openWindow defaultDisplayOptions+ { displayOptions_numRedBits = 8+ , displayOptions_numGreenBits = 8+ , displayOptions_numBlueBits = 8+ , displayOptions_numAlphaBits = 8+ , displayOptions_numDepthBits = 24+ , displayOptions_width = width+ , displayOptions_height = height+ , 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 ()++risingEdge :: Signal Bool -> SignalGen p (Signal Bool)+risingEdge signal = do+ signal' <- delay True signal+ memo $ liftA2 (&&) signal (not <$> signal') ++toggle :: Signal Bool -> SignalGen p (Signal Bool)+toggle = transfer False (const (/=))
+ ConvolutionFilter.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE OverloadedStrings, PackageImports, TypeOperators, ParallelListComp, DataKinds #-}++import Control.Monad+import Control.Monad.Fix+import qualified Data.ByteString.Char8 as SB+import qualified Data.Trie as T+import Data.Time.Clock+import Data.Vect+import Data.Vect.Float.Instances ()+import qualified Data.Vector.Storable as V+import "GLFW-b" Graphics.UI.GLFW as GLFW+import Text.Printf++import LC_API+import LC_Mesh++import Common.Utils+import Common.GraphicsUtils++windowWidth, windowHeight :: Num a => a+windowWidth = 512+windowHeight = 512++weights = gaussianSamples 1000 101+dirH = V2 1 0+dirV = V2 0 1++finalImage :: Exp Obj (FrameBuffer 1 V4F)+finalImage = filterPass dirV (filterPass dirH originalImage)+ where+ filterPass dir = convolve dir weights . projectBuffer+ projectBuffer = PrjFrameBuffer "" tix0++--finalImage = additiveSample "verticalFilter" (projectBuffer (additiveSample "horizontalFilter" (projectBuffer originalImage)))+--finalImage = originalImage++main :: IO ()+main = do+ let pipeline :: Exp Obj (Image 1 V4F)+ pipeline = PrjFrameBuffer "outFB" tix0 finalImage++ initWindow "LambdaCube 3D Convolution Filter Demo" windowWidth windowHeight++ (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 []+ + horizontalSamplingMesh <- compileMesh (samplingQuads dirH weights)+ verticalSamplingMesh <- compileMesh (samplingQuads dirV weights)+ addMesh renderer "horizontalFilter" horizontalSamplingMesh []+ addMesh renderer "verticalFilter" verticalSamplingMesh []+ + addMesh renderer "geometrySlot" quadMesh []++ startTime <- getCurrentTime+ flip fix (0, startTime) $ \loop (frameCount, lastTime) -> do+ input <- readInput+ case input of+ Nothing -> return ()+ Just dt -> do+ (w, h) <- getWindowDimensions+ setScreenSize renderer (fromIntegral w) (fromIntegral h)+ render renderer+ swapBuffers+ currentTime <- getCurrentTime+ let elapsedTime = realToFrac (diffUTCTime currentTime lastTime) :: Float+ next = case elapsedTime > 5.0 of + True -> (0, currentTime)+ False -> frameCount' `seq` (frameCount', lastTime)+ where+ frameCount' = frameCount+1+ when (fst next == 0) $+ printf "%d frames in %0.3f seconds (%0.2f ms/f)\n" (round frameCount :: Int) elapsedTime (1000 * elapsedTime / frameCount) + loop next++ dispose renderer+ putStrLn "Renderer destroyed."++ closeWindow++readInput :: IO (Maybe Float)+readInput = do+ t <- getTime+ resetTime++ k <- keyIsPressed KeyEsc+ return $ if k then Nothing else Just (realToFrac t)++-- the threshold and offsetWeight optimisations can be commented out independently+gaussianSamples :: Float -> Int -> [(Float, Float)]+gaussianSamples tolerance = normalise . threshold tolerance . offsetWeight . withOffsets . binomialCoefficients++binomialCoefficients :: Int -> [Float]+binomialCoefficients n = iterate next [1] !! (n-1)+ where+ next xs = [x+y | x <- xs ++ [0] | y <- 0:xs]++withOffsets :: [Float] -> [(Float, Float)]+withOffsets cs = [(o, c) | c <- cs | o <- [-lim..lim]]+ where+ lim = fromIntegral (length cs `quot` 2)++offsetWeight :: [(Float, Float)] -> [(Float, Float)]+offsetWeight [] = []+offsetWeight [ow] = [ow] +offsetWeight ((o1,w1):(o2,w2):ows) = (o1+w2/w', w') : offsetWeight ows+ where+ w' = w1+w2++threshold :: Float -> [(Float, Float)] -> [(Float, Float)]+threshold t ocs = [oc | oc@(_, c) <- ocs, c*t >= m]+ where+ m = maximum [c | (_, c) <- ocs]++normalise :: [(Float, Float)] -> [(Float, Float)]+normalise ocs = [(o, c/s) | (o, c) <- ocs]+ where+ s = sum [c | (_, c) <- ocs]++originalImage :: Exp Obj (FrameBuffer 1 V4F)+originalImage = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) clearBuf+ where+ accCtx = AccumulationContext Nothing (ColorOp NoBlending (one' :: V4B) :. ZT)+ clearBuf = FrameBuffer (ColorImage n1 (V4 0 0 0 1) :. ZT)+ prims = Transform vert (Fetch "geometrySlot" Triangles (IV2F "position"))+ + vert :: Exp V V2F -> VertexOut () ()+ vert pos = VertexOut pos' (floatV 1) ZT ZT+ where+ V2 x y = unpack' pos+ pos' = pack' (V4 x y (floatV 0) (floatV 1))+ + frag :: Exp F () -> FragmentOut (Color V4F :+: ZZ)+ frag _ = FragmentOut (col :. ZT)+ where+ V4 x y _ _ = unpack' fragCoord'+ x' = sqrt' x @* floatF 16+ y' = sqrt' y @* floatF 16+ r = Cond ((x' @+ y') @% (floatF 50) @< (floatF 25)) (floatF 0) (floatF 1)+ g = floatF 0+ b = Cond ((x' @- y') @% (floatF 50) @< (floatF 25)) (floatF 0) (floatF 1)+ col = pack' (V4 r g b (floatF 1))++convolve :: V2F -> [(Float, Float)] -> Exp Obj (Image 1 V4F) -> Exp Obj (FrameBuffer 1 V4F)+convolve (V2 dx dy) weights img = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) clearBuf+ where+ resX = windowWidth+ resY = windowHeight+ dir' :: Exp F V2F+ dir' = Const (V2 (dx / fromIntegral resX) (dy / fromIntegral resY))+ + accCtx = AccumulationContext Nothing (ColorOp NoBlending (one' :: V4B) :. ZT)+ clearBuf = FrameBuffer (ColorImage n1 (V4 0 0 0 1) :. ZT)+ prims = Transform vert (Fetch "postSlot" Triangles (IV2F "position"))++ vert :: Exp V V2F -> VertexOut () V2F+ vert uv = VertexOut pos (Const 1) ZT (NoPerspective uv' :. ZT)+ where+ uv' = uv @* floatV 0.5 @+ floatV 0.5+ pos = pack' (V4 u v (floatV 1) (floatV 1))+ V2 u v = unpack' uv++ frag :: Exp F V2F -> FragmentOut (Color V4F :+: ZZ)+ frag uv = FragmentOut (sample :. ZT)+ where+ sample = foldr1 (@+) [ texture' smp (uv @+ dir' @* floatF ofs) @* floatF coeff+ | (ofs, coeff) <- weights]+ smp = Sampler LinearFilter ClampToEdge tex+ tex = Texture (Texture2D (Float RGBA) n1) (V2 resX resY) NoMip [img]++additiveSample :: SB.ByteString -> Exp Obj (Image 1 V4F) -> Exp Obj (FrameBuffer 1 V4F)+additiveSample slot img = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) clearBuf+ where+ resX = windowWidth+ resY = windowHeight+ + accCtx = AccumulationContext Nothing (ColorOp blendEquation (one' :: V4B) :. ZT)+ blendEquation = Blend (FuncAdd, FuncAdd) ((SrcAlpha, One), (SrcAlpha, One)) (V4 1 1 1 1)+ clearBuf = FrameBuffer (ColorImage n1 (V4 0 0 0 1) :. ZT)+ prims = Transform vert (Fetch slot Triangles (IV2F "position", IV2F "uv", IFloat "alpha"))++ vert :: Exp V (V2F, V2F, Float) -> VertexOut () (V2F, Float)+ vert attr = VertexOut pos' (Const 1) ZT (NoPerspective uv :. Flat alpha :. ZT)+ where+ pos' = pack' (V4 x y (floatV 1) (floatV 1))+ V2 x y = unpack' pos+ (pos, uv, alpha) = untup3 attr++ frag :: Exp F (V2F, Float) -> FragmentOut (Color V4F :+: ZZ)+ frag attr = FragmentOut (pack' (V4 r g b alpha) :. ZT)+ where+ V4 r g b _ = unpack' (texture' smp uv)+ smp = Sampler LinearFilter ClampToEdge tex+ tex = Texture (Texture2D (Float RGBA) n1) (V2 resX resY) NoMip [img]+ (uv, alpha) = untup2 attr++samplingQuads :: V2F -> [(Float, Float)] -> Mesh+samplingQuads (V2 dx dy) weights = Mesh+ { mAttributes = T.fromList+ [ ("position", A_V2F $ V.fromList (concat (replicate (length weights) quadCoords)))+ , ("uv", A_V2F $ V.fromList (concatMap makeUVs weights))+ , ("alpha", A_Float $ V.fromList (concatMap makeAlphas weights))+ ]+ , mPrimitive = P_Triangles+ , mGPUData = Nothing+ }+ where+ infixr 0 ^+ (^) = V2+ quadCoords = [-1 ^ 1, -1 ^ -1, 1 ^ -1, 1 ^ -1, 1 ^ 1, -1 ^ 1]+ makeUVs (ofs, _) = [V2 (x*0.5+0.5+dx*ofs/resX) (y*0.5+0.5+dy*ofs/resY) | V2 x y <- quadCoords]+ makeAlphas (_,w) = map (const w) quadCoords+ resX = windowWidth+ resY = windowHeight
+ CubeMap.hs view
@@ -0,0 +1,271 @@+{-# OPTIONS -cpp #-}+{-# LANGUAGE OverloadedStrings, PackageImports, TypeOperators, DataKinds #-}++import Control.Applicative hiding (Const)+import Control.Monad+import qualified Data.ByteString.Char8 as SB+import qualified Data.Trie as T+import Data.Vect hiding (reflect')+import Data.Vect.Float.Instances ()+import FRP.Elerea.Param+import "GLFW-b" Graphics.UI.GLFW as GLFW+import Text.Printf++import LC_API+import LC_Mesh++import Common.Utils+import Common.GraphicsUtils++#ifdef CAPTURE+import Graphics.Rendering.OpenGL.Raw.Core32+import Codec.Image.DevIL+import Text.Printf+import Foreign++withFrameBuffer :: Int -> Int -> Int -> Int -> (Ptr Word8 -> IO ()) -> IO ()+withFrameBuffer x y w h fn = allocaBytes (w*h*4) $ \p -> do+ glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) gl_RGBA gl_UNSIGNED_BYTE $ castPtr p+ fn p+#endif++main :: IO ()+main = do+#ifdef CAPTURE+ ilInit+#endif+ + let pipeline :: Exp Obj (Image 1 V4F)+ pipeline = PrjFrameBuffer "outFB" tix0 sceneRender++ windowSize <- initWindow "LambdaCube 3D Cube Map Demo" 1280 720++ (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 1)+ + (duration, cubeObjects) <- measureDuration $ replicateM 6 $ addMesh renderer "geometrySlot" cubeMesh ["modelMatrix"]+ putStrLn $ "Cube meshes added - " ++ show duration+ + reflectorMesh <- compileMesh (capsule 2.5 3.5 25) -- (sphere 5 25)+ (duration, reflectorObject) <- measureDuration $ addMesh renderer "reflectSlot" reflectorMesh ["modelMatrix"]++ putStrLn $ "Reflector mesh added - " ++ show duration+ + let objectSlots = reflectorSlot : map objectUniformSetter cubeObjects+ reflectorSlot = objectUniformSetter reflectorObject+ sceneSlots = uniformSetter renderer++ draw command = do+ render renderer+ command+ 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 (reflectorSlot:planeSlot:cubeSlots) windowSize = do+ pause <- toggle =<< risingEdge =<< effectful (keyIsPressed (CharKey 'P'))+ time <- transfer 0 (\dt paused time -> time + if paused then 0 else dt) pause + + capture <- toggle =<< risingEdge =<< effectful (keyIsPressed (CharKey 'C'))+ frameCount <- stateful (0 :: Int) (const (+1))+ + 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)+ directionControl <- effectful $ (,,,,)+ <$> keyIsPressed KeyLeft+ <*> keyIsPressed KeyUp+ <*> keyIsPressed KeyDown+ <*> keyIsPressed KeyRight+ <*> keyIsPressed KeyRightShift+ + mousePosition' <- delay zero mousePosition+ camera <- userCamera (Vec3 (-4) 0 10) (mousePosition - mousePosition') directionControl+ + let setViewCameraMatrix = uniformM44F "viewCameraMatrix" sceneSlots . fromMat4+ setViewCameraPosition = uniformV3F "viewCameraPosition" sceneSlots . fromVec3+ setCubeCameraMatrix i = uniformM44F (cubeMatrixName i) sceneSlots . fromMat4+ setCubeCameraPosition = uniformV3F "cubeCameraPosition" sceneSlots . fromVec3+ setLightPosition = uniformV3F "lightPosition" sceneSlots . fromVec3+ setPlaneModelMatrix = uniformM44F "modelMatrix" planeSlot . fromMat4+ setCubeModelMatrices = [uniformM44F "modelMatrix" cubeSlot . fromMat4 | cubeSlot <- cubeSlots]+ setReflectorModelMatrix = uniformM44F "modelMatrix" reflectorSlot . fromMat4+ + setupRendering ((_, _, fps), frameCount, capture) (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 (15 * sin time) 2 10+ reflectorPosition = Vec3 (-8) (5 * sin (time * 0.25)) 0+ + cubeCameraProjection = perspective 0.1 50 (pi/2) 1+ cubeLookAt dir up = fromProjective (lookat reflectorPosition (reflectorPosition &+ dir) up)+ cubeCameraMatrix 1 = cubeLookAt (Vec3 1 0 0) (Vec3 0 (-1) 0)+ cubeCameraMatrix 2 = cubeLookAt (Vec3 (-1) 0 0) (Vec3 0 (-1) 0)+ cubeCameraMatrix 3 = cubeLookAt (Vec3 0 1 0) (Vec3 0 0 1)+ cubeCameraMatrix 4 = cubeLookAt (Vec3 0 (-1) 0) (Vec3 0 0 (-1))+ cubeCameraMatrix 5 = cubeLookAt (Vec3 0 0 1) (Vec3 0 (-1) 0)+ cubeCameraMatrix 6 = cubeLookAt (Vec3 0 0 (-1)) (Vec3 0 (-1) 0)+ + case fps of+ Just value -> putStrLn $ "FPS: " ++ show value+ Nothing -> return ()+ + setViewCameraMatrix (cameraView .*. cameraProjection)+ setViewCameraPosition cameraPosition+ setLightPosition lightPosition+ + setCubeCameraPosition reflectorPosition+ setReflectorModelMatrix (fromProjective (translation reflectorPosition))+ forM_ [1..6] $ \index -> setCubeCameraMatrix index (cubeCameraMatrix index .*. cubeCameraProjection)+ + 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)+ + return $ do+#ifdef CAPTURE+ when capture $ do+ glFinish+ withFrameBuffer 0 0 windowWidth windowHeight $ writeImageFromPtr (printf "frame%08d.jpg" frameCount) (windowHeight, windowWidth)+#endif+ return ()+ + effectful4 setupRendering ((,,) <$> fpsTracking <*> frameCount <*> capture) windowSize camera time++readInput :: IO (Maybe Float)+readInput = do+ t <- getTime+ resetTime++ k <- keyIsPressed KeyEsc+ return $ if k then Nothing else Just (realToFrac t)++sceneRender :: Exp Obj (FrameBuffer 1 (Float, V4F))+sceneRender = Accumulate accCtx PassAll reflectFrag (Rasterize rastCtx reflectPrims) directRender+ where+ directRender = Accumulate accCtx PassAll frag (Rasterize rastCtx directPrims) clearBuf+ cubeMapRender = Accumulate accCtx PassAll frag (Rasterize rastCtx cubePrims) clearBuf6+ + accCtx = AccumulationContext Nothing (DepthOp Less True :. ColorOp NoBlending (one' :: V4B) :. ZT)+ rastCtx = triangleCtx { ctxCullMode = CullFront CCW }+ clearBuf = FrameBuffer (DepthImage n1 1000 :. ColorImage n1 (V4 0.1 0.2 0.6 1) :. ZT)+ clearBuf6 = FrameBuffer (DepthImage n6 1000 :. ColorImage n6 (V4 0.05 0.1 0.3 1) :. ZT)+ worldInput = Fetch "geometrySlot" Triangles (IV3F "position", IV3F "normal")+ reflectInput = Fetch "reflectSlot" Triangles (IV3F "position", IV3F "normal")+ directPrims = Transform directVert worldInput+ cubePrims = Reassemble geom (Transform cubeMapVert worldInput)+ reflectPrims = Transform directVert reflectInput++ lightPosition = Uni (IV3F "lightPosition")+ viewCameraMatrix = Uni (IM44F "viewCameraMatrix")+ viewCameraPosition = Uni (IV3F "viewCameraPosition")+ cubeCameraMatrix i = Uni (IM44F (cubeMatrixName i))+ cubeCameraPosition = Uni (IV3F "cubeCameraPosition")+ modelMatrix = Uni (IM44F "modelMatrix")+ + transformGeometry :: Exp f V4F -> Exp f V3F -> Exp f M44F -> (Exp f V4F, Exp f V4F, Exp f V3F)+ transformGeometry localPos localNormal viewMatrix = (viewPos, worldPos, worldNormal)+ where+ worldPos = modelMatrix @*. localPos+ viewPos = viewMatrix @*. worldPos+ worldNormal = normalize' (v4v3 (modelMatrix @*. n3v4 localNormal))++ directVert :: Exp V (V3F, V3F) -> VertexOut () (V3F, V3F, V3F)+ directVert attr = VertexOut viewPos (floatV 1) ZT (Smooth (v4v3 worldPos) :. Smooth worldNormal :. Flat viewCameraPosition :. ZT)+ where+ (localPos, localNormal) = untup2 attr+ (viewPos, worldPos, worldNormal) = transformGeometry (v3v4 localPos) localNormal viewCameraMatrix++ cubeMapVert :: Exp V (V3F, V3F) -> VertexOut () V3F+ cubeMapVert attr = VertexOut (v3v4 localPos) (floatV 1) ZT (Smooth localNormal :. ZT)+ where+ (localPos, localNormal) = untup2 attr++ geom :: GeometryShader Triangle Triangle () () 6 V3F (V3F, V3F, V3F) + geom = GeometryShader n6 TrianglesOutput 18 init prim vert+ where+ init attr = tup2 (primInit, intG 6)+ where+ primInit = tup2 (intG 0, attr)+ prim primState = tup5 (layer, layer, primState', vertInit, intG 3) + where+ (layer, attr) = untup2 primState+ primState' = tup2 (layer @+ intG 1, attr)+ vertInit = tup3 (intG 0, viewMatrix, attr)+ viewMatrix = indexG (map cubeCameraMatrix [1..6]) layer+ vert vertState = GeometryOut vertState' viewPos pointSize ZT (Smooth (v4v3 worldPos) :. Smooth worldNormal :. Flat cubeCameraPosition :. ZT)+ where+ (index, viewMatrix, attr) = untup3 vertState+ vertState' = tup3 (index @+ intG 1, viewMatrix, attr)+ (attr0, attr1, attr2) = untup3 attr+ (localPos, pointSize, _, localNormal) = untup4 (indexG [attr0, attr1, attr2] index)+ (viewPos, worldPos, worldNormal) = transformGeometry localPos localNormal viewMatrix++ frag :: Exp F (V3F, V3F, V3F) -> FragmentOut (Depth Float :+: Color V4F :+: ZZ)+ frag attr = FragmentOutRastDepth (luminance :. ZT)+ where+ lambert = max' (floatF 0) (worldNormal @. normalize' (lightPosition @- worldPos))+ reflectedRay = normalize' (reflect' (worldPos @- (cameraPosition :: Exp F V3F)) worldNormal)+ directLight = normalize' (lightPosition @- worldPos)+ phong = max' (floatF 0) (reflectedRay @. directLight)+ colour = pack' (V3 (floatF 0.7) (floatF 0.05) (floatF 0))+ luminance = v3v4 (colour @* lambert @+ pow' phong (floatF 10))+ (worldPos, worldNormal, cameraPosition) = untup3 attr++ reflectFrag :: Exp F (V3F, V3F, V3F) -> FragmentOut (Depth Float :+: Color V4F :+: ZZ)+ reflectFrag attr = FragmentOutRastDepth (luminance :. ZT)+ where+ reflectedRay = reflect' (worldPos @- (cameraPosition :: Exp F V3F)) worldNormal+ luminance = reflectionSample reflectedRay+ (worldPos, worldNormal, cameraPosition) = untup3 attr+ reflectionSample dir = texture' (Sampler LinearFilter ClampToEdge reflectionMap) dir+ reflectionMap = Texture (TextureCube (Float RGBA)) (V2 256 256) NoMip [PrjFrameBuffer "" tix0 cubeMapRender]++indexG :: GPU a => [Exp G a] -> Exp G Int32 -> Exp G a+indexG xs index = go xs 0+ where+ go [x] _ = x+ go (x:xs) i = Cond (index @== intG i) x (go xs (i+1))++cubeMatrixName :: Int -> SB.ByteString+cubeMatrixName i = SB.pack (printf "cubeCameraMatrix%d" i)+
+ Hello.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE OverloadedStrings, PackageImports, TypeOperators, DataKinds #-}++import "GLFW-b" Graphics.UI.GLFW as GLFW+import Control.Monad+import Data.Vect+import qualified Data.Trie as T+import qualified Data.Vector.Storable as SV++import LC_API+import LC_Mesh++import Codec.Image.STB hiding (Image)++import Paths_lambdacube_samples (getDataFileName)++-- Our vertices. Tree consecutive floats give a 3D vertex; Three consecutive vertices give a triangle.+-- A cube has 6 faces with 2 triangles each, so this makes 6*2=12 triangles, and 12*3 vertices+g_vertex_buffer_data =+ [ ( 1.0, 1.0,-1.0)+ , ( 1.0,-1.0,-1.0)+ , (-1.0,-1.0,-1.0)+ , ( 1.0, 1.0,-1.0)+ , (-1.0,-1.0,-1.0)+ , (-1.0, 1.0,-1.0)+ , ( 1.0, 1.0,-1.0)+ , ( 1.0, 1.0, 1.0)+ , ( 1.0,-1.0, 1.0)+ , ( 1.0, 1.0,-1.0)+ , ( 1.0,-1.0, 1.0)+ , ( 1.0,-1.0,-1.0)+ , ( 1.0, 1.0, 1.0)+ , (-1.0,-1.0, 1.0)+ , ( 1.0,-1.0, 1.0)+ , ( 1.0, 1.0, 1.0)+ , (-1.0, 1.0, 1.0)+ , (-1.0,-1.0, 1.0)+ , (-1.0, 1.0, 1.0)+ , (-1.0,-1.0,-1.0)+ , (-1.0,-1.0, 1.0)+ , (-1.0, 1.0, 1.0)+ , (-1.0, 1.0,-1.0)+ , (-1.0,-1.0,-1.0)+ , ( 1.0, 1.0,-1.0)+ , (-1.0, 1.0,-1.0)+ , (-1.0, 1.0, 1.0)+ , ( 1.0, 1.0,-1.0)+ , (-1.0, 1.0, 1.0)+ , ( 1.0, 1.0, 1.0)+ , ( 1.0, 1.0,-1.0)+ , ( 1.0, 1.0, 1.0)+ , (-1.0, 1.0, 1.0)+ , ( 1.0, 1.0,-1.0)+ , (-1.0, 1.0, 1.0)+ , (-1.0, 1.0,-1.0)+ ]++-- Two UV coordinatesfor each vertex. They were created with Blender.+g_uv_buffer_data =+ [ (0.0, 0.0)+ , (0.0, 1.0)+ , (1.0, 1.0)+ , (0.0, 0.0)+ , (1.0, 1.0)+ , (1.0, 0.0)+ , (0.0, 0.0)+ , (1.0, 0.0)+ , (1.0, 1.0)+ , (0.0, 0.0)+ , (1.0, 1.0)+ , (0.0, 1.0)+ , (1.0, 0.0)+ , (0.0, 1.0)+ , (1.0, 1.0)+ , (1.0, 0.0)+ , (0.0, 0.0)+ , (0.0, 1.0)+ , (0.0, 0.0)+ , (1.0, 1.0)+ , (0.0, 1.0)+ , (0.0, 0.0)+ , (1.0, 0.0)+ , (1.0, 1.0)+ , (0.0, 0.0)+ , (1.0, 0.0)+ , (1.0, 1.0)+ , (0.0, 0.0)+ , (1.0, 1.0)+ , (0.0, 1.0)+ , (0.0, 0.0)+ , (0.0, 1.0)+ , (1.0, 1.0)+ , (0.0, 0.0)+ , (1.0, 1.0)+ , (1.0, 0.0)+ ]++cube :: Mesh+cube = Mesh+ { mAttributes = T.fromList+ [ ("vertexPosition_modelspace", A_V3F $ SV.fromList [V3 x y z | (x,y,z) <- g_vertex_buffer_data])+ , ("vertexUV", A_V2F $ SV.fromList [V2 u v | (u,v) <- g_uv_buffer_data])+ ]+ , mPrimitive = P_Triangles+ , mGPUData = Nothing+ }++texturing :: Exp Obj (VertexStream Triangle (V3F,V2F)) -> Exp Obj (FrameBuffer 1 (Float,V4F))+texturing objs = Accumulate fragmentCtx PassAll fragmentShader fragmentStream emptyFB+ where+ rasterCtx :: RasterContext Triangle+ rasterCtx = TriangleCtx (CullFront CW) PolygonFill NoOffset LastVertex++ fragmentCtx :: AccumulationContext (Depth Float :+: (Color (V4 Float) :+: ZZ))+ fragmentCtx = AccumulationContext Nothing $ DepthOp Less True:.ColorOp NoBlending (one' :: V4B):.ZT++ emptyFB :: Exp Obj (FrameBuffer 1 (Float,V4F))+ emptyFB = FrameBuffer (DepthImage n1 1000:.ColorImage n1 (V4 0 0 0.4 1):.ZT)++ fragmentStream :: Exp Obj (FragmentStream 1 V2F)+ fragmentStream = Rasterize rasterCtx primitiveStream++ primitiveStream :: Exp Obj (PrimitiveStream Triangle () 1 V V2F)+ primitiveStream = Transform vertexShader objs++ modelViewProj :: Exp V M44F+ modelViewProj = Uni (IM44F "MVP")++ vertexShader :: Exp V (V3F,V2F) -> VertexOut () V2F+ vertexShader puv = VertexOut v4 (Const 1) ZT (Smooth uv:.ZT)+ where+ v4 :: Exp V V4F+ v4 = modelViewProj @*. v3v4 p+ (p,uv) = untup2 puv++ fragmentShader :: Exp F V2F -> FragmentOut (Depth Float :+: Color V4F :+: ZZ)+ fragmentShader uv = FragmentOutRastDepth $ color tex uv :. ZT+ where+ tex = TextureSlot "myTextureSampler" $ Texture2D (Float RGBA) n1++v3v4 :: Exp s V3F -> Exp s V4F+v3v4 v = let V3 x y z = unpack' v in pack' $ V4 x y z (Const 1)++color t uv = texture' (smp t) uv+smp t = Sampler LinearFilter ClampToEdge t++main :: IO ()+main = do+ initialize+ openWindow defaultDisplayOptions+ { displayOptions_width = 1024+ , displayOptions_height = 768+ , displayOptions_openGLVersion = (3,2)+ , displayOptions_openGLProfile = CoreProfile+ }+ setWindowTitle "LambdaCube 3D Textured Cube"++ let frameImage :: Exp Obj (Image 1 V4F)+ frameImage = PrjFrameBuffer "" tix0 $ texturing $ Fetch "stream" Triangles (IV3F "vertexPosition_modelspace", IV2F "vertexUV")++ renderer <- compileRenderer $ ScreenOut frameImage++ let uniformMap = uniformSetter renderer+ texture = uniformFTexture2D "myTextureSampler" uniformMap+ mvp = uniformM44F "MVP" uniformMap+ setWindowSize = setScreenSize renderer++ setWindowSize 1024 768+ Right img <- loadImage =<< getDataFileName "hello.png"+ texture =<< compileTexture2DRGBAF True False img++ gpuCube <- compileMesh cube+ addMesh renderer "stream" gpuCube []++ let cm = fromProjective (lookat (Vec3 4 3 3) (Vec3 0 0 0) (Vec3 0 1 0))+ pm = perspective 0.1 100 (pi/4) (1024 / 768)+ loop = do+ t <- getTime+ let angle = pi / 2 * realToFrac t+ mm = fromProjective $ rotationEuler $ Vec3 angle 0 0+ mvp $! mat4ToM44F $! mm .*. cm .*. pm+ render renderer+ swapBuffers++ k <- keyIsPressed KeyEsc+ unless k $ loop+ loop++ dispose renderer+ closeWindow++vec4ToV4F :: Vec4 -> V4F+vec4ToV4F (Vec4 x y z w) = V4 x y z w++mat4ToM44F :: Mat4 -> M44F+mat4ToM44F (Mat4 a b c d) = V4 (vec4ToV4F a) (vec4ToV4F b) (vec4ToV4F c) (vec4ToV4F d)++-- | 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
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Csaba Hruska++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Csaba Hruska nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ShadowMapping.hs view
@@ -0,0 +1,379 @@+{-# OPTIONS -cpp #-}+{-# LANGUAGE OverloadedStrings, PackageImports, TypeOperators, DataKinds #-}++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 Common.Utils+import Common.GraphicsUtils++#ifdef CAPTURE+import Graphics.Rendering.OpenGL.Raw.Core32+import Codec.Image.DevIL+import Text.Printf+import Foreign++withFrameBuffer :: Int -> Int -> Int -> Int -> (Ptr Word8 -> IO ()) -> IO ()+withFrameBuffer x y w h fn = allocaBytes (w*h*4) $ \p -> do+ glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) gl_RGBA gl_UNSIGNED_BYTE $ castPtr p+ fn p+#endif++main :: IO ()+main = do+#ifdef CAPTURE+ ilInit+#endif+ + let pipeline :: Exp Obj (Image 1 V4F)+ pipeline = PrjFrameBuffer "outFB" tix0 vsm++ windowSize <- initWindow "LambdaCube 3D Shadow Mapping Demo" 1280 720++ (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 1)+ + (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 command = do+ render renderer+ command+ 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+ pause <- toggle =<< risingEdge =<< effectful (keyIsPressed (CharKey 'P'))+ time <- transfer 0 (\dt paused time -> time + if paused then 0 else dt) pause + + capture <- risingEdge =<< effectful (keyIsPressed (CharKey 'C'))+ frameCount <- stateful (0 :: Int) (const (+1))+ + 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)+ directionControl <- effectful $ (,,,,)+ <$> keyIsPressed KeyLeft+ <*> keyIsPressed KeyUp+ <*> keyIsPressed KeyDown+ <*> keyIsPressed KeyRight+ <*> keyIsPressed KeyRightShift+ + mousePosition' <- delay zero mousePosition+ camera <- userCamera (Vec3 (-4) 0 0) (mousePosition - mousePosition') directionControl+ + 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), frameCount, capture) (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)+ + return $ do+#ifdef CAPTURE+ when capture $ do+ glFinish+ withFrameBuffer 0 0 windowWidth windowHeight $ writeImageFromPtr (printf "frame%08d.jpg" frameCount) (windowHeight, windowWidth)+#endif+ return ()+ + + effectful4 setupRendering ((,,) <$> fpsTracking <*> frameCount <*> capture) windowSize camera time++readInput :: IO (Maybe Float)+readInput = do+ t <- getTime+ resetTime++ k <- keyIsPressed KeyEsc+ return $ if k then Nothing else Just (realToFrac t)++shadowMapSize :: Num a => a+shadowMapSize = 512++blurCoefficients :: [(Float, Float)]+blurCoefficients = gaussFilter9++gaussFilter7 :: [(Float, Float)]+gaussFilter7 = + [ (-3.0, 0.015625)+ , (-2.0, 0.09375)+ , (-1.0, 0.234375)+ , (0.0, 0.3125)+ , (1.0, 0.234375)+ , (2.0, 0.09375)+ , (3.0, 0.015625)+ ]++gaussFilter9 :: [(Float, Float)]+gaussFilter9 = + [ (-4.0, 0.05)+ , (-3.0, 0.09)+ , (-2.0, 0.12)+ , (-1.0, 0.15)+ , (0.0, 0.16)+ , (1.0, 0.15)+ , (2.0, 0.12)+ , (3.0, 0.09)+ , (4.0, 0.05)+ ]++blur :: [(Float, Float)] -> Exp Obj (Image 1 V2F) -> Exp Obj (FrameBuffer 1 V2F)+blur coefficients img = filter1D dirH (PrjFrameBuffer "" tix0 (filter1D dirV img))+ where+ dirH v = Const (V2 (v / shadowMapSize) 0) :: Exp F V2F+ dirV v = Const (V2 0 (v / shadowMapSize)) :: Exp F V2F+ + filter1D :: (Float -> Exp F V2F) -> Exp Obj (Image 1 V2F) -> Exp Obj (FrameBuffer 1 V2F)+ filter1D dir img = Accumulate accCtx PassAll frag+ (Rasterize triangleCtx prims) clearBuf+ where+ accCtx = AccumulationContext Nothing+ (ColorOp NoBlending (one' :: V2B) :. ZT)+ clearBuf = FrameBuffer (ColorImage n1 (V2 0 0) :. ZT)+ prims = Transform vert (Fetch "postSlot" Triangles (IV2F "position"))++ vert :: Exp V V2F -> VertexOut () V2F+ vert uv = VertexOut pos (Const 1) ZT (NoPerspective uv' :. ZT)+ where+ uv' = uv @* floatV 0.5 @+ floatV 0.5+ pos = pack' (V4 u v (floatV 1) (floatV 1))+ V2 u v = unpack' uv++ frag :: Exp F V2F -> FragmentOut (Color V2F :+: ZZ)+ frag uv = FragmentOut (sample :. ZT)+ where+ sample = foldr1 (@+) [ texture' smp (uv @+ dir ofs) @* floatF coeff+ | (ofs, coeff) <- coefficients]+ smp = Sampler LinearFilter ClampToEdge tex+ tex = Texture (Texture2D (Float RG) n1)+ (V2 shadowMapSize shadowMapSize) NoMip [img]+ ++moments :: Exp Obj (FrameBuffer 1 (Float, V2F))+moments = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) clearBuf+ where+ accCtx = AccumulationContext Nothing (DepthOp Less True :. ColorOp NoBlending (one' :: V2B) :. ZT)+ clearBuf = FrameBuffer (DepthImage n1 1000 :. ColorImage n1 (V2 0 0) :. ZT)+ prims = Transform vert (Fetch "geometrySlot" Triangles (IV3F "position"))+ + lightMatrix = Uni (IM44F "lightMatrix")+ modelMatrix = Uni (IM44F "modelMatrix")++ vert :: Exp V V3F -> VertexOut () Float+ vert pos = VertexOut lightPos (floatV 1) ZT (Smooth depth :. ZT)+ where+ lightPos = lightMatrix @*. modelMatrix @*. v3v4 pos+ V4 _ _ depth _ = unpack' lightPos++ frag :: Exp F Float -> FragmentOut (Depth Float :+: Color V2F :+: ZZ)+ frag depth = FragmentOutRastDepth (pack' (V2 moment1 moment2) :. ZT)+ where+ dx = dFdx' depth+ dy = dFdy' depth+ moment1 = depth+ moment2 = depth @* depth @+ floatF 0.25 @* (dx @* dx @+ dy @* dy)++depth :: Exp Obj (FrameBuffer 1 (Float, Float))+depth = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) clearBuf+ where+ accCtx = AccumulationContext Nothing (DepthOp Less True :. ColorOp NoBlending True :. ZT)+ clearBuf = FrameBuffer (DepthImage n1 1000 :. ColorImage n1 0 :. ZT)+ prims = Transform vert (Fetch "geometrySlot" Triangles (IV3F "position"))+ + lightMatrix = Uni (IM44F "lightMatrix")+ modelMatrix = Uni (IM44F "modelMatrix")++ vert :: Exp V V3F -> VertexOut () Float+ vert pos = VertexOut lightPos (floatV 1) ZT (Smooth depth :. ZT)+ where+ lightPos = lightMatrix @*. modelMatrix @*. v3v4 pos+ V4 _ _ depth _ = unpack' lightPos++ frag :: Exp F Float -> FragmentOut (Depth Float :+: Color Float :+: ZZ)+ frag depth = FragmentOutRastDepth (depth :. ZT)++vsm :: Exp Obj (FrameBuffer 1 (Float, V4F))+vsm = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) clearBuf+ where+ accCtx = AccumulationContext Nothing+ (DepthOp Less True :. ColorOp NoBlending (one' :: V4B) :. ZT)+ clearBuf = FrameBuffer ( DepthImage n1 1000+ :. ColorImage n1 (V4 0.1 0.2 0.6 1) :. ZT)+ prims = Transform vert (Fetch "geometrySlot" Triangles (IV3F "position", IV3F "normal"))++ cameraMatrix = Uni (IM44F "cameraMatrix")+ lightMatrix = Uni (IM44F "lightMatrix")+ modelMatrix = Uni (IM44F "modelMatrix")+ lightPosition = Uni (IV3F "lightPosition")++ vert :: Exp V (V3F, V3F) -> VertexOut () (V3F, V4F, V3F)+ vert attr = VertexOut viewPos (floatV 1) ZT (Smooth (v4v3 worldPos) :. Smooth lightPos :. Smooth worldNormal :. ZT)+ where+ worldPos = modelMatrix @*. v3v4 localPos+ viewPos = cameraMatrix @*. worldPos+ lightPos = lightMatrix @*. worldPos+ worldNormal = normalize' (v4v3 (modelMatrix @*. n3v4 localNormal))+ (localPos, localNormal) = untup2 attr++ frag :: Exp F (V3F, V4F, V3F) -> FragmentOut (Depth Float :+: Color V4F :+: ZZ)+ frag attr = FragmentOutRastDepth (luminance :. ZT)+ where+ V4 lightU lightV lightDepth lightW = unpack' lightPos+ uv = clampUV (scaleUV (pack' (V2 lightU lightV) @/ lightW))+ + V2 moment1 moment2 = unpack' (texture' sampler uv)+ variance = max' (floatF 0.002) (moment2 @- moment1 @* moment1)+ distance = max' (floatF 0) (lightDepth @- moment1)+ lightProbMax = variance @/ (variance @+ distance @* distance)+ + lambert = max' (floatF 0) (dot' worldNormal (normalize' (lightPosition @- worldPos)))+ + uv' = uv @- floatF 0.5+ spotShape = floatF 1 @- length' uv' @* floatF 4+ intensity = max' (floatF 0) (spotShape @* lambert)+ + V2 spotR spotG = unpack' (scaleUV (round' (uv' @* floatF 10)) @* intensity)+ + luminance = pack' (V4 spotR spotG intensity (floatF 1)) @* pow' lightProbMax (floatF 2)+ + clampUV x = clamp' x (floatF 0) (floatF 1)+ scaleUV x = x @* floatF 0.5 @+ floatF 0.5+ + (worldPos, lightPos, worldNormal) = untup3 attr++ sampler = Sampler LinearFilter ClampToEdge shadowMapBlur+ + shadowMap :: Texture (Exp Obj) Tex2D SingleTex (Regular Float) RG+ shadowMap = Texture (Texture2D (Float RG) n1) (V2 shadowMapSize shadowMapSize) NoMip [PrjFrameBuffer "shadowMap" tix0 moments]++ shadowMapBlur :: Texture (Exp Obj) Tex2D SingleTex (Regular Float) RG+ shadowMapBlur = Texture (Texture2D (Float RG) n1) (V2 shadowMapSize shadowMapSize) NoMip [PrjFrameBuffer "shadowMap" tix0 blurredMoments]+ where+ blurredMoments = blur blurCoefficients (PrjFrameBuffer "blur" tix0 moments)++sm :: Exp Obj (FrameBuffer 1 (Float, V4F))+sm = Accumulate accCtx PassAll frag (Rasterize triangleCtx prims) clearBuf+ where+ accCtx = AccumulationContext Nothing (DepthOp Less True :. ColorOp NoBlending (one' :: V4B) :. ZT)+ clearBuf = FrameBuffer (DepthImage n1 1000 :. ColorImage n1 (V4 0.1 0.2 0.6 1) :. ZT)+ prims = Transform vert (Fetch "geometrySlot" Triangles (IV3F "position", IV3F "normal"))++ cameraMatrix = Uni (IM44F "cameraMatrix")+ lightMatrix = Uni (IM44F "lightMatrix")+ modelMatrix = Uni (IM44F "modelMatrix")+ lightPosition = Uni (IV3F "lightPosition")++ vert :: Exp V (V3F, V3F) -> VertexOut () (V3F, V4F, V3F)+ vert attr = VertexOut viewPos (floatV 1) ZT (Smooth (v4v3 worldPos) :. Smooth lightPos :. Smooth worldNormal :. ZT)+ where+ worldPos = modelMatrix @*. v3v4 localPos+ viewPos = cameraMatrix @*. worldPos+ lightPos = lightMatrix @*. worldPos+ worldNormal = normalize' (v4v3 (modelMatrix @*. n3v4 localNormal))+ (localPos, localNormal) = untup2 attr++ frag :: Exp F (V3F, V4F, V3F) -> FragmentOut (Depth Float :+: Color V4F :+: ZZ)+ frag attr = FragmentOutRastDepth (luminance :. ZT)+ where+ V4 lightU lightV lightDepth lightW = unpack' lightPos+ uv = clampUV (scaleUV (pack' (V2 lightU lightV) @/ lightW))+ + surfaceDistance = texture' sampler uv+ lightPortion = Cond (lightDepth @<= surfaceDistance @+ floatF 0.01) (floatF 1) (floatF 0)+ + lambert = max' (floatF 0) (dot' worldNormal (normalize' (lightPosition @- worldPos)))+ + --intensity = lambert @* lightPortion+ --luminance = pack' (V4 intensity intensity intensity (floatF 1))+ + uv' = uv @- floatF 0.5+ spotShape = floatF 1 @- length' uv' @* floatF 4+ intensity = max' (floatF 0) (spotShape @* lambert)+ + V2 spotR spotG = unpack' (scaleUV (round' (uv' @* floatF 10)) @* intensity)+ + luminance = pack' (V4 spotR spotG intensity (floatF 1)) @* lightPortion+ + clampUV x = clamp' x (floatF 0) (floatF 1)+ scaleUV x = x @* floatF 0.5 @+ floatF 0.5+ + (worldPos, lightPos, worldNormal) = untup3 attr++ sampler = Sampler PointFilter ClampToEdge shadowMap+ + shadowMap :: Texture (Exp Obj) Tex2D SingleTex (Regular Float) Red+ shadowMap = Texture (Texture2D (Float Red) n1) (V2 shadowMapSize shadowMapSize) NoMip [PrjFrameBuffer "shadowMap" tix0 depth]
+ hello.png view
binary file changed (absent → 684345 bytes)
+ lambdacube-samples.cabal view
@@ -0,0 +1,81 @@+name: lambdacube-samples+version: 0.1.0+synopsis: Samples for LambdaCube 3D+description:+ Executable samples to showcase the capabilities of LambdaCube+ 3D. Each sample is a separate executable called+ @lambdacube-\<samplename\>@. The following samples are included+ (each is described in a separate blog post):+ .+ * 'hello': the cannonical rotating cube+ .+ * 'convolutionfilter': a simple Gaussian blur (<http://lambdacube3d.wordpress.com/2013/04/11/optimising-convolution-filters/>)+ .+ * 'shadowmapping': variance shadow mapping (<http://lambdacube3d.wordpress.com/2012/10/14/variance-shadow-mapping/>)+ .+ * 'cubemap': cube mapped reflection using geometry shaders (<http://lambdacube3d.wordpress.com/2012/10/14/variance-shadow-mapping/>)+ .+ * 'bulletexample': integration with Bullet physics through Elerea;+ this sample is optional due to its dependence on Bullet, and you+ need to install the package with -fBulletInstalled to enable it.+ (first post: <http://lambdacube3d.wordpress.com/2012/12/20/using-bullet-physics-with-an-frp-approach-part-1/>,+ second post: <http://lambdacube3d.wordpress.com/2012/12/20/using-bullet-physics-with-an-frp-approach-part-2/>,+ third post: <http://lambdacube3d.wordpress.com/2012/12/20/using-bullet-physics-with-an-frp-approach-part-3/>)+ +homepage: http://lambdacube3d.wordpress.com/+license: BSD3+license-file: LICENSE+author: Csaba Hruska, Gergely Patai+maintainer: csaba.hruska@gmail.com, patai.gergely@gmail.com+-- copyright:+category: Graphics+build-type: Simple+cabal-version: >=1.10++extra-source-files:+ Common/Utils.hs+ Common/GraphicsUtils.hs++data-files: hello.png++flag BulletInstalled+ description: Enable samples that depend on Bullet+ default: False++executable lambdacube-hello+ main-is: Hello.hs+ -- other-modules:+ other-extensions: OverloadedStrings, TypeOperators, NoMonomorphismRestriction, ExistentialQuantification, PackageImports, DoRec, ParallelListComp, DataKinds, NamedFieldPuns+ build-depends: base >=4.6 && <4.7, mtl >=2.1 && <2.2, bytestring >=0.10 && <0.11, bytestring-trie >=0.2 && <0.3, vect >=0.4 && <0.5, vector >=0.10 && <0.11, elerea >=2.7 && <2.8, lambdacube-core >=0.1 && <0.2, time >=1.4 && <1.5, OpenGLRaw >=1.4 && <1.5, GLFW-b ==0.1.0.5, stb-image ==0.2.1+ default-language: Haskell2010++executable lambdacube-shadowmapping+ main-is: ShadowMapping.hs+ -- other-modules:+ other-extensions: OverloadedStrings, TypeOperators, NoMonomorphismRestriction, ExistentialQuantification, PackageImports, DoRec, ParallelListComp, DataKinds, NamedFieldPuns+ build-depends: base >=4.6 && <4.7, mtl >=2.1 && <2.2, bytestring >=0.10 && <0.11, bytestring-trie >=0.2 && <0.3, vect >=0.4 && <0.5, vector >=0.10 && <0.11, elerea >=2.7 && <2.8, lambdacube-core >=0.1 && <0.2, time >=1.4 && <1.5, OpenGLRaw >=1.4 && <1.5, GLFW-b ==0.1.0.5+ default-language: Haskell2010++executable lambdacube-cubemap+ main-is: CubeMap.hs+ -- other-modules:+ other-extensions: OverloadedStrings, TypeOperators, NoMonomorphismRestriction, ExistentialQuantification, PackageImports, DoRec, ParallelListComp, DataKinds, NamedFieldPuns+ build-depends: base >=4.6 && <4.7, mtl >=2.1 && <2.2, bytestring >=0.10 && <0.11, bytestring-trie >=0.2 && <0.3, vect >=0.4 && <0.5, vector >=0.10 && <0.11, elerea >=2.7 && <2.8, lambdacube-core >=0.1 && <0.2, time >=1.4 && <1.5, OpenGLRaw >=1.4 && <1.5, GLFW-b ==0.1.0.5+ default-language: Haskell2010++executable lambdacube-convolutionfilter+ main-is: ConvolutionFilter.hs+ -- other-modules:+ other-extensions: OverloadedStrings, TypeOperators, NoMonomorphismRestriction, ExistentialQuantification, PackageImports, DoRec, ParallelListComp, DataKinds, NamedFieldPuns+ build-depends: base >=4.6 && <4.7, mtl >=2.1 && <2.2, bytestring >=0.10 && <0.11, bytestring-trie >=0.2 && <0.3, vect >=0.4 && <0.5, vector >=0.10 && <0.11, elerea >=2.7 && <2.8, lambdacube-core >=0.1 && <0.2, time >=1.4 && <1.5, OpenGLRaw >=1.4 && <1.5, GLFW-b ==0.1.0.5+ default-language: Haskell2010++executable lambdacube-bulletexample+ main-is: BulletExample.hs+ -- other-modules:+ other-extensions: OverloadedStrings, TypeOperators, NoMonomorphismRestriction, ExistentialQuantification, PackageImports, DoRec, ParallelListComp, DataKinds, NamedFieldPuns+ if flag(BulletInstalled)+ build-depends: base >=4.6 && <4.7, mtl >=2.1 && <2.2, bytestring >=0.10 && <0.11, bytestring-trie >=0.2 && <0.3, vect >=0.4 && <0.5, vector >=0.10 && <0.11, elerea >=2.7 && <2.8, bullet >=0.2 && <0.3, lambdacube-core >=0.1 && <0.2, time >=1.4 && <1.5, OpenGLRaw >=1.4 && <1.5, GLFW-b ==0.1.0.5+ else+ buildable: False+ default-language: Haskell2010