haskell - Haskell で書かれたゲームの最小限の例は何ですか?

Question

三ヶ月ぶりの更新

I /O に Arrows と Kleisli Arrows を使用した Functional Reactive Programming の構造で、netwire-5.0.1+を使用して以下の回答があります。sdl「ゲーム」と呼ぶには単純すぎますが、非常に構成可能で、非常に拡張可能でなければなりません。

オリジナル

私はちょうど Haskell を学んでいて、それから小さなゲームを作ろうとしています。ただし、小さな（正規の）テキストゲームがどのような構造になるかを確認したいと思います。また、コードをできるだけ純粋に保つようにしています。私は今、実装方法を理解するのに苦労しています:

1. メインループ。ここに例があります Haskellでゲームループを書くにはどうすればよいですか? しかし、受け入れられた答えは末尾再帰ではないようです。これが重要かどうかは正確にはわかりません。私の理解では、メモリ使用量は増えますよね？
2. 状態遷移。しかし、これは最初のものとかなり関連していると思います。とhttp://www.gamedev.net/page/resources/_/technical/game-programming/haskell-game-object-design-or-how-functions-can-get-youState _ -apples-r3204ですが、個々のコンポーネントが機能し、有限の手順で更新される可能性がありますが、無限ループでどのように使用できるかわかりません。

可能であれば、基本的に次の最小限の例を見たいと思います。

1. プレーヤーに何かを繰り返し入力するように求めます
2. 何らかの条件が満たされると、状態が変化します
3. 他の条件が満たされた場合、終了します
4. 理論的には、メモリを吹き飛ばすことなく無限に実行できます

非常に基本的なものを取得できないため、投稿可能なコードはありません。私がウェブ上で見つけた他の資料/例は、他のライブラリを使用したり、イベントを推進しSDLたりします。GTK私が見つけた完全にHaskellで書かれた唯一のものはhttp://jpmoresmau.blogspot.com/2006/11/my-first-haskell-adventure-game.htmlですが、それはメインループの末尾再帰のようには見えませんも（繰り返しますが、それが重要かどうかはわかりません）。

それとも、Haskell はこのようなことを意図していないのでしょうか? mainまたは、おそらくCに入れるべきですか？

編集 1

だから私はhttps://wiki.haskell.org/Simple_StateT_useの小さな例を修正し、それをさらに単純にしました(そしてそれは私の基準を満たしていません):

module Main where
import Control.Monad.State

main = do 
  putStrLn "I'm thinking of a number between 1 and 100, can you guess it?"
  guesses <- execStateT (guessSession answer) 0
  putStrLn $ "Success in " ++ (show guesses) ++ " tries."
  where
    answer = 10

guessSession :: Int -> StateT Int IO ()
guessSession answer =
    do gs <- lift getLine    -- get guess from user
       let g = read gs       -- convert to number
       modify (+1)           -- increment number of guesses
       case g of
         10 -> do lift $ putStrLn "Right"
         _ -> do lift $ putStrLn "Continue"
                 guessSession answer

ただし、最終的にはメモリがオーバーフローします。でテストしました

bash prompt$ yes 1 | ./Test-Game

メモリ使用量は直線的に増加し始めます。

編集 2

わかりました、 Haskell の再帰とメモリ使用量を見つけ、「スタック」についてある程度理解しました...私のテスト方法に何か問題はありますか?

Answer 1

序文

3 か月間、多数の Web サイトを掘り下げ、いくつかの小さなプロジェクトを試した後、私は最終的に非常に異なる方法でミニマルなゲーム (またはそうですか?) を実装することができました。この例は、Haskell で記述されたゲームの可能な構造の 1 つを示すためだけに存在し、より複雑なロジックとゲームプレイを処理するために簡単に拡張する必要があります。

https://github.com/carldong/HMovePad-Tutorialで利用可能な完全なコードとチュートリアル

概要

このミニゲームには、プレイヤーが左右のキーを押すことで左右に移動できる長方形が 1 つだけあり、それが「ゲーム」全体です。

ゲームは を使用して実装され、グラフィックスnetwire-5.0.1を処理します。SDL私の理解が正しければ、アーキテクチャは完全に機能的でリアクティブです。ほぼすべてが Arrow コンポジションによって実装され、 で公開される関数は 1 つだけIOです。したがって、Haskell の Arrow 構文は広く使用されているため、読者にはその基本的な理解が必要です。

このゲームの実装順序は、デバッグを容易にするために選択されており、実装自体は、さまざまな使用方法をnetwire可能な限り示すように選択されています。

I/O には連続時間セマンティックが使用されますが、ゲーム ロジック内でのゲーム イベントの処理には離散イベントが使用されます。

SDL のセットアップ

最初のステップは、SDL が機能することを確認することです。ソースは簡単です：

module Main where

import qualified Graphics.UI.SDL as SDL

main :: IO ()
main = do
  SDL.init [SDL.InitEverything]
  w <- SDL.setVideoMode 800 600 32 [SDL.SWSurface]
  s <- SDL.createRGBSurfaceEndian [SDL.SWSurface] 800 600 32 
  SDL.fillRect s (Just testRect) (SDL.Pixel 0xFFFFFFFF)
  SDL.blitSurface s (Nothing) w (Nothing) 
  SDL.flip w
  testLoop
  SDL.quit
      where
        testLoop = testLoop
        testRect = SDL.Rect 350 500 100 50

すべてが機能する場合、ウィンドウの下部に白い四角形が表示されます。をクリックしてxもウィンドウは閉じないことに注意してください。Ctrl+Cまたは killで閉じる必要があります。

出力ワイヤの設定

最後のステップまで実装したくないので、画面に何も描画できないことがわかったので、最初に出力部分を実行しています。

Arrows 構文が必要です。

{-# LANGUAGE Arrows #-}

また、いくつかのものをインポートする必要があります。

import Prelude hiding ((.), id)
import Control.Wire
import Control.Arrow
import Control.Monad
import Data.Monoid
import qualified Graphics.UI.SDL as SDL

Kleisli Wires: Netwire 5 の Kleisli Arrowを構築する方法を理解する必要がありますか? . Kleisli Wires を使用した対話型プログラムの基本構造は、次の例に示されています。. type を持つものから Kleisli Wire を構築するには、次のものa -> m bが必要です。

mkKleisli :: (Monad m, Monoid e) => (a -> m b) -> Wire s e m a b
mkKleisli f = mkGen_ $ \a -> liftM Right $ f a

次に、Arrow プロセスの下で作業することができなかったので、traceオブジェクトをコンソールに出力するためのデバッグ ワイヤが作成されます。

wDebug :: (Show a, Monoid e) => Wire s e IO a ()
wDebug = mkKleisli $ \a -> putStrLn $ show a

今度は、ワイヤーに持ち上げられるいくつかの関数を作成します。SDL.Surface出力には、パッドの X 座標を指定して描画された適切な長方形を返す関数が必要です。

padSurf :: SDL.Surface
            -> Int
            -> IO SDL.Surface
padSurf surf x' = do
  let rect' = SDL.Rect x' 500 100 50
  clipRect <- SDL.getClipRect surf
  SDL.fillRect surf (Just clipRect) (SDL.Pixel 0x00000000)
  SDL.fillRect surf (Just rect') (SDL.Pixel 0xFFFFFFFF)
  return surf

注意してください。この関数は破壊的な更新を行います。渡されたサーフェスは、後でウィンドウ サーフェスにブリットされます。

これで表面ができました。出力ワイヤは簡単です。

wTestOutput :: SDL.Surface -> Wire s () IO () SDL.Surface
wTestOutput surf = mkKleisli $ \_ -> testPad
    where
      testPad = padSurf surf 350

次に、ワイヤーをまとめて、少し遊んでみます。

gameWire :: SDL.Surface 
         -> Wire s () IO () SDL.Surface
gameWire w = proc _ -> do
               finalSurf <- wTestOutput w -< ()
               wDebug -< "Try a debug message"
               returnA -< finalSurf

最後にmain、ワイヤを適切に変更して駆動します。

main :: IO ()
main = do
  SDL.init [SDL.InitEverything]
  w <- SDL.setVideoMode 800 600 32 [SDL.SWSurface]
  s <- SDL.createRGBSurfaceEndian [SDL.SWSurface] 800 600 32 
  run w (countSession_ 1) $ gameWire w
  SDL.quit

run ::SDL.Surface ->  Session IO s -> Wire s () IO () SDL.Surface -> IO ()
run mainSurf s w  = do
  (ds, s') <- stepSession s
  (eSrcSurf, w') <- stepWire w ds (Right ())
  case eSrcSurf of 
    Right srcSurf -> do 
                  SDL.blitSurface srcSurf (Nothing) mainSurf (Nothing)
                  SDL.flip mainSurf
                  SDL.delay 30
                  run mainSurf s' w'
    _ -> return ()

必要に応じて、メイン ウィンドウ サーフェスを処理する別のワイヤを作成することもできます (これは簡単で、現在の実装よりも優れています)。上記の対話型の例をチェックして、どのように単純run化できるかを確認してください (その例の代わりに抑制を使用すると、さらに単純化できますquitWire)。

プログラムを実行すると、その外観は以前と同じになるはずです。

完全なコードは次のとおりです。

{-|
  01-OutputWires.hs: This step, the output wires are constructed first for
  easy debugging
-}

{-# LANGUAGE Arrows #-}

module Main where

import Prelude hiding ((.), id)
import Control.Wire
import Control.Arrow
import Control.Monad
import Data.Monoid
import qualified Graphics.UI.SDL as SDL

{- Wire Utilities -}

-- | Make a Kleisli wire
mkKleisli :: (Monad m, Monoid e) => (a -> m b) -> Wire s e m a b
mkKleisli f = mkGen_ $ \a -> liftM Right $ f a

-- | The debug wire
wDebug :: (Show a, Monoid e) => Wire s e IO a ()
wDebug = mkKleisli $ \a -> putStrLn $ show a

{- Functions to be lifted -}

padSurf :: SDL.Surface
            -- ^ Previous state of surface 
            -> Int
            -- ^ X'
            -- | New state
            -> IO SDL.Surface
padSurf surf x' = do
  let rect' = SDL.Rect x' 500 100 50
  clipRect <- SDL.getClipRect surf
  SDL.fillRect surf (Just clipRect) (SDL.Pixel 0x00000000)
  SDL.fillRect surf (Just rect') (SDL.Pixel 0xFFFFFFFF)
  return surf


{- Wires -}

wTestOutput :: SDL.Surface -> Wire s () IO () SDL.Surface
wTestOutput surf = mkKleisli $ \_ -> testPad
    where
      testPad = padSurf surf 350


-- | This is the main game wire
gameWire :: SDL.Surface 
         -- ^ The main surface (i.e. the window)
         -> Wire s () IO () SDL.Surface
gameWire w = proc _ -> do
               finalSurf <- wTestOutput w -< ()
               wDebug -< "Try a debug message"
               returnA -< finalSurf

main :: IO ()
main = do
  SDL.init [SDL.InitEverything]
  w <- SDL.setVideoMode 800 600 32 [SDL.SWSurface]
  s <- SDL.createRGBSurfaceEndian [SDL.SWSurface] 800 600 32 
  run w (countSession_ 1) $ gameWire w
  SDL.quit

run ::SDL.Surface ->  Session IO s -> Wire s () IO () SDL.Surface -> IO ()
run mainSurf s w  = do
  (ds, s') <- stepSession s
  (eSrcSurf, w') <- stepWire w ds (Right ())
  case eSrcSurf of 
    Right srcSurf -> do 
                  SDL.blitSurface srcSurf (Nothing) mainSurf (Nothing)
                  SDL.flip mainSurf
                  SDL.delay 30
                  run mainSurf s' w'
    _ -> return ()

入力ワイヤ

このセクションでは、プレーヤーの入力をプログラムに取得するワイヤーを作成します。

ロジック部分で個別のイベントを使用するため、ゲーム イベントのデータ型が必要です。

data GameEvent = MoveR
               | MoveL
               | NoEvent
                 deriving (Show, Eq)
-- | Make it Monoid so that game events can be combined 
-- (Only applicable in this "game"!)
instance Monoid GameEvent where
    mempty = NoEvent
    -- | Simultaneously moving left and right is just nothing
    MoveR `mappend` MoveL = NoEvent
    MoveL `mappend` MoveR = NoEvent
    -- | NoEvent is the identity
    NoEvent `mappend` x = x
    x `mappend` NoEvent = x
    x `mappend` y 
        -- | Make sure identical events return same events
        | x == y = x
        -- | Otherwise, no event
        | otherwise = NoEvent

コメントが示唆したように、Monoidインスタンスはこの特定のゲームにのみ適用されます。これは、左と右の 2 つの反対の操作しかないためです。

まず、SDL からイベントをポーリングします。

pollEvents :: [SDL.Event] -> IO (Either () ([SDL.Event]))
pollEvents es = do
  e <- SDL.pollEvent
  case e of 
    SDL.NoEvent -> return $ Right es
    SDL.Quit -> return $ Left ()
    _ -> pollEvents $ e:es

明らかに、この関数は SDL からのイベントをリストとしてポーリングし、Quitイベントが受信されると抑制します。

次に、イベントがキーボード イベントかどうかを確認する必要があります。

isKeyEvent :: SDL.Event -> Bool
isKeyEvent (SDL.KeyDown k) = True
isKeyEvent (SDL.KeyUp k) = True
isKeyEvent _ = False

現在押されているキーのリストがあり、キーボード イベントが発生すると更新されます。つまり、キーが押されている場合は、そのキーをリストに挿入し、その逆も同様です。

keyStatus :: [SDL.Keysym] -> [SDL.Event] -> [SDL.Keysym]
keyStatus keysDown (e:es) = 
    case e of
      -- | If a KeyDown is detected, add key to list
      SDL.KeyDown k -> keyStatus (k:keysDown) es
      -- | If a KeyUp is detected, remove key from list
      SDL.KeyUp k -> keyStatus (filter (/= k) keysDown) es
      _ -> keyStatus keysDown es
keyStatus keysDown [] = keysDown

次に、キーボード イベントをゲーム イベントに変換する関数を記述します。

toGameEv :: SDL.Keysym -> GameEvent
toGameEv (SDL.Keysym SDL.SDLK_RIGHT _ _) = MoveR
toGameEv (SDL.Keysym SDL.SDLK_LEFT _ _) = MoveL
toGameEv _ = NoEvent

ゲーム イベントを折りたたんで、1 つのイベントを取得します (本当に、本当に、ゲーム固有です!)。

fireGameEv :: [SDL.Keysym] -> GameEvent
fireGameEv ks = foldl mappend NoEvent $ fmap toGameEv ks

これで、ワイヤーの作成を開始できます。

まず、イベントをポーリングするワイヤが必要です。

wPollEvents :: Wire s () IO () [SDL.Event]
wPollEvents = mkGen_ $ \_ -> pollEvents []

mkKleisli禁止しないワイヤを作成することに注意してください。ただし、プログラムは終了するはずのときに終了する必要があるため、このワイヤで禁止が必要です。したがって、mkGen_ここで使用します。

次に、イベントをフィルタリングする必要があります。まず、連続時間フィルター ワイヤーを作成するヘルパー関数を作成します。

mkFW_ :: (Monad m, Monoid e) => (a -> Bool) -> Wire s e m [a] [a]
mkFW_ f = mkSF_ $ filter f 

mkFW_フィルターを作成するために使用します。

wKeyEvents :: (Monad m, Monoid e) => Wire s e m [SDL.Event] [SDL.Event]
wKeyEvents = mkFW_ isKeyEvent

次に、 type のステートフル関数からステートフル ワイヤを作成する別の便利な関数が必要ですb -> a -> b。

mkSW_ :: (Monad m, Monoid e) => b -> (b->a->b) -> Wire s e m a b
mkSW_ b0 f = mkSFN $ g b0
    where
      g b0 a = let b1 = f b0 a in 
               (b1, mkSW_ b1 f)

次に、すべてのキー ステータスを記憶するステートフル ワイヤを作成します。

wKeyStatus :: (Monad m, Monoid e) => Wire s e m [SDL.Event] [SDL.Keysym]
wKeyStatus = mkSW_ empty keyStatus

ワイヤ セグメントの最後の部分がゲーム イベントを発生させます。

wFireGameEv :: (Monad m, Monoid e) => Wire s e m [SDL.Keysym] (GameEvent)
wFireGameEv = arr fireGameEv

ゲーム イベントを含む個別のイベント (netwire イベント) をアクティブに発生させるには、常にイベントを発生させるワイヤを提供しないため、netwire を少しハックする必要があります (まだ完全ではないと思います)。

always :: (Monad m, Monoid e) => Wire s e m a (Event a)
always = mkSFN $ \x -> (WE.Event x, always)

の実装と比較するとnow、唯一の違いはneverとalwaysです。

最後に、上記のすべての入力ワイヤを結合した大きなワイヤ:

wGameInput :: Wire s () IO () (Event GameEvent)
wGameInput = proc _ -> do
               ge <- wFireGameEv <<< wKeyStatus
                     <<< wKeyEvents <<< wPollEvents -< ()
               e <- always -< ge
               -- Debug!
               case e of 
                 WE.NoEvent -> wDebug -< "No Event?!!"
                 WE.Event g -> wDebug -< "Game Event: " ++ show g
               -- End Debug
               returnA -< e

デバッグの例もこのワイヤに示されています。

メイン プログラムとインターフェイスするgameWireには、入力を使用するように変更します。

gameWire w = proc _ -> do
               ev <- wGameInput -< ()
               finalSurf <- wTestOutput w -< ()
               returnA -< finalSurf

他に何も変更する必要はありません。面白いですね。

プログラムを実行すると、現在発生しているゲーム イベントを示す多くの出力がコンソールに表示されます。左と右、およびそれらの組み合わせを押してみて、動作が期待どおりかどうかを確認してください。もちろん四角形は動きません。

これはコードの巨大なブロックです:

{-|
  02-InputWires.hs: This step, input wires are constructed and
  debugged by using wDebug
-}

{-# LANGUAGE Arrows #-}

module Main where

import Prelude hiding ((.), id)
import Control.Wire
import Control.Arrow
import Control.Monad
import Data.Monoid
import qualified Graphics.UI.SDL as SDL
import qualified Control.Wire.Unsafe.Event as WE

{- Data types -}
-- | The unified datatype of game events 
data GameEvent = MoveR
               | MoveL
               | NoEvent
                 deriving (Show, Eq)
-- | Make it Monoid so that game events can be combined 
-- (Only applicable in this "game"!)
instance Monoid GameEvent where
    mempty = NoEvent
    -- | Simultaneously moving left and right is just nothing
    MoveR `mappend` MoveL = NoEvent
    MoveL `mappend` MoveR = NoEvent
    -- | NoEvent is the identity
    NoEvent `mappend` x = x
    x `mappend` NoEvent = x
    x `mappend` y 
        -- | Make sure identical events return same events
        | x == y = x
        -- | Otherwise, no event
        | otherwise = NoEvent

{- Wire Utilities -}

-- | Make a stateless filter wire
mkFW_ :: (Monad m, Monoid e) => (a -> Bool) -> Wire s e m [a] [a]
mkFW_ f = mkSF_ $ filter f 

-- -- | Make a stateful wire from a chained stateful function and initial value
-- -- The function (a -> b -> a) takes in an old state /a/, and returns state 
-- -- transition function (b -> a). 
mkSW_ :: (Monad m, Monoid e) => b -> (b->a->b) -> Wire s e m a b
mkSW_ b0 f = mkSFN $ g b0
    where
      g b0 a = let b1 = f b0 a in 
               (b1, mkSW_ b1 f)

-- | Make a Kleisli wire
mkKleisli :: (Monad m, Monoid e) => (a -> m b) -> Wire s e m a b
mkKleisli f = mkGen_ $ \a -> liftM Right $ f a

-- | The debug wire
wDebug :: (Show a, Monoid e) => Wire s e IO a ()
wDebug = mkKleisli $ \a -> putStrLn $ show a

-- | The "always" wire
always :: (Monad m, Monoid e) => Wire s e m a (Event a)
always = mkSFN $ \x -> (WE.Event x, always)

{- Functions to be lifted -}

-- | This is the pad surface whose X coordinate can be updated
padSurf :: SDL.Surface
            -- ^ Previous state of surface 
            -> Int
            -- ^ X'
            -- | New state
            -> IO SDL.Surface
padSurf surf x' = do
  let rect' = SDL.Rect x' 500 100 50
  clipRect <- SDL.getClipRect surf
  SDL.fillRect surf (Just clipRect) (SDL.Pixel 0x00000000)
  SDL.fillRect surf (Just rect') (SDL.Pixel 0xFFFFFFFF)
  return surf


-- | The function to poll events and add to a list of events
pollEvents :: [SDL.Event] -> IO (Either () ([SDL.Event]))
pollEvents es = do
  e <- SDL.pollEvent
  case e of 
    SDL.NoEvent -> return $ Right es
    SDL.Quit -> return $ Left ()
    _ -> pollEvents $ e:es

-- | Checks whether one SDL.Event is a keyboard event
isKeyEvent :: SDL.Event -> Bool
isKeyEvent (SDL.KeyDown k) = True
isKeyEvent (SDL.KeyUp k) = True
isKeyEvent _ = False

-- | The raw function to process key status from events
keyStatus :: [SDL.Keysym] -> [SDL.Event] -> [SDL.Keysym]
keyStatus keysDown (e:es) = 
    case e of
      -- | If a KeyDown is detected, add key to list
      SDL.KeyDown k -> keyStatus (k:keysDown) es
      -- | If a KeyUp is detected, remove key from list
      SDL.KeyUp k -> keyStatus (filter (/= k) keysDown) es
      _ -> keyStatus keysDown es
-- | If all events are processed, return
keyStatus keysDown [] = keysDown

-- | Convert a SDL Keysym into "standard" game events
toGameEv :: SDL.Keysym -> GameEvent
toGameEv (SDL.Keysym SDL.SDLK_RIGHT _ _) = MoveR
toGameEv (SDL.Keysym SDL.SDLK_LEFT _ _) = MoveL
toGameEv _ = NoEvent

-- | Combine all game events to get one single firing
fireGameEv :: [SDL.Keysym] -> GameEvent
fireGameEv ks = foldl mappend NoEvent $ fmap toGameEv ks



{- Wires -}

-- | The Kleisli wire to poll events
wPollEvents :: Wire s () IO () [SDL.Event]
wPollEvents = mkGen_ $ \_ -> pollEvents []

-- | A stateless wire that filters out keyboard events
wKeyEvents :: (Monad m, Monoid e) => Wire s e m [SDL.Event] [SDL.Event]
wKeyEvents = mkFW_ isKeyEvent

-- | A stateful wire to keep track of key status
wKeyStatus :: (Monad m, Monoid e) => Wire s e m [SDL.Event] [SDL.Keysym]
wKeyStatus = mkSW_ empty keyStatus

-- | A wire to fire game events from SDL events
wFireGameEv :: (Monad m, Monoid e) => Wire s e m [SDL.Keysym] (GameEvent)
wFireGameEv = arr fireGameEv

-- | This is the connected wire for the entire game input
wGameInput :: Wire s () IO () (Event GameEvent)
wGameInput = proc _ -> do
               ge <- wFireGameEv <<< wKeyStatus
                     <<< wKeyEvents <<< wPollEvents -< ()
               e <- always -< ge
               -- Debug!
               case e of 
                 WE.NoEvent -> wDebug -< "No Event?!!"
                 WE.Event g -> wDebug -< "Game Event: " ++ show g
               -- End Debug
               returnA -< e

-- | The wire to test output
wTestOutput :: SDL.Surface -> Wire s () IO () SDL.Surface
wTestOutput surf = mkKleisli $ \_ -> testPad
    where
      testPad = padSurf surf 350


-- | This is the main game wire
gameWire :: SDL.Surface 
         -- ^ The main surface (i.e. the window)
         -> Wire s () IO () SDL.Surface
gameWire w = proc _ -> do
               ev <- wGameInput -< ()
               finalSurf <- wTestOutput w -< ()
               returnA -< finalSurf

main :: IO ()
main = do
  SDL.init [SDL.InitEverything]
  w <- SDL.setVideoMode 800 600 32 [SDL.SWSurface]
  s <- SDL.createRGBSurfaceEndian [SDL.SWSurface] 800 600 32 
  run w (countSession_ 1) $ gameWire w
  SDL.quit

run ::SDL.Surface ->  Session IO s -> Wire s () IO () SDL.Surface -> IO ()
run mainSurf s w  = do
  (ds, s') <- stepSession s
  (eSrcSurf, w') <- stepWire w ds (Right ())
  case eSrcSurf of 
    Right srcSurf -> do 
                  SDL.blitSurface srcSurf (Nothing) mainSurf (Nothing)
                  SDL.flip mainSurf
                  SDL.delay 30
                  run mainSurf s' w'
    _ -> return ()

「ゲーム」のロジック --- いよいよ総まとめ！

まず、パッドの X 位置の積分関数を書きます。

padDX :: Int -> GameEvent -> Int
padDX x0 e 
    | x > 700 = 700
    | x < 0 = 0
    | otherwise = x
    where
      x = x0 + go e
      go MoveR = dx
      go MoveL = -dx
      go _ = 0
      dx = 15

すべてをハードコーディングしましたが、これらはこの最小限の例では重要ではありません。それは簡単であるべきです。

次に、パッドの現在の位置を表すワイヤを作成します。

wPadX :: (Monad m, Monoid e) => Wire s e m (Event GameEvent) Int
wPadX = accumE padDX 400 >>> hold

hold離散イベントのストリームの最新の値で保持されます。

次に、すべてのロジックを大きなロジック ワイヤに配置します。

wGameLogic :: Wire s () IO (Event GameEvent) Int
wGameLogic = proc ev -> do
               x' <- wPadX -< ev
               returnA -< x'

X 座標に関して 1 つの状態があるため、出力ワイヤを変更する必要があります。

wGameOutput :: SDL.Surface -> Wire s () IO Int SDL.Surface
wGameOutput surf = mkKleisli $ testPad
    where
      testPad = padSurf surf 

最後に、すべてをチェーンしますgameWire:

gameWire w = proc _ -> do
               ev <- wGameInput -< ()
               x <- wGameLogic -< ev
               finalSurf <- wGameOutput w -< x
               returnA -< finalSurf

と で何も変更する必要はありませmainんrun。わお！

で、これだ！それを実行すると、長方形を左右に動かすことができます!

巨大なコード ブロック (同じことを行う C++ プログラムがどれくらいの長さになるのか興味があります):

{-|
  03-GameLogic.hs: The final product!
-}

{-# LANGUAGE Arrows #-}

module Main where

import Prelude hiding ((.), id)
import Control.Wire
import Control.Arrow
import Control.Monad
import Data.Monoid
import qualified Graphics.UI.SDL as SDL
import qualified Control.Wire.Unsafe.Event as WE

{- Data types -}
-- | The unified datatype of game events 
data GameEvent = MoveR
               | MoveL
               | NoEvent
                 deriving (Show, Eq)
-- | Make it Monoid so that game events can be combined 
-- (Only applicable in this "game"!)
instance Monoid GameEvent where
    mempty = NoEvent
    -- | Simultaneously moving left and right is just nothing
    MoveR `mappend` MoveL = NoEvent
    MoveL `mappend` MoveR = NoEvent
    -- | NoEvent is the identity
    NoEvent `mappend` x = x
    x `mappend` NoEvent = x
    x `mappend` y 
        -- | Make sure identical events return same events
        | x == y = x
        -- | Otherwise, no event
        | otherwise = NoEvent

{- Wire Utilities -}

-- | Make a stateless filter wire
mkFW_ :: (Monad m, Monoid e) => (a -> Bool) -> Wire s e m [a] [a]
mkFW_ f = mkSF_ $ filter f 

-- -- | Make a stateful wire from a chained stateful function and initial value
-- -- The function (a -> b -> a) takes in an old state /a/, and returns state 
-- -- transition function (b -> a). 
mkSW_ :: (Monad m, Monoid e) => b -> (b->a->b) -> Wire s e m a b
mkSW_ b0 f = mkSFN $ g b0
    where
      g b0 a = let b1 = f b0 a in 
               (b1, mkSW_ b1 f)

-- | Make a Kleisli wire
mkKleisli :: (Monad m, Monoid e) => (a -> m b) -> Wire s e m a b
mkKleisli f = mkGen_ $ \a -> liftM Right $ f a

-- | The debug wire
wDebug :: (Show a, Monoid e) => Wire s e IO a ()
wDebug = mkKleisli $ \a -> putStrLn $ show a

-- | The "always" wire
always :: (Monad m, Monoid e) => Wire s e m a (Event a)
always = mkSFN $ \x -> (WE.Event x, always)

{- Functions to be lifted -}

-- | This is the pad surface whose X coordinate can be updated
padSurf :: SDL.Surface
            -- ^ Previous state of surface 
            -> Int
            -- ^ X'
            -- | New state
            -> IO SDL.Surface
padSurf surf x' = do
  let rect' = SDL.Rect x' 500 100 50
  clipRect <- SDL.getClipRect surf
  SDL.fillRect surf (Just clipRect) (SDL.Pixel 0x00000000)
  SDL.fillRect surf (Just rect') (SDL.Pixel 0xFFFFFFFF)
  return surf


-- | The function to poll events and add to a list of events
pollEvents :: [SDL.Event] -> IO (Either () ([SDL.Event]))
pollEvents es = do
  e <- SDL.pollEvent
  case e of 
    SDL.NoEvent -> return $ Right es
    SDL.Quit -> return $ Left ()
    _ -> pollEvents $ e:es

-- | Checks whether one SDL.Event is a keyboard event
isKeyEvent :: SDL.Event -> Bool
isKeyEvent (SDL.KeyDown k) = True
isKeyEvent (SDL.KeyUp k) = True
isKeyEvent _ = False

-- | The raw function to process key status from events
keyStatus :: [SDL.Keysym] -> [SDL.Event] -> [SDL.Keysym]
keyStatus keysDown (e:es) = 
    case e of
      -- | If a KeyDown is detected, add key to list
      SDL.KeyDown k -> keyStatus (k:keysDown) es
      -- | If a KeyUp is detected, remove key from list
      SDL.KeyUp k -> keyStatus (filter (/= k) keysDown) es
      _ -> keyStatus keysDown es
-- | If all events are processed, return
keyStatus keysDown [] = keysDown

-- | Convert a SDL Keysym into "standard" game events
toGameEv :: SDL.Keysym -> GameEvent
toGameEv (SDL.Keysym SDL.SDLK_RIGHT _ _) = MoveR
toGameEv (SDL.Keysym SDL.SDLK_LEFT _ _) = MoveL
toGameEv _ = NoEvent

-- | Combine all game events to get one single firing
fireGameEv :: [SDL.Keysym] -> GameEvent
fireGameEv ks = foldl mappend NoEvent $ fmap toGameEv ks

-- | The integrator of X position of pad
padDX :: Int -> GameEvent -> Int
padDX x0 e 
    | x > 700 = 700
    | x < 0 = 0
    | otherwise = x
    where
      x = x0 + go e
      go MoveR = dx
      go MoveL = -dx
      go _ = 0
      dx = 15

{- Wires -}

-- | The Kleisli wire to poll events
wPollEvents :: Wire s () IO () [SDL.Event]
wPollEvents = mkGen_ $ \_ -> pollEvents []

-- | A stateless wire that filters out keyboard events
wKeyEvents :: (Monad m, Monoid e) => Wire s e m [SDL.Event] [SDL.Event]
wKeyEvents = mkFW_ isKeyEvent

-- | A stateful wire to keep track of key status
wKeyStatus :: (Monad m, Monoid e) => Wire s e m [SDL.Event] [SDL.Keysym]
wKeyStatus = mkSW_ empty keyStatus

-- | A wire to fire game events from SDL events
wFireGameEv :: (Monad m, Monoid e) => Wire s e m [SDL.Keysym] (GameEvent)
wFireGameEv = arr fireGameEv

-- | This is the connected wire for the entire game input
wGameInput :: Wire s () IO () (Event GameEvent)
wGameInput = proc _ -> do
               ge <- wFireGameEv <<< wKeyStatus
                     <<< wKeyEvents <<< wPollEvents -< ()
               e <- always -< ge
               returnA -< e

-- | The stateful wire of X position of pad
wPadX :: (Monad m, Monoid e) => Wire s e m (Event GameEvent) Int
wPadX = accumE padDX 400 >>> hold

-- | This is the connected wire for the entire game logic
wGameLogic :: Wire s () IO (Event GameEvent) Int
wGameLogic = proc ev -> do
               x' <- wPadX -< ev
               returnA -< x'

-- | The wire of output
wGameOutput :: SDL.Surface -> Wire s () IO Int SDL.Surface
wGameOutput surf = mkKleisli $ testPad
    where
      testPad = padSurf surf 


-- | This is the main game wire
gameWire :: SDL.Surface 
         -- ^ The main surface (i.e. the window)
         -> Wire s () IO () SDL.Surface
gameWire w = proc _ -> do
               ev <- wGameInput -< ()
               x <- wGameLogic -< ev
               finalSurf <- wGameOutput w -< x
               returnA -< finalSurf

main :: IO ()
main = do
  SDL.init [SDL.InitEverything]
  w <- SDL.setVideoMode 800 600 32 [SDL.SWSurface]
  s <- SDL.createRGBSurfaceEndian [SDL.SWSurface] 800 600 32 
  run w (countSession_ 1) $ gameWire w
  SDL.quit

run ::SDL.Surface ->  Session IO s -> Wire s () IO () SDL.Surface -> IO ()
run mainSurf s w  = do
  (ds, s') <- stepSession s
  (eSrcSurf, w') <- stepWire w ds (Right ())
  case eSrcSurf of 
    Right srcSurf -> do 
                  SDL.blitSurface srcSurf (Nothing) mainSurf (Nothing)
                  SDL.flip mainSurf
                  SDL.delay 30
                  run mainSurf s' w'
    _ -> return ()