什么可以是用Haskell编写的游戏的最小例子?

时间:2015-06-18 03:20:11

标签: haskell game-engine frp arrows netwire

三个月后更新

我在下面使用netwire-5.0.1 + sdl得到了一个答案,在使用Arrows和Kleisli Arrows进行I / O的功能反应编程结构中。虽然过于简单而不被称为游戏"但它应该是非常易于组合且非常可扩展的。

原创

我正在学习Haskell,并尝试用它制作一个小游戏。但是,我想看看小型(规范)文本游戏的结构。我也尽量保持代码尽可能纯净。我现在正在努力了解如何实施:

  1. 主循环。这里有一个例子How do I write a game loop in Haskell?但似乎接受的答案不是尾递归。我不确定这是否重要。根据我的理解,内存使用量会增长,对吗?
  2. 国家转型。不过,我认为这与第一个问题非常相关。我尝试使用Statehttp://www.gamedev.net/page/resources/_/technical/game-programming/haskell-game-object-design-or-how-functions-can-get-you-apples-r3204中的某些内容,但是虽然单个组件可以在有限的步骤中工作和更新,但我不知道如何在无限循环中使用它。 / LI>

    如果可能的话,我想看一个基本上最小的例子:

    1. 要求玩家重复输入内容
    2. 满足某些条件时,请更改状态
    3. 当满足其他一些意愿时,退出
    4. 理论上可以无限时间运行而不会破坏内存
    5. 我没有任何可用的代码,因为我无法获得最基本的东西。我在网上找到的任何其他材料/示例都使用其他一些库来驱动事件,例如SDLGTK。我在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 recursion and memory usage并且对#34;堆栈有了一些了解...#34 ...我的测试方法有什么问题吗?

2 个答案:

答案 0 :(得分:3)

前言

经过3个月的时间挖掘大量网站并尝试一些小项目后,我终于以一种非常非常不同的方式实现了一个简约游戏(或者是它?)。这个例子的存在仅仅是为了演示用Haskell编写的游戏的一种可能结构,并且应该很容易扩展以处理更复杂的逻辑和游戏玩法。

https://github.com/carldong/HMovePad-Tutorial

上的完整代码和教程

摘要

这个迷你游戏只有一个矩形,玩家可以通过按下左右键来左右移动,这就是整个游戏&#34;。

游戏使用netwire-5.0.1实施,SDL处理图片。如果我理解正确,该架构是完全功能反应。几乎所有内容都由Arrow组合实现,只有一个函数在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关闭或杀死。

设置输出线

由于我们不希望一直到最后一步,并且发现屏幕上无法绘制任何内容,我们首先要做输出部分。

我们需要箭头语法:

{-# 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 in Netwire 5?。此示例中显示了使用Kleisli Wires的交互式程序的基本结构:Console interactivity in Netwire?。要从类型a -> m b的任何东西构建Kleisli Wire,我们需要:

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事件),我们需要稍微破解网络(我认为它仍然非常不完整),因为它不提供始终触发事件的连线:

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

now的实施相比,唯一的区别是neveralways

最后,一条结合了上述所有输入线的大线:

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

&#34;游戏&#34;逻辑---最后把所有东西放在一起!

首先,我们写一个垫的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

mainrun无需更改任何内容。哇!

就是这样!运行它,你就可以左右移动矩形了!

GIGANTIC代码块(我很好奇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 ()

答案 1 :(得分:2)

你的问题是你正在使用StateT转换器的惰性版本,它会从重复的modify中构建一个庞大的thunk(因为它们永远不会被完全评估)。如果您导入Control.Monad.State.Strict,它可能会正常工作而不会出现任何溢出。