hw/src/Main.hs

173 lines
4.6 KiB
Haskell
Raw Normal View History

2017-09-11 03:08:08 +00:00
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
2017-09-09 14:39:41 +00:00
module Main where
import Affection
import SDL (($=))
import qualified SDL
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU
2017-09-19 15:27:49 +00:00
import Physics.Bullet.Raw
2017-09-09 14:39:41 +00:00
2017-09-19 15:27:49 +00:00
import Control.Monad (when)
2017-11-03 00:33:12 +00:00
import Control.Monad.IO.Class (liftIO)
2017-09-09 14:39:41 +00:00
import Linear as L
import System.Random (randomRIO)
2017-09-19 15:27:49 +00:00
import SpatialMath
2017-09-09 14:39:41 +00:00
2017-09-19 15:27:49 +00:00
import Init
import Types
2017-09-09 14:39:41 +00:00
2017-09-19 15:27:49 +00:00
import Debug.Trace as T
2017-09-09 14:39:41 +00:00
main :: IO ()
main =
withAffection AffectionConfig
{ initComponents = All
, windowTitle = "hw"
2020-01-05 14:07:27 +00:00
, windowConfigs =
[ ( 0
, SDL.defaultWindow
{ SDL.windowInitialSize = SDL.V2 1600 900
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 3
}
}
)
]
2017-09-11 03:08:08 +00:00
, initScreenMode = SDL.Fullscreen
2017-09-09 14:39:41 +00:00
, preLoop = return ()
2018-05-17 19:59:22 +00:00
, eventLoop = mapM_ handle
2017-09-09 14:39:41 +00:00
, updateLoop = update
, drawLoop = draw
, loadState = load
, cleanUp = const (return ())
, canvasSize = Nothing
}
update :: Double -> Affection StateData ()
2017-09-19 15:27:49 +00:00
update dt = do
sd <- getAffection
let phys = physics sd
physos = physicsObjects sd
liftIO $ stepSimulation (pWorld phys) dt 10 Nothing
2017-09-21 08:28:42 +00:00
(pos, rot) <- do
ms <- liftIO $ getMotionState (bodyRigidBody $ poBall physos)
2017-09-21 10:27:17 +00:00
npos <- liftIO $ return . fmap realToFrac =<< getPosition ms
nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
2017-09-19 15:27:49 +00:00
return (npos, nrot)
2017-09-21 08:28:42 +00:00
let nship =
(ship sd)
2017-09-19 15:27:49 +00:00
{ shipRot = rot
, shipPos = pos
}
putAffection sd
2017-09-21 08:28:42 +00:00
{ ship = nship
2017-09-19 15:27:49 +00:00
}
2017-09-09 14:39:41 +00:00
draw :: Affection StateData ()
draw = do
2017-09-11 03:08:08 +00:00
GL.viewport $= (GL.Position 0 0, GL.Size 1600 900)
2017-09-21 08:44:02 +00:00
StateData{..} <- getAffection
2017-09-11 03:08:08 +00:00
GL.currentProgram $= (Just . GLU.program $ program)
2017-09-29 20:06:20 +00:00
let proj = case projection of
Ortho m -> m
Perspective m -> m
2017-09-21 08:44:02 +00:00
(\Ship{..} -> do
2017-09-11 03:08:08 +00:00
let view = lookAt
(cameraFocus camera +
2017-09-21 08:44:02 +00:00
rotVecByEulerB2A
2017-09-11 03:08:08 +00:00
(cameraRot camera)
2017-09-21 08:44:02 +00:00
(V3 0 0 (-cameraDist camera)))
2017-09-11 03:08:08 +00:00
(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)
2017-09-21 08:28:42 +00:00
) ship
2017-09-09 14:39:41 +00:00
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
2017-09-11 03:08:08 +00:00
handle (SDL.MouseMotionEvent dat) = do
sd <- getAffection
2017-09-21 08:44:02 +00:00
let (V2 rx ry) = fromIntegral <$> SDL.mouseMotionEventRelMotion dat
2017-09-11 03:08:08 +00:00
c = camera sd
putAffection sd
{ camera =
case SDL.mouseMotionEventState dat of
[SDL.ButtonRight] ->
2017-09-19 15:27:49 +00:00
let (V3 sx sy sz) = rotVecByEuler (cameraRot c) (V3 (rx / 10) 0 (ry / 10))
2017-09-21 08:44:02 +00:00
in c {cameraFocus = cameraFocus c + V3 sx 0 sy}
2017-09-11 03:08:08 +00:00
[] ->
2017-09-19 15:27:49 +00:00
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
2017-09-11 03:08:08 +00:00
in c
2017-09-19 15:27:49 +00:00
{ cameraRot = nrot
2017-09-11 03:08:08 +00:00
}
_ ->
c
}
2017-09-09 14:39:41 +00:00
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
2017-09-29 20:06:20 +00:00
| code == SDL.KeycodeO =
toggleOrtho
2017-09-09 14:39:41 +00:00
| otherwise =
return ()
2017-09-29 20:06:20 +00:00
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) }