hw/examples/example00/Main.hs

195 lines
5.6 KiB
Haskell

{-# 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.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
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"
, windowConfigs =
[ ( 0
, SDL.defaultWindow
{ SDL.windowInitialSize = SDL.V2 1600 900
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.glProfile = SDL.Compatibility SDL.Debug 4 0
}
}
, SDL.Fullscreen
)
]
} :: AffectionConfig StateData)
instance Affectionate StateData where
loadState = load
preLoop _ = return ()
handleEvents sd = mapM_ (handle sd)
update = Main.update
draw = Main.draw
cleanUp = const (return ())
hasNextStep = liftIO . readTVarIO . quitGame
quit = liftIO . atomically . (\sd -> writeTVar (quitGame sd) False)
update :: StateData -> Double -> Affection ()
update sd dt = do
let phys = physics sd
physos = physicsObjects sd
(phys, physos) <- liftIO $ atomically $
(,)
<$> readTVar (physics sd)
<*> readTVar (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))
. bodyRigidBody) (poBalls physos)
let nships shipss = map (\(ship, (pos, rot)) ->
ship
{ shipRot = rot
, shipPos = pos
}
) (zip shipss posrots)
liftIO $ atomically $ modifyTVar (ships sd) $ \shs -> nships shs
draw :: StateData -> Affection ()
draw sd = do
(cam, p, ships, program) <- liftIO $ do
cam <- readTVarIO (camera sd)
p <- readTVarIO (proj sd)
ships <- readTVarIO (ships sd)
program <- readTVarIO (program sd)
return (cam, p, ships, program)
GL.viewport $= (GL.Position 0 0, GL.Size 1600 900)
GL.currentProgram $= (Just . GLU.program $ program)
mapM_ (\Ship{..} -> do
let view = lookAt
(cameraFocus cam +
rotVecByEulerB2A
(cameraRot cam)
(V3 0 0 (-cameraDist cam)))
(cameraFocus cam)
(V3 0 1 0)
model = mkTransformation shipRot shipPos
pvm = p !*! view !*! model
liftIO $ GLU.setUniform program "mvp" pvm
GL.bindVertexArrayObject $= Just shipVao
liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
) ships
handle :: StateData -> SDL.EventPayload -> Affection ()
handle sd (SDL.WindowClosedEvent _) = quit sd
handle sd (SDL.KeyboardEvent dat) = do
let key = SDL.keysymKeycode (SDL.keyboardEventKeysym dat)
when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
handleKey sd key
handle sd (SDL.MouseMotionEvent dat) = do
let (V2 rx ry) = fromIntegral <$> SDL.mouseMotionEventRelMotion dat
liftIO $ atomically $ modifyTVar (camera sd) $ \c ->
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 :: StateData -> SDL.Keycode -> Affection ()
handleKey sd 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 sd
| code == SDL.KeycodeF = do
dt <- deltaTime <$> get
liftIO $ putStrLn $ show (1 / dt) ++ " FPS"
| code == SDL.KeycodeT =
toggleScreen 0
| code `elem`
[ SDL.KeycodeW
, SDL.KeycodeS
, SDL.KeycodeA
, SDL.KeycodeD
, SDL.KeycodeQ
, SDL.KeycodeE
]
= do
shipss <- liftIO $ atomically $ readTVar (ships sd)
let ship = head shipss
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
liftIO $ atomically $ modifyTVar (ships sd) $ \shipss ->
ship
{ shipRot = nquat
} : tail shipss
| otherwise =
return ()