Учебник по Haskell

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