hw/examples/example03/Init.hs

188 lines
5.5 KiB
Haskell
Raw Normal View History

2017-11-12 16:10:47 +00:00
{-# LANGUAGE OverloadedStrings #-}
module Init where
import SDL (($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU
import Data.List.Split (chunksOf)
import qualified Data.ByteString as BS
import Physics.Bullet.Raw
import Codec.Wavefront
import Linear as L
import SpatialMath
import Foreign
import Util
import Types
2017-11-18 10:02:55 +00:00
import Logging as LL
2017-11-12 16:10:47 +00:00
2017-11-16 18:48:11 +00:00
import Debug.Trace
2017-11-12 16:10:47 +00:00
load :: IO StateData
load = do
_ <- SDL.setMouseLocationMode SDL.RelativeLocation
GL.depthFunc $= Just GL.Less
2017-11-16 18:48:11 +00:00
svao <- GL.genObjectName
GL.bindVertexArrayObject $= Just svao
2017-11-12 16:10:47 +00:00
(shipBO, sobj, stl) <- genVertBufObject "assets/ships/jaeger/jaeger.obj"
texture <- GL.genObjectName
GL.bindBuffer GL.ArrayBuffer $= Just texture
maybe (return ()) (\a -> withArray a $ \ptr ->
GL.bufferData GL.ArrayBuffer $=
( fromIntegral $ length a * 2 * sizeOf (0 :: Double)
, ptr
, GL.StaticDraw
)) (loTexTri sobj)
GL.vertexAttribPointer (GL.AttribLocation 1) $=
( GL.ToFloat
, GL.VertexArrayDescriptor 2 GL.Float 0 (plusPtr nullPtr 0)
)
GL.vertexAttribArray (GL.AttribLocation 1) $= GL.Enabled
2017-11-16 18:48:11 +00:00
GL.bindBuffer GL.ArrayBuffer $= Nothing
2017-11-12 16:10:47 +00:00
GL.texture GL.Texture2D $= GL.Enabled
GL.activeTexture $= GL.TextureUnit 0
t <- loadTex "assets/ships/jaeger/jaeger.texture.tga"
GL.textureBinding GL.Texture2D $= Just t
2017-11-16 18:48:11 +00:00
GL.bindVertexArrayObject $= Nothing
hvao <- GL.genObjectName
GL.bindVertexArrayObject $= Just hvao
(vectHandleBO, hobj, vhtl) <- genVertBufObject "assets/spheres/vertHandle.obj"
GL.bindVertexArrayObject $= Nothing
2017-11-12 16:10:47 +00:00
let vertexShader = foldl BS.append BS.empty
[ "attribute vec3 coord3d;"
, "attribute vec2 texcoord;"
, "uniform mat4 mvp;"
, "varying vec2 f_texcoord;"
, "void main(void) {"
, " gl_Position = mvp * vec4(coord3d, 1.0);"
, " f_texcoord = texcoord;"
, "}"
]
fragmentShaderShip = foldl BS.append BS.empty
[ "varying vec2 f_texcoord;"
, "uniform sampler2D texture;"
, "void main(void) {"
, " vec2 flip = vec2(f_texcoord.x, 1.0 - f_texcoord.y);"
, " gl_FragColor = texture2D(texture, flip);"
, "}"
]
fragmentShaderHandle = foldl BS.append BS.empty
[ "varying vec2 f_texcoord;"
, "void main(void) {"
2017-11-16 18:48:11 +00:00
, " gl_FragColor = vec4(1.0,0.0,1.0,0.5);"
2017-11-12 16:10:47 +00:00
, "}"
]
2017-11-16 18:48:11 +00:00
hProgram <- GLU.simpleShaderProgramBS vertexShader fragmentShaderHandle
sProgram <- GLU.simpleShaderProgramBS vertexShader fragmentShaderShip
2017-11-12 16:10:47 +00:00
phys <- initPhysics
2017-11-18 10:02:55 +00:00
po <- initPhysicsObjects (map listToPos $ chunksOf 4 $ loLocations sobj)
2017-11-12 16:10:47 +00:00
2017-11-16 18:48:11 +00:00
-- traceIO $ show $ loLines sobj
2017-11-12 16:10:47 +00:00
-- mapM_ (addRigidBody (pWorld phys)) (map bodyRigidBody (poBalls po))
2017-11-18 10:02:55 +00:00
mapM_ (\b -> addRigidBody (pWorld phys) (bodyRigidBody b)) (poBalls po)
logIO Debug "Hello world"
2017-11-12 16:10:47 +00:00
return StateData
2017-11-16 18:48:11 +00:00
{ ship = (Ship svao stl
2017-11-12 16:10:47 +00:00
(V3 0 0 0)
(Quaternion 1 (V3 0 0 0))
(Just t)
2017-11-16 18:48:11 +00:00
(Just texture))
2017-11-18 10:02:55 +00:00
, vertHandles = createHandles hvao vhtl (loLocations sobj)
2017-11-12 16:10:47 +00:00
, proj = perspective (pi/2) (1600 / 900) 1 (-1)
, camera = Camera
{ cameraFocus = V3 0 0 0
, cameraRot = Euler 0 0 0
, cameraDist = -10
}
, physics = phys
, physicsObjects = po
2017-11-16 18:48:11 +00:00
, shipProgram = sProgram
, handleProgram = hProgram
2017-11-12 16:10:47 +00:00
}
initPhysics :: IO Physics
initPhysics = do
bp <- newDbvtBroadphase
config <- newDefaultCollisionConfiguration
disp <- newCollisionDispatcher config
solver <- newSequentialImpulseConstraintSolver
world <- newDiscreteDynamicsWorld disp bp solver config
setGravity world (V3 0 0 0)
return $ Physics bp config disp solver world
2017-11-18 10:02:55 +00:00
initPhysicsObjects :: [V3 Float] -> IO PhysicsObjects
initPhysicsObjects poss = do
2017-11-12 16:10:47 +00:00
-- ground <- newStaticPlaneShape (V3 0 1 0) 1
2017-11-18 10:02:55 +00:00
ball <- newSphereShape 0.05
2017-11-12 16:10:47 +00:00
-- groundMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0)) (V3 0 (-51) 0)
-- groundBody <- newRigidBody 0 groundMotionState 0.9 0.5 ground (V3 0 0 0)
2017-11-18 10:02:55 +00:00
balls <- mapM (\pos -> do
ballMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
(fmap realToFrac pos)
localInertia <- calculateLocalInertia ball 1 (V3 0 0 0)
ballBody <- newRigidBody 0 ballMotionState 0 0 ball localInertia
setSleepingThresholds ballBody 0 0
return $ PhysBody ball ballMotionState ballBody
) poss
2017-11-12 16:10:47 +00:00
return PhysicsObjects
-- { poGround = PhysBody ground groundMotionState groundBody
2017-11-18 10:02:55 +00:00
{ poBalls = balls
2017-11-12 16:10:47 +00:00
}
2017-11-16 18:48:11 +00:00
genVertBufObject :: FilePath -> IO (GL.BufferObject, LoadedObject, Int)
2017-11-12 16:10:47 +00:00
genVertBufObject path = do
eobj <- fromFile path
let obj = case eobj of
Right o -> o
Left err -> error err
lobj = loadObj obj
2017-11-16 18:48:11 +00:00
vbo <- GL.genObjectName
GL.bindBuffer GL.ArrayBuffer $= Just vbo
2017-11-12 16:10:47 +00:00
withArray (loTriangles lobj) $ \ptr ->
GL.bufferData GL.ArrayBuffer $=
( fromIntegral $ length (loTriangles lobj) * 3 * sizeOf (0 :: Double)
, ptr
, GL.StaticDraw
)
GL.vertexAttribPointer (GL.AttribLocation 0) $=
( GL.ToFloat
, GL.VertexArrayDescriptor 4 GL.Float 0 (plusPtr nullPtr 0)
)
GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled
2017-11-16 18:48:11 +00:00
return (vbo, lobj, length (loTriangles lobj))
2017-11-12 16:10:47 +00:00
createHandles :: GL.VertexArrayObject -> Int -> [Float] -> [Ship]
createHandles bo len ps =
2017-11-18 10:02:55 +00:00
map (\p -> Ship bo len (listToPos p) (Quaternion 1 (V3 0 0 0)) Nothing Nothing) tris
2017-11-12 16:10:47 +00:00
where
2017-11-18 10:02:55 +00:00
tris = chunksOf 4 ps
listToPos :: [Float] -> V3 Float
listToPos [x, y, z, _] = V3 x y z
listToPos _ = error "listToPos: not triangular coordinates encountered"