fun & play

examples/example02/Init.hs

@@ -71,13 +71,20 @@ load = do
         , "  f_texcoord = texcoord;"
         , "}"
         ]
-      fragmentShader = foldl BS.append BS.empty
+      fragmentShaderSmall = foldl BS.append BS.empty
         [ "varying vec2 f_texcoord;"
         , "void main(void) {"
         , "  gl_FragColor = vec4(1.0,1.0,1.0,1.0);"
         , "}"
         ]
-  p <- GLU.simpleShaderProgramBS vertexShader fragmentShader
+      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)
@@ -86,21 +93,33 @@ load = do
     return (V3 x y z)
     ) [0..2000]
 
+  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
+  po <- initPhysicsObjects poss poss2
 
   mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poSmallBalls po)
+  mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBigBalls po)
   addRigidBody (pWorld phys) (bodyRigidBody $ poBigBall po)
 
   return StateData
     { ships = shipList
     , planet = planet
+    , oplanets = otherPlanets
     , proj = perspective (pi/2) (1600 / 900) 1 (-1)
     , camera = Camera
       { cameraFocus = V3 0 0 0
@@ -108,8 +127,10 @@ load = do
       , cameraDist = -100
       }
     , program = p
+    , program2 = p2
     , physics = phys
     , physicsObjects = po
+    , focusIndex = 0
     }
 
 loadTex :: FilePath -> IO GL.TextureObject
@@ -129,8 +150,8 @@ initPhysics = do
   setGravity world (V3 0 0 0)
   return $ Physics bp config disp solver world
 
-initPhysicsObjects :: [V3 Float] -> IO PhysicsObjects
+initPhysicsObjects :: [V3 Float] -> [V3 Float] -> IO PhysicsObjects
-initPhysicsObjects poss = do
+initPhysicsObjects poss poss2 = do
   -- ground <- newStaticPlaneShape (V3 0 1 0) 1
   smallBall <- newSphereShape 1
   bigBall <- newSphereShape 5
@@ -139,13 +160,30 @@ initPhysicsObjects poss = do
   -- 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)
     smallBallMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
       (fmap realToFrac pos)
     localInertia <- calculateLocalInertia smallBall 1 (V3 0 0 0)
     smallBallBody <- newRigidBody 1 smallBallMotionState 0.9 0.5 smallBall localInertia
+    -- applyCentralForce smallBallBody (V3 fx fy fz)
     return $ PhysBody smallBall smallBallMotionState smallBallBody 1
     ) 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)
@@ -156,4 +194,5 @@ initPhysicsObjects poss = do
   return PhysicsObjects
     { poBigBall = bigBallPO
     , poSmallBalls  = smallBallPOs
+    , poBigBalls = bigBallsPOs
     }

examples/example02/Main.hs

@@ -52,20 +52,52 @@ update dt = do
   sd <- getAffection
   let phys = physics sd
       physos = physicsObjects sd
+      g = 0.0667300
+      -- g = 0.0000000000667300
+
   mapM_ (\smallBall -> do
     ms1 <- liftIO $ getMotionState (bodyRigidBody smallBall)
     ms2 <- liftIO $ getMotionState (bodyRigidBody $ poBigBall physos)
     r1 <- liftIO $ return . fmap realToFrac =<< getPosition ms1
     r2 <- liftIO $ return . fmap realToFrac =<< getPosition ms2
-    let g = 0.0000000000667300
+    let m1 = bodyMass smallBall
-        m1 = bodyMass smallBall
         -- m2 = bodyMass (poBigBall physos)
-        m2 = 1000000000000000
+        -- m2 = 1000000000000000
+        m2 = 1000000
         eta_sq = 0.1 ^ 2
         force = (g * m2 * m1 *^ (r2 - r1)) ^/
           ((sqrt (((r2 - r1) `dot` (r2 - r1)) + eta_sq)) ^ 3)
     liftIO $ applyCentralForce (bodyRigidBody smallBall) force
-    ) (poSmallBalls physos)
+    ) (poSmallBalls physos ++ poBigBalls physos)
+
+  mapM_ (\(bb1, bb2) -> do
+    ms1 <- liftIO $ getMotionState (bodyRigidBody bb1)
+    ms2 <- liftIO $ getMotionState (bodyRigidBody bb2)
+    r1 <- liftIO $ return . fmap realToFrac =<< getPosition ms1
+    r2 <- liftIO $ return . fmap realToFrac =<< getPosition ms2
+    let m1 = bodyMass bb1
+        -- m2 = bodyMass (poBigBall physos)
+        m2 = bodyMass bb2
+        eta_sq = 0.1 ^ 2
+        force = (g * m2 * m1 *^ (r2 - r1)) ^/
+          ((sqrt (((r2 - r1) `dot` (r2 - r1)) + eta_sq)) ^ 3)
+    liftIO $ applyCentralForce (bodyRigidBody bb1) force
+    ) ((,) <$> (poBigBalls physos) <*> (poBigBalls physos))
+
+  mapM_ (\(bb1, bb2) -> do
+    ms1 <- liftIO $ getMotionState (bodyRigidBody bb1)
+    ms2 <- liftIO $ getMotionState (bodyRigidBody bb2)
+    r1 <- liftIO $ return . fmap realToFrac =<< getPosition ms1
+    r2 <- liftIO $ return . fmap realToFrac =<< getPosition ms2
+    let m1 = bodyMass bb1
+        -- m2 = bodyMass (poBigBall physos)
+        m2 = bodyMass bb2
+        eta_sq = 0.1 ^ 2
+        force = (g * m2 * m1 *^ (r2 - r1)) ^/
+          ((sqrt (((r2 - r1) `dot` (r2 - r1)) + eta_sq)) ^ 3)
+    liftIO $ applyCentralForce (bodyRigidBody bb1) force
+    ) ((,) <$> (poSmallBalls physos) <*> (poBigBalls physos))
+
   liftIO $ stepSimulation (pWorld phys) dt 10 Nothing
   posrots <- mapM ((\ball -> do
     ms <- liftIO $ getMotionState ball
@@ -73,35 +105,56 @@ update dt = do
     nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
     return (npos, nrot))
     . bodyRigidBody) (poSmallBalls physos)
+  posrots2 <- mapM ((\ball -> do
+    ms <- liftIO $ getMotionState ball
+    npos <- liftIO $ return . fmap realToFrac =<< getPosition ms
+    nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
+    return (npos, nrot))
+    . bodyRigidBody) (poBigBalls physos)
   let nships = map (\(ship, (pos, rot)) ->
         ship
           { shipRot = rot
           , shipPos = pos
           }
         ) (zip (ships sd) posrots)
+      nplanets = map (\(ball, (pos, rot)) ->
+        ball
+          { shipRot = rot
+          , shipPos = pos
+          }
+        ) (zip (oplanets sd) posrots2)
   putAffection sd
     { ships = nships
+    , oplanets = nplanets
+    , camera = (camera sd)
+      { cameraFocus = shipPos ((planet sd : nplanets) !! focusIndex sd)
+      }
     }
 
 draw :: Affection StateData ()
 draw = do
   GL.viewport $= (GL.Position 0 0, GL.Size 1600 900)
   StateData{..} <- getAffection
-  GL.currentProgram $= (Just . GLU.program $ program)
+  drawThings program (planet : ships)
-  mapM_ (\Ship{..} -> do
+  drawThings program2 oplanets
-    let view = lookAt
+  where
-          (cameraFocus camera +
+  drawThings prog ts = do
-            rotVecByEulerB2A
+    StateData{..} <- getAffection
-            (cameraRot camera)
+    GL.currentProgram $= (Just . GLU.program $ prog)
-            (V3 0 0 (-cameraDist camera)))
+    mapM_ (\Ship{..} -> do
-          (cameraFocus camera)
+      let view = lookAt
-          (V3 0 1 0)
+            (cameraFocus camera +
-        model = mkTransformation shipRot shipPos
+              rotVecByEulerB2A
-        pvm = proj !*! view !*! model
+              (cameraRot camera)
-    liftIO $ GLU.setUniform program "mvp" pvm
+              (V3 0 0 (-cameraDist camera)))
-    GL.bindVertexArrayObject $= Just shipVao
+            (cameraFocus camera)
-    liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
+            (V3 0 1 0)
-    ) (planet : ships)
+          model = mkTransformation shipRot shipPos
+          pvm = proj !*! view !*! model
+      liftIO $ GLU.setUniform program "mvp" pvm
+      GL.bindVertexArrayObject $= Just shipVao
+      liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
+      ) ts
 
 handle :: SDL.EventPayload -> Affection StateData ()
 handle (SDL.WindowClosedEvent _) = quit
@@ -117,9 +170,9 @@ handle (SDL.MouseMotionEvent dat) = do
   putAffection sd
     { camera =
       case SDL.mouseMotionEventState dat of
-        [SDL.ButtonRight] ->
+        -- [SDL.ButtonRight] ->
-          let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10))
+        --   let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10))
-          in  c {cameraFocus = cameraFocus c + V3 sx 0 sy}
+        --   in  c {cameraFocus = cameraFocus c + V3 sx 0 sy}
         [] ->
           let dphi = pi / 4 / 45 / 10
               (Euler yaw pitch roll) = cameraRot c
@@ -147,6 +200,17 @@ handle _ = return ()
 
 handleKey :: SDL.Keycode -> Affection StateData ()
 handleKey code
+  | code == SDL.KeycodeTab = do
+      ud <- getAffection
+      let ind = focusIndex ud
+          ps  = planet ud : oplanets ud
+      if ind + 1 < length ps
+      then putAffection ud
+        { focusIndex = ind + 1
+        }
+      else putAffection ud
+        { focusIndex = 0
+        }
   | code == SDL.KeycodeR =
     GL.clearColor $= GL.Color4 1 0 0 1
   | code == SDL.KeycodeG =

examples/example02/Types.hs

@@ -12,11 +12,14 @@ import Physics.Bullet.Raw as Bullet
 data StateData = StateData
   { ships :: [Ship]
   , planet :: Ship
+  , oplanets :: [Ship]
   , camera :: Camera
   , proj :: M44 Float
   , program :: GLU.ShaderProgram
+  , program2 :: GLU.ShaderProgram
   , physics :: Physics
   , physicsObjects :: PhysicsObjects
+  , focusIndex :: Int
   }
 
 data Ship = Ship
@@ -43,6 +46,7 @@ data Physics = Physics
 data PhysicsObjects = PhysicsObjects
   { poBigBall :: PhysBody SphereShape
   , poSmallBalls  :: [PhysBody SphereShape]
+  , poBigBalls  :: [PhysBody SphereShape]
   }
 
 data PhysBody a = PhysBody