TypeClass (empty) → 0.1
raw patch · 5 files changed
+219/−0 lines, 5 filesdep +SDLdep +SDL-ttfsetup-changedbinary-added
Dependencies added: SDL, SDL-ttf
Files
- LICENSE +23/−0
- Setup.hs +2/−0
- TypeClass.cabal +21/−0
- src/FreeSansBold.ttf binary
- src/Main.hs +173/−0
+ LICENSE view
@@ -0,0 +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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple +main = defaultMain
+ TypeClass.cabal view
@@ -0,0 +1,21 @@+name: TypeClass +version: 0.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: SDL, SDL-ttf + +
+ src/FreeSansBold.ttf view
binary file changed (absent → 91432 bytes)
+ src/Main.hs view
@@ -0,0 +1,173 @@+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 + SDL.quit