What can be a minimal example of game written in Haskell?

Question

Update after three months

I have an answer below using netwire-5.0.1 + sdl, in a structure of Functional Reactive Programming using Arrows and Kleisli Arrows for I/O. Though too simple to be called a "game", it should be very composible and very extendable.

Original

I am just learning Haskell, and trying to make a small game out of it. However, I would like to see what structure a small(canonical) text game can be. I also try to keep the code as pure as possible. I am now struggling to understand how to implement:

1. The main loop. There is an example here How do I write a game loop in Haskell? but it seems that the accepted answer is not tail recursive. I am not exactly sure whether this matters. In my understanding, the memory usage will grow, right?
2. State transition. I think this is quite related to the first one, though. I tried a bit using State, and something in http://www.gamedev.net/page/resources/_/technical/game-programming/haskell-game-object-design-or-how-functions-can-get-you-apples-r3204 , but although individual components may work and update in finite steps, I don't see how it can be used in an infinite loop.

If possible, I would like to see a minimal example which basically:

1. Asks the player to input something, repeatedly
2. When some condition is met, change state
3. When some other contition is met, exit
4. Theoretically can run for infinite time without blowing the memory

I don't have any postable code because I cannot get the very basic stuff. Any other material/examples I found on the web either use some other libraries, like SDL or GTK to drive events. The only one written totally in Haskell I found is http://jpmoresmau.blogspot.com/2006/11/my-first-haskell-adventure-game.html , but that one does not look like a tail recursion in its main loop too(Again, I don't know if it matters).

Or, probably Haskell is not intended to do things like this? Or probably I should put the main in C?

Edit 1

So I modified a small example in https://wiki.haskell.org/Simple_StateT_use and made it even simpler(and it does not meet my criteria):

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

However, it will eventually overflow the memory. I tested with

bash prompt$ yes 1 | ./Test-Game

and the memory usage starts growing linearly.

Edit 2

OK, I found Haskell recursion and memory usage and gained some understanding about the "stack"... So is there anything wrong about my testing method?

Answer 1

Foreword

After 3 months of digging through numerous websites and trying out some small projects, I finally get to implement a minimalistic game (or is it?), in a very, very different way. This example exists merely to demonstrate one possible structure of a game written in Haskell, and should easily be extended to handle more complex logic and gameplay.

Full code and tutorial available on https://github.com/carldong/HMovePad-Tutorial

Abstract

This mini game has only one rectangle, which the player can move left and right by pressing Left and Right key, and that is the whole "game".

The game is implemented using netwire-5.0.1, with SDL handling graphics. If I understand correctly, the architecture is fully functional reactive. Almost everything is implemented by Arrow composition, with only one function exposed in IO. Therefore, I expect the reader to have basic understanding of the Arrow syntax of Haskell, since it is used extensively.

The implementation order of this game is chosen to make debugging easy, and the implementation itself is chosen to demonstrate different usage of netwire as much as possible.

Continuous time semantic is used for I/O, but discrete events are used to handle game events within the game logic.

Set up SDL

The very first step is to make sure SDL works. The source is simple:

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

If everything works, there should be a white rectangle appearing on the bottom of the window appearing. Note that clicking the x will not close the window. It has to be closed by Ctrl+C or killing.

Set up Output Wires

Since we do not want to implement all the way to the last step and find that nothing can be drawn on screen, we are doing the output part first.

We need the Arrows syntax:

{-# LANGUAGE Arrows #-}

Also, we need to import some stuff:

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

We need to understand how to construct Kleisli Wires: Kleisli Arrow in Netwire 5?. A basic structure of a interactive program using Kleisli Wires is shown in this example: Console interactivity in Netwire?. To construct a Kleisli Wire from anything with type a -> m b, we need:

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

Then, since I did not get trace to work under Arrow processes, a debug wire is made to print objects to console:

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

Now it is time to write some functions to be lifted into wires. For output, we need a function that returns a SDL.Surface with proper rectangle drawn given the X coordinate of the pad:

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

Be careful, this function does destructive updates. The surface passed in will be blitted onto the window surface later.

Now we have the surface. The output wire is then trivil:

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

Then, we put wires together, and play with them a bit:

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

Finally, we change main and drive the wires properly:

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

Note that if you like, you can also make another wire to handle the main window surface too (and it is easy and better than my current implementation), but I was too late and lazy to add that. Check out the interactive example I mentioned above to see how simple run can get (it can get even simpler if inhibition is used instead of quitWire in that example).

When the program is run, its appearance should be the same as before.

Here is the complete code:

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

Input Wires

In this section, we are going to construct wires that gets player input into the program.

Since we will use discrete events in the logic part, we need a data type for 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

As comment suggested, the Monoid instance only applies for this particular game since it has only two opposite operations: left and right.

First, we will poll events from 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

Obviously enough, this function polls events from SDL as a list, and inhibits when the Quit event is received.

Next, we need to check whether an event is a keyboard event:

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

We will have a list of keys that are currently pressed, and it should update when a keyboard event occurs. In short, when a key is down, insert that key into the list, and vice versa:

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

Next, we write a function to convert a keyboard event to a game event:

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

We fold on the game events and get a single event (really, really, game specific!):

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

Now we can start making wires.

First, we need a wire that polls events:

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

Note that mkKleisli makes wire that does not inhibit, but we want inhibition in this wire since the program should quit when it is supposed to. Therefore, we use mkGen_ here.

Then, we need to filter the events. First, make a helper function that makes a continuous time filter wire:

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

Use mkFW_ to make a filter:

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

Then, we need another convenient function to make a stateful wire from a stateful function of type b -> a -> b:

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

Next, construct a stateful wire that remembers all key status:

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

The last piece of wire segment fires the game event:

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

To actively fire discrete events (netwire events) that contain game events, we need to hack netwire a bit (I think it is still quite incomplete) since it does not provide a wire that always fires events:

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

Comparing to the implementation of now, the only difference is never and always.

Finally, a big wire that combines all input wires above:

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

An example of debugging is also shown in this wire.

To interface with the main program, modify gameWire to use the input:

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

Nothing else needs to be changed. Well, interesting, isn't it?

When the program is run, the console gives a lot of output showing the current game events being fired. Try pressing left and right, and their combinations and see whether the behavior is expected. Of course, the rectangle will not move.

Here is a huge block of code:

{-|
  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" Logic --- Finally putting everything together!

First, we write an integrating function of the X position of the 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

I hard coded everything, but those are not important for this minimalistic example. It should be straightforward.

Then, we create the wire that represents the current position of the pad:

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

hold holds at the latest value of a stream of discrete event.

Next, we put all logic things in a big logic wire:

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

Since we have one state about the X coordinate, we need to modify the output wire:

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

Finally, we chain everything in the gameWire:

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

Nothing needs to be changed in main and run. Wow!

And this is it! Run it and you shou be able to move the rectangle left and right!

A GIGANTIC block of code (I am curious how long will a C++ program that does the same thing be):

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