summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJeanPhilippeMoresmau <>2013-11-28 21:08:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2013-11-28 21:08:00 (GMT)
commit8bb367f5c9a040b4559ce9a1a256eb91cc6b92ec (patch)
tree4437164a1b2cf6052e93c9969b6907c7e90e59b0
parent14836d7c155ae7e048c115ec498c15d064c1dd8b (diff)
version 0.2.00.2.0
-rw-r--r--LICENSE46
-rw-r--r--README.md4
-rw-r--r--Setup.hs4
-rw-r--r--TypeClass.cabal55
-rw-r--r--font/FreeSansBold.ttf (renamed from src/FreeSansBold.ttf)bin91432 -> 91432 bytes
-rw-r--r--src/Main.hs384
6 files changed, 275 insertions, 218 deletions
diff --git a/LICENSE b/LICENSE
index 0cb7ff8..ec2af25 100644
--- 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
index 0000000..d47529a
--- /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
index 833b4c6..9a994af 100644
--- 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
index 0a27973..34e9679 100644
--- 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/src/FreeSansBold.ttf b/font/FreeSansBold.ttf
index e75685b..e75685b 100644
--- a/src/FreeSansBold.ttf
+++ b/font/FreeSansBold.ttf
Binary files differ
diff --git a/src/Main.hs b/src/Main.hs
index 638b58c..99232f1 100644
--- 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 \ No newline at end of file