lambdacube-examples-0.2.2: src/lambdacube-cameratrack.hs

import Control.Applicative
import Control.Monad.Trans
import qualified Data.List as List

import FRP.Elerea.Param
import Graphics.UI.GLFW as GLFW

import Graphics.LambdaCube
import Graphics.LambdaCube.RenderSystem.GL
import qualified Graphics.LambdaCube.Loader.StbImage as Stb

import Paths_lambdacube_examples (getDataFileName)

import Utils

main :: IO ()
main = do
    windowSize <- initCommon "LambdaCube Engine Camera Track Example"

    mediaPath <- getDataFileName "media"
    renderSystem <- mkGLRenderSystem
    runLCM renderSystem [Stb.loadImage] $ do
        let simpleLight = Light
                { lgType                = LT_POINT
                , lgDiffuse             = (1,1,1,1)
                , lgDirection           = Vec3 0 0 1
                , lgSpecular            = (0,0,0,0)
                , lgSpotOuter           = pi / 180 * 40
                , lgSpotFalloff         = 1
                , lgRange               = 100000
                , lgAttenuationConst    = 1
                , lgAttenuationLinear   = 0
                , lgAttenuationQuad     = 0
                }

        -- inLCM $ addConfig "resources.cfg"
        addResourceLibrary [("General",[(PathDir,mediaPath)])]
        let mrq = mesh defaultRQP
            m = mrq Nothing
        addScene $
            [ node "Root" "OgreHead" idmtx [m "ogrehead.vmesh"]
            , node "Root" "Light1" idmtx [light simpleLight { lgDiffuse = (1,0,0,1) }]
            , node "Root" "Light2" idmtx [defaultLight]
            , node "Root" "Light3" idmtx [light simpleLight { lgDiffuse = (0,0,1,1) }]
            , node "Light1" "Cube1" (scalingUniformProj4 0.2) [mrq (Just (repeat "Examples/TransparentTest")) "knot.mesh.xml"]
            , node "Light2" "Cube2" (scalingUniformProj4 0.2) [mrq (Just (repeat "Examples/TransparentTest")) "knot.mesh.xml"]
            , node "Light3" "Cube3" (scalingUniformProj4 0.2) [mrq (Just (repeat "Examples/TransparentTest")) "knot.mesh.xml"]
            , node "Root" "CameraNode1" idmtx [simpleCamera "Camera1"]
            , node "Root" "GroundNode1" (scalingUniformProj4 7000 .*. translation (Vec3 0 (-70) 0) ) [mrq (Just ["MyAnimMaterial"]) "Ground.mesh.xml"]
            , node "Root" "SkyBoxNode1" (scalingUniformProj4 1000) [mesh (Just RQP_EarlySky) Nothing "Box.mesh.xml"]
            ]
        addRenderWindow "MainWindow" 640 480 [viewport 0 0 1 1 "Camera1" []]

        s <- liftIO fpsState
        sc <- liftIO $ start $ scene windowSize
        driveNetwork sc (readInput s)

    closeWindow

scene :: RenderSystem r vb ib q t p lp => Signal (Int, Int) -> SignalGen FloatType (Signal (LCM (World r vb ib q t p lp) e ()))
scene windowSize = do
    time <- stateful 0 (+)
    let animCm = curve track <$> time
        animL1 = curve trackLight1 <$> time
        animL2 = curve trackLight2 <$> time
        animL3 = curve trackLight3 <$> time
    return $ drawGLScene <$> windowSize <*> animCm <*> animL1 <*> animL2 <*> animL3 <*> time
  where
    curve kfl t = (fx + t' * dx, fy + t' * dy, fz + t' * dz)
      where
        t''             = len * (snd $ (properFraction :: FloatType -> (Int,FloatType)) $ realToFrac t / len)
        t'              = t'' - ft
        (al,bl)         = List.span (\(a,_)-> a <= t'') kfl
        (ft,(fx,fy,fz)) = last al
        (gt,(gx,gy,gz)) = head bl
        dt              = gt - ft
        dx              = (gx-fx) / dt
        dy              = (gy-fy) / dt
        dz              = (gz-fz) / dt
        len             = fst $ last kfl

    track =
        [ (0,   (-100 , 100 , 100))
        , (2.5, (-300 ,-10  ,-200))
        , (5,   ( 500 , 700 ,-500))
        , (7.5, ( 200 ,-10  , 400))
        , (10,  (-100 , 100 , 100))
        ]
    trackLight1 =
        [ (0,     ( 200 , 200 , 100))
        , (2*2.5, ( 100 ,-10  ,-200))
        , (2*5,   (-500 , 700 ,-500))
        , (2*7.5, (-200 ,-10  , 400))
        , (2*10,  ( 200 , 200 , 100))
        ]
    trackLight2 =
        [ (3*0,   (-100 , 100 , 100))
        , (3*2.5, (-300 ,-10  ,-200))
        , (3*5,   ( 500 , 700 ,-500))
        , (3*7.5, ( 200 ,-10  , 400))
        , (3*10,  (-100 , 100 , 100))
        ]
    trackLight3 =
        [ (0.3*0,   (-100 , 10 , 100))
        , (0.3*2.5, (-300 ,-10  ,-200))
        , (0.3*5,   ( 500 , 70 ,-500))
        , (0.3*7.5, ( 200 ,-10  , 400))
        , (0.3*10,  (-100 , 10 , 100))
        ]

drawGLScene :: RenderSystem r vb ib q t p lp
            => (Int, Int)
            -> (Float, Float, Float)
            -> (Float, Float, Float)
            -> (Float, Float, Float)
            -> (Float, Float, Float)
            -> FloatType
            -> LCM (World r vb ib q t p lp) e ()
drawGLScene (w,h) (x,y,z) l1 l2 l3 time = do
    let t (x,y,z) = translation (Vec3 x y z)
    updateTransforms
        [ ("CameraNode1", inverse $ lookat (Vec3 x y z) (Vec3 0 0 0) (Vec3 0 1 0))
        , ("Light1", t l1), ("Light2", t l2), ("Light3", t l3)
        , ("SkyBoxNode1", scalingUniformProj4 1000 .*. translation (Vec3 x y z))
        ]
    updateTargetSize "MainWindow" w h
    renderWorld (realToFrac time) "MainWindow"
    liftIO $ swapBuffers

readInput :: State -> IO (Maybe FloatType)
readInput s = do
    t <- getTime
    updateFPS s t
    setTime 0
    k <- keyIsPressed KeyEsc
    return (if k then Nothing else Just (realToFrac t))