diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/breakout.cabal b/breakout.cabal new file mode 100644 --- /dev/null +++ b/breakout.cabal @@ -0,0 +1,23 @@ +Name: breakout +Version: 0.0.1 +Cabal-Version: >= 1.2 +Synopsis: A simple Breakout game implementation. +Category: game +Description: + + A simple Breakout game implementation. + +Author: Eyal Lotem +Maintainer: Eyal Lotem (eyal.lotem@gmail.com) +Homepage: http://github.com/Peaker/breakout/tree/master +Copyright: (c) 2009, Eyal Lotem +License: GPL +Stability: experimental +Build-Type: Simple + +Executable breakout + Executable: breakout + HS-Source-Dirs: src + Main-IS: breakout.hs + Build-Depends: base >=4 && < 5, haskgame >= 0.0.6, mtl, SDL + GHC-Options: -O2 -Wall diff --git a/src/breakout.hs b/src/breakout.hs new file mode 100644 --- /dev/null +++ b/src/breakout.hs @@ -0,0 +1,209 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +module Main where + +import qualified Graphics.UI.HaskGame as HaskGame +import qualified Graphics.UI.HaskGame.Vector2 as Vector2 +import qualified Graphics.UI.HaskGame.Rect as Rect +import Graphics.UI.HaskGame.Vector2(Vector2(..)) +import Graphics.UI.HaskGame.Color(Color(..)) +import qualified Graphics.UI.SDL as SDL +import Graphics.UI.SDL(Rect(..)) +import qualified System.IO as IO +import qualified Control.Exception as Exception +import Control.Exception(Exception) +import Data.Typeable(Typeable) +import Data.Maybe(listToMaybe, isNothing, mapMaybe) +import Control.Monad(forM_, forever, when) +import Control.Monad.State.Strict(evalStateT, modify, get) +import Control.Monad.Trans(liftIO) +import Control.Applicative((<$>)) + +data Direction = X | Y + deriving (Eq, Ord, Show, Read) + +data QuitException = QuitException + deriving (Show, Typeable) +instance Exception QuitException where + -- Nothing + +displayWidth :: Int +displayHeight :: Int +displaySize :: Vector2 Int +displaySize@(Vector2 displayWidth displayHeight) = Vector2 640 480 +colordepth :: Int +colordepth = 32 + +capRange :: Ord a => a -> a -> a -> a +capRange bottom top x = (x `max` bottom) `min` top + +bgColor :: Color +bgColor = Color 0 0 0 + +brickColor :: Color +brickColor = Color 255 0 0 +brickWidth :: Int +brickWidth = 72 +brickHeight :: Int +brickHeight = 30 +spaceWidth :: Int +spaceWidth = 8 +spaceHeight :: Int +spaceHeight = 5 +ballRadius :: Int +ballRadius = 8 + +playerColor :: Color +playerColor = Color 0 0 255 + +playerHeight :: Int +playerHeight = 15 +initialPlayerWidth :: Int +initialPlayerWidth = 80 +initialBallSpeed :: Vector2 Double +initialBallSpeed = Vector2 1 (-2) + +playerRect :: GameState -> Rect +playerRect GameState{gsPlayerPos=playerPos + ,gsPlayerWidth=playerWidth} = + Rect (playerPos - halfWidth) (displayHeight - playerHeight) + playerWidth displayHeight + where + halfWidth = playerWidth `div` 2 + +capPlayerRange :: Int -> Int -> Int +capPlayerRange curPlayerWidth = capRange halfWidth (displayWidth - halfWidth) + where halfWidth = curPlayerWidth `div` 2 + +data GameState = GameState { + gsPlayerPos :: Int + , gsPlayerWidth :: Int + , gsBall :: Maybe (Vector2 Double, Vector2 Double) + , gsBrickPositions :: [Vector2 Int] + } + +initGameState :: GameState +initGameState = GameState 0 initialPlayerWidth Nothing initBrickPositions + +-- This boilerplate should really be automatic from records :-( +type Endo a = (a -> a) +type Inside whole part = Endo part -> Endo whole +atGsPlayerPos :: Inside GameState Int +atGsPlayerPos f gs = gs{gsPlayerPos = f (gsPlayerPos gs)} +atGsPlayerWidth :: Inside GameState Int +atGsPlayerWidth f gs = gs{gsPlayerWidth = f (gsPlayerWidth gs)} +atGsBall :: Inside GameState (Maybe (Vector2 Double, Vector2 Double)) +atGsBall f gs = gs{gsBall = f (gsBall gs)} +atGsBrickPositions :: Inside GameState [Vector2 Int] +atGsBrickPositions f gs = gs{gsBrickPositions = f (gsBrickPositions gs)} + +initBrickPositions :: [Vector2 Int] +initBrickPositions = + let height = displayHeight * 2 `div` 5 + in [Vector2 x y + | x <- [0, brickWidth+spaceWidth..displayWidth-brickWidth] + , y <- [0, brickHeight+spaceHeight..height-brickHeight]] + +brickRect :: Vector2 Int -> Rect +brickRect (Vector2 x y) = Rect x y brickWidth brickHeight + +handleEvents :: [SDL.Event] -> IO () +handleEvents events = do + forM_ events $ \event -> case event of + SDL.Quit -> Exception.throwIO QuitException + _ -> return () + +draw :: SDL.Surface -> GameState -> IO () +draw display gs = do + forM_ (gsBrickPositions gs) $ \pos -> + HaskGame.fillRect display (brickRect pos) brickColor + let Vector2 ballx bally = ballPosition gs + HaskGame.fillRect display (playerRect gs) playerColor + let ballRect = Rect (truncate ballx - ballRadius) (truncate bally - ballRadius) (ballRadius*2) (ballRadius*2) + HaskGame.fillRect display ballRect playerColor + +nextGameState :: GameState -> GameState +nextGameState gs = + maybe gs newState $ gsBall gs + where + Rect px _ pw _ = playerRect gs + brickPositions = gsBrickPositions gs + fi = fromIntegral + newState (ballPos, ballSpeed@(Vector2 speedX speedY)) = + gs{gsBall=if ballY - fi ballRadius >= fi displayHeight + then Nothing + else Just (ballPos', ballSpeed') + ,gsBrickPositions=filter (isNothing . collision) $ brickPositions } + where + ballPos'@(Vector2 ballX ballY) = ballPos + ballSpeed + collision = collideBall (truncate <$> ballPos') . brickRect + firstCollision = listToMaybe $ mapMaybe collision brickPositions + + hitPlayer = ballY + fi ballRadius >= fi (displayHeight - playerHeight) && + ballX+fi ballRadius >= fi px && ballX-fi ballRadius <= fi (px+pw) + factor = if hitPlayer + then (+) $ 8 * (ballX - fi px - fi pw/2) / fi pw + else id + collideX = maybe False (==X) firstCollision + collideY = maybe False (==Y) firstCollision + + ballSpeed' = + Vector2 + (factor $ + if ballX - fi ballRadius > 0 && ballX + fi ballRadius < fi displayWidth && not collideX + then speedX + else -speedX) + (if ballY - fi ballRadius > 0 && not hitPlayer && not collideY + then speedY + else -speedY) + +collideBall :: Vector2 Int -> Rect -> Maybe Direction +collideBall (Vector2 ballX ballY) r = + let intersect = r `Rect.intersect` (Rect (ballX - ballRadius) (ballY - ballRadius) + (ballRadius*2) (ballRadius*2)) + Vector2 iwidth iheight = Rect.getSize intersect + in if iwidth <= 0 || iheight <= 0 + then Nothing + else Just $ + if iwidth < iheight + then X + else Y + +ballPosition :: GameState -> Vector2 Double +ballPosition GameState{gsBall=ballPosSpeed + ,gsPlayerPos=playerPos} = + maybe (fromIntegral <$> Vector2 playerPos (displayHeight - playerHeight - ballRadius)) + fst $ + ballPosSpeed + +sdlIteration :: SDL.Surface -> GameState -> IO () +sdlIteration display gs = + do + HaskGame.fillSurface display bgColor + draw display gs + SDL.flip display + HaskGame.getEvents >>= handleEvents + ticks <- SDL.getTicks + SDL.delay (10 - (ticks `mod` 10)) + +mainLoop :: SDL.Surface -> IO () +mainLoop display = + (`evalStateT` initGameState) . forever $ do + (mouseX, _, buttons) <- liftIO $ SDL.getMouseState + let leftPressed = SDL.ButtonLeft `elem` buttons + + gameState <- get + liftIO $ sdlIteration display gameState + modify . atGsPlayerPos . const . capPlayerRange (gsPlayerWidth gameState) $ mouseX + modify nextGameState + when leftPressed $ do + ballPos <- ballPosition `fmap` get + modify . atGsBall . const $ Just (ballPos, initialBallSpeed) + +main :: IO () +main = do + HaskGame.withInit $ do + display <- HaskGame.setVideoMode displaySize colordepth + mainLoop display + `Exception.catch` + \QuitException -> return ()