diff --git a/examples/example01/Init.hs b/examples/example01/Init.hs new file mode 100644 index 0000000..1a03e1d --- /dev/null +++ b/examples/example01/Init.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Init where + +import SDL (($=)) +import qualified SDL + +import qualified Graphics.Rendering.OpenGL as GL +import qualified Graphics.GLUtil as GLU + +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 + eobj <- fromFile "assets/ships/jaeger/jaeger.obj" + let obj = case eobj of + Right o -> o + Left err -> error err + -- (ptr, len) <- objLocsToPtr obj + -- (tptr, tlen) <- objUVsToPtr obj + let 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 + + 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 lobj) + 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;" + , "}" + ] + fragmentShader = 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);" + , "}" + ] + p <- GLU.simpleShaderProgramBS vertexShader fragmentShader + + phys <- initPhysics + + po <- initPhysicsObjects + + -- mapM_ (addRigidBody (pWorld phys)) (map bodyRigidBody (poBalls po)) + addRigidBody (pWorld phys) (bodyRigidBody $ poBall po) + + return StateData + { ship = Ship shipBO (length $ loTriangles lobj) + (V3 0 0 0) + (Quaternion 1 (V3 0 0 0)) + , proj = perspective (pi/2) (1600 / 900) 1 (-1) + , camera = Camera + { cameraFocus = V3 0 0 0 + , cameraRot = Euler 0 0 0 + , cameraDist = -10 + } + , program = p + , physics = phys + , physicsObjects = po + } + +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 + +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 + } diff --git a/examples/example01/Main.hs b/examples/example01/Main.hs new file mode 100644 index 0000000..6b79660 --- /dev/null +++ b/examples/example01/Main.hs @@ -0,0 +1,178 @@ +{-# 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 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 + { windowInitialSize = SDL.V2 1600 900 + , 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 + GL.currentProgram $= (Just . GLU.program $ program) + (\Ship{..} -> do + let view = lookAt + (cameraFocus camera + + rotVecByEulerB2A + (cameraRot camera) + (V3 0 0 (-cameraDist camera))) + (cameraFocus camera) + (V3 0 1 0) + 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) + ) ship + +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/example01/Types.hs b/examples/example01/Types.hs new file mode 100644 index 0000000..61f5dcc --- /dev/null +++ b/examples/example01/Types.hs @@ -0,0 +1,51 @@ +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 + , camera :: Camera + , proj :: M44 Float + , program :: GLU.ShaderProgram + , physics :: Physics + , physicsObjects :: PhysicsObjects + } + +data Ship = Ship + { shipVao :: GL.VertexArrayObject + , shipVaoLen :: Int + , shipPos :: V3 Float + , shipRot :: Quaternion Float + } + +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/example01/Util.hs b/examples/example01/Util.hs new file mode 100644 index 0000000..91bfac5 --- /dev/null +++ b/examples/example01/Util.hs @@ -0,0 +1,67 @@ +module Util where + +import Codec.Wavefront + +import Control.Monad (sequence) + +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) diff --git a/hw.cabal b/hw.cabal index cb962f5..25170f5 100644 --- a/hw.cabal +++ b/hw.cabal @@ -71,3 +71,28 @@ executable example00 default-language: Haskell2010 ghc-options: -Wall extra-libraries: stdc++ + +executable example01 + 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 + hs-source-dirs: examples/example01 + default-language: Haskell2010 + ghc-options: -Wall + extra-libraries: stdc++ diff --git a/src/Init.hs b/src/Init.hs index 1a03e1d..8a89bbd 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -102,7 +102,7 @@ load = do { ship = Ship shipBO (length $ loTriangles lobj) (V3 0 0 0) (Quaternion 1 (V3 0 0 0)) - , proj = perspective (pi/2) (1600 / 900) 1 (-1) + -- , proj = perspective (pi/2) (1600 / 900) 1 (-1) , camera = Camera { cameraFocus = V3 0 0 0 , cameraRot = Euler 0 0 0 @@ -111,6 +111,7 @@ load = do , program = p , physics = phys , physicsObjects = po + , projection = Perspective (perspective (pi/2) (1600 / 900) 1 (-1)) } loadTex :: FilePath -> IO GL.TextureObject diff --git a/src/Main.hs b/src/Main.hs index 505377d..6abb06f 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -71,6 +71,9 @@ draw = do GL.viewport $= (GL.Position 0 0, GL.Size 1600 900) StateData{..} <- getAffection GL.currentProgram $= (Just . GLU.program $ program) + let proj = case projection of + Ortho m -> m + Perspective m -> m (\Ship{..} -> do let view = lookAt (cameraFocus camera + @@ -149,30 +152,16 @@ handleKey code 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 $ applyTorque - (bodyRigidBody $ poBall $ physicsObjects sd) - torqueimp + | code == SDL.KeycodeO = + toggleOrtho | otherwise = return () + +toggleOrtho :: Affection StateData () +toggleOrtho = do + sd <- getAffection + case projection sd of + Ortho _ -> putAffection sd + { projection = Perspective (perspective (pi/2) (1600 / 900) 1 (-1)) } + Perspective _ -> putAffection sd + { projection = Ortho (ortho (-10) 10 (-5) 5 (-50) 50) } diff --git a/src/Types.hs b/src/Types.hs index 61f5dcc..810f380 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -12,10 +12,11 @@ import Physics.Bullet.Raw as Bullet data StateData = StateData { ship :: Ship , camera :: Camera - , proj :: M44 Float + -- , proj :: M44 Float , program :: GLU.ShaderProgram , physics :: Physics , physicsObjects :: PhysicsObjects + , projection :: Projection } data Ship = Ship @@ -49,3 +50,5 @@ data PhysBody a = PhysBody , bodyMotionState :: MotionState , bodyRigidBody :: RigidBody } + +data Projection = Ortho (M44 Float) | Perspective (M44 Float)