import Control.Applicative
import Data.StateVar
import Data.IORef
import Graphics.UI.GLFW
import System.Exit
import Control.Monad
import qualified Physics.Hipmunk
as H
import qualified Graphics.UI.GLFW as G
import qualified Graphics.Rendering.OpenGL as G
title = ”in the box”
----------------------------
-- inits
type Time = Double
-- frames per second
fps :: Int
fps = 60
296 | Глава 20: Императивное программирование
-- frame time in milliseconds
frameTime :: Time
frameTime = 1000 * ((1::Double) / fromIntegral fps)
nearOne = 0.9999
ballMass = 20
ballMoment = H. momentForCircle ballMass (0, ballRadius) 0
ballRadius = 10
initPos = H.Vector 0 0
initVel = H.Vector 0 0
wallThickness = 1
wallPoints = fmap (uncurry f) [
((-ow2, -oh2), (-ow2, oh2)),
((-ow2, oh2),
(ow2, oh2)),
((ow2, oh2),
(ow2, -oh2)),
((ow2, -oh2),
(-ow2, -oh2))]
where f a b = (g a, g b)
g (a, b) = H.Vector a b
dt :: Double
dt = 0.5
minVel :: Double
minVel = 10
width, height :: Double
height = 500
width = 700
w2, h2 :: Double
h2 = height / 2
w2 = width / 2
ow2, oh2 :: Double
ow2 = w2 - 50
oh2 = h2 - 50
data State = State
{ stateBall
:: H.Body
, stateSpace
:: H.Space
}
ballPos :: State -> StateVar H.Position
ballPos = H. position . stateBall
ballVel :: State -> StateVar H.Velocity
ballVel = H. velocity . stateBall
main = do
H. initChipmunk
initGLFW
state <- newIORef =<< initState
loop state
loop :: IORef State -> IO ()
loop state = do
display state
onMouse state
sleep frameTime
Основные библиотеки | 297
loop state
simulate :: State -> IO Time
simulate a = do
t0 <- get G. time
H. step (stateSpace a) dt
t1 <- get G. time
return (t1 - t0)
initGLFW :: IO ()
initGLFW = do
G. initialize
G. openWindow (G.Size (d2gli width) (d2gli height)) [] G.Window
G. windowTitle $= title
G. windowCloseCallback $= exitWith ExitSuccess
G. windowSizeCallback
$= (\size -> G. viewport $= (G.Position 0 0, size))
G. clearColor $= G.Color4 1 1 1 1
G. ortho (-dw2) (dw2) (-dh2) (dh2) (-1) 1
where dw2 = realToFrac w2
dh2 = realToFrac h2
initState :: IO State
initState = do
space <- H. newSpace
initWalls space
ball <- initBall space initPos initVel
return $ State ball space
initWalls :: H.Space -> IO ()
initWalls space = mapM_ (uncurry $ initWall space) wallPoints
initWall :: H.Space -> H.Position -> H.Position -> IO ()
initWall space a b = do
body
<- H. newBody H. infinity H. infinity
shape
<- H. newShape body (H.LineSegment a b wallThickness) 0
H. elasticity shape $= nearOne
H. spaceAdd space body
H. spaceAdd space shape
initBall :: H.Space -> H.Position -> H.Velocity -> IO H.Body
initBall space pos vel = do
body
<- H. newBody ballMass ballMoment
shape
<- H. newShape body (H.Circle ballRadius) 0
H. position body $= pos
H. velocity body $= vel
H. elasticity shape $= nearOne
H. spaceAdd space body
H. spaceAdd space shape
return body
-------------------------------
-- graphics
display state = do
drawState =<< get state
simTime <- simulate =<< get state
sleep (max 0 $ frameTime - simTime)
drawState :: State -> IO ()
drawState st = do
pos <- get $ ballPos st
G. clear [G.ColorBuffer]
drawWalls
drawBall pos
G. swapBuffers
drawBall :: H.Position -> IO ()
298 | Глава 20: Императивное программирование
drawBall pos = do
G. color red
circle x y $ d2gl ballRadius
where (x, y) = vec2gl pos
drawWalls :: IO ()
drawWalls = do
G. color black
line (-dow2) (-doh2) (-dow2) doh2
line (-dow2) doh2
dow2
doh2
line dow2
doh2
dow2
(-doh2)
line dow2
(-doh2)
(-dow2) (-doh2)
where dow2 = d2gl ow2
doh2 = d2gl oh2
onMouse state = do
mb <- G. getMouseButton ButtonLeft
when (mb == Press) (get G. mousePos >>= updateVel state)
updateVel state pos = do
size <- get G. windowSize
st <- get state
p0 <- get $ ballPos st
v0 <- get $ ballVel st
let p1 = mouse2canvas size pos
ballVel st $=