trying to make vertex handles

assets/spheres/vertHandle.mtl

@@ -0,0 +1,10 @@
+# Blender MTL File: 'vertHandle.blend'
+# Material Count: 1
+
+newmtl None
+Ns 0
+Ka 0.000000 0.000000 0.000000
+Kd 0.8 0.8 0.8
+Ks 0.8 0.8 0.8
+d 1
+illum 2

assets/spheres/vertHandle.obj

@@ -0,0 +1,58 @@
+# Blender v2.79 (sub 0) OBJ File: 'vertHandle.blend'
+# www.blender.org
+mtllib vertHandle.mtl
+o Icosphere
+v 0.000000 -0.100000 0.000000
+v 0.072360 -0.044721 0.052572
+v -0.027639 -0.044721 0.085064
+v -0.089442 -0.044721 0.000000
+v -0.027639 -0.044721 -0.085064
+v 0.072360 -0.044721 -0.052572
+v 0.027639 0.044721 0.085064
+v -0.072360 0.044721 0.052572
+v -0.072360 0.044721 -0.052572
+v 0.027639 0.044721 -0.085064
+v 0.089442 0.044721 0.000000
+v 0.000000 0.100000 0.000000
+vn 0.1876 -0.7947 0.5774
+vn 0.6071 -0.7947 0.0000
+vn -0.4911 -0.7947 0.3568
+vn -0.4911 -0.7947 -0.3568
+vn 0.1876 -0.7947 -0.5774
+vn 0.9822 -0.1876 0.0000
+vn 0.3035 -0.1876 0.9342
+vn -0.7946 -0.1876 0.5774
+vn -0.7946 -0.1876 -0.5774
+vn 0.3035 -0.1876 -0.9342
+vn 0.7946 0.1876 0.5774
+vn -0.3035 0.1876 0.9342
+vn -0.9822 0.1876 0.0000
+vn -0.3035 0.1876 -0.9342
+vn 0.7946 0.1876 -0.5774
+vn 0.4911 0.7947 0.3568
+vn -0.1876 0.7947 0.5774
+vn -0.6071 0.7947 0.0000
+vn -0.1876 0.7947 -0.5774
+vn 0.4911 0.7947 -0.3568
+usemtl None
+s off
+f 1//1 2//1 3//1
+f 2//2 1//2 6//2
+f 1//3 3//3 4//3
+f 1//4 4//4 5//4
+f 1//5 5//5 6//5
+f 2//6 6//6 11//6
+f 3//7 2//7 7//7
+f 4//8 3//8 8//8
+f 5//9 4//9 9//9
+f 6//10 5//10 10//10
+f 2//11 11//11 7//11
+f 3//12 7//12 8//12
+f 4//13 8//13 9//13
+f 5//14 9//14 10//14
+f 6//15 10//15 11//15
+f 7//16 11//16 12//16
+f 8//17 7//17 12//17
+f 9//18 8//18 12//18
+f 10//19 9//19 12//19
+f 11//20 10//20 12//20

examples/example03/Init.hs

@@ -0,0 +1,171 @@
+{-# 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
+
+load :: IO StateData
+load = do
+  _ <- SDL.setMouseLocationMode SDL.RelativeLocation
+  GL.depthFunc $= Just GL.Less
+
+  (shipBO, sobj, stl) <- genVertBufObject "assets/ships/jaeger/jaeger.obj"
+
+  (vectHandleBO, hobj, vhtl) <- genVertBufObject "assets/spheres/vertHandle.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
+
+  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
+
+  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) {"
+        , "  gl_FragColor = vec4(0,0,0,0.5);"
+        , "}"
+        ]
+
+  handleProgram <- GLU.simpleShaderProgramBS vertexShader fragmentShaderHandle
+  shipProgram   <- GLU.simpleShaderProgramBS vertexShader fragmentShaderShip
+
+  phys <- initPhysics
+
+  po <- initPhysicsObjects
+
+  -- mapM_ (addRigidBody (pWorld phys)) (map bodyRigidBody (poBalls po))
+  addRigidBody (pWorld phys) (bodyRigidBody $ poBall po)
+
+  return StateData
+    { ship = Ship shipBO stl
+      (V3 0 0 0)
+      (Quaternion 1 (V3 0 0 0))
+      (Just t)
+    , vertHandles = createHandles vectHandleBO vhtl (loPoints sobj)
+    , 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
+    , shipProgram = shipProgram
+    , handleProgram = handleProgram
+    }
+
+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 :: IO PhysicsObjects
+initPhysicsObjects = do
+  -- ground <- newStaticPlaneShape (V3 0 1 0) 1
+  ball <- newSphereShape 3
+
+  -- 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
+  ballMotionState <- newDefaultMotionState (Quaternion 1 (V3 0 0 0))
+    (V3 0 0 0)
+  localInertia <- calculateLocalInertia ball 1 (V3 0 0 0)
+  ballBody <- newRigidBody 1 ballMotionState 0 0 ball localInertia
+  setSleepingThresholds ballBody 0 0
+  -- ) poss
+
+  return PhysicsObjects
+    -- { poGround = PhysBody ground groundMotionState groundBody
+    { poBall  = PhysBody ball ballMotionState ballBody
+    }
+
+genVertBufObject :: FilePath -> IO (GL.VertexArrayObject, LoadedObject, Int)
+genVertBufObject path = do
+  eobj <- fromFile path
+  let obj = case eobj of
+        Right o -> o
+        Left err -> error err
+      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) * 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
+  return (shipBO, lobj, length (loTriangles lobj))
+
+createHandles :: GL.VertexArrayObject -> Int -> [Float] -> [Ship]
+createHandles bo len ps =
+  map (\p -> Ship bo len (toPos p) (Quaternion 1 (V3 0 0 0)) Nothing) tris
+  where
+    tris            = chunksOf 3 ps
+    toPos [x, y, z] = V3 x y z
+    toPos _         = error "not triangular"

examples/example03/Main.hs

@@ -0,0 +1,186 @@
+{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+
+module Main where
+
+import Affection
+
+import SDL (($=))
+import qualified SDL
+
+import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.GLUtil as GLU
+
+import Physics.Bullet.Raw
+
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
+
+import qualified Data.ByteString as BS
+
+import Linear as L
+
+import System.Random (randomRIO)
+
+import SpatialMath
+
+import Init
+import Types
+
+import Debug.Trace as T
+
+main :: IO ()
+main =
+  withAffection AffectionConfig
+    { initComponents = All
+    , windowTitle    = "hw"
+    , windowConfig   = SDL.defaultWindow
+      { SDL.windowInitialSize = SDL.V2 1600 900
+      , SDL.windowOpenGL = Just SDL.defaultOpenGL
+        { SDL.glProfile = SDL.Core SDL.Normal 3 2
+        }
+      }
+    , initScreenMode = SDL.Fullscreen
+    , preLoop = return ()
+    , eventLoop = handle
+    , updateLoop = update
+    , drawLoop = draw
+    , loadState = load
+    , cleanUp = const (return ())
+    , canvasSize = Nothing
+    }
+
+update :: Double -> Affection StateData ()
+update dt = do
+  sd <- getAffection
+  let phys = physics sd
+      physos = physicsObjects sd
+  liftIO $ stepSimulation (pWorld phys) dt 10 Nothing
+  (pos, rot) <- do
+    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
+    }
+
+draw :: Affection StateData ()
+draw =
+  do
+    GL.viewport $= (GL.Position 0 0, GL.Size 1600 900)
+    StateData{..} <- getAffection
+    let view = lookAt
+          (cameraFocus camera +
+            rotVecByEulerB2A
+            (cameraRot camera)
+            (V3 0 0 (-cameraDist camera)))
+          (cameraFocus camera)
+          (V3 0 1 0)
+    GL.currentProgram $= (Just . GLU.program $ shipProgram)
+    drawShip shipProgram view ship
+    GL.currentProgram $= (Just . GLU.program $ handleProgram)
+    mapM_ (drawShip shipProgram view) vertHandles
+  where
+    drawShip program view (Ship{..}) = do
+      StateData{..} <- getAffection
+      let 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)
+
+handle :: SDL.EventPayload -> Affection StateData ()
+handle (SDL.WindowClosedEvent _) = quit
+
+handle (SDL.KeyboardEvent dat) = do
+  let key = SDL.keysymKeycode (SDL.keyboardEventKeysym dat)
+  when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
+    handleKey key
+handle (SDL.MouseMotionEvent dat) = do
+  sd <- getAffection
+  let (V2 rx ry) = fromIntegral <$> SDL.mouseMotionEventRelMotion dat
+      c = camera sd
+  putAffection sd
+    { camera =
+      case SDL.mouseMotionEventState dat of
+        [SDL.ButtonRight] ->
+          let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10))
+          in  c {cameraFocus = cameraFocus c + V3 sx 0 sy}
+        [] ->
+          let dphi = pi / 4 / 45 / 10
+              (Euler yaw pitch roll) = cameraRot c
+              nangle
+                | nangle' >= qc = qc - mu
+                | nangle' <= -qc = -qc + mu
+                | otherwise     = nangle'
+                where
+                  nangle' = (dphi * ry) + roll
+                  qc = pi / 2
+                  mu = 0.01
+              nrot =
+                Euler
+                  yaw
+                  (pitch + (rx * dphi))
+                  nangle
+          in  c
+            { cameraRot = nrot
+            }
+        _ ->
+          c
+    }
+
+handle _ = return ()
+
+handleKey :: SDL.Keycode -> Affection StateData ()
+handleKey code
+  | code == SDL.KeycodeR =
+    GL.clearColor $= GL.Color4 1 0 0 1
+  | code == SDL.KeycodeG =
+    GL.clearColor $= GL.Color4 0 1 0 1
+  | code == SDL.KeycodeB =
+    GL.clearColor $= GL.Color4 0 0 1 1
+  | code == SDL.KeycodeP = do
+    r <- liftIO $ randomRIO (0, 1)
+    g <- liftIO $ randomRIO (0, 1)
+    b <- liftIO $ randomRIO (0, 1)
+    a <- liftIO $ randomRIO (0, 1)
+    GL.clearColor $= GL.Color4 r g b a
+  | code == SDL.KeycodeEscape =
+    quit
+  | code == SDL.KeycodeF = do
+    dt <- deltaTime <$> get
+    liftIO $ putStrLn $ show (1 / dt) ++ " FPS"
+  | code == SDL.KeycodeT =
+    toggleScreen
+  -- | code `elem`
+  --   [ SDL.KeycodeW
+  --   , SDL.KeycodeS
+  --   , SDL.KeycodeA
+  --   , SDL.KeycodeD
+  --   , SDL.KeycodeQ
+  --   , SDL.KeycodeE
+  --   ]
+  --   = do
+  --     sd <- getAffection
+  --     let body = bodyRigidBody $ poBall $ physicsObjects sd
+  --     ms <- liftIO $ getMotionState body
+  --     rot <- liftIO $ return . fmap realToFrac =<< getRotation ms
+  --     let tor = 5
+  --         torqueimp = case code of
+  --           SDL.KeycodeW -> rotate rot (V3 (-tor) 0 0) -- (-dphi)
+  --           SDL.KeycodeS -> rotate rot (V3 tor 0 0) -- dphi
+  --           SDL.KeycodeA -> rotate rot (V3 0 (-tor) 0) -- (-dphi)
+  --           SDL.KeycodeD -> rotate rot (V3 0 tor 0) -- dphi
+  --           SDL.KeycodeE -> rotate rot (V3 0 0 (-tor)) -- (-dphi)
+  --           SDL.KeycodeQ -> rotate rot (V3 0 0 tor) -- dphi
+  --           _            -> V3 0 0 0
+  --     liftIO $ applyTorqueImpulse
+  --       (bodyRigidBody $ poBall $ physicsObjects sd)
+  --       torqueimp
+  | otherwise =
+    return ()

examples/example03/Types.hs

@@ -0,0 +1,54 @@
+module Types where
+
+import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.GLUtil as GLU
+
+import Linear as L
+
+import SpatialMath
+
+import Physics.Bullet.Raw as Bullet
+
+data StateData = StateData
+  { ship :: Ship
+  , vertHandles :: [Ship]
+  , camera :: Camera
+  , proj :: M44 Float
+  , physics :: Physics
+  , physicsObjects :: PhysicsObjects
+  , shipProgram :: GLU.ShaderProgram
+  , handleProgram :: GLU.ShaderProgram
+  }
+
+data Ship = Ship
+  { shipVao     :: GL.VertexArrayObject
+  , shipVaoLen  :: Int
+  , shipPos     :: V3 Float
+  , shipRot     :: Quaternion Float
+  , shipTexture :: Maybe GL.TextureObject
+  }
+
+data Camera = Camera
+  { cameraFocus :: V3 Float
+  , cameraRot :: Euler Float
+  , cameraDist :: Float
+  }
+
+data Physics = Physics
+  { pBroadphase :: DbvtBroadphase
+  , pConfig     :: DefaultCollisionConfiguration
+  , pDispatcher :: CollisionDispatcher
+  , pSolver     :: SequentialImpulseConstraintSolver
+  , pWorld      :: DiscreteDynamicsWorld
+  }
+
+data PhysicsObjects = PhysicsObjects
+  -- { poGround :: PhysBody StaticPlaneShape
+  { poBall   :: PhysBody SphereShape
+  }
+
+data PhysBody a = PhysBody
+  { bodyShape       :: a
+  , bodyMotionState :: MotionState
+  , bodyRigidBody   :: RigidBody
+  }

examples/example03/Util.hs

@@ -0,0 +1,79 @@
+module Util where
+
+import Codec.Wavefront
+
+import Control.Monad (sequence)
+
+import SDL (($=))
+
+import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.GLUtil as GLU
+
+import qualified Data.Vector as V
+
+data LoadedObject = LoadedObject
+  { loTriangles :: [Float]
+  , loLines     :: [Float]
+  , loPoints    :: [Float]
+  , loTexTri    :: Maybe [Float]
+  }
+
+loadObj :: WavefrontOBJ -> LoadedObject
+loadObj obj =
+  LoadedObject ts ls ps tritex
+  where
+    inter = objLocations obj
+    interTex = objTexCoords obj
+    faces = map elValue (V.toList $ objFaces obj)
+    lns = map elValue (V.toList $ objLines obj)
+    points = map elValue (V.toList $ objPoints obj)
+    deface (Face a b c []) =
+      map (\i -> inter V.! (faceLocIndex i -1)) [a, b, c]
+    deface _ =
+      error "loadObj: obj with quads encountered"
+    deline (Line a b) =
+      map (\i -> inter V.! (lineLocIndex i -1)) [a, b]
+    depoint (Point i) = inter V.! (i - 1)
+    tsLocs = concatMap deface faces
+    lsLocs = concatMap deline lns
+    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
+    defaceTex :: Face -> Maybe [TexCoord]
+    defaceTex (Face a b c []) =
+      mapM
+      (fmap (\x -> interTex V.! (x - 1)) . faceTexCoordIndex)
+      [a, b, c]
+    defaceTex _ =
+      error "loadObj: obj with quads encountered"
+    tritex :: Maybe [Float]
+    tritex = concatMap deTex <$> mftxs
+    mftxs :: Maybe [TexCoord]
+    mftxs = fmap concat (mapM defaceTex faces)
+
+-- objLocsToPtr :: WavefrontOBJ -> IO (Ptr Float, Int)
+-- objLocsToPtr obj = do
+--   let ivs = objLocations obj
+--       faces = map elValue $ V.toList $ objFaces obj
+--       vs = concatMap
+--         (\(Face a b c []) ->
+--           map (\i -> ivs V.! ((faceLocIndex i) - 1)) [a, b, c])
+--         faces
+--   ptr <- newArray $ concatMap (\(Location x y z w) -> [x, y, z, w]) vs
+--   return (ptr, length vs)
+-- 
+-- objUVsToPtr :: WavefrontOBJ -> IO (Ptr Float, Int)
+-- objUVsToPtr obj = do
+--   let uvs= V.toList $ objTexCoords obj
+--   ptr <- newArray $ concatMap (\(TexCoord r s t) -> [r, s, t]) uvs
+--   return (ptr, length uvs)
+
+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

hw.cabal

@@ -121,3 +121,29 @@ executable example02
   default-language:    Haskell2010
   ghc-options:         -Wall
   extra-libraries:     stdc++
+
+executable example03
+  main-is:             Main.hs
+  other-modules:       Util
+                     , Types
+                     , Init
+  -- other-extensions:    
+  default-extensions:  OverloadedStrings
+  build-depends:       base >=4.9
+                     , affection
+                     , sdl2
+                     , linear
+                     , spatial-math
+                     , bytestring
+                     , OpenGL
+                     , OpenGLRaw
+                     , GLUtil
+                     , random
+                     , vector
+                     , wavefront
+                     , shoot
+                     , split
+  hs-source-dirs:      examples/example03
+  default-language:    Haskell2010
+  ghc-options:         -Wall
+  extra-libraries:     stdc++