TypeClass 0.1.1 → 0.2.0
raw patch · 7 files changed
+275/−218 lines, 7 filesdep +filepathdep +reactive-bananadep +reactive-banana-sdlsetup-changedbinary-added
Dependencies added: filepath, reactive-banana, reactive-banana-sdl, transformers
Files
- LICENSE +23/−23
- README.md +4/−0
- Setup.hs +2/−2
- TypeClass.cabal +34/−21
- font/FreeSansBold.ttf binary
- src/FreeSansBold.ttf binary
- src/Main.hs +212/−172
LICENSE view
@@ -1,23 +1,23 @@-Copyright 2010, Jean-Philippe Moresmau. All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY -EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR -PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE -LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR -CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF -SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR -BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, -WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE -OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN -IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +Copyright 2010, Jean-Philippe Moresmau. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++- Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.+ +- Redistributions in binary form must reproduce the above copyright notice,+this list of conditions and the following disclaimer in the documentation+and/or other materials provided with the distribution.+ +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,4 @@+TypeClass+=========++Simple SDL based game in Haskell. This uses the reactive-banana-SDL library
Setup.hs view
@@ -1,2 +1,2 @@-import Distribution.Simple -main = defaultMain +import Distribution.Simple+main = defaultMain
TypeClass.cabal view
@@ -1,21 +1,34 @@-name: TypeClass -version: 0.1.1 -cabal-version: >= 1.2 -build-type: Simple -author: JP Moresmau -maintainer: jpmoresmau@gmail.com -synopsis: Typing speed game -description: A simple game where you need to type the letters scrolling down the screen before they reach the bottom. Using SDL and SDL_ttf. -category: Game -license: BSD3 -license-file: LICENSE -data-files: src/FreeSansBold.ttf - -executable TypeClass - hs-source-dirs: src - main-is: Main.hs - ghc-options: -Wall -fno-warn-unused-do-bind - extensions: NamedFieldPuns - build-depends: base < 5, SDL, SDL-ttf, random, containers - - +name: TypeClass+version: 0.2.0+cabal-version: >= 1.6+build-type: Simple+author: JP Moresmau+maintainer: jpmoresmau@gmail.com+synopsis: Typing speed game+description: A simple game where you need to type the letters scrolling down the screen before they reach the bottom. Using SDL and SDL_ttf.+category: Game+license: BSD3+license-file: LICENSE+data-files: font/FreeSansBold.ttf+extra-source-files: README.md++executable TypeClass+ hs-source-dirs: src+ main-is: Main.hs+ ghc-options: -Wall -fno-warn-unused-do-bind+ extensions: NamedFieldPuns+ build-depends: + base < 5,+ SDL,+ SDL-ttf,+ random,+ containers,+ filepath,+ reactive-banana,+ reactive-banana-sdl >= 0.1.2,+ transformers >=0.3.0 && <0.4+ includes: SDL.h++Source-Repository head+ Type: git+ Location: https://github.com/JPMoresmau/TypeClass
+ font/FreeSansBold.ttf view
binary file changed (absent → 91432 bytes)
− src/FreeSansBold.ttf
binary file changed (91432 → absent bytes)
src/Main.hs view
@@ -1,173 +1,213 @@-module Main where - -import qualified Graphics.UI.SDL as SDL -import qualified Graphics.UI.SDL.TTF as TTF - -import Control.Concurrent -import Control.Monad - -import Data.Char -import qualified Data.Map as M -import Data.Word -import System.Random - -main::IO() -main= do - gd<-initGraphics - r<-getStdGen - let gs=newChar $ GameState 0 100 2000 M.empty r 0 0 lives - tcks<-SDL.getTicks - drawloop gs tcks gd - endGraphics gd - -checkEvent :: GameState -> SDL.Event -> (GameState ,Bool) -checkEvent gs SDL.Quit = (gs,True) -checkEvent gs@GameState{gs_shown,gs_score} (SDL.KeyDown ks) = - let c=toUpper $ SDL.symUnicode ks - in ((if M.member c gs_shown - then gs{gs_shown=M.delete c gs_shown,gs_score=gs_score+1} - else gs),False) - -checkEvent gs _ = (gs,False) - -drawloop :: GameState- -> Data.Word.Word32- -> GraphicsData- -> IO () -drawloop gs oldTicks gd@GraphicsData{gd_mainSurf}=do - e<-SDL.pollEvent - let (gs1,shouldStop)=checkEvent gs e - if shouldStop - then return () - else if gs_lives gs1 > 0 - then do - newTicks<-SDL.getTicks - let d=newTicks-oldTicks - -- update game state - let mvs=(gs_moves gs1)+(fromIntegral d) - let gsInc=speedup gs1{gs_moves=mvs} - let gsMoved=if (mod mvs (gs_movespeed gsInc )) == 0 then moveDown gsInc else gsInc - let alive=gs_lives gsMoved > 0 - SDL.fillRect gd_mainSurf (Just (SDL.Rect 0 0 width height)) (SDL.Pixel 0) - let gsNew=if alive - then if (mod mvs (gs_newspeed gsMoved)) == 0 then newChar gsMoved else gsMoved - else gsMoved - - -- draw screen - SDL.fillRect gd_mainSurf (Just (SDL.Rect 0 0 width height)) (SDL.Pixel 0) - if alive - then do - mapM_ (drawChar gd) (M.assocs $ gs_shown gsNew) - drawScore gd gsNew - else do - gameOver gd gsNew - SDL.flip gd_mainSurf - - newTicks'<-SDL.getTicks - let d'=newTicks'-oldTicks - when (d'<16) (threadDelay (fromIntegral d')) - drawloop gsNew newTicks gd - else drawloop gs oldTicks gd - -data GraphicsData = GraphicsData { - gd_font :: TTF.Font - , gd_mainSurf :: SDL.Surface - } - -data GameState = GameState { - gs_moves :: Int - , gs_movespeed :: Int - , gs_newspeed :: Int - , gs_shown :: M.Map Char (Int,Int) - , gs_rand :: StdGen - , gs_score :: Int - , gs_score_beforespeed :: Int - , gs_lives :: Int - } - -speedup :: GameState -> GameState -speedup gs@GameState{gs_moves,gs_score,gs_movespeed,gs_newspeed,gs_score_beforespeed}=let - speed=1 - (1 / (log $ ((fromIntegral gs_score)::Double) ^ (2::Int))) - (ratio,sc)=if (gs_score-gs_score_beforespeed)>5 && (mod gs_moves 1000)==0 then (speed,gs_score) else (1,gs_score_beforespeed) - in gs{gs_movespeed=round ((fromIntegral gs_movespeed)*ratio),gs_newspeed=round ((fromIntegral gs_newspeed)*ratio),gs_score_beforespeed=sc} - - -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'} - -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'} - -drawChar :: GraphicsData -> (Char,(Int,Int)) -> IO() -drawChar GraphicsData{gd_font,gd_mainSurf} (c,(x,y))=do - let r = Just (SDL.Rect x y 10 10) - txtS<-TTF.renderUTF8Solid gd_font [c] (SDL.Color 255 255 255) - SDL.blitSurface txtS Nothing gd_mainSurf r - SDL.freeSurface txtS - -drawScore :: GraphicsData -> GameState -> IO() -drawScore GraphicsData{gd_font,gd_mainSurf} GameState{gs_score,gs_lives}=do - let half= (div width 2) - let r1 = Just (SDL.Rect 0 0 half 10) - let r2 = Just (SDL.Rect (half+1) 0 half 10) - txtS1<-TTF.renderUTF8Solid gd_font ("Lives:" ++ (show gs_lives) ++ "/" ++ (show lives)) (SDL.Color 255 20 20) - SDL.blitSurface txtS1 Nothing gd_mainSurf r1 - SDL.freeSurface txtS1 - txtS2<-TTF.renderUTF8Solid gd_font ("Score:" ++ show gs_score) (SDL.Color 255 20 20) - SDL.blitSurface txtS2 Nothing gd_mainSurf r2 - SDL.freeSurface txtS2 - -gameOver :: GraphicsData -> GameState -> IO() -gameOver GraphicsData{gd_font,gd_mainSurf} GameState{gs_score}=do - let halfH=(div height 2) - let halfW=(div width 2) - let x=halfW-40 - let r1 = Just (SDL.Rect x (halfH-20) 200 10) - let r2 = Just (SDL.Rect x (halfH+10) 200 10) - txtS1<-TTF.renderUTF8Solid gd_font ("Game Over!") (SDL.Color 255 20 20) - SDL.blitSurface txtS1 Nothing gd_mainSurf r1 - SDL.freeSurface txtS1 - txtS2<-TTF.renderUTF8Solid gd_font ("Score:" ++ show gs_score) (SDL.Color 255 20 20) - SDL.blitSurface txtS2 Nothing gd_mainSurf r2 - SDL.freeSurface txtS2 - -width :: Int -width = 640 - -height :: Int -height = 480 - -lives :: Int -lives = 3 - -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" - font<-TTF.openFont "FreeSansBold.ttf" 24 - mainSurf <- SDL.getVideoSurface - return $ GraphicsData font mainSurf - -endGraphics :: GraphicsData -> IO() -endGraphics GraphicsData{gd_font=font}=do - TTF.closeFont font - TTF.quit +{-# 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