trying to make vertex handles

This commit is contained in:
nek0 2017-11-12 17:10:47 +01:00
parent b98541a76d
commit c833fc847c
8 changed files with 584 additions and 0 deletions

Binary file not shown.

View file

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

View file

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

171
examples/example03/Init.hs Normal file
View file

@ -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"

186
examples/example03/Main.hs Normal file
View file

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

View file

@ -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
}

View file

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

View file

@ -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++