Haskellでポン!(4)

今回はポンの完成偏です。
まずGUI部分だけを作って、ロジックは後からつくろうとも思いましたが、
分割するほどコード量が多くないので、結局一度に書きます。

まず、完成品の画面です。

本当に最小限のポンです。ボールのスピードを変化させたりする前に力尽きました。

基本

ウィジェットの定義やコールバックは、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を使います。

感想

HaskellGUIに向いていない?

キーボード処理の不具合など、WxHaskellはwxPythonに比べて未完成なようです。

GUI部分を書く場合には、HaskellPythonなどの手続き型言語よりも、
特に優れているとは感じませんでした。
do で順番に書いていくだけなので。

一方でロジック部を書く場合は、破壊的な操作が必要ないので書きやすいと感じました。

前置と中置の混在
take i alist

のような、前置記法の関数適用と

x ++ y

のような演算子の中置記法が混在するのが書きにくいです。
中置記法では"$"が使えません。

i `take` alist
(++) x y

のように、関数を中置記法で、演算子を前置記法で各方法はありますが、
いっそ、(Lispのように)全部前置記法で統一すればすっきりすると思います。

記号

また、Pythonに慣れた身には、Haskellは記号が多すぎます。

完成したコード

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
広告を非表示にする