diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,4 @@ +TypeClass +========= + +Simple SDL based game in Haskell. This uses the reactive-banana-SDL library diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/TypeClass.cabal b/TypeClass.cabal --- a/TypeClass.cabal +++ b/TypeClass.cabal @@ -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 diff --git a/font/FreeSansBold.ttf b/font/FreeSansBold.ttf new file mode 100644 Binary files /dev/null and b/font/FreeSansBold.ttf differ diff --git a/src/FreeSansBold.ttf b/src/FreeSansBold.ttf deleted file mode 100644 Binary files a/src/FreeSansBold.ttf and /dev/null differ diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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