Haskellでポン！（４）
今回はポンの完成偏です。
まずＧＵＩ部分だけを作って、ロジックは後からつくろうとも思いましたが、
分割するほどコード量が多くないので、結局一度に書きます。
まず、完成品の画面です。
本当に最小限のポンです。ボールのスピードを変化させたりする前に力尽きました。
基本
ウィジェットの定義やコールバックは、IO()をdo文を使って書きます。
リストの各要素に対して、アクションを実行したいときは、"mapM_"を使います。
たとえば、次は
do mapM_ print ["Spam", "Egg", "Ham"]
は以下と同等です。
do print "Spam" print "Egg" print "Ham"
mapM_はHaskellにもともと入っている物なので、WxHaskell以外でも使います。
変数
状態変化が必要な場所ではvar***を使います。
| 初期化 | var <- varCreate value |
| 参照 | varGet value |
| 代入 | varSet var value |
| 更新 | varUpdate var f |
ここでvarUpdateは、varに格納された値をfに渡し、返り値をvarに代入します。
また、varGet以外は、全てdo文の中でしか使えません。
コールバックの設定
コールバック関数や表示方法などの設定は、
f <- frame [on paint := paintPon vPon
,clientSize := size]のように、ウィジェットの初期化時に設定するか、
set t [on command := update t vPon vKeyboard f]
set で設定します。
Windowsでの不具合
Windowsでは on (charKey char)が使えません。
そのため、sampleのBouncingBallsでキーボードが効きません。
かわりにGraphics.UI.WXCoreをimportして、windowOnKeyDownやwindowOnKeyUpを使います。
感想
HaskellはGUIに向いていない？
キーボード処理の不具合など、WxHaskellはwxPythonに比べて未完成なようです。
GUI部分を書く場合には、HaskellがPythonなどの手続き型言語よりも、
特に優れているとは感じませんでした。
do で順番に書いていくだけなので。
一方でロジック部を書く場合は、破壊的な操作が必要ないので書きやすいと感じました。
完成したコード
import Graphics.UI.WX
import Graphics.UI.WXCore
import Data.List
data Ball
= Ball{
ballPos::Vector,
ballRadius::Int,
ballVel::Vector
}
data Bar
= Bar {
barPos::Vector,
barSize::Int
}
data Pon
= Pon {
ponBalls::[Ball],
ponBars::[Bar],
ponSize::Size
}
main = start mainFrame
mainFrame =
do let pon = ponCreate
size = ponSize pon
vKeyboard <- varCreate []
vPon <- varCreate pon
f <- frame [on paint := paintPon vPon
,clientSize := size]
t <- timer f [interval := 20]
set t [on command := update t vPon vKeyboard f]
windowOnKeyDown f $ onKeyDown vKeyboard
windowOnKeyUp f $ onKeyUp vKeyboard
return ()
where
paintPon vPon dc view
= do pon <- varGet vPon
mapM_ (drawABall dc) $ ponBalls pon
mapM_ (drawABar dc) $ ponBars pon
drawABall dc ball
= do set dc [brushColor := red, brushKind := BrushSolid]
circle dc (pointFromVec $ ballPos ball) (ballRadius ball) []
drawABar dc bar
= do let x = vecX (barPos bar)
top = vecY (barPos bar) - barSize bar
bottom = vecY (barPos bar) + barSize bar
line dc (pt x top) (pt x bottom) []
update timer vPon vKeyboard view
= do pon <- varGet vPon
if ponIsGameOver pon
then
do
set timer [enabled := False]
beep
else
do keyboard <- varGet vKeyboard
mapM_ (moveBar vPon) keyboard
varUpdate vPon ponUpdate
repaint view
beep
= wxcBell --putStr "\a"
onKeyDown vKeyboard evt
= do varUpdate vKeyboard $ union [keyKey evt]
return ()
onKeyUp vKeyboard evt
= do varUpdate vKeyboard $ delete $ keyKey evt
return ()
moveBar vPon k
= case k of
KeyChar 'Q' -> moveBar' vPon 0 (-5)
KeyChar 'A' -> moveBar' vPon 0 5
KeyUp -> moveBar' vPon 1 (-5)
KeyDown -> moveBar' vPon 1 5
_ -> skipCurrentEvent
moveBar' vPon i dy
= do varUpdate vPon (\pon -> ponMoveBar pon i dy)
return ()
{- ここから、ゲームのロジック部-}
-- 初期状態
ponCreate = let ball = Ball (vec 150 150) 5 (vec 5 5)
bar1 = Bar (vec 30 150) 30
bar2 = Bar (vec 570 150) 30
size = sz 600 300
in Pon [ball] [bar1, bar2] size
ponUpdate pon
= pon {ponBalls=(map (\ball -> ballPosUpdate ball pon) (ponBalls pon))}
ballPosUpdate ball pon
= let pos = ballPos ball
vel = ballVel ball
line = (pos, vecAdd pos vel, vel)
bars = ponBars pon
reflects = [reflect_top pon, reflect_bottom pon] ++ map reflect_bar bars
(from, to, vel1) = foldr (\f li -> f li) line reflects
in ball {ballPos=to, ballVel=vel1}
reflect_top::Pon -> (Vector, Vector, Vector) -> (Vector, Vector, Vector)
reflect_top pon line
= let (from, to, vel) = line
Vector {vecX=x1, vecY=y1} = to
Vector {vecX=x0, vecY=y0} = from
in
if y1 >= 0
then line
else
let y = -y1
x = div (y0 * x1 - y * x0) (y0 + y)
in (vec x 0, vec x1 y, vecInvY vel)
vecInvX v = v {vecX= - vecX v}
vecInvY v = v {vecY= - vecY v}
reflect_bottom::Pon -> (Vector, Vector, Vector) -> (Vector, Vector, Vector)
reflect_bottom pon line
= let (from, to, vel) = line
Vector {vecX=x1, vecY=y1} = to
Vector {vecX=x0, vecY=y0} = from
h = sizeH $ ponSize pon
in
if y1 <= h
then line
else
let y = 2 * h - y1
x = div ((h - y0) * x1 + (h - y) * x0) ((h - y0) + (h - y))
in (vec x h, vec x1 y, vecInvY vel)
reflect_bar::Bar -> (Vector, Vector, Vector) -> (Vector, Vector, Vector)
reflect_bar bar line
= let (from, to, vel) = line
Vector {vecX=x1, vecY=y1} = to
Vector {vecX=x0, vecY=y0} = from
Vector {vecX=bx, vecY=by} = barPos bar
crossY
= if x1 - x0 == 0
then y1
else (div (bx - x0) (x1 - x0)) * (y1 - y0) + y0
in
if ((abs (crossY - by)) <= (barSize bar)) &&
((x1 == bx) || (x1 < bx && bx < x0) || (x1 > bx && bx > x0))
then (vec bx 0, vec (2 * bx - x1) y1, vecInvX vel)
else line
ponMoveBar pon i dy
= if i < (length $ ponBars pon)
then ponMoveBar' pon i dy
else pon
ponMoveBar' pon i dy
= let height= sizeH $ ponSize pon
bars = (ponBars pon)
bar = bars !! i
bar1 = barMove bar dy height
bars1 = (take i bars) ++ [bar1] ++ (drop (i + 1) bars)
in pon {ponBars=bars1}
barMove bar dy height
= let pos = barPos bar
y = vecY pos
size = barSize bar
y1 = max size $ min (height - size) (y + dy)
pos1 = pos {vecY=y1}
in bar {barPos=pos1}
ponIsGameOver pon
= let xList = map (\ball -> vecX $ ballPos ball) $ ponBalls pon
width = sizeW $ ponSize pon
in all (\x -> x <= 0 || width <= x) xList
