diff --git a/assets/spheres/vertHandle.blend b/assets/spheres/vertHandle.blend new file mode 100644 index 0000000..0f517db Binary files /dev/null and b/assets/spheres/vertHandle.blend differ diff --git a/assets/spheres/vertHandle.mtl b/assets/spheres/vertHandle.mtl new file mode 100644 index 0000000..9ce65d9 --- /dev/null +++ b/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 diff --git a/assets/spheres/vertHandle.obj b/assets/spheres/vertHandle.obj new file mode 100644 index 0000000..c1b2e6a --- /dev/null +++ b/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 diff --git a/examples/example03/Init.hs b/examples/example03/Init.hs new file mode 100644 index 0000000..217d2fb --- /dev/null +++ b/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" diff --git a/examples/example03/Main.hs b/examples/example03/Main.hs new file mode 100644 index 0000000..8a2b01e --- /dev/null +++ b/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 () diff --git a/examples/example03/Types.hs b/examples/example03/Types.hs new file mode 100644 index 0000000..4dacd93 --- /dev/null +++ b/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 + } diff --git a/examples/example03/Util.hs b/examples/example03/Util.hs new file mode 100644 index 0000000..130400a --- /dev/null +++ b/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 diff --git a/hw.cabal b/hw.cabal index 4a44ade..4767bbf 100644 --- a/hw.cabal +++ b/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++