loop (n-1) space ball
showPosition :: Body -> IO ()
showPosition ball = do
pos <- get $ position ball
print pos
initWalls :: Space -> IO ()
initWalls space = mapM_ (uncurry $ initWall space) wallPoints
initWall :: Space -> Position -> Position -> IO ()
initWall space a b = do
body
<- newBody infinity infinity
shape
<- newShape body (LineSegment a b wallThickness) 0
elasticity shape $= nearOne
spaceAdd space body
spaceAdd space shape
initBall :: Space -> Position -> Velocity -> IO Body
initBall space pos vel = do
body
<- newBody ballMass ballMoment
shape
<- newShape body (Circle ballRadius) 0
Основные библиотеки | 295
position body $= pos
velocity body $= vel
elasticity shape $= nearOne
spaceAdd space body
spaceAdd space shape
return body
----------------------------
-- inits
nearOne = 0.9999
ballMass = 20
ballMoment = momentForCircle ballMass (0, ballRadius) 0
ballRadius = 10
initPos = Vector 0 0
initVel = Vector 10 5
wallThickness = 1
wallPoints = fmap (uncurry f) [
((-w2, -h2), (-w2, h2)),
((-w2, h2),
(w2, h2)),
((w2, h2),
(w2, -h2)),
((w2, -h2),
(-w2, -h2))]
where f a b = (g a, g b)
g (a, b) = H.Vector a b
h2 = 100
w2 = 100
Функция initChipmunk инициализирует библиотеку Chipmunk. Она должна быть вызвана один раз до
любой из функций библиотеки Hipmunk. Функции new[Body|Shape|Space] создают объекты модели. Мы сде-
лали стены неподвижными, присвоив им бесконечную массу и момент инерции (initWall). Упругость удара
определяется переменной elasticity, она не может быть больше единицы. Единица обозначает абсолютно
упругое столкновение. В документации к Hipmunk не рекомендуют присваивать значение равное единице
из-за возможных погрешностей округления, поэтому мы выбираем число близкое к единице. После иници-
ализации элементов модели мы запускаем цикл, в котором происходит обновление модели (step) и печать
положения шарика. Обратите внимание на то, что координаты шарика никогда не выйдут за установленные
рамки.
Теперь объединим OpenGL и Hipmunk:
module Main where
import Control.Applicative
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 ()