game.hs

{-# LANGUAGE Rank2Types #-}
import qualified Graphics.UI.SDL as SDL

import Reactive.Banana
import Reactive.Banana.Frameworks

{------------------------------------------------------------------------------
    Main
    ---------------------------------------------------------------------------}

main = do
    SDL.init [SDL.InitEverything]
    SDL.setVideoMode 640 480 32 []
    gameLoop game

{------------------------------------------------------------------------------
    Game logic
    ---------------------------------------------------------------------------}

game :: forall t. Frameworks t => GameNetworkDescription t
game space left right = do
    screen <- liftIO SDL.getVideoSurface
    let
        ship = accumE 100 move

        move = whenMove left (constE (flip (-) 1))
            `union` whenMove right (constE (+ 1))

        whenMove e = whenE (stepper False e)

        constE = flip accumE never

    return $ stepper (return ()) $ fmap (render screen) ship

render :: SDL.Surface -> Int -> IO ()
render s n = (SDL.mapRGB . SDL.surfaceGetPixelFormat) s 255 255 255
    >>= SDL.fillRect s (Just $ SDL.Rect n 100 50 50)
    >> SDL.flip s

{------------------------------------------------------------------------------
    Game Loop
    ---------------------------------------------------------------------------}

type GameNetworkDescription t
    =  Event t Bool
    -> Event t Bool
    -> Event t Bool
    -> Moment t (Behavior t (IO ()))

gameLoop :: (forall t. Frameworks t => GameNetworkDescription t) -> IO ()
gameLoop game = do
    (gfxHandler,   gfxFire)   <- newAddHandler
    (spaceHandler, spaceFire) <- newAddHandler
    (leftHandler,  leftFire)  <- newAddHandler
    (rightHandler, rightFire) <- newAddHandler
    let
        fire (SDL.Keysym SDL.SDLK_SPACE _ _) = spaceFire
        fire (SDL.Keysym SDL.SDLK_LEFT  _ _) = leftFire
        fire (SDL.Keysym SDL.SDLK_RIGHT _ _) = rightFire
        fire _ = \_ -> return ()
        processEvents = do
            event <- SDL.pollEvent
            case event of
                SDL.KeyDown k -> fire k True
                SDL.KeyUp k   -> fire k False
                _             -> return ()

        go = do
            processEvents
            gfxFire ()
            go

    network <- compile $ do
        eSpace <- fromAddHandler spaceHandler
        eLeft  <- fromAddHandler leftHandler
        eRight <- fromAddHandler rightHandler
        eGfx   <- fromAddHandler gfxHandler
        bGfx   <- game eSpace eLeft eRight
        reactimate $ bGfx <@ eGfx
    actuate network

    go