circle cx cy rad =
renderPrimitive Polygon $ mapM_ (uncurry vertex2f) points
where n = 50
points = zip xs ys
xs = fmap (x -> cx + rad * sin (2*pi*x/n)) [0 .. n]
ys = fmap (x -> cy + rad * cos (2*pi*x/n)) [0 .. n]
Рис. 20.1: Начальное положение
Мы рисуем с помощью функции renderPrimitive. Она принимает метку элемента, который мы собира-
емся рисовать и набор вершин. Так метка Lines обозначает линии, а метка Polygon – закрашенные много-
угольники. В OpenGL нет специальной операции для рисования окружностей, поэтому нам придётся предста-
вить окружность в виде многоугольника (circle). Функция ortho устанавливает область видимости рисунка,
шесть аргументов функции обозначают пары диапазонов по каждой из трёх координат. При этом вершины
передаются не списком а в специальном do-блоке. За счёт этого мы можем изменить какие-нибудь парамет-
ры OpenGL во время рисования. Обратите внимание на то, как мы изменяем цвет примитива. Перед тем как
рисовать примитив мы устанавливаем значение цвета (color).
Анимация
Оживим нашу картинку. При клике мышкой шарик игрока последует в направлении курсора. Для того
чтобы картинка задвигалась нам необходимо обновлять рисунок с определённой частотой. Мы будем регу-
лировать частоту обновления с помощью функции sleep, с её помощью мы можем задержать выполнение
программы (время измеряется в секундах):
sleep :: Double -> IO ()
За перехват действий пользователя отвечает функции:
getMouseButton
:: MouseButton -> IO KeyButtonState
mousePos
:: StateVar Position
Функция getMouseButton сообщает текущее состояние кнопок мыши, мы будем перехватывать положение
мыши во время нажатия левой кнопки:
292 | Глава 20: Императивное программирование
onMouse ball = do
mb <- getMouseButton ButtonLeft
when (mb == Press) (get mousePos >>= updateVel ball)
Стандартная функция when из модуля Control.Monad выполняет действие только в том случае, если пер-
вый аргумент равен True. Для обновления положения и направления скорости шарика нам придётся вос-
пользоваться глобальной переменной типа IORef Ball:
data Ball = Ball
{ ballPos :: Vec2d
, ballVel :: Vec2d
}
Код программы:
module Main where
import Control.Applicative
import Data.IORef
import Graphics.UI.GLFW
import Graphics.Rendering.OpenGL
import System.Exit
import Control.Monad
type Time = Double
title = ”Hello OpenGL”
width, height :: GLsizei
fps :: Int
fps = 60
frameTime :: Time
frameTime = 1000 * ((1::Double) / fromIntegral fps)
width
= 700
height
= 600
w2, h2 :: GLfloat
w2 = (fromIntegral $ width) / 2
h2 = (fromIntegral $ height)
/ 2
dw2, dh2 :: GLdouble
dw2 = fromRational $ toRational w2
dh2 = fromRational $ toRational h2
type Vec2d = (GLfloat, GLfloat)
data Ball = Ball
{ ballPos :: Vec2d
, ballVel :: Vec2d
}
initBall = Ball (0, 0) (0, 0)
dt :: GLfloat
dt = 0.3
minVel = 10
main = do
initialize
openWindow (Size width height) [] Window
windowTitle $= title
Основные библиотеки | 293
clearColor $= Color4 1 1 1 1
ortho (—dw2) (dw2) (—dh2) (dh2) (—1) 1
ball <- newIORef initBall
windowCloseCallback $= exitWith ExitSuccess
windowSizeCallback
$= (size -> viewport $= (Position 0 0, size))
loop ball
loop :: IORef Ball -> IO ()
loop ball = do
display ball
onMouse ball
sleep frameTime
loop ball
display ball = do
(px, py) <- ballPos get ball
(vx, vy) <- ballVel get ball
ball $= Ball (px + dt*vx, py + dt*vy) (vx, vy)
clear [ColorBuffer]
color black
line (—ow2) (—oh2) (—ow2) oh2
line (—ow2) oh2
ow2
oh2
line ow2
oh2
ow2
(—oh2)
line ow2
(—oh2)
(—ow2) (—oh2)
color red
circle px py 10
swapBuffers
where ow2 = w2 — 50
oh2 = h2 — 50
onMouse ball = do
mb <- getMouseButton ButtonLeft
when (mb == Press) (get mousePos >>= updateVel ball)
updateVel ball pos = do
(p0x, p0y) <- ballPos get ball
v0
<- ballVel get ball
size <- get windowSize
let (p1x, p1y) = mouse2canvas size pos
v1 = scaleV (max minVel $ len v0) $ norm (p1x — p0x, p1y — p0y)
ball $= Ball (p0x, p0y) v1
where norm v@(x, y) = (x / len v, y / len v)
len
(x, y) = sqrt (x*x + y*y)
scaleV k (x, y) = (k*x, k*y)
mouse2canvas :: Size -> Position -> (GLfloat, GLfloat)
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
