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 tick space left right = do
    screen <- liftIO SDL.getVideoSurface
    let
        ship = accumB 100 move

        move = whenMove left sub
            `union` whenMove right add

        add = once (+ 1) <@ tick
        sub = once (flip (-) 1) <@ tick

        whenMove e = whenE (stepper False e)

        once = flip accumE never

    return $ pure (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 ()
    -> 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
    (tickHandler,  tickFire)  <- 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
            tickFire ()
            gfxFire ()
            go

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

    go