Императивное программирование

В этой главе мы потренируемся в укрощении императивного кода. В Haskell все побочные эффекты огорожены от чистых функций бетонной стеной IO. Однажды оступившись, мы не можем свернуть с пути побочных эффектов, мы вынуждены тащить на себе груз IO до самого конца программы. Тип IO, хоть и обволакивает программу, всё же позволяет пользоваться благами чистых вычислений. От программиста зависит насколько сильна будет хватка IO. Необходимо уметь выделять точки, в которых применение побочных вычислений действительно необходимо, подключая в них чистые функции через методы классов Functor, Applicative и Monad. Тип IO похож на дорогу с контрольными пунктами, в которых необходимо отчитаться перед компилятором за “грязный код”. При неумелом проектировании написание программ, насыщенных побочными эффектами, может превратится в пытку. Контрольные пункты будут встречаться в каждой функции.

Естественный источник побочных эффектов – это пользователь программы. Но, к сожалению, это не единственный источник. Haskell – открытый язык программирования. В нём можно пользоваться программами из низкоуровневого языка C. Основное преимущество С заключается в непревзойдённой скорости программ. Этот язык позволяет программисту работать с памятью компьютера напрямую. Но за эту силу приходится платить. Возможны очень неприятные и трудноуловимые ошибки. Утечки памяти, обращение по неверному адресу в памяти, неожиданное обновление переменных. Ещё один плюс С в том, что это язык с историей, на нём написано много хороших библиотек. Некоторые из них встроены в Haskell с помощью специального механизма FFI (foreign function interface). Обсуждение того, как устроен FFI выходит за рамки этой книги. Интересующийся читатель может обратиться к книге Real World Haskell. Мы же потренируемся в использовании таких библиотек. Язык C является императивным, поэтому, применяя его функций в Haskell, мы неизбежно сталкиваемся с типом IO, поскольку большинство интересных функций в С изменяют состояние своих аргументов. В С пишут и чистые функции, такие функции переносятся в Haskell без потери чистоты, но это не всегда возможно.

В этой главе мы напишем небольшую 2D-игру, подключив две FFI-библиотеки, это графическая библиотека OpenGL и физический движок Chipmunk.

Описание игры

Игра происходит на бильярдной доске. Игрок управляет красным шаром, кликнув в любую точку экрана, он может изменить направление вектора скорости красного шара. Шар покатится туда, куда кликнул пользователь в последний раз. Из луз будут вылетать шары трёх типов: синие, зелёные и оранжевые. Столкновение красного шара с синим означает минус одну жизнь, с зелёным – плюс одну жизнь, оранжевый шар означает бонус. Если шар игрока сталкивается с оранжевым шаром все шары в определённом радиусе от места столкновения исчезают и записываются в бонусные очки, за каждый шар по одному очку, при этом шар с которым произошло столкновение не считается. Все столкновения – абсолютно упругие, поэтому при столкновении энергия сохраняется и шары никогда не остановятся. Если шар попадает в лузу, то он исчезает. Если в лузу попал шар игрока – это означает, что игра окончена. Игрок стартует с несколькими жизнями, когда их число подходит к нулю игра останавливается. После столкновения с зелёным шаром, шар пропадает, а после столкновения с синим – нет. В итоге все против игрока, кроме зелёных и оранжевых шаров.

Основные библиотеки

Контролировать физику игрового мира будет библиотека Chipmunk, а библиотека OpenGL будет рисовать (конечно если мы её этому научим). Пришло время с ними познакомится.

Изменяемые значения

Перед тем как мы перейдём к библиотекам нам нужно узнать ещё кое-что. В Haskell мы не можем изменять значения. Но в С это делается постоянно, а соответственно и в библиотеках написанных на С тоже. Для того чтобы имитировать в Haskell механизм обновления значений были придуманы специальные типы. Мы можем объявить изменяемое значение и обновлять его, но только в пределах типа IO.

IORef

Тип IORef из модуля Data.IORef описывает изменяемые значения:

newIORef :: a -> IO IORef

readIORef   :: IORef a -> IO a
writeIORef  :: IORef a -> a -> IO ()
modifyIORef :: IORef a -> (a -> a) -> IO ()

Функция newIORef создаёт изменяемое значение и инициализирует его некоторым значением, которые мы можем считать с помощью функции readIORef или обновить с помощью функций writeIORef или modifyIORef. Посмотрим как это работает:

module Main where

import Data.IORef

main = var >>= (\v -> 
       readIORef v >>= print 
    >> writeIORef v 4 
    >> readIORef v >>= print)
    where var = newIORef 2    

Теперь посмотрим на ответ ghci:

*Main> :l HelloIORef
[1 of 1] Compiling Main             ( HelloIORef.hs, interpreted )
Ok, modules loaded: Main.
*Main> main
2
4

Самое время вернуться к главе 17 и вспомнить о do-нотации. Такой императивный код гораздо нагляднее писать так:

main = do
    var <- newIORef 2
    x <- readIORef var
    print x
    writeIORef var 4
    x <- readIORef var
    print x

Эта запись выглядит как последовательность действий. Не правда ли очень похоже на обычный императивный язык. Такие переменные встречаются очень часто в библиотеках, заимствованных из С.

StateVar

В модуле Data.StateVar определены типы, которые накладывают ограничение на права по чтению и записи. Мы можем определять переменные доступные только для чтения (GettableStateVar a), только для записи (SettableStateVar a) или обычные изменяемые переменные (SetVar a).

Операции чтения и записи описываются с помощью классов:

class HasGetter s where
    get :: s a -> IO a

class HasSetter s where
    ($=) :: s a -> a -> IO ()

Тип IORef принадлежит и тому, и другому классу:

main = do
    var <- newIORef 2
    x   <- get var
    print x
    var $= 4
    x   <- get var
    print x

OpenGL

OpenGL является ярким примером библиотеки построенной на изменяемых переменных. OpenGL можно представить как большой конечный автомат. Каждая строчка кода – это запрос на изменение состояния. Причём этот автомат является глобальной переменной. Его текущее состояние зависит от всей цепочки предыдущих команд. Параметры рисования задаются глобальными переменными (тип StateVar).

OpenGL не зависит от конкретной оконной системы, она отвечает лишь за рисование. Для того чтобы создать окно и перехватывать в нём действия пользователя нам понадобится отдельная библиотека. Для этого мы воспользуемся GLFW, это библиотека также пришла в Haskell из С. Интерфейсы GLFW и OpenGL очень похожи. Мы будем обновлять различные параметры библиотеки с помощью типа StateVar. Давайте создадим окно и закрасим фон белым цветом:

module Main where

import Graphics.UI.GLFW           
import Graphics.Rendering.OpenGL
import System.Exit

title = "Hello OpenGL"

width   = 700
height  = 600

main = do
    initialize
    openWindow (Size width height) [] Window
    windowTitle $= title
      
    clearColor $= Color4 1 1 1 1
    
    windowCloseCallback $= exitWith ExitSuccess
    loop

loop = do
    display
    loop

display = do
    clear [ColorBuffer]
    swapBuffers

Мы инициализируем GLFW, задаём параметры окна. Устанавливаем цвет фона. Цвет имеет четыре параметра это RGB-цвета и параметр прозрачности. Затем мы говорим, что программе делать при закрытии окна. Мы устанавливаем функцию обратного вызова (callback) windowCloseCallback. В самом конце мы входим в цикл, который только и делает, что стирает окно цветом фона и делает рабочий буфер видимым. Что такое буфер? Буфер – это место в котором мы рисуем. У нас есть два буфера. Один мы показываем пользователю, а в другом в это в время рисуем, когда приходит время обновлять картинку мы просто меняем их местами командой swapBuffers.

Посмотрим, что у нас получилось:

$ ghc --make HelloOpenGL.hs
$ ./HelloOpenGL

Нарисуем упрощённое начальное положение нашей игры: прямоугольную рамку и в ней – красный шар:

module Main where

import Graphics.UI.GLFW           
import Graphics.Rendering.OpenGL

import System.Exit

title = "Hello OpenGL"

width, height :: GLsizei

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

main = do
    initialize
    openWindow (Size width height) [] Window
    windowTitle $= title

    clearColor $= Color4 1 1 1 1
    ortho (-dw2-50) (dw2+50) (-dh2-50) (dh2+50) (-1) 1
   
    windowCloseCallback $= exitWith ExitSuccess
    windowSizeCallback  $= (\size -> viewport $= (Position 0 0, size))

    loop

loop = do
    display
    loop

display = do
    clear [ColorBuffer]

    color black
    line (-w2) (-h2) (-w2) h2
    line (-w2) h2    w2    h2
    line w2    h2    w2    (-h2)
    line w2   (-h2)  (-w2) (-h2)

    color red
    circle 0 0 10

    swapBuffers


vertex2f :: GLfloat -> GLfloat -> IO ()
vertex2f a b = vertex (Vertex3 a b 0)

-- colors

white = Color4 (0::GLfloat)
black = Color4 (0::GLfloat) 0 0 1
red   = Color4 (1::GLfloat) 0 0 1

-- primitives

line :: GLfloat -> GLfloat -> GLfloat -> GLfloat -> IO ()
line ax ay bx by = renderPrimitive Lines $ do
    vertex2f ax ay
    vertex2f bx by


circle :: GLfloat -> GLfloat -> GLfloat -> IO ()
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]
Начальное положение

Начальное положение

Мы рисуем с помощью функции renderPrimitive. Она принимает метку элемента, который мы собираемся рисовать и набор вершин. Так метка Lines обозначает линии, а метка Polygon – закрашенные многоугольники. В OpenGL нет специальной операции для рисования окружностей, поэтому нам придётся представить окружность в виде многоугольника (circle). Функция ortho устанавливает область видимости рисунка, шесть аргументов функции обозначают пары диапазонов по каждой из трёх координат. При этом вершины передаются не списком а в специальном do-блоке. За счёт этого мы можем изменить какие-нибудь параметры OpenGL во время рисования. Обратите внимание на то, как мы изменяем цвет примитива. Перед тем как рисовать примитив мы устанавливаем значение цвета (color).

Анимация

Оживим нашу картинку. При клике мышкой шарик игрока последует в направлении курсора. Для того чтобы картинка задвигалась нам необходимо обновлять рисунок с определённой частотой. Мы будем регулировать частоту обновления с помощью функции sleep, с её помощью мы можем задержать выполнение программы (время измеряется в секундах):

sleep :: Double -> IO ()

За перехват действий пользователя отвечает функции:

getMouseButton  :: MouseButton -> IO KeyButtonState
mousePos        :: StateVar Position

Функция getMouseButton сообщает текущее состояние кнопок мыши, мы будем перехватывать положение мыши во время нажатия левой кнопки:

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

    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 ()

Теперь функция 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
    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

-- 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
    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 ()
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 $= 
        H.scale (H.normalize $ p1 - p0) (max minVel $ H.len v0)

mouse2canvas :: G.Size -> G.Position -> H.Vector
mouse2canvas (G.Size sx sy) (G.Position mx my) = H.Vector x y
    where d a b  = fromIntegral a / fromIntegral b
          x  = width * (d mx sx - 0.5)
          y  = height * (negate $ d my sy - 0.5)


vertex2f :: G.GLfloat -> G.GLfloat -> IO ()
vertex2f a b = G.vertex (G.Vertex3 a b 0)

vec2gl :: H.Vector -> (G.GLfloat, G.GLfloat)
vec2gl (H.Vector x y) = (d2gl x, d2gl y)

d2gl :: Double -> G.GLfloat
d2gl = realToFrac

d2gli :: Double -> G.GLsizei
d2gli = toEnum . fromEnum . d2gl

...

Функции не претерпевшие особых изменений пропущены. Теперь наше глобальное состояние (State) содержит тело шара (оно пригодится нам для вычисления его положения) и пространство, в котором живёт наша модель. Стоит отметить функцию simulate. В ней происходит обновление состояния модели. При этом мы возвращаем время, которое ушло на вычисление этой функции. Оно нужно нам для того, чтобы показывать новые кадры равномерно. Мы вычтем время симуляции из общего времени, которое мы можем потратить на один кадр (frameTime).

Боремся с IO

Кажется, что мы попали в какой-то другой язык. Это совсем не тот элегантный Haskell, знакомый нам по предыдущим главам. Столько do и IO разбросано по всему коду. И такой примитивный результат в итоге. Если так будет продолжаться и дальше, то мы можем не вытерпеть и бросить и нашу задачу и Haskell…

Не отчаивайтесь!

Давайте лучше подумаем как свести этот псевдо-Haskell к минимуму. Подумаем какие источники IO точно будут в нашей программе. Это инициализация GLFW и Hipmunk, клики мышью, обновление модели в Hipmunk, также для рисования нам придётся считывать положения шаров. Нам придётся удалять и создавать новые шары, добавляя их к пространству модели. Также в IO происходит отрисовка игры. Hipmunk будет контролировать столкновения шаров, и эти данные нам тоже надо будет считывать из глобальных переменных. Сколько всего! Голова идёт кругом.

Но помимо всего этого у нас есть логика игры. Логика игры отвечает за реакцию игрового мира на различные события. Например столкновение с “плохим” шаром влечёт к уменьшению жизней, если игрок сталкивается с бонусным шаром, определённые шары необходимо удалить. Приходит момент и мы выпускаем новый шар из лузы новый шар. Давайте подумаем как сохранить логику игры в чистоте.

Тип IO обычно отвечает за связь с внешним миром, это глаза, уши, руки и ноги программы. Через IO мы получаем информацию из внешнего мира и отправляем её обратно. Но в нашем случае он проник в сердце программы. За обновление объектов отвечает насыщенная IO библиотека Hipmunk.

Мы постараемся побороться с IO-кодом так. Сначала мы выделим те параметры, которые могут быть обновлены чистыми функциями. Это все те параметры, для которых не нужен Hipmunk. Этот шаг разбивает наш мир на два лагеря: “чистый” и “грязный”:

data World = World 
    { worldPure   :: Pure
    , worldDirty  :: Dirty }

Чистые данные хотят как-то узнать о том, что происходит в грязных данных. Также чистые данные могут рассказать грязным, как им нужно измениться. Это приводит нас к определению двух языков запросов, на которых чистый и грязный мир общаются между собой:

data Query = Remove Ball | HeroVelocity H.Velocity | MakeBall Freq

data Event = Touch Ball | UserClick H.Position

data Sense = Sense 
    { senseHero     :: HeroBall
    , senseBalls    :: [Ball]  }

Через Query чистые данные могут рассказать грязным о том, что необходимо удалить шар из игры, обновить скорость шара игрока или создать новый шар (Freq отвечает за параметры создания шара). Грязные данные могут рассказать чистым на языке Event и Sense о том, что один из шаров коснулся до шара игрока, или игрок кликнул мышкой в определённой точке. Также мы сообщаем все обновлённые положения параметры шаров в типе Sense. Тип Event отвечает за события, которые происходят иногда, а тип Sense за те параметры, которые мы наблюдаем непрерывно (это типы глазорук), Query – это язык действий (это тип руконог). Нам понадобится ещё один маленький язык, на котором мы будем объясняться с OpenGL.

data Picture = Prim Color Primitive
             | Join Picture Picture

data Primitive = Line Point Point | Circle Point Radius

data Point  = Point Double Double
type Radius = Double   

data Color = Color Double Double Double

Эти три языка станут барьером, которым мы ограничим влияние IO. У нас будут функции:

percept     :: Dirty -> IO (Sense, [Event])
updatePure  :: Sense -> [Event] -> Pure -> (Pure, [Query])
react       :: [Query] -> Dirty -> IO Dirty
updateDirty :: Dirty -> IO Dirty
picture     :: Pure -> Picture
draw        :: Picture -> IO ()

Вся логика игры будет происходить в чистой функции updatePure, обновлять модель мира мы будем в updateDirty. Давайте опять начнём проектирование сверху-вниз. С этими функциями мы уже можем написать основную функцию цикла игры:

loop :: IORef World -> IO ()
loop worldRef = do
    world <- get worldRef
    drawWorld world
    (world, dt) <- updateWorld world
    worldRef $= world
    G.addTimerCallback (max 0 $ frameTime - dt) $ loop worldRef

updateWorld :: World -> IO (World, Time)
updateWorld world = do
    t0 <- get G.elapsedTime
    (sense, events) <- percept dirty
    let (pure', queries) = updatePure sense events pure
    dirty' <- updateDirty =<< react queries dirty    
    t1 <- get G.elapsedTime
    return (World pure' dirty', t1 - t0)
    where dirty = worldDirty world
          pure  = worldPure  world  

drawWorld :: World -> IO ()
drawWorld = draw . picture . worldPure

Определяемся с типами

Давайте подумаем, из чего состоят типы Dirty и Pure. Начнём с Pure. Там точно будет вся информация необходимая нам для рисования картинки (ведь функция picture определена на Pure). Для рисования нам необходимо знать положения всех шаров и их типы (они определяют цвет). На картинке мы будем показывать разную статистику (данные о жизнях, бонусные очки). Также из типа Pure мы будем управлять созданием шаров. Так мы приходим к типу:

data Pure = Pure
    { pureScores     :: Scores
    , pureHero       :: HeroBall
    , pureBalls      :: [Ball]
    , pureStat       :: Stat
    , pureCreation   :: Creation
    }

Что нам нужно знать о шаре героя? Нам нужно его положение для отрисовки и модуль вектора скорости (он понадобится нам при обновлении вектора скорости шара игрока):

data HeroBall = HeroBall
    { heroPos   :: H.Position
    , heroVel   :: H.CpFloat
    }

Для остальных шаров нам нужно знать только тип шара, его положение и идентификатор шара. По идентификатору потом мы сможем понять какой шар удалить из грязных данных:

data Ball = Ball
    { ballType      :: BallType
    , ballPos       :: H.Position
    , ballId        :: Id
    }

data BallType = Hero | Good | Bad | Bonus
    deriving (Show, Eq, Enum)

type Id = Int

Статистика игры состоит из числа жизней и бонусных очков:

data Scores = Scores 
    { scoresLives :: Int
    , scoresBonus :: Int
    } 

Как будет происходить создание новых шаров? Если плохих шаров будет слишком много, то играть будет не интересно, игрок слишком быстро проиграет. Если хороших шаров будет слишком много, то игроку также быстро надоест. Будет очень легко. Нам необходимо поддерживать определённый баланс шаров. Создание шаров будет происходить случайным образом через равные промежутки времени, но создание нового шара будет зависеть от пропорции шаров на доске в данный момент. Если у нас слишком много плохих шаров, то скорее всего мы создадим хороший шар и наоборот. Если общее число шаров велико, то мы не будем усложнять игроку жизнь новыми шарами, дождёмся пока какие-нибудь шары не покинут пределы поля или не будут уничтожены игроком. Эти рассуждения приводят нас к типам:

data Creation = Creation 
    { creationStat      :: Stat
    , creationGoalStat  :: Stat
    , creationTick      :: Int
    }

data Stat = Stat
    { goodCount     :: Int
    , badCount      :: Int
    , bonusCount    :: Int
    } 

data Freq = Freq 
    { freqGood      :: Float
    , freqBad       :: Float
    , freqBonus     :: Float
    } 

Поле creationStat содержит текущее число шаров на поле, поле creationGoalStat – число шаров, к которому мы стремимся. Значение типа Freq содержит веса вероятностей создания нового шара определённого типа. На каждом шаге мы будем прибавлять единицу к creationTiсk, как только оно достигнет определённого значения мы попробуем создать новый шар.

Перейдём к грязным данным. Там мы будем хранить информацию, необходимую для обновления модели в Hipmunk, и значение, в которое GLFW будет записывать состояние мыши, также мы будем следить за тем, кто столкнулся с шаром игрока в данный момент:

data Dirty = Dirty 
    { dirtyHero     :: Obj
    , dirtyObjs     :: IxMap Obj
    , dirtySpace    :: H.Space
    , dirtyTouchVar :: Sensor H.Shape
    , dirtyMouse    :: Sensor H.Position
    }

data Obj = Obj 
    { objType     :: BallType
    , objShape    :: H.Shape
    , objBody     :: H.Body
    } 

type Sensor a = IORef (Maybe a)

Особая структура IxMap отвечает за хранение значений вместе с индексами. Пока остановимся на самом простом представлении:

type IxMap a = [(Id, a)]

Структура проекта

Наметим структуру проекта. У нас уже есть модуль Types.hs. Основной цикл игры будет описан в модуле Loop.hs. Общие функции обновления состояния будут определены в World.hs, также у нас будет два модуля отвечающие за обновление чистых и грязных данных – Pure.hs и Dirty.hs. Мы выделим отдельный модуль для описания всех констант игры (Inits.hs). Так нам будет удобно настроить игру, когда мы закончим с кодом. Отдельный модуль Utils будет содержать все функции общего назначения, преобразования между типами OpenGL и Hipmunk.

Детализируем функции обновления состояния игры

Начнём с восприятия:

module World where

import qualified Physics.Hipmunk as H

import Data.Maybe
import Types
import Utils

import Pure
import Dirty

percept :: Dirty -> IO (Sense, [Event])
percept a = do
    hero    <- obj2hero $ dirtyHero a
    balls   <- mapM (uncurry obj2ball) $ setIds dirtyObjs a
    evts1   <- fmap maybeToList $ getTouch (dirtyTouchVar a) $ dirtyObjs a
    evts2   <- fmap maybeToList $ getClick $ dirtyMouse a
    return $ (Sense hero balls, evts1 ++ evts2)
    where setIds = zip [0..]

-- в Dirty.hs
obj2hero    :: Obj -> IO HeroBall
obj2ball    :: Id -> Obj -> IO Ball
getTouch    :: Sensor H.Shape -> IxMap Obj -> IO (Maybe Event)
getClick    :: Sensor H.Position -> IO (Maybe Event)

Далее мы не будем каждый раз выписывать новые неопределённые функции, мы будем просто оставлять объявления типов без определений. Итак мы написали одну функцию, и получили ещё четыре новых.

Мы сделаем предположение о том, что сначала мы реагируем на непрерывные события, а затем на дискретные. Причём к запросам на реакции могут привести только дискретные события:

updatePure :: Sense -> [Event] -> Pure -> (Pure, [Query])
updatePure s evts = updateEvents evts . updateSenses s 

-- в Pure.hs
updateSenses :: Sense -> Pure -> Pure
updateEvents :: [Event] -> Pure -> (Pure, [Query])

В функции react мы предполагаем, что реакции мира на события независимы друг от друга. foldQuery~– функция свёртки для типа Query.

import Control.Monad
...

react :: [Query] -> Dirty -> IO Dirty
react = foldr (<=<) return   
    . fmap (foldQuery removeBall heroVelocity makeBall)

-- в Dirty.hs
removeBall      :: Ball         -> Dirty -> IO Dirty
heroVelocity    :: H.Velocity   -> Dirty -> IO Dirty
makeBall        :: Freq         -> Dirty -> IO Dirty

Обратите внимание на то, как мы воспользовались функциями foldr, return и <=< для того чтобы нанизывать друг на друга функции типа Dirty -> IO Dirty. Напомню, что функция <=<~– это аналог композиции для монадных функций.

Обновление модели:

updateDirty :: Dirty -> IO Dirty
updateDirty = stepDirty dt

-- в Dirty.hs
stepDirty :: H.Time -> Dirty -> IO Dirty

-- в Inits.hs
dt :: H.Time
dt = 0.5

Функции рисования поместим в отдельный модуль Graphics.hs

-- переместим из Loop.hs в World.hs 
drawWorld :: World -> IO ()
drawWorld = draw . picture . worldPure

-- в Graphics.hs
draw :: Picture -> IO ()

-- в Pure.hs
picture     :: Pure -> Picture

Добавим функцию инициализации игры:

initWorld :: IO World
initWorld = do
    dirty   <- initDirty
    (sense, events) <- percept dirty
    return $ World (initPure sense events) dirty

-- в Dirty.hs
initDirty :: IO Dirty
-- в Pure.hs
initPure :: Sense -> [Event] -> Pure

Детализируем дальше

Вот так на самом интересном месте… Мы вынуждены прерваться. Я надеюсь, что вы уловили основную идею метода и сможете закончить эту игру самостоятельно. Вся логика игры будет описана в модуле Pure.hs. Причём в этом модуле будут только чистые функции. Осталось примерно 1000 строк кода. Я не буду выписывать своё решение, если вы где-то запнётесь или у вас что-то не будет получаться, вы можете свериться с ним (оно входит в код, что прилагается с книгой).

Краткое содержание

В этой главе мы посмотрели на две интересные библиотеки. Физический движок Hipmunk и графическую библиотеку OpenGL и узнали метод укрощения императивного кода. Мы разделили состояние игры на две части. В одну поместили все те параметры, для которых невозможно обойтись без IO-функций, а в другой те параметры, которые необходимы для реализации логики игры. Все функции, отвечающие за логику игры являются чистыми. Параметры императивной части не обновляются сразу, сначала мы делаем с них снимок, потом передаём этот снимок в чистую часть, и она разбирается с тем как их обновлять. Части общаются между собой на специальных маленьких языках, которые закодированы в типах. Это язык наблюдений (Event), язык реакций (Query) и язык отрисовки игрового мира (Picture).

Упражнения

Закончите код игры. Или, возможно, при знакомстве с Hipmunk у вас появилась идея новой игры с невероятной динамикой. Ещё лучше! Напишите её. При этом продумайте проект игры так, чтобы IO-типы не разбежались по всей программе.

Зарегистрировано под лицензией Creative commons Attribution-NonCommercial-NoDerivs 3.0 Generic (CC BY-NC-ND 3.0)