fallingblocks 0.1.2 → 0.1.3

raw patch · 46 files changed

+724/−715 lines, 46 filesbinary-added

Files

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

− Board.hs

@@ -1,89 +0,0 @@-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

@@ -1,40 +0,0 @@-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

@@ -1,102 +0,0 @@-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

@@ -1,110 +0,0 @@-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

@@ -1,23 +0,0 @@-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

@@ -1,21 +0,0 @@-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

@@ -1,77 +0,0 @@-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

@@ -1,14 +0,0 @@-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

binary file changed (23320 → absent bytes)

− README

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

− Shape.hs

@@ -1,69 +0,0 @@-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

@@ -1,32 +0,0 @@-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

@@ -1,27 +0,0 @@-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 ()

− blueblock.bmp

binary file changed (774 → absent bytes)

− cyanblock.bmp

binary file changed (774 → absent bytes)

+ data/Joystix.ttf view

binary file changed (absent → 23320 bytes)

+ data/blueblock.bmp view