mouse2canvas (Size sx sy) (Position mx my) = (x, y)
where d a b
= fromIntegral a / fromIntegral b
x
= fromIntegral width * (d mx sx - 0.5)
y
= fromIntegral height * (negate $ d my sy - 0.5)
vertex2f :: GLfloat -> GLfloat -> IO ()
vertex2f a b = vertex (Vertex3 a b 0)
-- colors
... white, black, red
-- primitives
line
:: GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
circle
:: GLfloat -> GLfloat -> GLfloat -> IO ()
294 | Глава 20: Императивное программирование
Теперь функция display принимает ссылку на глобальную переменную, которая отвечает за движение
шарика. Функция mouse2canvas переводит координаты в окне GLFW в координаты OpenGL. В GLFW начало ко-
ординат лежит в левом верхнем углу окна и ось Oy направлена вниз. Мы же переместили начало координат
в центр окна и ось Oy направлена вверх.
Посмотрим что у нас получилось:
$ ghc --make Animation.hs
$ ./Animation
Chipmunk
Картинка ожила, но шарик движется не реалистично. Он проходит сквозь стены. Добавим в нашу про-
грамму немного физики. Воспользуемся библиотекой Hipmunk
cabal install Hipmunk
Она даёт возможность вызывать из Haskell функции С-библиотеки Chipmunk. Эта библиотека позволя-
ет строить двухмерные физические модели. Основным элементом модели является пространство (Space).
К нему мы можем добавлять различные объекты. Объект состоит из двух компонент: тела (Body) и формы
(Shape). Тело отвечает за такие физические характеристики как масса, момент инерции, восприимчивость к
силам. По форме определяются моменты столкновения тел. Форма может состоять из нескольких примити-
вов: окружностей, линий и выпуклых многоугольников. Также мы можем добавлять различные ограничения
(Constraint) они имитируют пружинки, шарниры. Мы можем назначать выполнение IO-действий на столк-
новения.
Опишем в Hipmunk модель шарика бегающего в замкнутой коробке:
module Main where
import Data.StateVar
import Physics.Hipmunk
main = do
initChipmunk
space <- newSpace
initWalls space
ball <- initBall space initPos initVel
loop 100 space ball
loop :: Int -> Space -> Body -> IO ()
loop 0 _
_
= return ()
loop n space ball = do
showPosition ball
step space 0.5
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