game.hs

{-# LANGUAGE Rank2Types #-}
import Data.Word (Word8)
import Data.Bits (shiftL, (.|.))
import qualified Graphics.UI.SDL as SDL
import qualified Graphics.UI.SDL.Primitives as Prims

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 = whenEvent left sub
            `union` whenEvent right add

        add = (+ 1) <$ tick
        sub = (flip (-) 1) <$ tick

        whenEvent e = whenE (stepper False e)

        once = flip accumE never

        color = accumB 0 move

    return $ pure (render screen) <*> ship <*> color

render :: SDL.Surface -> Int -> Int -> IO ()
render s n c = do
    Prims.box s (SDL.Rect 640 480  0  0) (rgbColor 255 255 255)
    Prims.box s (SDL.Rect   n 100 50 50) (rgbColor (fromIntegral c) 162 255)
    -- Prims.box s (SDL.Rect  50  50  n 100) (rgbColor (fromIntegral c) 162 255)
    -- above code give same result as that of line 46
    print n
    SDL.flip s

rgbColor :: Word8 -> Word8 -> Word8 -> SDL.Pixel
rgbColor r g b = SDL.Pixel (shiftL (fi r) 24 .|.
                            shiftL (fi g) 16 .|.
                            shiftL (fi b) 8  .|.
                            255)
  where fi = fromIntegral

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