Учебник по Haskell

Стандартная функция 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