stunts-0.1.0: src/Main.hs

import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.IORef
import Data.List
import FRP.Elerea.Param
import Graphics.UI.GLFW as GLFW

import Graphics.LambdaCube as LC
import Graphics.LambdaCube.Bullet
import Graphics.LambdaCube.RenderSystem.GL
import qualified Graphics.LambdaCube.Loader.StbImage as Stb
import Graphics.LambdaCube.World (SceneObject(..), Camera(..), Viewport(..), peekLCM, wrRenderSystem)

import Physics.Bullet.Raw
import Physics.Bullet.Raw.Class

#ifdef CAPTURE
import Codec.Image.DevIL
import Graphics.LambdaCube.RenderSystem
import Text.Printf
#endif

import System.Directory
import System.Environment
import System.Exit

import Paths_Stunts (getDataFileName)

import GameData
import GamePhysics
import Utils

type Sink a = a -> IO ()

data CameraMode = FollowNear | FollowFar | UserControl

captureRate :: Float
captureRate = 30

main :: IO ()
main = do
#ifdef PORTABLE
    let mediaPath = "."
#else
    mediaPath <- getDataFileName "media"
#endif

    gameOk <- doesFileExist (mediaPath ++ "/STUNTS11.ZIP")
    unless gameOk $ do
        putStrLn "Missing game file! Please download the original game from"
        putStrLn "<http://downloads.pigsgrame.de/STUNTS11.ZIP> and move it to"
#ifdef PORTABLE
        putStrLn "the same folder as this executable."
#else
        putStrLn mediaPath
#endif
        putStrLn "For reference, the above file should be 1077864 bytes."
        exitFailure

    args <- getArgs

    let carNum = case filter ("--car=" `isPrefixOf`) args of
            [] -> 4
            n:_ -> read (drop 6 n)

        trkFile = case filter ("--track=" `isPrefixOf`) args of
            [] -> "zct114.trk"
            n:_ -> drop 8 n

#ifdef CAPTURE
    ilInit
#endif
    windowSize <- initCommon "Stunts NextGen powered by LambdaCube Engine"

    (mousePosition,mousePositionSink) <- external (0,0)
    (_mousePress,mousePressSink) <- external False
    (debugPress,debugPressSink) <- external False
    (capturePress,capturePressSink) <- external False
    (fblrPress,fblrPressSink) <- external (False,False,False,False,False)
    (cameraPress,cameraPressSink) <- external (False,False,False)
    (carPos,carPosSink) <- external idmtx
    (wheelPos,wheelPosSink) <- external []

    physicsWorld <- mkPhysicsWorld
    renderSystem <- mkGLRenderSystem
    runLCM renderSystem [Stb.loadImage] $ do
        let addSkyColour = fmap (\vp -> vp { vpBackColour = (0.36,0.99,0.99,1) })
            fixCameraClip = fmap (\(SO_Camera cm) -> SO_Camera cm { cmFar = 50000 })
        -- inLCM $ addConfig "resources.cfg"
        addResourceLibrary [("General", [(PathDir, mediaPath)])
                           ,("General", [(PathZip, mediaPath ++ "/STUNTS11.ZIP")])
                           ,("General", [(PathZip, mediaPath ++ "/newstunts.zip")])
                           ,("General", [(PathDir, ".")])
                           ]
        (car,wheels,terrain,track,startPos,carSim) <- readStuntsData carNum trkFile
        addVMesh "TrackMesh" track
        addVMesh "TerrainMesh" terrain
        addVMesh "CarMesh" car
        mapM_ (\((_,_,_,m),i) -> addVMesh ("Wheel" ++ show i) m) $ zip wheels [1..]
        addScene $
            [ node "Root" "CameraNode2" idmtx [fixCameraClip (simpleCamera "Camera2")]
            , node "Root" "Track" idmtx [mesh defaultRQP Nothing "TrackMesh", mesh defaultRQP Nothing "TerrainMesh"]
            , node "Root" "Car" idmtx [mesh defaultRQP Nothing "CarMesh"]
            , node "Root" "Wheel1" idmtx [mesh defaultRQP Nothing "Wheel1"]
            , node "Root" "Wheel2" idmtx [mesh defaultRQP Nothing "Wheel2"]
            , node "Root" "Wheel3" idmtx [mesh defaultRQP Nothing "Wheel3"]
            , node "Root" "Wheel4" idmtx [mesh defaultRQP Nothing "Wheel4"]
            , node "Root" "CameraNode1" idmtx [fixCameraClip (simpleCamera "Camera1")]
            , node "Root" "Light" (translation (Vec3 400 800 400)) [defaultLight]
            ]
        addRenderWindow "MainWindow" 640 480 $ map addSkyColour
            [{-viewport 0 0.5 1 0.5 "Camera1" [], viewport 0 0 1 0.5 "Camera2" []-} viewport 0 0 1 1 "Camera1" []]

        -- setup physics
        trackMesh <- getVMesh "TrackMesh"
        terrainMesh <- getVMesh "TerrainMesh"
        carMesh <- getVMesh "CarMesh"
        car <- liftIO $ do
            addStaticPlane physicsWorld (Vec3 0 1 0) 0 1 1
            addStaticShape physicsWorld trackMesh 1 1
            addStaticShape physicsWorld terrainMesh 1000 1000
            let (sO,Vec3 sX sY sZ) = startPos
            addCar physicsWorld carMesh wheels $ translateAfter4 (Vec3 sX (sY + 1) sZ) $ rotMatrixProj4 sO (Vec3 0 1 0)

        capRef <- liftIO $ newIORef False

        s <- liftIO fpsState
        sc <- liftIO $ start $ scene physicsWorld carPos wheelPos windowSize mousePosition fblrPress cameraPress debugPress capturePress capRef

        driveNetwork sc (readInput physicsWorld car s carPosSink wheelPosSink
                         mousePositionSink mousePressSink fblrPressSink
                         cameraPressSink debugPressSink capturePressSink capRef)

    closeWindow
    terminate

scene :: (RenderSystem r vb ib q t p lp, BtDynamicsWorldClass bc)
      => bc -> Signal Proj4 -> Signal [Proj4] -> Signal (Int, Int) -> Signal (FloatType, FloatType)
      -> Signal (Bool, Bool, Bool, Bool, Bool) -> Signal (Bool, Bool, Bool) -> Signal Bool -> Signal Bool -> IORef Bool
      -> SignalGen FloatType (Signal (LCM (World r vb ib q t p lp) e ()))
scene physicsWorld carPos wheelPos windowSize mousePosition fblrPress cameraPress debugPress capturePress capRef = do
    time <- stateful 0 (+)
    frameCount <- stateful (0 :: Int) (\_ c -> c + 1)

    last2 <- transfer ((0,0),(0,0)) (\_ n (_,b) -> (b,n)) mousePosition
    let mouseMove = (\((ox,oy),(nx,ny)) -> (nx-ox,ny-oy)) <$> last2

        pickMode _ (True,_,_) _ = FollowNear
        pickMode _ (_,True,_) _ = FollowFar
        pickMode _ (_,_,True) _ = UserControl
        pickMode _ _ mode       = mode

        selectCam FollowNear  (cam,dir) _ _      = lookat cam (cam &+ dir) (Vec3 0 1 0)
        selectCam FollowFar   _ (cam,dir) _      = lookat cam (cam &+ dir) (Vec3 0 1 0)
        selectCam UserControl _ _ (cam,dir,up,_) = lookat cam (cam &+ dir) up

    followCamNear <- followCamera 2 4 6 carPos
    followCamFar <- followCamera 20 40 60 carPos
    userCam <- userCamera (Vec3 (-4) 0 0) mouseMove fblrPress
    camMode <- transfer FollowNear pickMode cameraPress
    let camera = selectCam <$> camMode <*> followCamNear <*> followCamFar <*> userCam

    capturePress' <- delay False capturePress
    capture <- transfer2 False (\_ cp cp' cap -> cap /= (cp && not cp')) capturePress capturePress'

    return $ drawGLScene physicsWorld capRef <$> windowSize <*> camera <*> time <*> carPos <*> wheelPos  <*> debugPress <*> capture <*> frameCount

drawGLScene :: (RenderSystem r vb ib q t1 p lp, BtDynamicsWorldClass bc)
            => bc -> IORef Bool -> (Int, Int) -> Proj4 -> FloatType -> Proj4 -> [Proj4] -> Bool -> Bool -> Int
            -> LCM (World r vb ib q t1 p lp) e ()
#ifdef CAPTURE
drawGLScene physicsWorld capRef (w,h) camMat time carPos [wheel1,wheel2,wheel3,wheel4] debugPress capturing frameCount = do
#else
drawGLScene physicsWorld capRef (w,h) camMat time carPos [wheel1,wheel2,wheel3,wheel4] debugPress _capturing _frameCount = do
#endif
    updateTransforms $
        [ ("CameraNode1", inverse camMat)
--        , ("CameraNode2", inverse camMat2)
        , ("Car", carPos)
--        , ("Light", (translation cam))
        , ("Wheel1", wheel1)
        , ("Wheel2", wheel2)
        , ("Wheel3", wheel3)
        , ("Wheel4", wheel4)
        ]
    updateTargetSize "MainWindow" w h
    renderWorld time "MainWindow"
#ifdef CAPTURE
    rs <- wrRenderSystem <$> peekLCM
#endif
    when debugPress $ debugDrawPhysics physicsWorld camMat
    liftIO $ do
#ifdef CAPTURE
        when capturing $ withFrameBuffer rs 0 0 w h $ \p -> writeImageFromPtr (printf "frame%08d.png" frameCount) (h,w) p
        writeIORef capRef capturing
#endif
        swapBuffers

readInput :: (BtDynamicsWorldClass dw, BtRaycastVehicleClass v)
          => dw -> v -> State -> Sink Proj4 -> Sink [Proj4] -> Sink (FloatType, FloatType) -> Sink Bool
          -> Sink (Bool, Bool, Bool, Bool, Bool) -> Sink (Bool, Bool, Bool) -> Sink Bool -> Sink Bool -> IORef Bool
          -> IO (Maybe FloatType)
readInput physicsWorld car s carPos wheelPos mousePos mouseBut fblrPress cameraPress debugPress capturePress capRef = 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
    cameraPress =<< (,,) <$> keyIsPressed (CharKey '1') <*> keyIsPressed (CharKey '2') <*> keyIsPressed (CharKey '3')
    debugPress =<< keyIsPressed KeySpace
    capturePress =<< keyIsPressed (CharKey 'P')
    k <- keyIsPressed KeyEsc

    -- step physics
    isCapturing <- readIORef capRef
    let dt = if isCapturing then recip captureRate else realToFrac t
    steerCar dt car =<< forM "AWSDR" (\c -> keyIsPressed (CharKey c))
    btDynamicsWorld_stepSimulation physicsWorld dt 10 (1 / 200)
    wheelPos =<< updateCar car

    carPos =<< rigidBodyProj4 =<< btRaycastVehicle_getRigidBody car
    updateFPS s t
    return $ if k then Nothing else Just dt