Main.hs

{-# LANGUAGE Arrows #-}
module Main where

import Prelude hiding ((.), id)
import Control.Applicative
import Control.Arrow
import Control.Wire
import Control.Exception
import Control.Monad.Loops
import qualified Control.Monad as M (when)
import Debug.Trace (trace)

import Graphics.UI.SDL as SDL

type EventWire = EventM IO [SDL.Event]
type SDLWire = WireM IO [SDL.Event]

main :: IO ()
main = bracket_ (SDL.init [InitVideo]) SDL.quit $ do
    screen <- setVideoMode 800 600 0 [DoubleBuf, HWSurface]
    sess <- clockSession
    loop sess $ system screen
    where
        loop s w = do
            ev <- unfoldWhileM (/= NoEvent) pollEvent
            (v, w', s') <- stepSessionM_ s ev w
            M.when v $ loop s' w'

system :: Surface -> SDLWire Bool
system screen = proc ev -> do
    g <- hold (iterateW negate 1 . keyUp SDLK_SPACE) <|> pure (-1) -< ev
    q <- quitEv -< ev

    execute . periodically (1/50) <|> pure () -< (fillRect screen Nothing $ Pixel 0) >> (fillRect screen (Just $ Rect 0 (300 - g * 100) 800 10) $ Pixel 0xffffffff) >> SDL.flip screen

    returnA -< not q

quitEv :: SDLWire Bool
quitEv = pure True . (when (elem Quit)) <|> pure False

keyDown :: SDLKey -> EventWire
keyDown k = when $ not . null . filter f
    where
        f (KeyDown (Keysym k' _ _)) | k == k' = True
        f _ = False

keyUp :: SDLKey -> EventWire
keyUp k = when $ not . null . filter f
    where
        f (KeyUp (Keysym k' _ _)) | k == k' = True
        f _ = False