用 Haskell 编写的游戏的最小示例是什么?
What can be a minimal example of game written in Haskell?
三个月后更新
我在下面使用 netwire-5.0.1
+ sdl
的答案,在函数式反应式编程的结构中使用箭头和 Kleisli 箭头 I/O。虽然被称为 "game" 太简单了,但它应该是非常可组合和非常可扩展的。
原创
我正在学习 Haskell,并尝试用它制作一个小游戏。但是,我想看看小型(规范)文本游戏的结构是什么。我也尽量保持代码的纯净。我现在正在努力了解如何实施:
- 主循环。这里有一个例子 How do I write a game loop in Haskell? 但似乎接受的答案不是尾递归。我不确定这是否重要。据我了解,内存使用量会增长,对吗?
- 状态转换。不过,我认为这与第一个非常相关。我尝试使用
State
和 http://www.gamedev.net/page/resources/_/technical/game-programming/haskell-game-object-design-or-how-functions-can-get-you-apples-r3204 中的一些东西,但是尽管单个组件可以在有限的步骤中工作和更新,但我看不出如何在无限循环中使用它。
如果可能的话,我想看一个基本的例子:
- 要求玩家重复输入内容
- 当满足某些条件时,改变状态
- 当满足其他条件时,退出
- 理论上可以运行无限时间不烧毁内存
我没有任何可发布的代码,因为我无法获得最基本的东西。我在网上找到的任何其他 material/examples 要么使用其他一些库,例如 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 recursion and memory usage,对"stack"有了一些了解……那么我的测试方法有什么问题吗?
您的问题是您使用的是惰性版本的 StateT 转换器,它从重复的 modify
s 中构建了一个巨大的 thunk(因为它们从未被完全评估)。如果您改为导入 Control.Monad.State.Strict
,它可能会正常工作而不会出现任何溢出。
前言
经过 3 个月浏览大量网站并尝试一些小项目后,我终于以一种非常非常不同的方式实现了一个极简游戏(或者是吗?)。此示例仅用于演示用 Haskell 编写的游戏的一种可能结构,应该可以轻松扩展以处理更复杂的逻辑和游戏玩法。
https://github.com/carldong/HMovePad-Tutorial
上提供了完整的代码和教程
摘要
这个小游戏只有一个矩形,玩家可以通过左右键左右移动,这就是整个“游戏”。
游戏是使用 netwire-5.0.1
实现的,SDL
处理图形。如果我理解正确,该架构是完全功能性的。几乎所有的东西都是Arrow组合实现的,只有一个功能暴露在IO
中。因此,我希望 reader 对 Haskell 的箭头语法有基本的了解,因为它被广泛使用。
选择这个游戏的实现顺序是为了方便调试,选择实现本身是为了尽可能多地展示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
如果一切正常,window 的底部应该会出现一个白色矩形。请注意,单击 x
不会关闭 window。必须用Ctrl+C关闭或者killing.
设置输出线
因为不想一直执行到最后一步,发现屏幕上什么也画不出来,所以先做输出部分。
我们需要箭头语法:
{-# 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:. A basic structure of a interactive program using Kleisli Wires is shown in this example: 。要从类型为 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
现在是时候编写一些要提升到连线中的函数了。对于输出,我们需要一个 returns 一个 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
小心,此函数会进行破坏性更新。传入的表面稍后将被块化到 window 表面上。
现在我们有了地表。然后输出线很简单:
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 ()
请注意,如果你愿意,你也可以制作另一根电线来处理主要的 window 表面(这比我目前的实现更简单也更好),但我来不及添加了那。查看我上面提到的交互式示例,看看 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 ()
“游戏”逻辑---终于把所有东西放在一起了!
首先我们写一个焊盘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 ()
三个月后更新
我在下面使用 netwire-5.0.1
+ sdl
的答案,在函数式反应式编程的结构中使用箭头和 Kleisli 箭头 I/O。虽然被称为 "game" 太简单了,但它应该是非常可组合和非常可扩展的。
原创
我正在学习 Haskell,并尝试用它制作一个小游戏。但是,我想看看小型(规范)文本游戏的结构是什么。我也尽量保持代码的纯净。我现在正在努力了解如何实施:
- 主循环。这里有一个例子 How do I write a game loop in Haskell? 但似乎接受的答案不是尾递归。我不确定这是否重要。据我了解,内存使用量会增长,对吗?
- 状态转换。不过,我认为这与第一个非常相关。我尝试使用
State
和 http://www.gamedev.net/page/resources/_/technical/game-programming/haskell-game-object-design-or-how-functions-can-get-you-apples-r3204 中的一些东西,但是尽管单个组件可以在有限的步骤中工作和更新,但我看不出如何在无限循环中使用它。
如果可能的话,我想看一个基本的例子:
- 要求玩家重复输入内容
- 当满足某些条件时,改变状态
- 当满足其他条件时,退出
- 理论上可以运行无限时间不烧毁内存
我没有任何可发布的代码,因为我无法获得最基本的东西。我在网上找到的任何其他 material/examples 要么使用其他一些库,例如 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 recursion and memory usage,对"stack"有了一些了解……那么我的测试方法有什么问题吗?
您的问题是您使用的是惰性版本的 StateT 转换器,它从重复的 modify
s 中构建了一个巨大的 thunk(因为它们从未被完全评估)。如果您改为导入 Control.Monad.State.Strict
,它可能会正常工作而不会出现任何溢出。
前言
经过 3 个月浏览大量网站并尝试一些小项目后,我终于以一种非常非常不同的方式实现了一个极简游戏(或者是吗?)。此示例仅用于演示用 Haskell 编写的游戏的一种可能结构,应该可以轻松扩展以处理更复杂的逻辑和游戏玩法。
https://github.com/carldong/HMovePad-Tutorial
上提供了完整的代码和教程摘要
这个小游戏只有一个矩形,玩家可以通过左右键左右移动,这就是整个“游戏”。
游戏是使用 netwire-5.0.1
实现的,SDL
处理图形。如果我理解正确,该架构是完全功能性的。几乎所有的东西都是Arrow组合实现的,只有一个功能暴露在IO
中。因此,我希望 reader 对 Haskell 的箭头语法有基本的了解,因为它被广泛使用。
选择这个游戏的实现顺序是为了方便调试,选择实现本身是为了尽可能多地展示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
如果一切正常,window 的底部应该会出现一个白色矩形。请注意,单击 x
不会关闭 window。必须用Ctrl+C关闭或者killing.
设置输出线
因为不想一直执行到最后一步,发现屏幕上什么也画不出来,所以先做输出部分。
我们需要箭头语法:
{-# 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: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
现在是时候编写一些要提升到连线中的函数了。对于输出,我们需要一个 returns 一个 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
小心,此函数会进行破坏性更新。传入的表面稍后将被块化到 window 表面上。
现在我们有了地表。然后输出线很简单:
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 ()
请注意,如果你愿意,你也可以制作另一根电线来处理主要的 window 表面(这比我目前的实现更简单也更好),但我来不及添加了那。查看我上面提到的交互式示例,看看 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 ()
“游戏”逻辑---终于把所有东西放在一起了!
首先我们写一个焊盘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 ()