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

import Control.Applicative
import Control.Monad.Trans
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

width :: Float
width = 150

height :: Float
height = 150

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

    (mousePosition,mousePositionSink) <- external (0,0)
    (_mousePress,mousePressSink) <- external False
    (fblrPress,fblrPressSink) <- external (False,False,False,False,False)

    mediaPath <- getDataFileName "media"
    renderSystem <- mkGLRenderSystem
    runLCM renderSystem [Stb.loadImage] $ do
        -- inLCM $ addConfig "resources.cfg"
        addResourceLibrary [("General",[(PathDir,mediaPath)])]
        let mrq = mesh defaultRQP
            m   = mrq Nothing
            materials   = ["Examples/TransparentTest","Examples/Toon","2 - Default","Examples/EnvMappedRustySteel"]
            materialLen = length materials
            mat i =  materials !! (i `mod` materialLen)
        addScene $
            [ node "Root" "Robot" idmtx [m "robot.mesh.xml"]
            , node "Root" "OgreHead" (scalingUniformProj4 0.05) [m "ogrehead.vmesh",m "Quad.mesh.xml"]
            , node "Root" "Light1" (translation (Vec3 5 5 10)) [defaultLight,m "ogrehead.mesh.xml"]
            , node "Root" "CameraNode1" (translation (Vec3 0 0 10)) [simpleCamera "Camera1"]
            , node "Root" "CameraEye" idmtx [mesh (Just RQP_EarlySky) Nothing "Box.mesh.xml" ]
            , node "Root" "CameraNode2" idmtx [simpleCamera "Camera2"]
            ] ++
            [node "Root" ("Knot" ++ show i) idmtx [mrq (Just (repeat $ mat i)) "knot.mesh.xml"] | i <- [1..200]]
        addRenderTexture "RenderTex01" 640 480
        addRenderWindow "MainWindow" 640 480
            [viewport 0 0 1 0.5 "Camera1" ["Glass" {- "Tiling" -}], viewport 0 0.5 1 0.5 "Camera2" []]

        s <- liftIO fpsState
        sc <- liftIO $ start $ scene windowSize mousePosition fblrPress
        driveNetwork sc (readInput s mousePositionSink mousePressSink fblrPressSink)

    closeWindow

scene :: RenderSystem r vb ib q t p lp
      => Signal (Int, Int)
      -> Signal (FloatType, FloatType)
      -> Signal (Bool, Bool, Bool, Bool, Bool)
      -> SignalGen FloatType (Signal (LCM (World r vb ib q t p lp) e ()))
scene windowSize mousePosition fblrPress = do
    re1 <- integral 0 1.5
    re2 <- integral 10 (-1.0)
    re3 <- integral 110 0.8
    time <- stateful 0 (+)
    last2 <- transfer ((0,0),(0,0)) (\_ n (_,b) -> (b,n)) mousePosition
    let mouseMove = (\((ox,oy),(nx,ny)) -> (nx-ox,ny-oy)) <$> last2
    --let mouseMove = mousePosition
    cam <- cameraSignal (Vec3 (-4) 0 0) mouseMove fblrPress
    return $ drawGLScene <$> windowSize <*> re1 <*> re2 <*> re3 <*> cam <*> time

drawGLScene :: RenderSystem r vb ib q t2 p lp
            => (Int, Int)
            -> FloatType
            -> FloatType
            -> FloatType
            -> (Vec3, Vec3, Vec3, t1)
            -> FloatType
            -> LCM (World r vb ib q t2 p lp) e ()
drawGLScene (w,h) _re1 re2 re3 (cam,dir,up,_) time = do
    updateTransforms $
        [ ("Robot", scalingUniformProj4 0.1 .*. (linear $ rotMatrixY re2) .*. translation (Vec3 3.5 (-5) (-7)))
        , ("Light1", translation (Vec3 0 100 200) .*. (linear $ rotMatrixX re2))
        , ("CameraEye", scalingUniformProj4 1 .*. translation cam)
        , ("CameraNode2", inverse $ lookat (cam) (cam &+ dir) (up))
        ] ++
        [("Knot" ++ show i,
          ((linear $ rotMatrixY re3) .*.
           let (y,x) = quotRem i 14 in
           translation (Vec3 ((fromIntegral x - 7)*width) (height*(fromIntegral y - 7)) (-166))
          )
         ) | i <- [1..200 :: Int]]
    updateTargetSize "MainWindow" w h
    renderWorld (realToFrac time) "MainWindow"
    liftIO $ swapBuffers

readInput :: State
          -> ((FloatType, FloatType) -> IO a)
          -> (Bool -> IO b)
          -> ((Bool, Bool, Bool, Bool, Bool) -> IO c)
          -> IO (Maybe FloatType)
readInput s mousePos mouseBut fblrPress = do
    t <- getTime
    resetTime

    (x,y) <- getMousePosition
    mousePos (fromIntegral x,fromIntegral y)

    mouseBut =<< mouseButtonIsPressed MouseButton0
    fblrPress =<< ((,,,,) <$> keyIsPressed KeyLeft <*> keyIsPressed KeyUp <*> keyIsPressed KeyDown <*> keyIsPressed KeyRight <*> keyIsPressed KeyRightShift)

    updateFPS s t
    k <- keyIsPressed KeyEsc
    return $ if k then Nothing else Just (realToFrac t)