Что может быть минимальным примером игры, написанной на Хаскеле?

Question

Что может быть минимальным примером игры, написанной на Хаскеле?

Обновление через три месяца

У меня есть ответ ниже, используя netwire-5.0.1 + sdlв структуре функционально-реактивного программирования с использованием стрелок и стрелок Клейсли для ввода-вывода. Хотя он слишком прост, чтобы называться "игрой", он должен быть очень сложным и расширяемым.

оригинал

Я только изучаю Haskell и пытаюсь сделать из него маленькую игру. Тем не менее, я хотел бы посмотреть, какой структурой может быть небольшая (каноническая) текстовая игра. Я также стараюсь сохранить код как можно более чистым. Я сейчас пытаюсь понять, как реализовать:

Основной цикл. Вот пример. Как мне написать игровой цикл в Haskell? но кажется, что принятый ответ не является хвостовым рекурсивным. Я не совсем уверен, имеет ли это значение. В моем понимании, использование памяти будет расти, верно?
Государственный переход. Я думаю, что это довольно связано с первым, хотя. Я попробовал немного, используя Stateи что-то в http://www.gamedev.net/page/resources/_/technical/game-programming/haskell-game-object-design-or-how-functions-can-get-you-apples-r3204, но хотя отдельные компоненты могут работать и обновляться конечными шагами, я не вижу, как это можно использовать в бесконечном цикле.

Если возможно, я хотел бы увидеть минимальный пример, который в основном:

Просит игрока ввести что-то, несколько раз
Когда какое-либо условие выполнено, измените состояние
Когда выполнено какое-либо другое условие, выйдите из
Теоретически может работать в течение бесконечного времени, не унося память

У меня нет никакого почтового кода, потому что я не могу получить самые простые вещи. Любой другой материал / примеры, которые я нашел в Интернете, используют другие библиотеки, такие как SDL или же GTK вести события. Единственный, написанный полностью на Хаскеле, который я нашел, - это http://jpmoresmau.blogspot.com/2006/11/my-first-haskell-adventure-game.html, но он не похож на хвостовую рекурсию в своем основном цикле тоже (опять же, я не знаю, имеет ли это значение).

Или, возможно, Haskell не предназначен для таких вещей? Или, возможно, я должен поставить main в С?

Редактировать 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 и использование памяти и получил некоторое представление о "стеке"... Так что же, не так с моим методом тестирования?

5

haskell game-engine frp arrows netwire

Источник

user2353597 18 июн '15 в 03:20

2 ответа

Решение

Ваша проблема в том, что вы используете ленивую версию преобразователя StateT, которая создает массивный поток от повторяющихся modifys (потому что они никогда не оцениваются полностью). Если вы импортируете Control.Monad.State.Strict вместо этого он, вероятно, будет работать нормально без каких-либо переполнений.

2

Источник

user365807 18 июн '15 в 14:36

Другие вопросы по тегам haskell game-engine frp arrows netwire

user2353597 01 окт '15 в 22:07 2015-10-01 22:07 · Accepted Answer · 2015-10-01 22:07

предисловие

После 3 месяцев копания на многочисленных веб-сайтах и опробования небольших проектов я наконец-то смог реализовать минималистичную игру (или это так?) Совершенно иным способом. Этот пример существует просто для демонстрации одной возможной структуры игры, написанной на Haskell, и его легко расширить, чтобы он обрабатывал более сложную логику и игровой процесс.

Полный код и учебник доступны на https://github.com/carldong/HMovePad-Tutorial

Аннотация

Эта мини-игра имеет только один прямоугольник, который игрок может перемещать влево и вправо, нажимая клавиши "Влево" и "Вправо", и это целая "игра".

Игра реализована с использованием netwire-5.0.1, с SDL обработка графики. Если я правильно понимаю, архитектура полностью функционально реактивна. Почти все реализовано с помощью композиции Arrow, только одна функция отображается в IO, Поэтому я ожидаю, что читатель будет иметь базовое понимание синтаксиса Arrow в Haskell, поскольку он широко используется.

Порядок реализации этой игры выбран для упрощения отладки, а сама реализация выбрана, чтобы продемонстрировать различное использование netwire как можно больше.

Семантика непрерывного времени используется для ввода / вывода, но дискретные события используются для обработки игровых событий в игровой логике.

Настройте 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 или убийство.

Настройте выходные провода

Поскольку мы не хотим реализовывать весь путь до последнего шага и обнаруживаем, что ничто не может быть нарисовано на экране, мы сначала выполняем часть вывода.

Нам нужен синтаксис стрелки:

{-# 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: Kleisli Arrow в Netwire 5?, Базовая структура интерактивной программы с использованием Kleisli Wires показана в следующем примере: Интерактивность консоли в Netwire?, Чтобы построить провод Клейсли из чего-либо с типом 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

Тогда, так как я не получил trace для работы в процессах Arrow отладочный провод выводит объекты на консоль:

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 Экземпляр применяется только для этой конкретной игры, поскольку он имеет только две противоположные операции: левую и правую.

Сначала мы будем опрашивать события из 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

Мы складываем игровые события и получаем одно событие (действительно, действительно, специфичное для игры!):

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

Затем нам нужна другая удобная функция для создания провода с состоянием из функции с состоянием типа 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 ()

Логика "Game" --- Наконец-то все собрано!

Сначала мы напишем интегрирующую функцию положения 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, нам нужно изменить выходной провод:

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