Bullet.hs

module Graphics.LambdaCube.Bullet where

import Control.Applicative
import Control.Monad
import Control.Monad.Trans
import Data.List
import Data.Maybe
import Data.Vector ((!))
import qualified Data.Vector as V
import System.IO.Unsafe

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

import Graphics.LambdaCube
import Graphics.LambdaCube.Common
import Graphics.LambdaCube.RenderSystem
import Graphics.LambdaCube.World

-- ideal code from LC:
{-
mkTriangleMeshInterface mesh = do
    mi <- btTriangleMesh True True
    forM_ (vertices of the mesh triangle) $ \(a,b,c) -> btTriangleMesh_addTriangle mi a b c
    return mi
-}

mkTriangleMeshInterfaceM :: VMesh -> IO BtTriangleMesh
mkTriangleMeshInterfaceM mesh = do
    mi <- btTriangleMesh True True
    forM_ (vmSubMeshList mesh) $ \sm -> do
        let VVD_POSITION pos = V.head $ V.filter (\vd -> VVT_POSITION == vectorVertexType vd) $ fromMaybe (fromJust $ vmSharedVertexData mesh) $ vsmVertexData sm
            idx = fromJust $ vsmIndexData sm
            f n = let Vec3 x y z = pos ! n in Vector3 x y z
            addStrip (a,b) i        = btTriangleMesh_addTriangle mi (f a) (f b) (f i) False >> return (b,i)
            addFan a b i            = btTriangleMesh_addTriangle mi (f a) (f b) (f i) False >> return i
        case vsmOperationType sm of
            OT_TRIANGLE_LIST    -> forM_ (unfoldr split3 idx) $ \iv -> do
                btTriangleMesh_addTriangle mi (f (iv ! 0)) (f (iv ! 1)) (f (iv ! 2)) False
              where
                split3 v
                    | V.length v < 3 = Nothing
                    | otherwise      = Just (V.take 3 v, V.drop 3 v)
            OT_TRIANGLE_STRIP   -> void $ let ab = V.take 2 idx in V.foldM' addStrip (ab ! 0, ab ! 1) $ V.drop 2 idx
            OT_TRIANGLE_FAN     -> void $ let ab = V.take 2 idx in V.foldM' (addFan $ ab ! 0) (ab ! 1) $ V.drop 2 idx
            _ -> return ()
    return mi

mkStaticTriangleMeshShapeM :: VMesh -> IO BtBvhTriangleMeshShape
mkStaticTriangleMeshShapeM mesh = do
    mi <- mkTriangleMeshInterfaceM mesh
    btBvhTriangleMeshShape0 mi True True

--mkGimpactTriangleMeshShape mesh = do
--    plNewGimpactTriangleMeshShape =<< mkTriangleMeshInterface mesh

mkConvexTriangleMeshShapeM :: VMesh -> IO BtConvexTriangleMeshShape
mkConvexTriangleMeshShapeM mesh = do
    mi <- mkTriangleMeshInterfaceM mesh
    btConvexTriangleMeshShape mi True

mkTriangleMeshInterface :: VMesh -> BtTriangleMesh
mkTriangleMeshInterface = unsafePerformIO . mkTriangleMeshInterfaceM

mkStaticTriangleMeshShape :: VMesh -> BtBvhTriangleMeshShape
mkStaticTriangleMeshShape = unsafePerformIO . mkStaticTriangleMeshShapeM

mkConvexTriangleMeshShape :: VMesh -> BtConvexTriangleMeshShape
mkConvexTriangleMeshShape = unsafePerformIO . mkConvexTriangleMeshShapeM

debugDrawPhysics :: (RenderSystem rs vb ib q t p lp, BtDynamicsWorldClass bc) => bc -> Proj4 -> LCM (World rs vb ib q t p lp) e ()
debugDrawPhysics dynamicsWorld camMat = do
    rs <- wrRenderSystem <$> peekLCM
    liftIO $ do
        -- debug draw bullet space
        --when debugDrawAll $
        --    GL.clear [GL.DepthBuffer]
        setWorldMatrix rs one
        setViewMatrix rs camMat
        setLightingEnabled rs False
        setCullingMode rs $ CULL_NONE
        forM_ [0..7] $ \i -> do
            setActiveTextureUnit rs i
            setTexture rs Nothing
        --setDepthBias rs 1 1

        btDynamicsWorld_debugDrawWorld dynamicsWorld