Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- {-# 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
Add Comment
Please, Sign In to add comment