英語だと “bouncing ball programming ” とか検索すると出てくるやつ。
単にボールが弾むだけなのだが、思ったより勉強になったので書き残す。
実際のプログラムの動作はGitHub Pages を参照。
プロジェクトの初期化# 適当なディレクトリを作って、その中でプロジェクトを作成。
% spago init
% spago build
今回は、追加のパッケージは必要なときにspago install
コマンドで入れることにする。
Canvas入門# src/Main.purs
を以下のようにする。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
module Main where
import Prelude
import Data.Maybe ( Maybe ( .. ))
import Effect ( Effect )
import Effect.Console ( log )
import Graphics.Canvas ( CanvasElement , Dimensions )
import Graphics.Canvas as Canvas
import Math as Math
canvasDimen :: Dimensions
canvasDimen =
{ width : 600.0
, height : 600.0
}
initCanvas :: CanvasElement -> Effect Unit
initCanvas canvas =
Canvas . setCanvasDimensions canvas canvasDimen
main :: Effect Unit
main =
Canvas . getCanvasElementById "canvas" >>=
case _ of
Just canvas -> do
initCanvas canvas
ctx <- Canvas . getContext2D canvas
Canvas . fillPath ctx $
Canvas . arc ctx
{ x : canvasDimen . width / 2.0
, y : canvasDimen . height / 2.0
, start : 0.0
, end : Math . tau
, radius : 10.0
}
Nothing ->
log "Error on getCanvasElementById."
ビルドに当たって,必要な以下の3つのパッケージをインストールする。
% spago install canvas math maybe
それぞれ以下の通り。
canvas :
JavaScriptのCanvas API のバインディング。math :
基本的にはJavaScriptのMath のバインディングになっているが、
上のコードで使っているMath.tau
に関しては2*Math.pi
として定義されている。maybe :
お馴染み。Canvas.getCanvasElementById
関数がMaybe
型を返すので必要。実は、Canvas APIを使うのが今回が初めてだった。PureScriptでもJSでも変わらず、次のような方法で書くようだ。
canvas
要素を取得。PureScriptの場合はgetCanvasElementById
を利用。canvas
要素からコンテキストを取得。PureScriptの場合はgetContext2D
を利用。パスを作成するときは、beginPath
でパスを開始し、moveTo
、lineTo
、arc
などでパスを作っていって、
最後にstroke
で実際の描画を行う。fill
にすると塗りつぶす。 JSではfillStyle
プロパティを書き換えて、塗りつぶしの色を設定する。PureScriptではsetFillStyle
関数を利用する。 上のコードでのfillPath
は、beginPath
とfill
を組み合わせて作られた関数であり、以下の2つのコードは同じ。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
-- 1つ目
Canvas . fillPath ctx $
Canvas . arc ctx
{ x : canvasDimen . width / 2.0
, y : canvasDimen . height / 2.0
, start : 0.0
, end : Math . tau
, radius : 10.0
}
-- 2つ目
Canvas . beginPath ctx
Canvas . arc ctx
{ x : canvasDimen . width / 2.0
, y : canvasDimen . height / 2.0
, start : 0.0
, end : Math . tau
, radius : 10.0
}
Canvas . fill ctx
ブラウザ上での確認# JSのファイルに変換する。出力先ディレクトリはpublic/
にする。
% spago bundle-app -t public/index.js
public/index.html
を作成し、内容を以下のようにする。
1
2
3
4
5
6
7
<!DOCTYPE html>
< html >
< body >
< canvas id = "canvas" style = "border: 1px solid #000" ></ canvas >
< script src = "index.js" ></ script >
</ body >
</ html >
index.html
を開くと、黒い円が表示される。
Canvasのユーティリティの作成# 後で利用するために、円を描画するための関数circle
と,キャンバス全体をクリアするための関数clearCanvas
を定義しておく。
パッケージ名はGraphics.Canvas.Extra
としたいので、src/Graphics/Canvas/Extra.purs
を作成し、内容を以下のようにする。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
module Graphics.Canvas.Extra where
import Prelude
import Effect ( Effect )
import Graphics.Canvas ( Context2D , Dimensions )
import Graphics.Canvas as Canvas
import Math as Math
clearCanvas :: Context2D -> Dimensions -> Effect Unit
clearCanvas ctx dimen =
Canvas . clearRect ctx
{ x : 0.0
, y : 0.0
, width : dimen . width
, height : dimen . height
}
type Circle =
{ x :: Number
, y :: Number
, radius :: Number
}
circle :: Context2D -> Circle -> Effect Unit
circle ctx { x , y , radius } =
Canvas . arc ctx
{ x
, y
, radius
, start : 0.0
, end : Math . tau
}
メインループの実装# 試しに、ボールが左から右へ動くプログラムを作成してみる。
src/Main.purs
を以下のようにする。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
module Main where
import Prelude
import Data.Maybe ( Maybe ( .. ))
import Effect ( Effect )
import Effect.Console ( log )
import Effect.Timer as Timer
import Graphics.Canvas ( CanvasElement , Context2D , Dimensions )
import Graphics.Canvas as Canvas
import Graphics.Canvas.Extra as Canvas
canvasDimen :: Dimensions
canvasDimen =
{ width : 600.0
, height : 600.0
}
initCanvas :: CanvasElement -> Effect Unit
initCanvas canvas =
Canvas . setCanvasDimensions canvas canvasDimen
type Model =
{ x :: Number
, y :: Number
}
init :: Model
init =
{ x : canvasDimen . width / 2.0
, y : canvasDimen . height / 2.0
}
update :: Model -> Model
update model @ { x } =
model { x = x + 1.0 }
view :: Context2D -> Model -> Effect Unit
view ctx { x , y } = do
Canvas . setFillStyle ctx "salmon"
Canvas . fillPath ctx $
Canvas . circle ctx
{ x
, y
, radius : 10.0
}
mainLoop :: Context2D -> Model -> Effect Unit
mainLoop ctx model = do
Canvas . clearCanvas ctx canvasDimen
view ctx model
void $ Timer . setTimeout 10 $ mainLoop ctx ( update model )
main :: Effect Unit
main =
Canvas . getCanvasElementById "canvas" >>=
case _ of
Just canvas -> do
initCanvas canvas
ctx <- Canvas . getContext2D canvas
mainLoop ctx init
Nothing ->
log "Error on getCanvasElementById."
setTimeout
を使いたいので、関連パッケージを入れておく。
% spago install js-timers
init
でモデル(ここではただのxy座標)を初期化し、view
で描画処理を行い、update
でモデルの更新をする。
なんとなくTEA っぽい設計をした。
setTimeout
で10msおきに同じ関数を呼び出すようにしており、これでメインループを実現している。
前節同様、spago bundle-app
を行ってindex.html
を開くと、ボールが左から右へ動く様子が表示される(画像は略)。
ボールの作成# 次のような仕様にする。
ボールはBall
という型で管理し、これはData.Ball
で宣言する。 ボールは位置、速度の情報を含むが、これは2次元のベクトルの形で管理する。
2次元ベクトルはVec
という型で管理し、これはData.Vec
で宣言する。 Vecの実装# src/Data/Vec.purs
を作成する。以下、このファイルに内容を追記していく。
まず、Vec
型を作成する。
recordを直接使うかnewtype
で包むかで選択肢があるが、
これは悩ましい問題(調べたらdiscourse で同じ議論があった。)。
ここではコンパイルエラーの見やすさの観点からnewtype
で包むことにした。
1
2
3
4
5
6
7
8
9
module Data.Vec where
import Prelude
newtype Vec = Vec
{ x :: Number
, y :: Number
}
newtype
で包んだので、値の取り出し方を考える必要がある。
Newtype
クラスのインスタンスにしてunwrap/wrap
を直接使うという手段もあるが、
それがコード中で多用されるとなんとなく見づらい気がしたので、ここではゲッターとセッターを定義することにした。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
getX :: Vec -> Number
getX ( Vec { x }) = x
getY :: Vec -> Number
getY ( Vec { y }) = y
setX :: Number -> Vec -> Vec
setX xnew ( Vec v ) =
Vec v { x = xnew }
setY :: Number -> Vec -> Vec
setY ynew ( Vec v ) =
Vec v { y = ynew }
Vec
のコンストラクタと、0ベクトルを作成する便利関数を作っておく。
1
2
3
4
5
6
new :: Number -> Number -> Vec
new x y = Vec { x , y }
zero :: Vec
zero = Vec { x : 0.0 , y : 0.0 }
ベクトル同士の演算やスカラー倍、ノルムを定義しておく。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
import Math as Math -- コード上部に書いておく
add :: Vec -> Vec -> Vec
add ( Vec u ) ( Vec v ) =
new ( u . x + v . x ) ( u . y + v . y )
sub :: Vec -> Vec -> Vec
sub ( Vec u ) ( Vec v ) =
new ( u . x - v . x ) ( u . y - v . y )
mult :: Number -> Vec -> Vec
mult c ( Vec v ) =
new ( c * v . x ) ( c * v . y )
div :: Vec -> Number -> Vec
div ( Vec v ) c =
new ( v . x / c ) ( v . y / c )
magSq :: Vec -> Number
magSq ( Vec v ) =
v . x * v . x + v . y * v . y
mag :: Vec -> Number
mag v = Math . sqrt $ magSq v
Ballの実装# src/Data/Ball.purs
を作成する。以下、このファイルに内容を追記していく。
とりあえず、Ball
は位置ベクトルr
と速度ベクトルv
と半径radius
を持っているとする。
後でいくつかフィールドを足す。
1
2
3
4
5
6
7
8
9
10
11
module Data.Ball where
import Prelude
import Data.Vec ( Vec )
newtype Ball = Ball
{ r :: Vec
, v :: Vec
, radius :: Number
}
ゲッター、セッターを定義する。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
getR :: Ball -> Vec
getR ( Ball { r }) = r
getV :: Ball -> Vec
getV ( Ball { v }) = v
setR :: Vec -> Ball -> Ball
setR r ( Ball b ) = Ball b { r = r }
setV :: Vec -> Ball -> Ball
setV v ( Ball b ) = Ball b { v = v }
getRadius :: Ball -> Number
getRadius ( Ball { radius }) = radius
コンストラクタを作成。
Canvas用の描画形式に変換する関数も定義しておく。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
-- 以下の2行はファイル最初に追加
import Data.Vec as Vec
import Graphics.Canvas.Extra ( Circle )
new :: Vec -> Vec -> Number -> Ball
new r v radius = Ball { r , v , radius }
toCircle :: Ball -> Circle
toCircle ( Ball { r , radius }) =
{ x : Vec . getX r
, y : Vec . getY r
, radius
}
Ballの作成・更新・描画# src/Main.purs
のModel
、init
、update
、view
を以下のようにする。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
--- 以下の3行はファイル最初に追加
import Data.Ball ( Ball )
import Data.Ball as Ball
import Data.Vec as Vec
type Model = Ball
init :: Model
init =
Ball . new
( Vec . new
( canvasDimen . width / 2.0 )
( canvasDimen . height / 2.0 ))
( Vec . new 1.0 2.0 )
10.0
update :: Model -> Model
update ball =
Ball . update ball
view :: Context2D -> Model -> Effect Unit
view ctx ball = do
Canvas . setFillStyle ctx "salmon"
Canvas . fillPath ctx $
Canvas . circle ctx $ Ball . toCircle ball
init
でボールを作成。update
でボールの状態(位置や速度)を更新。viewでBall
を円として描画している。
Ball.update
がまだ未実装なので、再びsrc/Data/Ball.purs
に戻る。ひとまず以下の定義にする。
単純に等速直線運動させる。
1
2
3
4
5
6
7
update :: Ball -> Ball
update ball =
setR
( Vec . add
( getR ball )
( getV ball ))
ball
spago bundle-app
した結果は以下のようになる。
跳ね返りの実装# src/Data/Ball.purs
を編集する。Ball
を動かす処理をmove
に任せ、跳ね返りの処理をcollide
に任せる。
1
2
3
4
5
6
7
8
9
10
move :: Ball -> Ball
move ball =
setR
( Vec . add ( getR ball ) ( getV ball ))
ball
update :: Dimensions -> Ball -> Ball
update dimen ball =
move $ collide 1.0 dimen ball
move
は位置ベクトルに速度ベクトルを加算しているだけ。
collide
は、キャンバスの四方にぶつかった際に、位置を補正して、速度を逆向きにする処理を行う。
第1引数に反発係数をとる(上のコードでは1.0
を設定している)。
この処理は擬似コードで書くと、
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
if (ボールが左にはみ出た) {
速度のx座標の符号を反転;
ボールの座標を左端に補正;
}
if (ボールが右にはみ出た) {
速度のx座標の符号を反転;
ボールの座標を右端に補正;
}
if (ボールが上にはみ出た) {
速度のy座標の符号を反転;
ボールの座標を上端に補正;
}
if (ボールが下にはみ出た) {
速度のy座標の符号を反転;
ボールの座標を下端に補正;
}
みたいに書きたい。上のように、「ボールの状態の変更するという命令」
を上から順に実行しているように書きたい場合は、State
モナドが適していると思われる(恐らく)。
ただし一応Stateモナドを使わないバージョンも考えみたので、いくつか実装例を示す。
実装例(1): 位置や速度をまとめて更新# 新しい位置や速度を計算して、最後に一気にball
に反映させる戦略。
ネストが深くなるのを防ぐために、あえて冗長な実装を考えてみた。
まずxy軸それぞれについて、キャンバスの外にはみ出ているか否かを判定するために、
getIntervalPosition
関数を定義する。
getIntervalPosition a b x
は、x
と閉区間[a, b]
との位置関係を返す関数である。すなわち、
x < a
であるか(Small
)a <= x <= b
であるか(Within
)b < x
であるか(Large
)を返す関数である。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
data IntervalPosition
= Small
| Within
| Large
getIntervalPosition :: Number -> Number -> Number -> IntervalPosition
getIntervalPosition a b x =
if x < a
then
Small
else
if x <= b
then Within
else Large
これを使ってcollide
関数を実装する。円の大きさを衝突の計算で考慮するために、
変数x0, x1, y0, y1
を導入している。そして、
ボールのx座標が区間[x0, x1]
に対しどのような位置にあるか ボールのy座標が区間[y0, y1]
にに対しどのような位置にあるか をgetIntervalPosition
で計算している。その返却値によって新しい位置ベクトル、速度ベクトルのxy座標を決定する。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
import Data.Tuple ( Tuple ( .. )) -- ファイル最初に追記
collide :: Number -> Dimensions -> Ball -> Ball
collide e dimen ball =
setR ( Vec . new newX newY ) $
setV ( Vec . new newVx newVy ) ball
where
r = getR ball
v = getV ball
x = Vec . getX r
y = Vec . getY r
vx = Vec . getX v
vy = Vec . getY v
radius = getRadius ball
x0 = radius
x1 = dimen . width - radius
y0 = radius
y1 = dimen . height - radius
Tuple newX newVx =
case getIntervalPosition x0 x1 x of
Small ->
Tuple x0 ( - e * vx )
Large ->
Tuple x1 ( - e * vx )
Within ->
Tuple x vx
Tuple newY newVy =
case getIntervalPosition y0 y1 y of
Small ->
Tuple y0 ( - e * vy )
Large ->
Tuple y1 ( - e * vy )
Within ->
Tuple y vy
Tuple
を使っているので、tuples をインストールしておく。
% spago install tuples
個人的に見通しよく書けたと思うが、やっぱり難しく考えすぎかも…。
実装例(2) Stateを使わない状態の変更# 条件分岐の度にball
を更新する戦略。State
を使わないバージョンだと、
以下のように関数fx0, fx1, fy0, fy1
の適用を連鎖させる感じになる。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
collide :: Number -> Dimensions -> Ball -> Ball
collide e dimen ball = fy1 $ fy0 $ fx1 $ fx0 ball
where
r = getR ball
v = getV ball
radius = getRadius ball
x = Vec . getX r
y = Vec . getY r
vx = Vec . getX v
vy = Vec . getY v
x0 = radius
x1 = dimen . width - radius
y0 = radius
y1 = dimen . height - radius
fx0 :: Ball -> Ball
fx0 ball =
if ( x < x0 )
then setR ( Vec . setX x0 r ) $ setV ( Vec . setX ( - e * vx ) v ) ball
else ball
fx1 :: Ball -> Ball
fx1 ball =
if ( x > x1 )
then setR ( Vec . setX x1 r ) $ setV ( Vec . setX ( - e * vx ) v ) ball
else ball
fy0 :: Ball -> Ball
fy0 ball =
if ( y < y0 )
then setR ( Vec . setY y0 r ) $ setV ( Vec . setY ( - e * vy ) v ) ball
else ball
fy1 :: Ball -> Ball
fy1 ball =
if ( y > y1 )
then setR ( Vec . setY y1 r ) $ setV ( Vec . setY ( - e * vy ) v ) ball
else ball
実装例(3) Stateを使う状態の変更# 上述した擬似コードと似た雰囲気で書ける。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
import Control.Monad.State ( State , execState , modify_ , gets ) -- ファイル最初に追記
collide :: Number -> Dimensions -> Ball -> Ball
collide e dimen ball = execState state ball
where
state :: State Ball Unit
state = do
r <- gets getR
v <- gets getV
radius <- gets getRadius
let x = Vec . getX r
y = Vec . getY r
vx = Vec . getX v
vy = Vec . getY v
x0 = radius
x1 = dimen . width - radius
y0 = radius
y1 = dimen . height - radius
when ( x < x0 ) do
modify_ $ setR ( Vec . setX x0 r )
modify_ $ setV ( Vec . setX ( - e * vx ) v )
when ( x > x1 ) do
modify_ $ setR ( Vec . setX x1 r )
modify_ $ setV ( Vec . setX ( - e * vx ) v )
when ( y < y0 ) do
modify_ $ setR ( Vec . setY y0 r )
modify_ $ setV ( Vec . setY ( - e * vy ) v )
when ( y > y1 ) do
modify_ $ setR ( Vec . setY y1 r )
modify_ $ setV ( Vec . setY ( - e * vy ) v )
State
を使っているのでtransformers を入れる。
% spago install transformers
簡易的な物理演算# 重力などの力を加えて加速度を生じさせたい。
力と質量の追加# Ball
にforce
フィールド、mass
フィールドを追加する。
1
2
3
4
5
6
7
newtype Ball = Ball
{ r :: Vec
, v :: Vec
, radius :: Number
, force :: Vec
, mass :: Number
}
force
、mass
のゲッターを追加する。
1
2
3
4
5
6
getForce :: Ball -> Vec
getForce ( Ball { force }) = force
getMass :: Ball -> Number
getMass ( Ball { mass }) = mass
力はaddForce
で追加することと、initForce
で初期化することしかできないようにする。
applyForce
は、運動方程式mass * a = force
から加速度a = force / mass
を計算し、
加速度を使ってv
を更新する関数。計算し終えたら力を初期化する。
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
addForce :: Vec -> Ball -> Ball
addForce newForce ( Ball b @ { force }) =
Ball b { force = Vec . add force newForce }
initForce :: Ball -> Ball
initForce ( Ball b ) =
Ball b { force = Vec . zero }
applyForce :: Ball -> Ball
applyForce ball =
let a = Vec . div ( getForce ball ) ( getMass ball )
newV = Vec . add ( getV ball ) a
in
initForce $ setV newV ball
Ball
のフィールドが増えたので、コンストラクタを修正する。
1
2
3
4
5
6
7
8
9
new :: Vec -> Vec -> Number -> Number -> Ball
new r v radius mass =
Ball
{ r
, v
, radius
, force : Vec . zero
, mass
}
それに伴いsrc/Main.purs
も修正する。
1
2
3
4
5
6
7
8
9
init :: Model
init =
Ball . new
( Vec . new
( canvasDimen . width / 2.0 )
( canvasDimen . height / 2.0 ))
( Vec . new 1.0 2.0 )
10.0
10.0
重力の追加# src/Data/Ball.purs
のupdate
を以下のようにする。mass * 定数
の力を返す関数gravity
を新たに定義する。
update
関数は以下の手順を踏む。
ボールに力を加えて、 ボールの衝突判定をして(反発係数は0.9)、 ボールの位置を動かして ボールが受けている力を元に速度を更新する。 1
2
3
4
5
6
7
8
9
10
11
update :: Dimensions -> Ball -> Ball
update dimen ball =
applyForce $
move $
collide 0.9 dimen $
addForce ( gravity ( getMass ball )) ball
gravity :: Number -> Vec
gravity mass =
Vec . mult mass $ Vec . new 0.0 0.25
初期速度がこのままだと動きがあまりなく面白くないので、初期速度を変更する。
src/Main.purs
のinit
関数にて、速度のx座標を大きくする。
1
2
3
4
5
6
7
8
9
init :: Model
init =
Ball . new
( Vec . new
( canvasDimen . width / 2.0 )
( canvasDimen . height / 2.0 ))
( Vec . new 10.0 2.0 )
10.0
10.0
spago bundle-app
して確認してみると以下のようになる(gif画像なのでカクついているが、実際はもっと滑らかに動く)。
(おまけ) update関数をStateを使って書き直す# State
を使うと以下のように書ける。
ボールの状態の変更を行う関数が上から下へと並んでいて、まるで命令型言語で書いてあるような雰囲気が出る。
1
2
3
4
5
6
7
8
9
update :: Dimensions -> Ball -> Ball
update dimen ball = execState state ball
where
state :: State Ball Unit
state = do
modify_ $ addForce ( gravity ( getMass ball ))
modify_ $ collide 0.9 dimen
modify_ $ move
modify_ $ applyForce
考えたこと# 位置と速度の書き間違い# collide
を定義するとき、以下のような文があった。
1
2
3
4
...
let r = getR ball
v = getV ball
...
これを次のようにしてもコンパイルは通ってしまうが、バグを産む
(実は実際やってしまい、ボールの挙動がおかしくなった)。
1
2
3
4
...
let r = getV ball
v = getR ball
...
このような論理的な間違いをコンパイルエラーにするためには、
次のように速度と位置をラッピングすると良いのだろうか、と思った。
(もっとも、これくらいのミスは自分で気付くべきかもしれないが…)。
ただし、色々書かなくてはならない部分が増える(例えば、速度と位置の足し算を行う関数など)。
1
2
3
4
5
6
7
8
newtype Position = Position Vec
newtype Velocity = Velocity Vec
newtype Ball = Ball
{ r :: Position
, v :: Velocity
, ...
}
これは力についてもいえて、力をVec
で扱うのではなくnewtype Force = Force Vec
と使うべきか。
ソースコードとデモ# ソースコードはGitHubのRepositry として公開した。
デモはGitHub Pages として公開した。