fallingblocks-0.1.1: Game.hs

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