214 lines
6 KiB
Haskell
214 lines
6 KiB
Haskell
![]() |
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
||
|
module Main where
|
||
|
|
||
|
import Affection
|
||
|
|
||
|
import SDL (($=))
|
||
|
import qualified SDL
|
||
|
|
||
|
import qualified Graphics.Rendering.OpenGL as GL
|
||
|
import qualified Graphics.GLUtil as GLU
|
||
|
import qualified Graphics.GLUtil.Camera3D as GLU (projectionMatrix)
|
||
|
|
||
|
import Control.Monad (when)
|
||
|
|
||
|
import qualified Data.ByteString as BS
|
||
|
|
||
|
import Codec.Wavefront
|
||
|
|
||
|
import Linear as L
|
||
|
|
||
|
import System.Random (randomRIO)
|
||
|
|
||
|
import Foreign
|
||
|
|
||
|
import Util
|
||
|
|
||
|
import Debug.Trace
|
||
|
|
||
|
main :: IO ()
|
||
|
main =
|
||
|
withAffection AffectionConfig
|
||
|
{ initComponents = All
|
||
|
, windowTitle = "hw"
|
||
|
, windowConfig = SDL.defaultWindow
|
||
|
{ windowInitialSize = SDL.V2 800 600
|
||
|
, windowOpenGL = Just SDL.defaultOpenGL
|
||
|
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
|
||
|
}
|
||
|
}
|
||
|
, initScreenMode = SDL.Windowed
|
||
|
, preLoop = return ()
|
||
|
, eventLoop = handle
|
||
|
, updateLoop = update
|
||
|
, drawLoop = draw
|
||
|
, loadState = load
|
||
|
, cleanUp = const (return ())
|
||
|
, canvasSize = Nothing
|
||
|
}
|
||
|
|
||
|
data StateData = StateData
|
||
|
{ ship :: (GL.VertexArrayObject, Int)
|
||
|
, proj :: M44 Float
|
||
|
, view :: M44 Float
|
||
|
, model :: V3 Float
|
||
|
, program :: GLU.ShaderProgram
|
||
|
, mrot :: Quaternion Float
|
||
|
}
|
||
|
|
||
|
load :: IO StateData
|
||
|
load = do
|
||
|
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) {"
|
||
|
-- , " gl_FragColor = vec4(color, 1.0);"
|
||
|
-- , " gl_FragColor = vec4(1.0);"
|
||
|
, " vec2 flip = vec2(f_texcoord.x, 1.0 - f_texcoord.y);"
|
||
|
, " gl_FragColor = texture2D(texture, flip);"
|
||
|
, "}"
|
||
|
]
|
||
|
p <- GLU.simpleShaderProgramBS vertexShader fragmentShader
|
||
|
|
||
|
return StateData
|
||
|
{ ship = (shipBO, length $ loTriangles lobj)
|
||
|
, proj = GLU.projectionMatrix (pi/2) (800 / 600) 1 (-1)
|
||
|
, view = lookAt (V3 0 2 0) (V3 0 0 (-4)) (V3 0 1 0)
|
||
|
, model = V3 0 0 (-5)
|
||
|
, program = p
|
||
|
, mrot = Quaternion 1 (V3 0 0 0)
|
||
|
}
|
||
|
|
||
|
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
|
||
|
|
||
|
update :: Double -> Affection StateData ()
|
||
|
update _ = return ()
|
||
|
|
||
|
draw :: Affection StateData ()
|
||
|
draw = do
|
||
|
GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
|
||
|
(StateData (shipbo, slen) p v m s rot) <- getAffection
|
||
|
let pvm = p !*! v !*! mkTransformation rot m
|
||
|
liftIO $ GLU.setUniform s "mvp" pvm
|
||
|
GL.currentProgram $= (Just . GLU.program $ s)
|
||
|
GL.bindVertexArrayObject $= Just shipbo
|
||
|
liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral slen)
|
||
|
|
||
|
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 _ = 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 rot = mrot sd
|
||
|
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
|
||
|
{ mrot = nquat
|
||
|
}
|
||
|
| otherwise =
|
||
|
return ()
|