diff --git a/README.md b/README.md index 4b443da..3bd5e94 100644 --- a/README.md +++ b/README.md @@ -16,3 +16,9 @@ you will need some unstable libraries in your sandbox: * [babl](https://github.com/nek0/babl) all other dependencies should be installable through cabal. + +## Building end Executing + +invoke `cabal build` and ignore the warnings… + +The latest experiment can be seen by invoking `./dist/build/hw/hw` diff --git a/examples/example00/Init.hs b/examples/example00/Init.hs new file mode 100644 index 0000000..b79940d --- /dev/null +++ b/examples/example00/Init.hs @@ -0,0 +1,165 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} + +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 System.Random (randomRIO) + +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 + + poss <- mapM (\_ -> do + x <- randomRIO (-50, 50) + y <- randomRIO (-50, 50) + z <- randomRIO (-50, 50) + return (V3 x y z) + ) [0..2000] + + let shipList = map (uncurry $ Ship shipBO (length $ loTriangles lobj)) $ + zip poss (repeat $ Quaternion 1 (V3 0 0 0)) + -- [ (V3 0 0 0, Quaternion 1 (V3 0 0 0)) + -- -- , (V3 3 0 0, Quaternion 1 (V3 0 0 0)) + -- ] + + phys <- initPhysics + + po <- initPhysicsObjects poss + + mapM_ (addRigidBody (pWorld phys)) (map bodyRigidBody (poBalls po)) + addRigidBody (pWorld phys) (bodyRigidBody $ poGround po) + + return StateData + { ships = shipList + , proj = perspective (pi/2) (1600 / 900) 1 (-1) + , camera = Camera + { cameraFocus = V3 0 0 0 + , cameraRot = Euler 0 0 0 + , cameraDist = (-50) + } + , 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 (-10) 0) + return $ Physics bp config disp solver world + +initPhysicsObjects :: [V3 Float] -> IO PhysicsObjects +initPhysicsObjects poss = 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)) + (fmap realToFrac pos) + localInertia <- calculateLocalInertia ball 1 (V3 0 0 0) + ballBody <- newRigidBody 1 ballMotionState 0.9 0.5 ball localInertia + return $ PhysBody ball ballMotionState ballBody + ) poss + + return PhysicsObjects + { poGround = PhysBody ground groundMotionState groundBody + , poBalls = balls + } diff --git a/examples/example00/Main.hs b/examples/example00/Main.hs new file mode 100644 index 0000000..f3df25e --- /dev/null +++ b/examples/example00/Main.hs @@ -0,0 +1,181 @@ +{-# 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 + posrots <- mapM (\ball -> do + ms <- liftIO $ getMotionState ball + npos <- liftIO $ return . fmap realToFrac =<< getPosition ms + nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms + return (npos, nrot) + ) (map bodyRigidBody $ poBalls physos) + let nships = map (\(ship, (pos, rot)) -> + ship + { shipRot = rot + , shipPos = pos + } + ) (zip (ships sd) posrots) + putAffection sd + { ships = nships + } + +draw :: Affection StateData () +draw = do + GL.viewport $= (GL.Position 0 0, GL.Size 1600 900) + (StateData{..}) <- getAffection + GL.currentProgram $= (Just . GLU.program $ program) + mapM_ (\(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) + ) ships + +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) = fmap 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 ship = ships sd !! 0 + rot = shipRot ship + dphi = pi / 2 / 45 + nquat = case code of + SDL.KeycodeW -> rot * axisAngle (V3 1 0 0) (-dphi) + SDL.KeycodeS -> rot * axisAngle (V3 1 0 0) dphi + SDL.KeycodeA -> rot * axisAngle (V3 0 1 0) (-dphi) + SDL.KeycodeD -> rot * axisAngle (V3 0 1 0) dphi + SDL.KeycodeE -> rot * axisAngle (V3 0 0 1) (-dphi) + SDL.KeycodeQ -> rot * axisAngle (V3 0 0 1) dphi + _ -> rot + putAffection sd + { ships = ship + { shipRot = nquat + } : tail (ships sd) + } + | otherwise = + return () diff --git a/examples/example00/Types.hs b/examples/example00/Types.hs new file mode 100644 index 0000000..73d4798 --- /dev/null +++ b/examples/example00/Types.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings, RecordWildCards #-} + +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 + { ships :: [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 + , poBalls :: [PhysBody SphereShape] + } + +data PhysBody a = PhysBody + { bodyShape :: a + , bodyMotionState :: MotionState + , bodyRigidBody :: RigidBody + } diff --git a/examples/example00/Util.hs b/examples/example00/Util.hs new file mode 100644 index 0000000..91bfac5 --- /dev/null +++ b/examples/example00/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 64de382..cb962f5 100644 --- a/hw.cabal +++ b/hw.cabal @@ -39,3 +39,35 @@ executable hw default-language: Haskell2010 ghc-options: -Wall extra-libraries: stdc++ + +flag examples + description: Build testing examples + default: False + +executable example00 + main-is: Main.hs + other-modules: Util + , Types + , Init + -- other-extensions: + default-extensions: OverloadedStrings + if flag(examples) + build-depends: base >=4.9 + , affection + , sdl2 + , linear + , spatial-math + , bytestring + , OpenGL + , OpenGLRaw + , GLUtil + , random + , vector + , wavefront + , shoot + else + buildable: False + hs-source-dirs: examples/example00 + default-language: Haskell2010 + ghc-options: -Wall + extra-libraries: stdc++