hw/examples/example02/Init.hs

{-# LANGUAGE OverloadedStrings #-}

module Init where

import SDL (($=))
import qualified SDL

import Control.Concurrent.STM.TVar

import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU

import qualified Data.ByteString as BS

import System.Random (randomRIO)

import Physics.Bullet.Raw

import Codec.Wavefront

import Linear as L

import SpatialMath

import Foreign

import Util
import Types

genVertBufObject path = do
  eobj <- fromFile path
  let obj = case eobj of
        Right o -> o
        Left err -> error err
  let lobj = loadObj obj

  shipBO <- GL.genObjectName
  GL.bindVertexArrayObject $= Just shipBO

  verts <- GL.genObjectName
  GL.bindBuffer GL.ArrayBuffer $= Just verts
  withArray (loTriangles lobj) $ \ptr ->
    GL.bufferData GL.ArrayBuffer $=
      ( fromIntegral $ length (loTriangles lobj) * sizeOf (0 :: Float)
      , 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
  GL.bindBuffer GL.ArrayBuffer $= Nothing
  GL.bindVertexArrayObject $= Nothing
  return (shipBO, length (loTriangles lobj))

load :: IO StateData
load = do
  _ <- SDL.setMouseLocationMode SDL.RelativeLocation
  GL.depthFunc $= Just GL.Less

  (shipBO, stl) <- genVertBufObject "assets/spheres/smallsphere.obj"

  (planetBO, ptl) <- genVertBufObject "assets/spheres/bigsphere.obj"

  let vertexShader = foldl BS.append BS.empty
        [ "attribute vec3 coord3d;"
        , "attribute vec2 texcoord;"
        , "uniform mat4 mvp;"
        , "varying vec2 f_texcoord;"
        , "void main(void) {"
        , "  float zoom = 1.0;"
        , "  gl_Position = mvp * vec4(coord3d, 1.0);"
        -- , "  gl_Position.z = 0.0;"
        -- , "  gl_Position.w += 10.0;"
        , "  f_texcoord = texcoord;"
        , "}"
        ]
      fragmentShaderSmall = foldl BS.append BS.empty
        [ "varying vec2 f_texcoord;"
        , "void main(void) {"
        , "  gl_FragColor = vec4(1.0,1.0,1.0,1.0);"
        , "}"
        ]
      fragmentShaderBig = foldl BS.append BS.empty
        [ "varying vec2 f_texcoord;"
        , "void main(void) {"
        , "  gl_FragColor = vec4(1.0,0,0,1.0);"
        , "}"
        ]
  p <- GLU.simpleShaderProgramBS vertexShader fragmentShaderSmall
  p2 <- GLU.simpleShaderProgramBS vertexShader fragmentShaderBig

  poss <- mapM (\_ -> do
    x <- randomRIO (-50, 50)
    y <- randomRIO (-50, 50)
    z <- randomRIO (-50, 50)
    return (V3 x y z)
    ) [0..1999]

  poss2 <- mapM (\_ -> do
    x <- randomRIO (-100, 100)
    y <- randomRIO (-100, 100)
    z <- randomRIO (-100, 100)
    return (V3 x y z)
    ) [] -- [0..9]

  let shipList = zipWith (Ship shipBO stl)
        poss
        (repeat $ Quaternion 1 (V3 0 0 0))
      planet = Ship planetBO ptl (V3 0 0 0) (Quaternion 1 (V3 0 0 0))
      otherPlanets = zipWith (Ship planetBO ptl)
        poss2
        (repeat $ Quaternion 1 (V3 0 0 0))

  phys <- initPhysics

  po <- initPhysicsObjects poss poss2

  mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poSmallBalls po)
  mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBigBalls po)
  addRigidBody (pWorld phys) (bodyRigidBody $ poBigBall po)

  StateData
    <$> newTVarIO shipList
    <*> newTVarIO planet
    <*> newTVarIO otherPlanets
    <*> newTVarIO (Camera
      { cameraFocus = V3 0 0 0
      , cameraRot = Euler 0 0 0
      , cameraDist = -100
      })
    <*> newTVarIO (infinitePerspective (pi/2) (1600 / 900) 1)
    <*> newTVarIO p
    <*> newTVarIO p2
    <*> newTVarIO phys
    <*> newTVarIO po
    <*> newTVarIO 0
    <*> newTVarIO True

loadTex :: FilePath -> IO GL.TextureObject
loadTex f = do
  t <- either error id <$> GLU.readTexture f
  GL.textureFilter GL.Texture2D $= ((GL.Linear', Nothing), GL.Linear')
  GLU.texture2DWrap $= (GL.Repeated, GL.ClampToEdge)
  return t

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

initPhysicsObjects :: [V3 Float] -> [V3 Float] -> IO PhysicsObjects
initPhysicsObjects poss poss2 = do
  -- ground <- newStaticPlaneShape (V3 0 1 0) 1
  smallBall <- newSphereShape 1
  bigBall <- newSphereShape 5

  -- 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)

  smallBallPOs <- mapM (\pos -> do
    -- fx <- randomRIO (-1000, 1000)
    -- fy <- randomRIO (-1000, 1000)
    -- fz <- randomRIO (-1000, 1000)
    let m = 100
    smallBallMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
      (fmap realToFrac pos)
    localInertia <- calculateLocalInertia smallBall m (V3 0 0 0)
    smallBallBody <- newRigidBody m smallBallMotionState 0.9 0.5 smallBall localInertia
    -- applyCentralForce smallBallBody (V3 fx fy fz)
    return $ PhysBody smallBall smallBallMotionState smallBallBody m
    ) poss

  bigBallsPOs <- mapM (\pos -> do
    let m = 1000000
    -- fx <- randomRIO (-1000, 1000)
    -- fy <- randomRIO (-1000, 1000)
    -- fz <- randomRIO (-1000, 1000)
    bigBallMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
      (fmap realToFrac pos)
    localInertia <- calculateLocalInertia bigBall m (V3 0 0 0)
    bigBallBody <- newRigidBody m bigBallMotionState 0.9 0.5 bigBall localInertia
    -- applyCentralForce bigBallBody (V3 fx fy fz)
    return $ PhysBody bigBall bigBallMotionState bigBallBody m
    ) poss2

  bigBallPO <- do
    bigBallMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
      (V3 0 0 0)
    localInertia <- calculateLocalInertia bigBall 1 (V3 0 0 0)
    bigBallBody <- newRigidBody 0 bigBallMotionState 0.9 0.5 bigBall localInertia
    return $ PhysBody bigBall bigBallMotionState bigBallBody 0

  return PhysicsObjects
    { poBigBall = bigBallPO
    , poSmallBalls  = smallBallPOs
    , poBigBalls = bigBallsPOs
    -- , poBigBalls = []
    }