hw/examples/example03/Main.hs

235 lines
6.6 KiB
Haskell
Raw Normal View History

2017-11-12 16:10:47 +00:00
{-# 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 Control.Monad.IO.Class (liftIO)
import qualified Data.ByteString as BS
import Linear as L
import System.Random (randomRIO)
import SpatialMath
2017-11-19 17:27:09 +00:00
import Options.Applicative
import Data.Semigroup ((<>))
2017-11-12 16:10:47 +00:00
import Init
import Types
2017-11-19 17:27:09 +00:00
import Foreign.C.Types (CInt(..))
2017-11-12 16:10:47 +00:00
import Debug.Trace as T
2017-11-19 17:27:09 +00:00
opts :: Parser Opts
opts = Opts
<$> option auto
( long "width"
<> short 'w'
<> value 1600
<> showDefault
<> metavar "NUM"
<> help "Screen width"
)
<*> option auto
( long "height"
<> short 'h'
<> value 900
<> showDefault
<> metavar "NUM"
<> help "Screen height"
)
2017-11-12 16:10:47 +00:00
main :: IO ()
2017-11-19 17:27:09 +00:00
main = do
o <- execParser $ info opts
( fullDesc
<> progDesc "sample for hw game"
)
2017-11-12 16:10:47 +00:00
withAffection AffectionConfig
{ initComponents = All
, windowTitle = "hw"
, windowConfig = SDL.defaultWindow
2017-11-19 17:27:09 +00:00
{ SDL.windowInitialSize = SDL.V2
(CInt $ fromIntegral $ width o)
(CInt $ fromIntegral $ height o)
2017-11-12 16:10:47 +00:00
, SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
}
}
, initScreenMode = SDL.Fullscreen
, preLoop = return ()
2018-05-17 19:59:22 +00:00
, eventLoop = mapM_ handle
2017-11-12 16:10:47 +00:00
, updateLoop = update
2017-11-19 17:27:09 +00:00
, drawLoop = draw (width o) (height o)
, loadState = load (width o) (height o)
2017-11-12 16:10:47 +00:00
, 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
2017-11-18 10:02:55 +00:00
nvhs <- mapM (\(smallBall, vh) -> do
ms1 <- liftIO $ getMotionState (bodyRigidBody smallBall)
r1 <- liftIO $ return . fmap realToFrac =<< getPosition ms1
return vh
{ shipPos = r1
}
) (zip (poBalls physos) (vertHandles sd))
-- (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
-- }
2017-11-12 16:10:47 +00:00
putAffection sd
2017-11-18 10:02:55 +00:00
{ -- ship = nship
vertHandles = nvhs
2017-11-12 16:10:47 +00:00
}
2017-11-19 17:27:09 +00:00
draw :: Word -> Word -> Affection StateData ()
draw w h =
2017-11-12 16:10:47 +00:00
do
2017-11-19 17:27:09 +00:00
GL.viewport $= (GL.Position 0 0, GL.Size (fromIntegral w) (fromIntegral h))
2017-11-12 16:10:47 +00:00
StateData{..} <- getAffection
let view = lookAt
(cameraFocus camera +
rotVecByEulerB2A
(cameraRot camera)
(V3 0 0 (-cameraDist camera)))
(cameraFocus camera)
(V3 0 1 0)
drawShip shipProgram view ship
2017-11-16 18:48:11 +00:00
mapM_ (drawShip handleProgram view) vertHandles
2017-11-12 16:10:47 +00:00
where
drawShip program view (Ship{..}) = do
StateData{..} <- getAffection
2017-11-16 18:48:11 +00:00
GL.currentProgram $= (Just . GLU.program $ program)
2017-11-12 16:10:47 +00:00
let model = mkTransformation shipRot shipPos
pvm = proj !*! view !*! model
liftIO $ GLU.setUniform program "mvp" pvm
GL.bindVertexArrayObject $= Just shipVao
2017-11-16 18:48:11 +00:00
GL.bindBuffer GL.ArrayBuffer $= shipUVs
2017-11-12 16:10:47 +00:00
liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
2017-11-16 18:48:11 +00:00
GL.currentProgram $= Nothing
GL.bindBuffer GL.ArrayBuffer $= Nothing
GL.bindVertexArrayObject $= Nothing
2017-11-12 16:10:47 +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
handle (SDL.MouseMotionEvent dat) = do
sd <- getAffection
2017-11-18 21:11:44 +00:00
curMode <- SDL.getMouseLocationMode
2017-11-12 16:10:47 +00:00
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}
[] ->
2017-11-18 21:11:44 +00:00
if curMode == SDL.RelativeLocation
then
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
}
else
c
2017-11-12 16:10:47 +00:00
_ ->
c
}
handle _ = return ()
handleKey :: SDL.Keycode -> Affection StateData ()
handleKey code
2017-11-18 21:11:44 +00:00
| code == SDL.KeycodeR = do
curMode <- SDL.getMouseLocationMode
if curMode == SDL.AbsoluteLocation
then do
_ <- SDL.setMouseLocationMode SDL.RelativeLocation
return ()
else do
_ <- SDL.setMouseLocationMode SDL.AbsoluteLocation
return ()
2017-11-12 16:10:47 +00:00
| 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 ()