{-# LANGUAGE ScopedTypeVariables #-} -- | a little typing game, demonstrating some reactive-banana-SDL code module Main where import qualified Graphics.UI.SDL as SDL import qualified Graphics.UI.SDL.TTF as TTF import Reactive.Banana import Reactive.Banana.SDL import Reactive.Banana.SDL.Graphics import Data.Char import qualified Data.Map as M import Data.Word import System.Random import System.FilePath import Paths_TypeClass import Control.Monad.IO.Class (liftIO) import Reactive.Banana.Frameworks (actuate, Frameworks) import Control.Monad (void) -- | entry point of the application main :: IO() main = do -- SDL event source sdlES<-getSDLEventSource -- call initializtion gd<-liftIO initGraphics -- get network network <- compile $ setupNetwork sdlES gd -- actuate actuate network -- run SDL loop runSDLPump sdlES -- clean up endGraphics gd -- | setup the FRP setupNetwork :: Frameworks t=> SDLEventSource -> GraphicsData -> Moment t () setupNetwork es gd=do r<-liftIO getStdGen eTickDiff <- tickDiffEvent es esdl <- sdlEvent es let -- | the initial gamestate gsInitial :: GameState gsInitial=GameState 0 100 2000 M.empty r 0 0 lives -- | the empty screen startGraphic :: Graphic startGraphic=draw (Fill (Just $ SDL.Rect 0 0 width height) black) (Mask Nothing 0 0) -- | we always use the same surface bScreen :: Behavior t Screen bScreen = pure (gd_mainSurf gd) -- | game state update event eGSChange= (updateGS <$> eTickDiff) `union` (updateGSOnKey <$> keyDownEvent esdl) -- | game state behavior bGameState=accumB gsInitial eGSChange -- | draw lives livesG GameState{gs_lives}=draw (Text ("Lives:" ++ show gs_lives ++ "/" ++ show lives) (gd_font gd) red) (Mask Nothing 0 0) -- | draw score scoreG GameState{gs_score}=draw (Text ("Score:" ++ show gs_score) (gd_font gd) red) (Mask Nothing (halfW+1) 0) -- | draw a character charG (c,(x,y))= draw (Text [c] (gd_font gd) white) (Mask Nothing x y) -- | draw characters charsG GameState{gs_shown}=let chars=map charG (M.assocs gs_shown) in (Graphic $ \surface ->mapM_ (\(Graphic f)->void $ f surface) chars >> return Nothing) -- | game over gameOverG GameState{gs_score}=draw (Text "Game Over!" (gd_font gd) red) (Mask Nothing (halfW-40) (halfH-20)) `over` draw (Text ("Score:" ++ show gs_score) (gd_font gd) red) (Mask Nothing (halfW-40) (halfH+10)) -- | draw behavior bG=(\g->if gs_lives g > 0 then scoreG g `over` livesG g `over` charsG g `over` startGraphic else gameOverG g `over` startGraphic) <$> bGameState -- render renderGraph bG bScreen return () -- | update game state on key press updateGSOnKey :: SDL.Keysym -> GameState -> GameState updateGSOnKey ks gs@GameState{gs_shown,gs_score}= let c=toUpper $ SDL.symUnicode ks in case c of '+'->speedup gs _ ->if M.member c gs_shown then gs{gs_shown=M.delete c gs_shown,gs_score=gs_score+1} else gs -- | update game state on tick updateGS :: Word32 -> GameState -> GameState updateGS d gs1=let mvs=gs_moves gs1 + fromIntegral d gsInc=changeif shouldSpeed speedup gs1{gs_moves=mvs} gsMoved=changeif ((0 ==) . mod mvs . gs_movespeed) moveDown gsInc alive=gs_lives gsMoved > 0 gsNew=if alive then changeif ((0==) . mod mvs . gs_newspeed) newChar gsMoved else gsMoved in gsNew -- | graphics info data GraphicsData = GraphicsData { gd_font :: TTF.Font -- ^ font for text , gd_mainSurf :: SDL.Surface -- ^ surface to draw on } -- | gamestate data GameState = GameState { gs_moves :: Int -- ^ number of ticks , gs_movespeed :: Int -- ^ speed at which letters fall , gs_newspeed :: Int -- ^ speed at which letters appear , gs_shown :: M.Map Char (Int,Int) -- ^ letters shown on screen with their position , gs_rand :: StdGen -- ^ random generator , gs_score :: Int -- ^ score , gs_score_beforespeed :: Int -- ^ score before last speedup , gs_lives :: Int -- ^ number of lives left } -- | apply the function if the first argument evaluates to true changeif :: (a -> Bool) -> (a->a) -> a-> a changeif test change obj=if test obj then change obj else obj -- | should we speed up the game? shouldSpeed :: GameState -> Bool shouldSpeed GameState{gs_score,gs_score_beforespeed}=(gs_score-gs_score_beforespeed)>5 -- && (mod gs_moves 1000)==0 -- | speed up the rate characters scroll down speedup :: GameState -> GameState speedup gs@GameState{gs_score,gs_movespeed,gs_newspeed}=let ratio= 0.9::Double -- 1 - (1 / (log $ ((fromIntegral (max gs_score 2))::Double) ^ (2::Int))) in gs{gs_movespeed=round (fromIntegral gs_movespeed * ratio),gs_newspeed=round (fromIntegral gs_newspeed * ratio),gs_score_beforespeed=gs_score} -- | generate a new character on screen newChar :: GameState -> GameState newChar gs@GameState{gs_rand,gs_shown}=let (c,r')=randomR ('A','Z') gs_rand (s',r'')=if not (M.member c gs_shown) then let (x,r2)=randomR (1,div width 10 - 2) r' in (M.insert c (x*10,20) gs_shown,r2) else (gs_shown,r') in gs{gs_rand=r'',gs_shown=s'} -- | move characters down moveDown :: GameState -> GameState moveDown gs@GameState{gs_shown,gs_lives}=let (dead,s')=M.foldWithKey (\c (x,y) (b,m)-> let y'=y+1 in if y' > (height - 20) then (True, m) else (b, M.insert c (x, y') m) ) (False,M.empty) gs_shown d'=if dead then gs_lives-1 else gs_lives in gs{gs_shown=s',gs_lives=d'} -- | width of window width :: Int width = 640 -- | height of window height :: Int height = 480 -- | half width halfW :: Int halfW= div width 2 -- | half height halfH :: Int halfH=div height 2 -- | start number of lives lives :: Int lives = 3 -- | red color red :: SDL.Color red = SDL.Color 255 20 20 -- | black color black :: SDL.Color black = SDL.Color 0 0 0 -- | white color white :: SDL.Color white=SDL.Color 255 255 255 -- | SDL initialization initGraphics :: IO GraphicsData initGraphics = do SDL.init [SDL.InitEverything] TTF.init SDL.enableUnicode True SDL.setVideoMode width height 32 [] SDL.setCaption "TypeClass: the typing game" "TypeClass" dd<-getDataDir realFont<- TTF.openFont (dd "font" "FreeSansBold.ttf") 24 mainSurf <- SDL.getVideoSurface return $ GraphicsData realFont mainSurf -- | SDL finalization endGraphics :: GraphicsData -> IO() endGraphics GraphicsData{gd_font=font}=do TTF.closeFont font TTF.quit SDL.quit