make make

assets/spheres/vertHandle.obj

@@ -2,18 +2,18 @@
 # www.blender.org
 mtllib vertHandle.mtl
 o Icosphere
-v 0.000000 -0.100000 0.000000
+v 0.000000 -0.050000 0.000000
-v 0.072360 -0.044721 0.052572
+v 0.036180 -0.022361 0.026286
-v -0.027639 -0.044721 0.085064
+v -0.013819 -0.022361 0.042532
-v -0.089442 -0.044721 0.000000
+v -0.044721 -0.022361 0.000000
-v -0.027639 -0.044721 -0.085064
+v -0.013819 -0.022361 -0.042532
-v 0.072360 -0.044721 -0.052572
+v 0.036180 -0.022361 -0.026286
-v 0.027639 0.044721 0.085064
+v 0.013819 0.022361 0.042532
-v -0.072360 0.044721 0.052572
+v -0.036180 0.022361 0.026286
-v -0.072360 0.044721 -0.052572
+v -0.036180 0.022361 -0.026286
-v 0.027639 0.044721 -0.085064
+v 0.013819 0.022361 -0.042532
-v 0.089442 0.044721 0.000000
+v 0.044721 0.022361 0.000000
-v 0.000000 0.100000 0.000000
+v 0.000000 0.050000 0.000000
 vn 0.1876 -0.7947 0.5774
 vn 0.6071 -0.7947 0.0000
 vn -0.4911 -0.7947 0.3568

examples/example03/Init.hs

@@ -23,6 +23,7 @@ import Foreign
 
 import Util
 import Types
+import Logging as LL
 
 import Debug.Trace
 
@@ -92,12 +93,14 @@ load = do
 
   phys <- initPhysics
 
-  po <- initPhysicsObjects
+  po <- initPhysicsObjects (map listToPos $ chunksOf 4 $ loLocations sobj)
 
   -- traceIO $ show $ loLines sobj
 
   -- mapM_ (addRigidBody (pWorld phys)) (map bodyRigidBody (poBalls po))
-  addRigidBody (pWorld phys) (bodyRigidBody $ poBall po)
+  mapM_ (\b -> addRigidBody (pWorld phys) (bodyRigidBody b)) (poBalls po)
+
+  logIO Debug "Hello world"
 
   return StateData
     { ship = (Ship svao stl
@@ -105,7 +108,7 @@ load = do
       (Quaternion 1 (V3 0 0 0))
       (Just t)
       (Just texture))
-    , vertHandles = createHandles hvao vhtl (loTriangles sobj)
+    , vertHandles = createHandles hvao vhtl (loLocations sobj)
     , proj = perspective (pi/2) (1600 / 900) 1 (-1)
     , camera = Camera
       { cameraFocus = V3 0 0 0
@@ -128,25 +131,26 @@ initPhysics = do
   setGravity world (V3 0 0 0)
   return $ Physics bp config disp solver world
 
-initPhysicsObjects :: IO PhysicsObjects
+initPhysicsObjects :: [V3 Float] -> IO PhysicsObjects
-initPhysicsObjects = do
+initPhysicsObjects poss = do
   -- ground <- newStaticPlaneShape (V3 0 1 0) 1
-  ball <- newSphereShape 3
+  ball <- newSphereShape 0.05
 
   -- 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)
 
-  -- balls <- mapM (\pos -> do
+  balls <- mapM (\pos -> do
-  ballMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
+    ballMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
-    (V3 0 0 0)
+      (fmap realToFrac pos)
-  localInertia <- calculateLocalInertia ball 1 (V3 0 0 0)
+    localInertia <- calculateLocalInertia ball 1 (V3 0 0 0)
-  ballBody <- newRigidBody 1 ballMotionState 0 0 ball localInertia
+    ballBody <- newRigidBody 0 ballMotionState 0 0 ball localInertia
-  setSleepingThresholds ballBody 0 0
+    setSleepingThresholds ballBody 0 0
-  -- ) poss
+    return $ PhysBody ball ballMotionState ballBody
+    ) poss
 
   return PhysicsObjects
     -- { poGround = PhysBody ground groundMotionState groundBody
-    { poBall  = PhysBody ball ballMotionState ballBody
+    { poBalls = balls
     }
 
 genVertBufObject :: FilePath -> IO (GL.BufferObject, LoadedObject, Int)
@@ -174,8 +178,10 @@ genVertBufObject path = do
 
 createHandles :: GL.VertexArrayObject -> Int -> [Float] -> [Ship]
 createHandles bo len ps =
-  map (\p -> Ship bo len (toPos p) (Quaternion 1 (V3 0 0 0)) Nothing Nothing) tris
+  map (\p -> Ship bo len (listToPos p) (Quaternion 1 (V3 0 0 0)) Nothing Nothing) tris
   where
-    tris            = chunksOf 3 ps
+    tris               = chunksOf 4 ps
-    toPos [x, y, z] = V3 x y z
+
-    toPos _         = error "not triangular"
+listToPos :: [Float] -> V3 Float
+listToPos [x, y, z, _] = V3 x y z
+listToPos _            = error "listToPos: not triangular coordinates encountered"

examples/example03/Logging.hs

@@ -0,0 +1,37 @@
+{-# LANGUAGE CPP #-}
+module Logging where
+
+import Debug.Trace
+
+data LogLevel
+  = Debug
+  | Warn
+  | Error
+
+log :: LogLevel -> String -> a -> a
+#if defined(DEBUG)
+log Debug s = trace ("DEBUG: " ++ s)
+#endif
+#if defined(WARN) || defined(DEBUG)
+log Warn s = trace ("WARN: " ++ s)
+#endif
+#if defined(ERROR) || defined(WARN) || defined(DEBUG)
+log Error s = trace ("ERROR: " ++ s)
+#endif
+#if !(defined(ERROR) && defined(WARN) && defined(DEBUG)) || !defined(DEBUG)
+log _ _ = id
+#endif
+
+logIO :: LogLevel -> String -> IO ()
+#if defined(DEBUG)
+logIO Debug s = traceIO ("DEBUG: " ++ s)
+#endif
+#if defined(WARN) || defined(DEBUG)
+logIO Warn s = traceIO ("WARN: " ++ s)
+#endif
+#if defined(ERROR) || defined(WARN) || defined(DEBUG)
+logIO Error s = traceIO ("ERROR: " ++ s)
+#endif
+#if !(defined(ERROR) && defined(WARN) && defined(DEBUG)) || !defined(DEBUG)
+logIO _ _ = return ()
+#endif

examples/example03/Main.hs

@@ -55,18 +55,26 @@ update dt = do
   let phys = physics sd
       physos = physicsObjects sd
   liftIO $ stepSimulation (pWorld phys) dt 10 Nothing
-  (pos, rot) <- do
+  nvhs <- mapM (\(smallBall, vh) -> do
-    ms <- liftIO $ getMotionState (bodyRigidBody $ poBall physos)
+    ms1 <- liftIO $ getMotionState (bodyRigidBody smallBall)
-    npos <- liftIO $ return . fmap realToFrac =<< getPosition ms
+    r1 <- liftIO $ return . fmap realToFrac =<< getPosition ms1
-    nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
+    return vh
-    return (npos, nrot)
+      { shipPos = r1
-  let nship =
+      }
-        (ship sd)
+    ) (zip (poBalls physos) (vertHandles sd))
-          { shipRot = rot
+  -- (pos, rot) <- do
-          , shipPos = pos
+  --   ms <- liftIO $ getMotionState (bodyRigidBody $ poBall physos)
-          }
+  --   npos <- liftIO $ return . fmap realToFrac =<< getPosition ms
+  --   nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
+  --   return (npos, nrot)
+  -- let nship =
+  --       (ship sd)
+  --         { shipRot = rot
+  --         , shipPos = pos
+  --         }
   putAffection sd
-    { ship = nship
+    { -- ship = nship
+      vertHandles = nvhs
     }
 
 draw :: Affection StateData ()

examples/example03/Types.hs

@@ -45,7 +45,7 @@ data Physics = Physics
 
 data PhysicsObjects = PhysicsObjects
   -- { poGround :: PhysBody StaticPlaneShape
-  { poBall   :: PhysBody SphereShape
+  { poBalls   :: [PhysBody SphereShape]
   }
 
 data PhysBody a = PhysBody

examples/example03/Util.hs

@@ -17,19 +17,19 @@ data LoadedObject = LoadedObject
   { loTriangles :: [Float]
   , loLines     :: [Float]
   , loPoints    :: [Float]
+  , loLocations :: [Float]
   , loTexTri    :: Maybe [Float]
   } deriving (Show)
 
 loadObj :: WavefrontOBJ -> LoadedObject
 loadObj obj =
-  LoadedObject ts ls ps tritex
+  LoadedObject ts ls ps locs tritex
   where
     inter = objLocations obj
     interTex = objTexCoords obj
     faces = map elValue (V.toList $ objFaces obj)
     lns = map elValue (V.toList $ objLines obj)
-    points = trace (show $ map elValue (V.toList $ objPoints obj))
+    points = map elValue (V.toList $ objPoints obj)
-      (map elValue (V.toList $ objPoints obj))
     deface (Face a b c []) =
       map (\i -> inter V.! (faceLocIndex i -1)) [a, b, c]
     deface _ =
@@ -39,12 +39,13 @@ loadObj obj =
     depoint (Point i) = inter V.! (i - 1)
     tsLocs = concatMap deface faces
     lsLocs = concatMap deline lns
-    psLocs = map depoint (trace (show points) points)
+    psLocs = map depoint points
     deLoc (Location x y z w) = [x, y, z, w]
     deTex (TexCoord r s _) = [r, s]
     ts = concatMap deLoc tsLocs
     ls = concatMap deLoc lsLocs
     ps = concatMap deLoc psLocs
+    locs = concatMap deLoc (V.toList inter)
     defaceTex :: Face -> Maybe [TexCoord]
     defaceTex (Face a b c []) =
       mapM

hw.cabal

@@ -15,6 +15,21 @@ build-type:          Simple
 extra-source-files:  ChangeLog.md
 cabal-version:       >=1.10
 
+flag debug
+  description:       Enable debug messages
+  default:           False
+  manual:            True
+
+flag warn
+  description:       Enable warning messages
+  default:           False
+  manual:            True
+
+flag error
+  description:       Enable error messages
+  default:           False
+  manual:            True
+
 executable hw
   main-is:             Main.hs
   other-modules:       Util
@@ -123,10 +138,17 @@ executable example02
   extra-libraries:     stdc++
 
 executable example03
+  if flag(debug)
+    cpp-options:       -DDEBUG
+  if flag(warn)
+    cpp-options:       -DWARN
+  if flag(error)
+    cpp-options:       -DERROR
   main-is:             Main.hs
   other-modules:       Util
                      , Types
                      , Init
+                     , Logging
   -- other-extensions:    
   default-extensions:  OverloadedStrings
   build-depends:       base >=4.9