Browse Source

modernize some examples

master
nek0 1 month ago
parent
commit
9e13158141
  1. 20
      examples/example00/Init.hs
  2. 158
      examples/example00/Main.hs
  3. 15
      examples/example00/Types.hs
  4. 28
      examples/example02/Init.hs
  5. 186
      examples/example02/Main.hs
  6. 23
      examples/example02/Types.hs
  7. 4
      hw.cabal

20
examples/example00/Init.hs

@ -5,6 +5,8 @@ module Init where
import SDL (($=))
import qualified SDL
import Control.Concurrent.STM
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU
@ -111,18 +113,18 @@ load = do
mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBalls po)
addRigidBody (pWorld phys) (bodyRigidBody $ poGround po)
return StateData
{ ships = shipList
, proj = perspective (pi/2) (1600 / 900) 1 (-1)
, camera = Camera
StateData
<$> newTVarIO shipList
<*> newTVarIO (Camera
{ cameraFocus = V3 0 0 0
, cameraRot = Euler 0 0 0
, cameraDist = -50
}
, program = p
, physics = phys
, physicsObjects = po
}
})
<*> newTVarIO (perspective (pi/2) (1600 / 900) 1 (-1))
<*> newTVarIO p
<*> newTVarIO phys
<*> newTVarIO po
<*> newTVarIO True
loadTex :: FilePath -> IO GL.TextureObject
loadTex f = do

158
examples/example00/Main.hs

@ -12,6 +12,9 @@ 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)
@ -28,7 +31,7 @@ import Debug.Trace as T
main :: IO ()
main =
withAffection AffectionConfig
withAffection (AffectionConfig
{ initComponents = All
, windowTitle = "hw"
, windowConfigs =
@ -36,26 +39,33 @@ main =
, SDL.defaultWindow
{ SDL.windowInitialSize = SDL.V2 1600 900
, SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
{ SDL.glProfile = SDL.Compatibility SDL.Debug 4 0
}
}
, SDL.Fullscreen
)
]
, initScreenMode = SDL.Fullscreen
, preLoop = return ()
, eventLoop = mapM_ handle
, updateLoop = update
, drawLoop = draw
, loadState = load
, cleanUp = const (return ())
, canvasSize = Nothing
}
update :: Double -> Affection StateData ()
update dt = do
sd <- getAffection
} :: 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
@ -63,80 +73,79 @@ update dt = do
nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
return (npos, nrot))
. bodyRigidBody) (poBalls physos)
let nships = map (\(ship, (pos, rot)) ->
let nships shipss = map (\(ship, (pos, rot)) ->
ship
{ shipRot = rot
, shipPos = pos
}
) (zip (ships sd) posrots)
putAffection sd
{ ships = nships
}
draw :: Affection StateData ()
draw = do
) (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)
StateData{..} <- getAffection
GL.currentProgram $= (Just . GLU.program $ program)
mapM_ (\Ship{..} -> do
let view = lookAt
(cameraFocus camera +
(cameraFocus cam +
rotVecByEulerB2A
(cameraRot camera)
(V3 0 0 (-cameraDist camera)))
(cameraFocus camera)
(cameraRot cam)
(V3 0 0 (-cameraDist cam)))
(cameraFocus cam)
(V3 0 1 0)
model = mkTransformation shipRot shipPos
pvm = proj !*! view !*! model
pvm = p !*! 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 :: StateData -> SDL.EventPayload -> Affection ()
handle sd (SDL.WindowClosedEvent _) = quit sd
handle (SDL.KeyboardEvent dat) = do
handle sd (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
handleKey sd key
handle sd (SDL.MouseMotionEvent dat) = do
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}
[] ->
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
}
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 ()
handle _ _ = return ()
handleKey :: SDL.Keycode -> Affection StateData ()
handleKey code
handleKey :: StateData -> SDL.Keycode -> Affection ()
handleKey sd code
| code == SDL.KeycodeR =
GL.clearColor $= GL.Color4 1 0 0 1
| code == SDL.KeycodeG =
@ -150,12 +159,12 @@ handleKey code
a <- liftIO $ randomRIO (0, 1)
GL.clearColor $= GL.Color4 r g b a
| code == SDL.KeycodeEscape =
quit
quit sd
| code == SDL.KeycodeF = do
dt <- deltaTime <$> get
liftIO $ putStrLn $ show (1 / dt) ++ " FPS"
| code == SDL.KeycodeT =
toggleScreen
toggleScreen 0
| code `elem`
[ SDL.KeycodeW
, SDL.KeycodeS
@ -165,8 +174,8 @@ handleKey code
, SDL.KeycodeE
]
= do
sd <- getAffection
let ship = head (ships sd)
shipss <- liftIO $ atomically $ readTVar (ships sd)
let ship = head shipss
rot = shipRot ship
dphi = pi / 2 / 45
nquat = case code of
@ -177,10 +186,9 @@ handleKey code
SDL.KeycodeE -> rot * axisAngle (V3 0 0 1) (-dphi)
SDL.KeycodeQ -> rot * axisAngle (V3 0 0 1) dphi
_ -> rot
putAffection sd
{ ships = ship
liftIO $ atomically $ modifyTVar (ships sd) $ \shipss ->
ship
{ shipRot = nquat
} : tail (ships sd)
}
} : tail shipss
| otherwise =
return ()

15
examples/example00/Types.hs

@ -9,13 +9,16 @@ import SpatialMath
import Physics.Bullet.Raw as Bullet
import Control.Concurrent.STM.TVar
data StateData = StateData
{ ships :: [Ship]
, camera :: Camera
, proj :: M44 Float
, program :: GLU.ShaderProgram
, physics :: Physics
, physicsObjects :: PhysicsObjects
{ ships :: TVar [Ship]
, camera :: TVar Camera
, proj :: TVar (M44 Float)
, program :: TVar GLU.ShaderProgram
, physics :: TVar Physics
, physicsObjects :: TVar PhysicsObjects
, quitGame :: TVar Bool
}
data Ship = Ship

28
examples/example02/Init.hs

@ -5,6 +5,8 @@ module Init where
import SDL (($=))
import qualified SDL
import Control.Concurrent.STM.TVar
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU
@ -119,22 +121,22 @@ load = do
mapM_ (addRigidBody (pWorld phys) . bodyRigidBody) (poBigBalls po)
addRigidBody (pWorld phys) (bodyRigidBody $ poBigBall po)
return StateData
{ ships = shipList
, planet = planet
, oplanets = otherPlanets
, proj = infinitePerspective (pi/2) (1600 / 900) 1
, camera = Camera
StateData
<$> newTVarIO shipList
<*> newTVarIO planet
<*> newTVarIO otherPlanets
<*> newTVarIO (Camera
{ cameraFocus = V3 0 0 0
, cameraRot = Euler 0 0 0
, cameraDist = -100
}
, program = p
, program2 = p2
, physics = phys
, physicsObjects = po
, focusIndex = 0
}
})
<*> newTVarIO (infinitePerspective (pi/2) (1600 / 900) 1)
<*> newTVarIO p
<*> newTVarIO p2
<*> newTVarIO phys
<*> newTVarIO po
<*> newTVarIO 0
<*> newTVarIO True
loadTex :: FilePath -> IO GL.TextureObject
loadTex f = do

186
examples/example02/Main.hs

@ -12,6 +12,9 @@ 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)
@ -28,7 +31,7 @@ import Debug.Trace as T
main :: IO ()
main =
withAffection AffectionConfig
withAffection (AffectionConfig
{ initComponents = All
, windowTitle = "hw - example 02"
, windowConfigs =
@ -39,26 +42,29 @@ main =
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
}
}
, SDL.FullscreenDesktop
)
]
, initScreenMode = SDL.FullscreenDesktop
, preLoop = return ()
, eventLoop = mapM_ handle
, updateLoop = update
, drawLoop = draw
, loadState = load
, cleanUp = const (return ())
, canvasSize = Nothing
}
} :: AffectionConfig StateData)
instance Affectionate StateData where
preLoop = const (return ())
handleEvents sd = mapM_(handle sd)
update = Main.update
draw = Main.draw
loadState = load
cleanUp = const (return ())
hasNextStep = liftIO . readTVarIO . nextStep
update :: Double -> Affection StateData ()
update dt = do
sd <- getAffection
let phys = physics sd
physos = physicsObjects sd
g = 0.0667300
-- g = 0.0000000000667300
quit = liftIO . atomically . flip writeTVar False . nextStep
update :: StateData -> Double -> Affection ()
update sd dt = do
let g = 0.0667300
(phys, physos) <- liftIO $ do
p <- readTVarIO (physics sd)
po <- readTVarIO (physicsObjects sd)
return (p, po)
mapM_ (\smallBall -> do
ms1 <- liftIO $ getMotionState (bodyRigidBody smallBall)
ms2 <- liftIO $ getMotionState (bodyRigidBody $ poBigBall physos)
@ -115,36 +121,50 @@ update dt = do
nrot <- liftIO $ return . fmap realToFrac =<< getRotation ms
return (npos, nrot))
. bodyRigidBody) (poBigBalls physos)
let nships = map (\(ship, (pos, rot)) ->
liftIO $ atomically $ do
modifyTVar (ships sd) $ \ships ->
map (\(ship, (pos, rot)) ->
ship
{ shipRot = rot
, shipPos = pos
}
) (zip (ships sd) posrots)
nplanets = map (\(ball, (pos, rot)) ->
) (zip ships posrots)
modifyTVar (oplanets sd) $ \oplanets ->
map (\(ball, (pos, rot)) ->
ball
{ shipRot = rot
, shipPos = pos
}
) (zip (oplanets sd) posrots2)
putAffection sd
{ ships = nships
, oplanets = nplanets
, camera = (camera sd)
{ cameraFocus = shipPos ((planet sd : nplanets) !! focusIndex sd)
) (zip oplanets posrots2)
liftIO $ atomically $ do
ind <- readTVar (focusIndex sd)
nplanets <- readTVar (oplanets sd)
planet <- readTVar (planet sd)
cam <- readTVar (camera sd)
writeTVar (camera sd) cam
{ cameraFocus = shipPos ((planet : nplanets) !! ind)
}
}
draw :: Affection StateData ()
draw = do
draw :: StateData -> Affection ()
draw sd = do
GL.viewport $= (GL.Position 0 0, GL.Size 1920 1080)
StateData{..} <- getAffection
(planet, oplanets, ships, program, program2) <- liftIO $ do
p <- readTVarIO $ planet sd
o <- readTVarIO $ oplanets sd
s <- readTVarIO $ ships sd
pr <- readTVarIO $ program sd
pr2 <- readTVarIO $ program2 sd
return (p, o, s, pr, pr2)
drawThings program (planet : ships)
-- drawThings program (ships)
drawThings program2 oplanets
where
drawThings prog ts = do
StateData{..} <- getAffection
(camera, proj, program) <- liftIO $ do
cam <- readTVarIO (camera sd)
p <- readTVarIO (proj sd)
program <- readTVarIO (program sd)
return (cam, p, program)
GL.currentProgram $= (Just . GLU.program $ prog)
mapM_ (\Ship{..} -> do
let view = lookAt
@ -161,62 +181,52 @@ draw = do
liftIO $ GL.drawArrays GL.Triangles 0 (fromIntegral shipVaoLen)
) ts
handle :: SDL.EventPayload -> Affection StateData ()
handle (SDL.WindowClosedEvent _) = quit
handle :: StateData -> SDL.EventPayload -> Affection ()
handle sd (SDL.WindowClosedEvent _) = quit sd
handle (SDL.KeyboardEvent dat) = do
handle sd (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
handleKey sd key
handle sd (SDL.MouseMotionEvent dat) = do
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}
[] ->
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
}
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 ()
handle _ _ = return ()
handleKey :: SDL.Keycode -> Affection StateData ()
handleKey code
handleKey :: StateData -> SDL.Keycode -> Affection ()
handleKey sd code
| code == SDL.KeycodeTab = do
ud <- getAffection
let ind = focusIndex ud
ps = planet ud : oplanets ud
-- ps = oplanets ud
if ind + 1 < length ps
then putAffection ud
{ focusIndex = ind + 1
}
else putAffection ud
{ focusIndex = 0
}
ps <- liftIO ((:) <$> readTVarIO (planet sd) <*> readTVarIO (oplanets sd))
liftIO $ atomically $ modifyTVar (focusIndex sd) $ \ind ->
if ind + 1 < length ps
then ind + 1
else 0
| code == SDL.KeycodeR =
GL.clearColor $= GL.Color4 1 0 0 1
| code == SDL.KeycodeG =
@ -230,12 +240,12 @@ handleKey code
a <- liftIO $ randomRIO (0, 1)
GL.clearColor $= GL.Color4 r g b a
| code == SDL.KeycodeEscape =
quit
quit sd
| code == SDL.KeycodeF = do
dt <- deltaTime <$> get
liftIO $ putStrLn $ show (1 / dt) ++ " FPS"
| code == SDL.KeycodeT =
toggleScreen
toggleScreen 0
| code `elem`
[ SDL.KeycodeW
, SDL.KeycodeS
@ -245,9 +255,8 @@ handleKey code
, SDL.KeycodeE
]
= do
sd <- getAffection
let ship = head (ships sd)
rot = shipRot ship
ship <- head <$> liftIO (readTVarIO $ ships sd)
let rot = shipRot ship
dphi = pi / 2 / 45
nquat = case code of
SDL.KeycodeW -> rot * axisAngle (V3 1 0 0) (-dphi)
@ -257,10 +266,9 @@ handleKey code
SDL.KeycodeE -> rot * axisAngle (V3 0 0 1) (-dphi)
SDL.KeycodeQ -> rot * axisAngle (V3 0 0 1) dphi
_ -> rot
putAffection sd
{ ships = ship
liftIO $ atomically $ modifyTVar (ships sd) $ \ships ->
ship
{ shipRot = nquat
} : tail (ships sd)
}
} : tail ships
| otherwise =
return ()

23
examples/example02/Types.hs

@ -3,6 +3,8 @@ module Types where
import qualified Graphics.Rendering.OpenGL as GL
import qualified Graphics.GLUtil as GLU
import Control.Concurrent.STM.TVar
import Linear as L
import SpatialMath
@ -10,16 +12,17 @@ import SpatialMath
import Physics.Bullet.Raw as Bullet
data StateData = StateData
{ ships :: [Ship]
, planet :: Ship
, oplanets :: [Ship]
, camera :: Camera
, proj :: M44 Float
, program :: GLU.ShaderProgram
, program2 :: GLU.ShaderProgram
, physics :: Physics
, physicsObjects :: PhysicsObjects
, focusIndex :: Int
{ ships :: TVar [Ship]
, planet :: TVar Ship
, oplanets :: TVar [Ship]
, camera :: TVar Camera
, proj :: TVar (M44 Float)
, program :: TVar GLU.ShaderProgram
, program2 :: TVar GLU.ShaderProgram
, physics :: TVar Physics
, physicsObjects :: TVar PhysicsObjects
, focusIndex :: TVar Int
, nextStep :: TVar Bool
}
data Ship = Ship

4
hw.cabal

@ -80,6 +80,7 @@ executable example00
, vector
, wavefront
, shoot
, stm
else
buildable: False
hs-source-dirs: examples/example00
@ -137,8 +138,9 @@ executable example02
, GLUtil
, random
, vector
, wavefront >= 0.7.1.2
, wavefront
, shoot
, stm
hs-source-dirs: examples/example02
default-language: Haskell2010
ghc-options: -Wall

Loading…
Cancel
Save