fallingblocks 0.1 → 0.1.1

raw patch · 24 files changed

+613/−1 lines, 24 filesbinary-added

Files

Board.hs +89/−0
BoardTest.hs +40/−0
Game.hs +102/−0
GameController.hs +110/−0
GameState.hs +23/−0
GameTest.hs +21/−0
GraphicsInfo.hs +77/−0
Helpers.hs +14/−0
Joystix.ttf binary
README +1/−0
Shape.hs +69/−0
ShapeTest.hs +32/−0
SplashController.hs +27/−0
TODO +7/−0
blueblock.bmp binary
cyanblock.bmp binary
fallingblocks.cabal +1/−1
greenblock.bmp binary
greyblock.bmp binary
music.mp3 binary
orangeblock.bmp binary
purpleblock.bmp binary
redblock.bmp binary
yellowblock.bmp binary

+ Board.hs view

@@ -0,0 +1,89 @@+module Board where+{- Really only want to export++Board, newBoard, copyBlockToBoard, removeCompleteRows, isMoveValid+-}++import Helpers+import qualified Data.Map as M+import Data.Maybe (fromJust, isJust, isNothing)+import Shape++-- A board has a map of Position to Color+data Board = Bd { m :: M.Map Position Color, ncol:: Int, nrow:: Int}+           deriving (Show, Eq)+++newBoard :: Int -> Int -> Board+newBoard x y = Bd M.empty x y++copyBlockToBoard :: Block -> Board -> Board+copyBlockToBoard block+    = copySquares (blockPositions block) (typeColor (blockType block))++--See about changing this to a foldl+copySquares :: [Position] -> Color -> Board -> Board+copySquares [] _ b = b+copySquares (p:ps) c b = copySquares ps c (insert p c b)++insert :: Position -> Color -> Board -> Board+insert p c (Bd m x y) = Bd (M.insert p c m) x y++--Returns board and number of lines cleared+removeCompleteRows :: Board -> (Board, Int)+removeCompleteRows board = foldl removeFullRow (board, 0) [0 .. (nrow board)]++removeFullRow :: (Board, Int) -> Int -> (Board, Int)+removeFullRow (b, ls) row = if rowIsFull b row+                            then removeFullRow (moveEverythingDown, ls + 1) row+                            else (b, ls)+    where moveEverythingDown = foldl (moveColumnDown row) b [0 .. (ncol b)]+          +moveColumnDown :: Int -> Board -> Int -> Board+moveColumnDown row board col +    | row <= (nrow board) = moveColumnDown (row + 1) (moveSquare col board row) col+    | otherwise = board++moveSquare :: Int -> Board -> Int -> Board+moveSquare x b y = mdelete (x, y + 1) newboard+    where abvSquare = doLookup (x, y + 1) b :: Maybe Color+          newboard  = if isNothing abvSquare+                      then mdelete (x, y) b+                      else insert (x, y) (fromJust abvSquare) b+          ++mdelete :: Position -> Board -> Board+mdelete p (Bd m x y) = Bd (M.delete p m) x y++rowIsFull :: Board -> Int -> Bool+rowIsFull b row = and (map test [0 .. (ncol b)])+    where test col = isJust $ doLookup (col, row) b++isMoveValid :: Block -> Board -> Bool+isMoveValid block board = and (map test blks)+    where blks = blockPositions block+          test pos@(x, y) = x >= 0 && x <= (ncol board) && isFree pos+          isFree pos = Nothing == doLookup pos board+          +checkBelow :: Block -> Board -> Bool+checkBelow block board = or (map (stopBelow board) (blockPositions block))++stopBelow :: Board -> Position -> Bool+stopBelow b (x, y) = y == 0 || Nothing /= doLookup (x, y - 1) b++doLookup :: Position -> Board -> Maybe Color+doLookup p@(x,y) (Bd b nc nr) = if x<0 || y <0 || x>nc+                               then error ("Tried to look up " ++ show x ++ "," ++ show y)+                               else M.lookup p b++--test :: M.Map (Int, Int) Color+--test = M.insert (0,0) Blue $ M.insert (1,0) Blue $ M.empty++typeColor :: ShapeType -> Color+typeColor O = Red+typeColor I = Blue+typeColor S = Yellow+typeColor Z = Green+typeColor L = Purple+typeColor J = Cyan+typeColor T = Orange

+ BoardTest.hs view

@@ -0,0 +1,40 @@+import Board+import Helpers+import Shape++import Test.HUnit+import Data.Maybe (isNothing, isJust)++main :: IO Counts+main = runTestTT $ TestList [first, second, third, forth, fifth]++board1 :: Board+board1 = foldl (\b p -> insert p Red b) (newBoard 2 2) [(0,0), (1,0), (2,0), (1,1)]++first :: Test+first = TestCase $ assertBool "should remove" ((isNothing $ doLookup (0,0) b')+                                               && (isJust $ doLookup (1,0) b'))+    where b' = removeCompleteRows board1++second :: Test+second = TestCase $ assertBool "row is full" (rowIsFull board1 0)++third :: Test+third = TestCase $ assertBool "should move" (isNothing $ doLookup (1, 1) b')+    where b = insert (1,1) Red (newBoard 2 2)+          b' = moveSquare 1 b 1++forth :: Test+forth = TestCase $ assertBool "should move" (isJust $ doLookup (1, 0) b')+    where b = insert (1,1) Red (newBoard 2 2)+          b' = moveSquare 1 b 0+          +board2 :: Board+board2 = foldl (\b p -> insert p Red b) (newBoard 2 2) +         [(0,0), (1,0), (2,0), (0,1), (1,1), (2,1), (2,2)]++fifth :: Test+fifth = TestCase $ assertEqual "should be same" exp b+    where b = removeCompleteRows board2+          exp = insert (2,0) Red (newBoard 2 2)+

+ Game.hs view

@@ -0,0 +1,102 @@+module Game where+{-- put this back in+(Game,+             newGame,+             Color(..),+             addBlock,+             move,+             colorAt,+             nrows, ncols,+             activeBlock) where+--}+import Shape+import Board+import Helpers++import Monad (mplus)+import Data.Maybe (fromJust, isJust, isNothing)++-- Score/Num lines/Level/isRunning+type GameInfo = (Int, Int, Int, Bool)++-- board, current piece, next piece, game info+data Game = Gm { board::Board,+                 activeBlock::(Maybe Block),+                 nextBlock::(Maybe Block),+                 gameInfo::GameInfo }+++score (Gm _ _ _ (s, _, _, _)) = s+numLines (Gm _ _ _ (_, l, _, _)) = l+curLevel (Gm _ _ _ (_, _, lv, _)) = lv+stillRunning (Gm _ _  _ (_, _, _, r)) = r++newGame :: ShapeType -> ShapeType -> Game+newGame ct nt = Gm (newBoard ncols nrows) c n (0,0, 0, True)+    where c = Just $ makeBlock ct initPos+          n = Just $ makeBlock nt initPos++addBlock :: Game -> ShapeType -> Game+addBlock (Gm b cur next (s, n, lv, _)) t = Gm b blockToUse newNext (s, n, lv, keepGoing)+    where newBlock = makeBlock t initPos+          keepGoing = isMoveValid newBlock b+          (blockToUse, newNext) | keepGoing = (cur, Just newBlock)+                                | otherwise = (cur, Just newBlock)++move :: Game -> Move -> Game+move g@(Gm b Nothing _ _) move = g+move g@(Gm b _ Nothing _) move = g+move g@(Gm board (Just block) (Just nextBlock) (s, n, lv, r)) move +     | not $ stillRunning g = g+     | otherwise = Gm board' newblock newNext ((computeScore lv s ls), n + ls, level, r)+     where potentialBlock = moveBlock block move+           isValid = isMoveValid potentialBlock board+           isFinalMove = (move == MoveDown) && checkBelow block board+           (newblock, newNext) | isFinalMove = (Just nextBlock, Nothing)+                               | not isValid = (Just block, Just nextBlock)+                               | otherwise = (Just potentialBlock, Just nextBlock)+           (board', ls)   | isFinalMove = +                              removeCompleteRows $ copyBlockToBoard block board+                          | otherwise = (board, 0)+           level | isFinalMove = (n + ls) `div` 10+                 | otherwise = lv+++computeScore :: Int -> Int -> Int -> Int+computeScore level oldScore numLines = oldScore + extra+    where extra | numLines == 1 = 40 * (level + 1)+                | numLines == 2 = 100 * (level + 1)+                | numLines == 3 = 300 * (level + 1)+                | numLines == 4 = 1200 * (level + 1)+                | otherwise = 0 +++colorAt :: Game -> Position -> Maybe Color+colorAt (Gm board block _ _) p = boardC `mplus` (block >>= blockC)+    where +      boardC :: Maybe Color+      boardC = doLookup p board+      blockC :: Block -> Maybe Color+      blockC c | elem p (blockPositions c) = Just . typeColor $ blockType c+               | otherwise = Nothing++instance Show Game where+    show g = unlines $ reverse[ makeRow g y| y <- [0 .. nrows]]++makeRow :: Game -> Int -> String+makeRow g y = [showCol (colorAt g (x,y)) | x <- [0..ncols]]++showCol :: Maybe Color -> Char+showCol Nothing = '.'+showCol (Just c) = head $ show c++initPos :: Position+initPos = (6, 20)++nrows :: Int+nrows = 20++ncols :: Int+ncols = 10++

+ GameController.hs view

@@ -0,0 +1,110 @@+module GameController where++import Graphics.UI.SDL as SDL+import Graphics.UI.SDL.TTF as TTF++import Board+import Game+import Shape+import Helpers+import GameState+import GraphicsInfo++-- Takes a list of events and a game state and returns a modified gamestate+handleGameEvents :: [Event] -> GameState -> GameState+handleGameEvents [] gs = gs+handleGameEvents ((KeyUp (Keysym SDLK_q _ _)):es) gs = gs { keepGoing = False}+handleGameEvents (e:es) gs = handleGameEvents es (gs' themove)+    where gs' Nothing = gs+          gs' (Just m) = gs { game = move (game gs) m }+          themove = +              case e of +                (KeyDown (Keysym SDLK_LEFT _ _))  -> Just MoveLeft+                (KeyDown (Keysym SDLK_RIGHT _ _)) -> Just MoveRight+                (KeyDown (Keysym SDLK_UP _ _)) -> Just Rotate+                (KeyDown (Keysym SDLK_DOWN _ _)) -> Just MoveDown+                otherwise  -> Nothing+         ++-- Renders the current game state+renderGameState:: GameState -> IO ()+renderGameState gs = do+  let gri = grInfo gs+      g = game gs+      s = screen gri+      fnt = font gri++  -- Clear the screen+  worked <- fillRect s+            Nothing+            (Pixel 0)++  title <- renderTextSolid (titlefont gri) "FALLING BLOCKS!" (Color 255 0 0)+  blitSurface title Nothing s (Just (Rect 10 10 200 0))+  +--  scoreMessage <- renderTextSolid fnt ("Score:" ++ (show (score g))) (Color 255 0 0)+--  blitSurface scoreMessage Nothing s (Just (Rect 220 45 200 0))++  screenText "Score" fnt s 220 45+  screenText (show $ score g) fnt s 220 70++  screenText "Lines" fnt s 220 100+  screenText (show $ numLines g) fnt s 220 125++  screenText "Level" fnt s 220 155+  screenText (show $ curLevel g) fnt s 220 190+  +  screenText "Next" fnt s 220 220+  +  sequence_ [drawBlock x (nrows - y) 20 60 (colorAt g (x, y)) gri s+             | x <- [0..ncols], y <- [0..nrows]]++  drawBlockRect (bkgdblock gri) s++  drawNextBlock (nextBlock g) g gri++  if not . stillRunning $ game gs+   then do +     gameOver <- renderTextSolid (titlefont gri) "Game Over!" (Color 255 0 0)+     blitSurface gameOver Nothing s (Just (Rect 50 200 200 0))+   else return False++  SDL.flip s++screenText :: String -> Font -> Surface -> Int -> Int -> IO Bool+screenText msg fnt s x y = do  +  screenMessage <- renderTextSolid fnt msg (Color 255 0 0)+  blitSurface screenMessage Nothing s (Just (Rect x y 200 0))+++drawNextBlock :: (Maybe Block) -> Game -> GraphicsInfo -> IO ()+drawNextBlock Nothing _ _ = return ()+drawNextBlock (Just b) g gri = sequence_ [drawBlock (-1 * x)+ y 250 260 +                                        (Just . typeColor $ blockType b) gri s +                                            | (x, y) <- blockPos b]+    where s = screen gri+++--Change to take in coordinates+drawBlockRect :: Surface -> Surface -> IO ()+drawBlockRect block screen = do+  sequence_ [db2 x y block screen | x <- [0, ncols + 2],  y <- [0..nrows + 2]]+  sequence_ [db2 x y block screen | x <- [0 .. ncols + 2], y<- [0, nrows + 2]]+ +db2 :: Int -> Int -> Surface -> Surface -> IO Bool+db2 x y block screen+    = blitSurface block+      Nothing +      screen+      (Just (Rect ((x * 15) + 5) ((y * 15) + 45) 15 15))+  ++drawBlock :: Int -> Int -> Int -> Int -> Maybe Helpers.Color -> GraphicsInfo -> Surface -> IO Bool+drawBlock _ _ _ _ Nothing _ _ = return False+drawBlock x y xoff yoff (Just c) gri screen+    = blitSurface+      (getBlockSurface gri c)+      Nothing +      screen+      (Just (Rect ((x * 15)+ xoff) ((y * 15) + yoff) 15 15))

+ GameState.hs view

@@ -0,0 +1,23 @@+module GameState where++import Game+import GraphicsInfo+import Graphics.UI.SDL as SDL+import Graphics.UI.SDL.Mixer as Mix++data GameState = GameState { +      grInfo :: GraphicsInfo,+      game   :: Game,+      ticks   :: Int,+      keepGoing :: Bool,+      mus :: Music,+      curController :: ([Event] -> GameState -> GameState),+      curRenderer :: (GameState -> IO ()),+      paused :: Bool+    }++doRender :: GameState -> IO ()+doRender gs = (curRenderer gs) gs++handleEvents :: [Event] -> GameState -> GameState+handleEvents es gs = (curController gs) es gs

+ GameTest.hs view

@@ -0,0 +1,21 @@+import Game+import Shape+import Helpers++import Test.HUnit++main :: IO Counts+main = runTestTT $ TestList testCases++assertList :: [([Position], Game)]+assertList = [([(5,20), (6,20), (7,20), (6,19)], (addBlock newGame T)),+              ([(5,19), (6,19), (7,19), (6,18)], move (addBlock newGame T) MoveDown)]++testCases :: [Test]+testCases = map t assertList+    where t (poslist, game) = +              TestCase $ assertBool (show poslist) (hasColorsHere poslist game)      ++hasColorsHere :: [Position] -> Game -> Bool+hasColorsHere ps g = and (map test ps)+    where test p = Nothing /= colorAt g p

+ GraphicsInfo.hs view

@@ -0,0 +1,77 @@+module GraphicsInfo where++import Graphics.UI.SDL as SDL+import Graphics.UI.SDL.TTF as TTF++import Helpers++makeGraphics :: IO GraphicsInfo+makeGraphics = do+  redblock <- loadBMP "redblock.bmp"+  blueblock <- loadBMP "blueblock.bmp"+  yellowblock <- loadBMP "yellowblock.bmp"+  greenblock <- loadBMP "greenblock.bmp"+  purpleblock <- loadBMP "purpleblock.bmp"+  cyanblock <- loadBMP "cyanblock.bmp"+  orangeblock <- loadBMP "orangeblock.bmp"++  greyblock <- loadBMP "greyblock.bmp"+  font <- openFont "Joystix.ttf" 16+  titlefont <- openFont "Joystix.ttf" 20+  screen <- getVideoSurface++  return $ GraphicsInfo screen +             (BS redblock +                 blueblock+                 yellowblock+                 greenblock+                 purpleblock+                 cyanblock+                 orangeblock+             ) +             greyblock font titlefont++cleanupGraphics :: GraphicsInfo -> IO ()+cleanupGraphics gi = do+  freeSurface $ screen gi+  let bs = blocks gi+           +  freeSurface $ redBlock bs+  freeSurface $ blueBlock bs+  freeSurface $ yellowBlock bs+  freeSurface $ greenBlock bs+  freeSurface $ purpleBlock bs+  freeSurface $ cyanBlock bs+  freeSurface $ orangeBlock bs++  closeFont $ font gi+  closeFont $ titlefont gi++data BlockSurfaces = BS {+      redBlock :: Surface,+      blueBlock :: Surface,+      yellowBlock :: Surface,+      greenBlock :: Surface,+      purpleBlock :: Surface,+      cyanBlock :: Surface,+      orangeBlock :: Surface+    }+++data GraphicsInfo = GraphicsInfo {+      screen :: Surface,+      blocks  :: BlockSurfaces,+      bkgdblock :: Surface,+      font   :: Font,+      titlefont :: Font+    }++getBlockSurface :: GraphicsInfo -> Helpers.Color -> Surface+getBlockSurface gi c = g $ blocks gi+    where g | c == Red = redBlock+            | c == Blue = blueBlock+            | c == Yellow = yellowBlock+            | c == Green = greenBlock+            | c == Purple = purpleBlock+            | c == Cyan = cyanBlock+            | c == Orange = orangeBlock

+ Helpers.hs view

@@ -0,0 +1,14 @@+module Helpers where++-- | The ways a piece can move+data Move = MoveLeft | MoveRight | MoveDown | Rotate+            deriving (Eq, Show)+++-- | Position: (col, row)+type Position = (Int, Int)++data Color = Red | Blue | Yellow | Green | Purple | Cyan | Orange+           deriving (Eq)+instance Show Color where+    show _ = "X"

+ Joystix.ttf view

binary file changed (absent → 23320 bytes)

+ README view

@@ -0,0 +1,1 @@+This is the readme file.  Put stuff here.

+ Shape.hs view

@@ -0,0 +1,69 @@+module Shape (ShapeType(..), +              Block,+              makeBlock,+              moveBlock,+              blockType,+              blockPositions,+              blockPos) where++import Helpers++-- | The various shape types+data ShapeType = O | I | S | Z | L | J | T+                 deriving (Eq, Show, Enum)++type ShapeConfig = [Position]++rotations :: ShapeType -> [ShapeConfig]+rotations O = [[(-1, -1), (0, -1), (-1, 0), (0,0)]]+rotations I = [[(-2, 0), (-1, 0), (0,0), (1,0)],+               [(0, -2), (0, -1), (0,0), (0, 1)]]+rotations S = [[(-1, -1), (0,-1), (0,0), (1,0)],+               [(1, -1), (1, 0), (0,0), (0,1)]]+rotations Z = [[(-1, 0), (0,0), (0,-1), (1, -1)],+               [(0, -1), (0,0), (1, 0), (1,1)]]+rotations L = [[(-1, -1), (-1, 0), (0,0), (1,0)],+               [(0,-1), (1, -1), (0,0), (0, 1)],+               [(-1, 0), (0,0), (1,0), (1,1)],+               [(0,-1), (0,0), (0,1), (-1,1)]]+rotations J = [[(-1,0), (0,0), (1,0), (1,-1)],+               [(0,-1), (0,0), (0,1), (1,1)],+               [(-1,0), (-1,1), (0,0), (1,0)],+               [(-1,-1), (0,-1), (0,0), (0,1)]]+rotations T = [[(-1,0), (0,0), (0,-1), (1,0)],+               [(0,-1), (0,0), (0,1), (1,0)],+               [(-1,0), (0,0), (1,0), (0,1)],+               [(-1,0), (0,0), (0,-1), (0,1)]]++-- | A falling block.  Knows its current shape, +--   its current position, and the list of future shapes (rotations)+data Block = Blk ShapeType Position [ShapeConfig]++instance Show Block where+    show (Blk t p (c:cs)) = (show t) ++ " " ++ (show p) ++ " " ++ (show c)++-- | Given a ShapeType and an initial position, create a new block+makeBlock :: ShapeType -> Position -> Block+makeBlock t p = Blk t p rots+    where rots = cycle $ rotations t++-- | Move a block+moveBlock :: Block -> Move -> Block+moveBlock (Blk t p (c:cs)) Rotate = Blk t p cs+moveBlock (Blk t p cs) m = Blk t p' cs+    where p' | m == MoveLeft = addPos p (-1, 0)+             | m == MoveRight = addPos p (1, 0)+             | m == MoveDown = addPos p (0, -1)++addPos :: Position -> Position -> Position+addPos (x, y) (x', y') = (x + x', y + y')++blockType :: Block -> ShapeType+blockType (Blk s _ _) = s++-- | Given a block, get the positions it occupies+blockPositions :: Block -> [Position]+blockPositions (Blk _ p (c:cs)) = map (addPos p) c++blockPos :: Block -> [Position]+blockPos (Blk _ _ (c:cs)) = c

+ ShapeTest.hs view

@@ -0,0 +1,32 @@+import Shape+import Helpers++import Test.HUnit+import List (sort)+import Monad (unless)++main :: IO Counts+main = runTestTT $ TestList testCases ++movecases = [((makeBlock T initPos), [(20,20), (19, 20), (21, 20), (20, 19)])]++testCases :: [Test]+testCases = map t movecases+    where t (block, ps) = +              TestCase (assertRightPos ("expected " ++ show ps ++ " got " ++ show block) ps block)++initPos = (20, 20)+-- Helper functions+doMoves :: ShapeType -> [Move] -> Block+doMoves t moves = doMHelper (makeBlock t initPos) moves+    where doMHelper block [] = block+          doMHelper block (p:ps) = doMHelper (moveBlock block p) ps++assertRightPos :: String -> [Position] -> Block -> Assertion+assertRightPos msg exp b = assertSamePos msg exp (blockPositions b)++assertSamePos :: String -> [Position] -> [Position] -> Assertion+assertSamePos msg exp act = unless (samePos exp act) (assertFailure msg)+ +samePos :: [Position] -> [Position] -> Bool+samePos exp act = (sort exp) == (sort act)

+ SplashController.hs view

@@ -0,0 +1,27 @@+module SplashController where++import Graphics.UI.SDL as SDL+import Graphics.UI.SDL.TTF as TTF+import GameState+import GraphicsInfo+import GameController++handleSplashEvents :: [Event] -> GameState -> GameState+handleSplashEvents ((KeyUp _):_) gs = gs { curController = handleGameEvents, +                                           curRenderer = renderGameState,+                                           paused = False}+handleSplashEvents _ gs = gs+++renderSplashScreen :: GameState -> IO ()+renderSplashScreen gs = do+  let gri = grInfo gs+      s = screen gri+  title <- renderTextSolid (titlefont gri) "FALLING BLOCKS!" (Color 255 0 0)+  blitSurface title Nothing s (Just (Rect 10 100 200 0))++  subtext <- renderTextSolid (font gri) "press any key" (Color 255 0 0)+  blitSurface subtext Nothing s (Just (Rect 60 150 200 0))++  SDL.flip s+  return ()

+ TODO view

@@ -0,0 +1,7 @@+* Wall kicks+* Levels+* Pause+* Options screen (music on/off, maybe different music)+* Setup screen (options for speed, etc) that you see before starting a game+* Quit current game (back to setup screen)+* High scores

+ blueblock.bmp view