diff --git a/4Blocks.cabal b/4Blocks.cabal --- a/4Blocks.cabal +++ b/4Blocks.cabal @@ -4,7 +4,7 @@ Name: 4Blocks -Version: 0.1 +Version: 0.2 Synopsis: A tetris-like game (works with GHC 6.8.3 and Gtk2hs 0.9.13) @@ -24,6 +24,8 @@ Build-type: Simple +Extra-Source-Files: README + Cabal-version: >=1.2 Tested-with: GHC == 6.8.3 @@ -31,4 +33,42 @@ Executable 4Blocks Main-is: 4Blocks.hs - Build-depends: base >= 2 && <= 4,gtk>=0.9.13,haskell98,cairo>=0.9.13,containers>=0.1.0.2,mtl>=1.1.0.1 + Build-depends: base >= 2 && <= 4,gtk>=0.9.13,haskell98,cairo>=0.9.13,containers>=0.1.0.2,mtl>=1.1.0.1 + + Other-Modules: + Core.Brick + Core.Colour + Core.ColouredPoint + Core.Commands + Core.Direction + Core.Game + Core.Level + Core.Shape + Core.SimplePoint + Core.Status + Core.Well + Interface.CommandKeys + Interface.KeyEvents + Interface.MainWindow + Interface.OnePlayerModeWindow + Interface.WindowUpdate + Rendering.Background + Rendering.Block + Rendering.Brick + Rendering.Engine + Rendering.Game + Rendering.GhostBrick + Rendering.Intro + Rendering.IntroArea + Rendering.IntroText + Rendering.Point + Rendering.RGB + Rendering.Square + Rendering.Status + Rendering.StatusArea + Rendering.StatusNext + Rendering.StatusText + Rendering.Text + Rendering.Well + + diff --git a/Core/Brick.hs b/Core/Brick.hs new file mode 100644 --- /dev/null +++ b/Core/Brick.hs @@ -0,0 +1,157 @@ + +module Core.Brick ( Brick, + createBlocks, + createBrick, + getBlocksFromBrick, + getOffsetFromBrick, + getShapeFromBrick, + rotateBrickRight, + rotateBrickLeft, + shiftBrickLeft, + shiftBrickRight, + shiftBrickDown, + shiftBrickUp, + gameEndBrick + ) + +where + +import Core.SimplePoint +import Core.ColouredPoint +import Core.Direction +import Core.Shape +import Core.Colour + +data Brick = Brick { + blocks :: [ColouredPoint], + shape :: Shape, + offset :: SimplePoint, + direction :: Direction + } + +-------------------------------------------------------------------------------- +-- Create Brick + +createBrick :: Shape -> SimplePoint -> Brick +createBrick shape offset = Brick (createBlocks shape) shape offset Up_Direction + +createBlocks :: Shape -> [ColouredPoint] +createBlocks O_Shape = [(0,1,c),(0,2,c),(1,1,c),(1,2,c)] + where c = Blue_Colour +createBlocks L_Shape = [(0,1,c),(1,1,c),(2,1,c),(2,2,c)] + where c = Green_Colour +createBlocks J_Shape = [(0,1,c),(1,1,c),(2,1,c),(0,2,c)] + where c = Orange_Colour +createBlocks T_Shape = [(0,1,c),(1,1,c),(2,1,c),(1,2,c)] + where c = Cyan_Colour +createBlocks I_Shape = [(0,1,c),(1,1,c),(2,1,c),(3,1,c)] + where c = Red_Colour +createBlocks S_Shape = [(0,1,c),(1,1,c),(1,2,c),(2,2,c)] + where c = Purple_Colour +createBlocks Z_Shape = [(0,2,c),(1,2,c),(1,1,c),(2,1,c)] + where c = Yellow_Colour + +-------------------------------------------------------------------------------- +-- Update Translation + +shiftBrickLeft :: Brick -> Brick +shiftBrickLeft (Brick blocks shape (x,y) direction) = Brick blocks shape (x-1,y) direction + +shiftBrickRight :: Brick -> Brick +shiftBrickRight (Brick blocks shape (x,y) direction) = Brick blocks shape (x+1,y) direction + +shiftBrickUp :: Brick -> Brick +shiftBrickUp (Brick blocks shape (x,y) direction) = Brick blocks shape (x,y+1) direction + +shiftBrickDown :: Brick -> Brick +shiftBrickDown (Brick blocks shape (x,y) direction) = Brick blocks shape (x,y-1) direction + +-------------------------------------------------------------------------------- +-- Update Rotation + +rotateBrickLeft :: Brick -> Brick +rotateBrickLeft (Brick blocks shape offset direction) = Brick blocks shape offset newDirection + where + newDirection = + case direction of + Up_Direction -> Right_Direction + Right_Direction -> Down_Direction + Down_Direction -> Left_Direction + Left_Direction -> Up_Direction + +rotateBrickRight :: Brick -> Brick +rotateBrickRight (Brick blocks shape offset direction) = Brick blocks shape offset newDirection + where + newDirection = + case direction of + Up_Direction -> Left_Direction + Left_Direction -> Down_Direction + Down_Direction -> Right_Direction + Right_Direction -> Up_Direction + + +-------------------------------------------------------------------------------- +-- Apply Translation + +applyTranslationBlocks :: SimplePoint -> [ColouredPoint] -> [ColouredPoint] +applyTranslationBlocks offset blocks = map (applyTranslationBlock offset) blocks + +applyTranslationBlock :: SimplePoint -> ColouredPoint -> ColouredPoint +applyTranslationBlock (offx,offy) (x,y,c) = (x+offx,y+offy,c) + +-------------------------------------------------------------------------------- +-- Apply Rotation + +applyRotationBlocks :: Shape -> Direction -> [ColouredPoint] -> [ColouredPoint] +applyRotationBlocks shape direction blocks = map (applyRotationBlock shape direction) blocks + +applyRotationBlock :: Shape -> Direction -> ColouredPoint -> ColouredPoint +applyRotationBlock O_Shape _ block = block +applyRotationBlock I_Shape direction (x,y,c) = (newx,newy,c) + where + (newx,newy) = + case direction of + Up_Direction -> (x,y) + Left_Direction -> rotateBy90DegreesCWAboutXY (1.5,1.5) (x,y) + Down_Direction -> rotateBy180DegreesCWAboutXY (1.5,1.5) (x,y) + Right_Direction -> rotateBy270DegreesCWAboutXY (1.5,1.5) (x,y) +applyRotationBlock _ direction (x,y,c) = (newx,newy,c) + where + (newx,newy) = + case direction of + Up_Direction -> (x,y) + Left_Direction -> rotateBy90DegreesCWAboutXY (1.0,1.0) (x,y) + Down_Direction -> rotateBy180DegreesCWAboutXY (1.0,1.0) (x,y) + Right_Direction -> rotateBy270DegreesCWAboutXY (1.0,1.0) (x,y) + + +rotateBy90DegreesCWAboutOrigin :: SimplePoint -> SimplePoint +rotateBy90DegreesCWAboutOrigin (x,y) = (y,-x) + +rotateBy90DegreesCWAboutXY :: SimplePoint -> SimplePoint -> SimplePoint +rotateBy90DegreesCWAboutXY (centrex, centrey) (x,y) = (rotatedx + centrex, rotatedy + centrey) + where (rotatedx, rotatedy) = rotateBy90DegreesCWAboutOrigin (x-centrex,y-centrey) + +rotateBy180DegreesCWAboutXY :: SimplePoint -> SimplePoint -> SimplePoint +rotateBy180DegreesCWAboutXY (centrex, centrey) = rotateBy90DegreesCWAboutXY (centrex, centrey) . rotateBy90DegreesCWAboutXY (centrex, centrey) + +rotateBy270DegreesCWAboutXY :: SimplePoint -> SimplePoint -> SimplePoint +rotateBy270DegreesCWAboutXY (centrex, centrey) = rotateBy90DegreesCWAboutXY (centrex, centrey) . rotateBy180DegreesCWAboutXY (centrex, centrey) + +-------------------------------------------------------------------------------- + +getBlocksFromBrick :: Brick -> [ColouredPoint] +getBlocksFromBrick (Brick blocks shape offset direction) = translatedRotatedBlocks + where rotatedBlocks = applyRotationBlocks shape direction blocks + translatedRotatedBlocks = applyTranslationBlocks offset rotatedBlocks + +getOffsetFromBrick :: Brick -> SimplePoint +getOffsetFromBrick = offset + +getShapeFromBrick :: Brick -> Shape +getShapeFromBrick = shape + +-------------------------------------------------------------------------------- + +gameEndBrick :: Brick -> Brick +gameEndBrick (Brick blocks shape offset direction) = Brick (convertAllColouredPointsToColour Dark_Grey_Colour blocks) shape offset direction diff --git a/Core/Colour.hs b/Core/Colour.hs new file mode 100644 --- /dev/null +++ b/Core/Colour.hs @@ -0,0 +1,25 @@ + +module Core.Colour ( Colour ( Cyan_Colour, + Yellow_Colour, + Purple_Colour, + Green_Colour, + Red_Colour, + Blue_Colour, + Orange_Colour, + Grey_Colour, + Dark_Grey_Colour + ) + ) + +where + +data Colour = Cyan_Colour + | Yellow_Colour + | Purple_Colour + | Green_Colour + | Red_Colour + | Blue_Colour + | Orange_Colour + | Grey_Colour + | Dark_Grey_Colour + deriving (Eq, Ord, Enum, Show) diff --git a/Core/ColouredPoint.hs b/Core/ColouredPoint.hs new file mode 100644 --- /dev/null +++ b/Core/ColouredPoint.hs @@ -0,0 +1,108 @@ + +module Core.ColouredPoint ( ColouredPoint, + getColouredPointX, + getColouredPointY, + getColouredPointColour, + convertColouredToSimplePoints, + moveColouredPointDown, + moveColouredPointUp, + moveColouredPointLeft, + moveColouredPointRight, + removeColouredPoints, + filterColouredPoints, + extractColouredPoints, + getLinesOfColouredPoints, + getSortedLinesOfColouredPoints, + getColumnsOfColouredPoints, + getSortedColumnsOfColouredPoints, + getColouredPointsFromLines, + convertAllColouredPointsToColour ) + +where + +import Core.Colour +import Core.SimplePoint + +import Data.Function +import Data.List + +type ColouredPoint = (Double,Double,Colour) + +getColouredPointX :: ColouredPoint -> Double +getColouredPointX (x,_,_) = x + +getColouredPointY :: ColouredPoint -> Double +getColouredPointY (_,y,_) = y + +getColouredPointColour :: ColouredPoint -> Colour +getColouredPointColour (_,_,c) = c + +convertColouredToSimplePoint :: ColouredPoint -> SimplePoint +convertColouredToSimplePoint (x,y,c) = (x,y) + +convertColouredToSimplePoints :: [ColouredPoint] -> [SimplePoint] +convertColouredToSimplePoints xs = map (convertColouredToSimplePoint) xs + +moveColouredPointDown :: ColouredPoint -> ColouredPoint +moveColouredPointDown (x,y,c) = (x,y-1,c) + +moveColouredPointUp :: ColouredPoint -> ColouredPoint +moveColouredPointUp (x,y,c) = (x,y+1,c) + +moveColouredPointLeft :: ColouredPoint -> ColouredPoint +moveColouredPointLeft (x,y,c) = (x-1,y,c) + +moveColouredPointRight :: ColouredPoint -> ColouredPoint +moveColouredPointRight (x,y,c) = (x+1,y,c) + +removeColouredPoints :: Colour -> [ColouredPoint] -> [ColouredPoint] +removeColouredPoints colour = filter ((/= colour).getColouredPointColour) + +filterColouredPoints :: Colour -> [ColouredPoint] -> [ColouredPoint] +filterColouredPoints colour = filter ((== colour).getColouredPointColour) + +extractColouredPoints :: Colour -> [ColouredPoint] -> ([ColouredPoint],[ColouredPoint]) +extractColouredPoints colour colouredPoints = (filterColouredPoints colour colouredPoints,removeColouredPoints colour colouredPoints) + +getLinesOfColouredPoints :: [ColouredPoint] -> [[ColouredPoint]] +getLinesOfColouredPoints colouredPoints = linesOfColouredPoints + where + sortedByYColouredPoints = sortBy (compare `on` getColouredPointY) colouredPoints + groupedColouredPoints = groupBy (\(x1,y1,c1) (x2,y2,c2) -> (y1==y2)) sortedByYColouredPoints + reversedGroupedColouredPoints = reverse groupedColouredPoints + linesOfColouredPoints = reversedGroupedColouredPoints + +getSortedLinesOfColouredPoints :: [ColouredPoint] -> [[ColouredPoint]] +getSortedLinesOfColouredPoints colouredPoints = linesOfColouredPoints + where + sortedByYColouredPoints = sortBy (compare `on` getColouredPointY) colouredPoints + groupedColouredPoints = groupBy (\(x1,y1,c1) (x2,y2,c2) -> (y1==y2)) sortedByYColouredPoints + sortedByXYColouredPointsLines = map (sortBy (compare `on` getColouredPointX)) groupedColouredPoints + reversedGroupedColouredPoints = reverse sortedByXYColouredPointsLines + linesOfColouredPoints = reversedGroupedColouredPoints + +getColumnsOfColouredPoints :: [ColouredPoint] -> [[ColouredPoint]] +getColumnsOfColouredPoints colouredPoints = columnsOfColouredPoints + where + sortedByXColouredPoints = sortBy (compare `on` getColouredPointX) colouredPoints + groupedColouredPoints = groupBy (\(x1,y1,c1) (x2,y2,c2) -> (x1==x2)) sortedByXColouredPoints + columnsOfColouredPoints = groupedColouredPoints + +getSortedColumnsOfColouredPoints :: [ColouredPoint] -> [[ColouredPoint]] +getSortedColumnsOfColouredPoints colouredPoints = columnsOfColouredPoints + where + sortedByXColouredPoints = sortBy (compare `on` getColouredPointX) colouredPoints + groupedColouredPoints = groupBy (\(x1,y1,c1) (x2,y2,c2) -> (x1==x2)) sortedByXColouredPoints + sortedByXYColouredPointsLines = map (sortBy (compare `on` getColouredPointY)) groupedColouredPoints + columnsOfColouredPoints = sortedByXYColouredPointsLines + +getColouredPointsFromLines :: [[ColouredPoint]] -> [ColouredPoint] +getColouredPointsFromLines = concat + +convertAllColouredPointsToColour :: Colour -> [ColouredPoint] -> [ColouredPoint] +convertAllColouredPointsToColour c colouredPoints = unColouredPoints ++ filteredColouredPoints + where (filteredColouredPoints,removedColouredPoints) = extractColouredPoints Grey_Colour colouredPoints + unColouredPoints = map (convertAllColouredPointToColour c) removedColouredPoints + +convertAllColouredPointToColour :: Colour -> ColouredPoint -> ColouredPoint +convertAllColouredPointToColour c (x,y,_) = (x,y,c) diff --git a/Core/Commands.hs b/Core/Commands.hs new file mode 100644 --- /dev/null +++ b/Core/Commands.hs @@ -0,0 +1,168 @@ + +module Core.Commands ( Game, + standardGame, + shift_brick_down, + shift_brick_up, + shift_brick_left, + shift_brick_right, + rotate_brick_left, + rotate_brick_right, + next_brick, + clear_brick_lines, + lock_brick, + increment_speed, + decrement_speed, + increment_score, + reset_score, + increment_lines, + reset_lines, + soft_drop_brick, + hard_drop_brick, + lock_clear_next_brick, + drop_lock_clear_next_brick, + pause_resume ) + +where + +import Core.Game + +import Control.Monad.State + + +next_brick :: State Game Bool +next_brick + = do game <- get + let (newGame, newResult) = nextBrick game + put newGame + return newResult + + +shift_brick_down :: State Game Bool +shift_brick_down + = do game <- get + let (newGame, newResult) = shiftDown game + put newGame + return newResult + +shift_brick_up :: State Game Bool +shift_brick_up + = do game <- get + let (newGame, newResult) = shiftUp game + put newGame + return newResult + +shift_brick_left :: State Game Bool +shift_brick_left + = do game <- get + let (newGame, newResult) = shiftLeft game + put newGame + return newResult + +shift_brick_right :: State Game Bool +shift_brick_right + = do game <- get + let (newGame, newResult) = shiftRight game + put newGame + return newResult + +rotate_brick_left :: State Game Bool +rotate_brick_left + = do game <- get + let (newGame, newResult) = rotateLeft game + put newGame + return newResult + +rotate_brick_right :: State Game Bool +rotate_brick_right + = do game <- get + let (newGame, newResult) = rotateRight game + put newGame + return newResult + +clear_brick_lines :: State Game Bool +clear_brick_lines + = do game <- get + let (newGame, newResult) = clearLines game + put newGame + return newResult + +lock_brick :: State Game Bool +lock_brick + = do game <- get + let (newGame, newResult) = lockBrick game + put newGame + return newResult + +increment_speed :: State Game Bool +increment_speed + = do game <- get + let (newGame, newResult) = incrementSpeed game + put newGame + return newResult + +decrement_speed :: State Game Bool +decrement_speed + = do game <- get + let (newGame, newResult) = decrementSpeed game + put newGame + return newResult + +increment_score :: Int -> State Game Bool +increment_score n + = do game <- get + let (newGame, newResult) = incrementScore n game + put newGame + return newResult + +reset_score :: State Game Bool +reset_score + = do game <- get + let (newGame, newResult) = resetScore game + put newGame + return newResult + +increment_lines :: Int -> State Game Bool +increment_lines n + = do game <- get + let (newGame, newResult) = incrementLines n game + put newGame + return newResult + +reset_lines :: State Game Bool +reset_lines + = do game <- get + let (newGame, newResult) = resetLines game + put newGame + return newResult + +soft_drop_brick :: State Game Bool +soft_drop_brick + = do game <- get + let (newGame, newResult) = softDrop game + put newGame + return newResult + +hard_drop_brick :: State Game Bool +hard_drop_brick + = do game <- get + let (newGame, newResult) = hardDrop game + put newGame + return newResult + +lock_clear_next_brick :: State Game Bool +lock_clear_next_brick + = do lock_brick + clear_brick_lines + next_brick + +drop_lock_clear_next_brick :: State Game Bool +drop_lock_clear_next_brick + = do hard_drop_brick + lock_clear_next_brick + +pause_resume :: State Game Bool +pause_resume + = do game <- get + let (newGame, newResult) = pause game + put newGame + return newResult diff --git a/Core/Direction.hs b/Core/Direction.hs new file mode 100644 --- /dev/null +++ b/Core/Direction.hs @@ -0,0 +1,16 @@ + +module Core.Direction ( Direction ( Up_Direction, + Right_Direction, + Down_Direction, + Left_Direction + ) + ) + +where + +data Direction + = Up_Direction + | Right_Direction + | Down_Direction + | Left_Direction + deriving (Eq,Enum) diff --git a/Core/Game.hs b/Core/Game.hs new file mode 100644 --- /dev/null +++ b/Core/Game.hs @@ -0,0 +1,416 @@ + +module Core.Game ( Game, + createGameFixed, + createGameRandom, + nullGame, + standardGame, + standardRandomGame, + getWellFromGame, + getBrickFromGame, + getSeedFromGame, + getGravityFromGame, + getGoalFromGame, + getLevelNumFromGame, + getScoreFromGame, + getLinesFromGame, + getNextFromGame, + getStatusFromGame, + nextBrick, + shiftUp, + shiftDown, + shiftLeft, + shiftRight, + rotateLeft, + rotateRight, + incrementSpeed, + decrementSpeed, + incrementScore, + resetScore, + incrementLines, + resetLines, + clearLines, + lockBrick, + softDrop, + hardDrop, + pause) + +where + +import Random +import Data.List + +import Core.Brick +import Core.Well +import Core.Level +import Core.Shape +import Core.ColouredPoint +import Core.Status + +data Game = Game { + well :: Well, + brick :: Brick, + seed :: StdGen, + level :: Level, + score :: Integer, + completeLines :: Integer, + nextBrickNums :: [Int], + status :: Status + } + +-------------------------------------------------------------------------------- +-- Game Creation +createGameFixed :: Double -> Double -> Int -> Int -> Integer -> Integer -> Game +createGameFixed wellX wellY seedNum levelNum score lines = Game newWell newBrick newSeed newLevel newScore newLines newBrickNums newStatus + where + newWell = generateWell (wellX,wellY) + initSeed = mkStdGen seedNum + (headBrickNum,newBrickNums,newSeed) = getNextBrickNum [] initSeed + newShape = toEnum headBrickNum + newBrick = createBrickInWell newShape newWell + newLevel = initLevel levelNum + newScore = score + newLines = lines + newStatus = Start + +createGameRandom :: Double -> Double -> StdGen -> Int -> Integer -> Integer -> Game +createGameRandom wellX wellY seed levelNum score lines = Game newWell newBrick newSeed newLevel newScore newLines newBrickNums newStatus + where + newWell = generateWell (wellX,wellY) + (headBrickNum,newBrickNums,newSeed) = getNextBrickNum [] seed + newShape = toEnum headBrickNum + newBrick = createBrickInWell newShape newWell + newLevel = initLevel levelNum + newScore = score + newLines = lines + newStatus = Start + +nullGame :: Game +nullGame = createGameFixed 0 0 0 0 0 0 + +standardGame :: Game +standardGame = createGameFixed 10 22 1 0 0 0 + +standardRandomGame :: StdGen -> Game +standardRandomGame seed = createGameRandom 10 22 seed 0 0 0 + +-------------------------------------------------------------------------------- +-- Interface +getWellFromGame :: Game -> Well +getWellFromGame = well + +getBrickFromGame :: Game -> Brick +getBrickFromGame = brick + +getSeedFromGame :: Game -> StdGen +getSeedFromGame = seed + +getGravityFromGame :: Game -> Int +getGravityFromGame = getGravityFromLevel.level + +getGoalFromGame :: Game -> Integer +getGoalFromGame = getGoalFromLevel.level + +getLevelNumFromGame :: Game -> Int +getLevelNumFromGame = getLevelNumFromLevel.level + +getScoreFromGame :: Game -> Integer +getScoreFromGame = score + +getLinesFromGame :: Game -> Integer +getLinesFromGame = completeLines + +getNextFromGame :: Game -> [Int] +getNextFromGame = nextBrickNums + +getStatusFromGame :: Game -> Status +getStatusFromGame = status +-------------------------------------------------------------------------------- +-- Brick-in-Well operations + +-- Add Brick points to Well points +addBrickInWell :: Well -> Brick -> Well +addBrickInWell well brick = newWell + where + brickBlocks = getBlocksFromBrick brick + wellBlocks = getBlocksFromWell well + wellSize = getSizeFromWell well + newBlocks = wellBlocks ++ brickBlocks + newWell = createWell newBlocks wellSize + +-- Check if Brick points can be added to Well points +checkBrickInWell :: Well -> Brick -> Bool +checkBrickInWell well brick = ((length intersectionBlocks) == 0) + where + intersectionBlocks = intersect simpleBrickBlocks simpleWellBlocks + simpleBrickBlocks = convertColouredToSimplePoints $ getBlocksFromBrick brick + simpleWellBlocks = convertColouredToSimplePoints $ getBlocksFromWell well + +-- Lock brick in well if valid brick position +lockBrickInWell :: Well -> Brick -> (Well,Bool) +lockBrickInWell well brick + = if (checkBrickInWell well brick) + then (addBrickInWell well brick, True) + else (well, False) + +-- Create brick related to Well +createBrickInWell :: Shape -> Well -> Brick +createBrickInWell shape well = newBrick + where + newBrick = createBrick shape (newX,newY) + (sizeX,sizeY) = getSizeFromWell well + (newX,newY) = if (shape == O_Shape) + then ((sizeX/2)-1,sizeY-3) + else ((sizeX/2)-2,sizeY-3) +-------------------------------------------------------------------------------- +-- Actions on Brick + +-- One action on Brick +actionOnBrick :: (Brick -> Brick) -> Game -> (Game,Bool) +actionOnBrick action (Game well brick seed level score lines next status) = (newGame, newResult) + where + newGame = if newResult + then Game well newBrick seed level score lines next status + else Game well brick seed level score lines next status + newResult = checkBrickInWell well newBrick + newBrick = action brick + +-- Repeated action on Brick +repeatOnBrick :: (Brick -> Brick) -> Int -> Game -> (Game,Int) +repeatOnBrick action currentTimes oldGame = (newGame,repeatedTimes) + where Game well brick seed level score lines next status = oldGame + tempBrick = action brick + tempResult = checkBrickInWell well (tempBrick) + tempGame = Game well tempBrick seed level score lines next status + (newGame,repeatedTimes) + = if (tempResult) + then repeatOnBrick action (currentTimes + 1) tempGame + else (Game well brick seed level score lines next status,currentTimes) +-------------------------------------------------------------------------------- +-- Actions on Level + +incrementLevel :: Game -> (Game,Bool) +incrementLevel (Game well brick seed level score lines next status) = (newGame,newResult) + where goal = getGoalFromLevel level + (newLevel,newResult) = if (lines >= goal) + then (incLevel level,True) + else (level,False) + newGame = Game well brick seed newLevel score lines next status + +decrementLevel :: Game -> (Game,Bool) +decrementLevel (Game well brick seed level score lines next status) + = (Game well brick seed (decLevel level) score lines next status,True) + +-------------------------------------------------------------------------------- +-- Actions on Score + +-- Increment Score +incScore :: Int -> Game -> (Game,Bool) +incScore valueScore (Game well brick seed level score lines next status) + = (Game well brick seed level (score + toInteger(valueScore)) lines next status,True) + +-- Reset Score +zeroScore :: Game -> (Game, Bool) +zeroScore (Game well brick seed level _ lines next status) + = (Game well brick seed level 0 lines next status,True) + +-------------------------------------------------------------------------------- +-- Actions on Lines + +-- Increment Lines +incLines :: Int -> Game -> (Game, Bool) +incLines valueLines (Game well brick seed level score lines next status) + = (Game well brick seed level score (lines + toInteger(valueLines)) next status,True) + +-- Reset Level +zeroLines :: Game -> (Game, Bool) +zeroLines (Game well brick seed level score _ next status) + = (Game well brick seed level score 0 next status,True) + +-------------------------------------------------------------------------------- +-- Actions on Well + +-- Clear Full Lines From Well +clearNFullLines :: Game -> (Game,Int) +clearNFullLines (Game well brick seed level score lines next status) = (Game newWell brick seed level score lines next status,repeatedTimes) + where (newWell,repeatedTimes) = clearFullLinesFromWell well 0 + +clearFullLines :: Game -> (Game,Bool) +clearFullLines game = (newGame,newResult) + where level = getLevelNumFromGame game + (tempGame,repeatedTimes) = clearNFullLines game + (newGame,newResult) = case repeatedTimes of + 0 -> (setStatus Playing tempGame,False) + 1 -> (updateGameValuesOnClearLines (100 * level) 1 Line_1 tempGame,True) + 2 -> (updateGameValuesOnClearLines (300 * level) 3 Line_2 tempGame,True) + 3 -> (updateGameValuesOnClearLines (500 * level) 5 Line_3 tempGame,True) + 4 -> (updateGameValuesOnClearLines (800 * level) 8 Line_4 tempGame,True) + +updateGameValuesOnClearLines :: Int -> Int -> Status -> Game -> Game +updateGameValuesOnClearLines score lines status = fst.incrementSpeed.fst.incLines lines.fst.incScore score.setStatus status + +-- Lock Brick in Well of Game +lockBrickInPlace :: Game -> (Game,Bool) +lockBrickInPlace (Game well brick seed level score lines next status) = (Game newWell brick seed level score lines next status, newResult) + where (newWell, newResult) = lockBrickInWell well brick + +-------------------------------------------------------------------------------- +-- Actions on Next +generateNewNext :: StdGen -> ([Int], StdGen) +generateNewNext seed = (newResult,newSeed) + where (index, newSeed) = randomR (0,5039) seed + newResult = bagOfBricksPermutations !! index + +getNextBrickNum :: [Int] -> StdGen -> (Int,[Int],StdGen) +getNextBrickNum [] seed = (headBrickNum, newBrickNums, newSeed) + where (headBrickNum:newBrickNums, newSeed) = generateNewNext seed +getNextBrickNum brickNums seed = (newHeadBrickNum,newTailBrickNums,newSeed) + where (headBrickNum:tailBrickNums) = brickNums + (newBrickNums,newSeed) = if ((length brickNums) < 5) + then (brickNums ++ genBrickNums,genSeed) + else (brickNums, seed) + (genBrickNums,genSeed) = generateNewNext seed + (newHeadBrickNum:newTailBrickNums) = newBrickNums + +bagOfBricksPermutations :: [[Int]] +bagOfBricksPermutations = permutations [0..6] + +selections [] = [] +selections (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- selections xs ] + +permutations :: [a] -> [[a]] +permutations [] = [[]] +permutations xs = [ y : zs | (y,ys) <- selections xs, zs <- permutations ys] + +-- Get next Brick +getNextBrick :: Game -> (Game,Bool) +getNextBrick (Game well brick seed level score lines next status) = (newGame,newResult) + where + (nextHead,nextTail,newSeed) = getNextBrickNum next seed + newShape = toEnum nextHead + newBrick = createBrickInWell newShape well + newResult = checkBrickInWell well newBrick + newGame = if newResult + then Game well newBrick newSeed level score lines nextTail status + else Game endWell endBrick seed level score lines next GameOver -- this means end of game! + endWell = gameEndWell well + endBrick = gameEndBrick brick +-------------------------------------------------------------------------------- +-- Actions on Status +setStatus :: Status -> Game -> Game +setStatus newStatus (Game well brick seed level score lines next status) = (Game well brick seed level score lines next newStatus) + +getStatus :: Game -> Status +getStatus (Game well brick seed level score lines next status) = status + +checkStatus :: (Game -> (Game,Bool)) -> Game -> (Game,Bool) +checkStatus move game = + if (getStatus game == Paused) + then (game,False) + else move game +-------------------------------------------------------------------------------- +-- Randomization +makeRandomValue :: StdGen -> (Int, StdGen) +makeRandomValue seed = randomR (0,6) seed + +-------------------------------------------------------------------------------- +-- Brick Drops +softBrickDrop :: Game -> (Game,Bool) +softBrickDrop game = (finalGame, finalResult) + where + (tempGame, tempResult) = actionOnBrick shiftBrickDown game + (finalGame, finalResult) + = if (tempResult) + then incScore 1 tempGame + else (tempGame, tempResult) + +hardBrickDrop :: Game -> (Game,Bool) +hardBrickDrop game = (finalGame,finalResult) + where + (tempGame, tempTimes) = repeatOnBrick shiftBrickDown 0 game + (finalGame, finalResult) + = if (tempTimes > 0) + then (incScore (tempTimes*2) tempGame) + else (game, False) + +-------------------------------------------------------------------------------- +-- Pause Game +pauseGame :: Game -> (Game,Bool) +pauseGame game = + case status of + Paused -> (setStatus Playing game, True) + otherwise -> (setStatus Paused game,True) + where (Game well brick seed level score lines next status) = game +-------------------------------------------------------------------------------- +-- Commands/Module Interface + +-- Generate a new brick +nextBrick :: Game -> (Game,Bool) +nextBrick = checkStatus getNextBrick + +-- Move Down +shiftDown :: Game -> (Game,Bool) +shiftDown = checkStatus $ actionOnBrick shiftBrickDown + +-- Move Up +shiftUp :: Game -> (Game,Bool) +shiftUp = checkStatus $ actionOnBrick shiftBrickUp + +-- Move Left +shiftLeft :: Game -> (Game,Bool) +shiftLeft = checkStatus $ actionOnBrick shiftBrickLeft + +-- Move Right +shiftRight :: Game -> (Game,Bool) +shiftRight = checkStatus $ actionOnBrick shiftBrickRight + +-- Rotate Right +rotateRight :: Game -> (Game,Bool) +rotateRight = checkStatus $ actionOnBrick rotateBrickRight + +-- Rotate Left +rotateLeft :: Game -> (Game,Bool) +rotateLeft = checkStatus $ actionOnBrick rotateBrickLeft + +-- Increase Speed +incrementSpeed :: Game -> (Game,Bool) +incrementSpeed = checkStatus $ incrementLevel + +-- Decrease Speed +decrementSpeed :: Game -> (Game,Bool) +decrementSpeed = checkStatus $ decrementLevel + +-- Increment Score +incrementScore :: Int -> Game -> (Game,Bool) +incrementScore n = checkStatus $ incScore n + +-- Reset Score +resetScore :: Game -> (Game,Bool) +resetScore = checkStatus $ zeroScore + +-- Increment Lines +incrementLines :: Int -> Game -> (Game,Bool) +incrementLines n = checkStatus $ incLines n + +-- Reset Lines +resetLines :: Game -> (Game,Bool) +resetLines = checkStatus $ zeroLines + +-- Clear lines +clearLines :: Game -> (Game,Bool) +clearLines = checkStatus $ clearFullLines + +-- Lock Brick +lockBrick :: Game -> (Game,Bool) +lockBrick = checkStatus $ lockBrickInPlace + +-- Soft Drop Brick +softDrop :: Game -> (Game,Bool) +softDrop = checkStatus $ softBrickDrop + +-- Hard Drop Brick +hardDrop :: Game -> (Game,Bool) +hardDrop = checkStatus $ hardBrickDrop + +-- Pause Game +pause :: Game -> (Game,Bool) +pause = pauseGame diff --git a/Core/Level.hs b/Core/Level.hs new file mode 100644 --- /dev/null +++ b/Core/Level.hs @@ -0,0 +1,67 @@ + +module Core.Level ( Level, + getGravityFromLevel, + getGoalFromLevel, + getLevelNumFromLevel, + initLevel, + incLevel, + decLevel ) + +where + +data Level = Level { + gravity :: Int, + goal :: Integer + } deriving Show + +getGravityFromLevel :: Level -> Int +getGravityFromLevel (Level gravity _) = gravity + +getGoalFromLevel :: Level -> Integer +getGoalFromLevel (Level _ goal) = goal + +getLevelNumFromLevel :: Level -> Int +getLevelNumFromLevel (Level gravity _) + = if gravity >= 1 + then gravity - 1 + else gravity + +initLevel :: Int -> Level +initLevel level = Level newGravity newGoal + where newGravity = if level >= 0 + then level+1 + else level + newGoal = if (newGravity < 0) + then 0 + else getGoalFromGravity newGravity + +incLevel :: Level -> Level +incLevel (Level gravity goal) = Level newGravity newGoal + where newGravity = incGravity gravity + newGoal = if (newGravity < 0) + then 0 + else getGoalFromGravity newGravity + +decLevel :: Level -> Level +decLevel (Level gravity goal) = Level newGravity newGoal + where newGravity = decGravity gravity + newGoal = if (newGravity < 0) + then 0 + else getGoalFromGravity newGravity + +getGoalFromGravity :: Int -> Integer +getGoalFromGravity n = toInteger $ foldr1 (+) (map (*5) [1..n]) + +-- Increment Gravity +incGravity :: Int -> Int +incGravity gravity + | gravity < -1 = gravity+1 + | gravity == -1 = 1 + | (gravity >= 1) = gravity+1 + +-- Decrement Gravity +decGravity :: Int -> Int +decGravity gravity + | gravity > 1 = gravity-1 + | gravity == 1 = -1 + | (gravity <= -1) = gravity-1 diff --git a/Core/Shape.hs b/Core/Shape.hs new file mode 100644 --- /dev/null +++ b/Core/Shape.hs @@ -0,0 +1,24 @@ + +module Core.Shape ( Shape ( O_Shape, + L_Shape, + J_Shape, + T_Shape, + I_Shape, + S_Shape, + Z_Shape + ) + ) + +where + +data Shape + = O_Shape + | L_Shape + | J_Shape + | T_Shape + | I_Shape + | S_Shape + | Z_Shape + deriving (Eq,Enum) + + diff --git a/Core/SimplePoint.hs b/Core/SimplePoint.hs new file mode 100644 --- /dev/null +++ b/Core/SimplePoint.hs @@ -0,0 +1,30 @@ + +module Core.SimplePoint ( SimplePoint, + getSimplePointX, + getSimplePointY, + moveSimplePointDown, + moveSimplePointUp, + moveSimplePointLeft, + moveSimplePointRight ) + +where + +type SimplePoint = (Double,Double) + +getSimplePointX :: SimplePoint -> Double +getSimplePointX (x,_) = x + +getSimplePointY :: SimplePoint -> Double +getSimplePointY (_,y) = y + +moveSimplePointDown :: SimplePoint -> SimplePoint +moveSimplePointDown (x,y) = (x,y-1) + +moveSimplePointUp :: SimplePoint -> SimplePoint +moveSimplePointUp (x,y) = (x,y+1) + +moveSimplePointLeft :: SimplePoint -> SimplePoint +moveSimplePointLeft (x,y) = (x-1,y) + +moveSimplePointRight :: SimplePoint -> SimplePoint +moveSimplePointRight (x,y) = (x+1,y) diff --git a/Core/Status.hs b/Core/Status.hs new file mode 100644 --- /dev/null +++ b/Core/Status.hs @@ -0,0 +1,33 @@ + +module Core.Status ( Status ( Start, + Line_1, + Line_2, + Line_3, + Line_4, + Playing, + GameOver, + Paused + ) + ) + +where + +data Status = Start + | Line_1 + | Line_2 + | Line_3 + | Line_4 + | Playing + | GameOver + | Paused + deriving Eq + +instance Show Status where + show Start = "Good Luck!" + show Line_1 = "One Line!" + show Line_2 = "Two Lines!" + show Line_3 = "Three Lines!" + show Line_4 = "Four Lines !!!" + show Playing = "Playing..." + show GameOver = "Game Over!" + show Paused = "...Paused" diff --git a/Core/Well.hs b/Core/Well.hs new file mode 100644 --- /dev/null +++ b/Core/Well.hs @@ -0,0 +1,91 @@ + +module Core.Well ( Well, + createWell, + generateWell, + getBlocksFromWell, + getSizeFromWell, + clearFullLinesFromWell, + gameEndWell + ) + +where + +import Core.ColouredPoint +import Core.SimplePoint +import Core.Colour + +data Well = Well { + blocks :: [ColouredPoint], + size :: SimplePoint + } + +-------------------------------------------------------------- +createWell :: [ColouredPoint] -> SimplePoint -> Well +createWell blocks size = Well blocks size + +generateWell :: SimplePoint -> Well +generateWell (x,y) = Well blocks size + where + size = (x+2,y+3) + blocks = addBorderBlocks size + +addBorderBlocks :: SimplePoint -> [ColouredPoint] +addBorderBlocks (x,y) = leftBorderBlocks ++ bottomBorderBlocks ++ rightBorderBlocks + where + leftBorderBlocks = [(0,j,Grey_Colour) | j <- [1..(y-1)]] + bottomBorderBlocks = [(i,0,Grey_Colour) | i <- [0..(x-1)]] + rightBorderBlocks = [(x-1,j,Grey_Colour) | j <- [1..(y-1)]] + +-------------------------------------------------------------- + +getBlocksFromWell :: Well -> [ColouredPoint] +getBlocksFromWell = blocks + +getSizeFromWell :: Well -> SimplePoint +getSizeFromWell = size + +-------------------------------------------------------------- + +splitLinesOfBlocksAtFullLine :: Int -> [[ColouredPoint]] -> ([[ColouredPoint]],[ColouredPoint],[[ColouredPoint]]) +splitLinesOfBlocksAtFullLine fullLineSize wellLines = (beforeFullLine,fullLine,afterFullLine) + where + (beforeFullLine,fullLineAndRest) = span ((< fullLineSize).length) wellLines + (fullLine,afterFullLine) = if (fullLineAndRest == []) then ([],[]) else (head fullLineAndRest, tail fullLineAndRest) + +moveLinesOfBlocksDown :: [ColouredPoint] -> [[ColouredPoint]] -> [[ColouredPoint]] +moveLinesOfBlocksDown fullContentsLine beforeContentsLines + = if (fullContentsLine /= []) + then map (map moveColouredPointDown) beforeContentsLines + else beforeContentsLines + +clearFullLineFromWell :: Well -> Well +clearFullLineFromWell (Well blocks (sizeX,sizeY)) = Well newBlocks (sizeX,sizeY) + where + -- extract and structure blocks for use + (wellBorderBlocks,wellContentsBlocks) = extractColouredPoints Grey_Colour blocks + wellContentsLines = getLinesOfColouredPoints wellContentsBlocks + -- split lines at full line and move lines before full line downwards + (beforeContentsLines,fullContentsLine,afterContentsLines) = splitLinesOfBlocksAtFullLine (truncate (sizeX-2)) wellContentsLines + updatedBeforeContentsLines = moveLinesOfBlocksDown fullContentsLine beforeContentsLines + -- convert lines back to blocks and create one list + updatedBeforeContentsBlocks = getColouredPointsFromLines updatedBeforeContentsLines + afterContentsBlocks = getColouredPointsFromLines afterContentsLines + newBlocks = updatedBeforeContentsBlocks ++ afterContentsBlocks ++ wellBorderBlocks + +-------------------------------------------------------------- + +clearFullLinesFromWell :: Well -> Int -> (Well,Int) +clearFullLinesFromWell well currentTimes = (newWell,newTimes) + where tempWell = clearFullLineFromWell well + hasClearedLines = (length (blocks well) /= length (blocks tempWell)) + (newWell,newTimes) = if (hasClearedLines) + then clearFullLinesFromWell tempWell (currentTimes+1) + else (well,currentTimes) + +-------------------------------------------------------------- +gameEndWell :: Well -> Well +gameEndWell (Well blocks size) = Well (convertAllColouredPointsToColour Dark_Grey_Colour blocks) size + + + + diff --git a/Interface/CommandKeys.hs b/Interface/CommandKeys.hs new file mode 100644 --- /dev/null +++ b/Interface/CommandKeys.hs @@ -0,0 +1,64 @@ + +module Interface.CommandKeys ( setupCommandKeyMode, + setupCommandKeyShiftBrick, + setupCommandKeyRotateBrick, + setupCommandKeyPauseResumeGame + ) + +where + +import Core.Game +import Interface.KeyEvents +import Interface.WindowUpdate + +import Control.Monad.State +import Control.Concurrent +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.Events +import qualified Data.Set as Set; import Data.Set (Set) +import Data.IORef; + +------------------------------------------------------------------------------------------------------------------------- +-- Setting up of keys which are: +-- > mode selection (once forever), +-- > shifting the brick (repeatable), +-- > rotating the brick (once), +-- > pausing/resuming game (once) + +setupCommandKeyMode :: String -> Window -> DrawingArea -> IORef (Bool) -> (DrawingArea -> Window -> IO ()) -> IO () +setupCommandKeyMode chrString window drawArea modeSelectedIORef mode + = do onKeyPress window $ \Key { eventKeyName = key } -> + do when (key == chrString) $ + do selected <- readIORef modeSelectedIORef + unless (selected) $ + do writeIORef modeSelectedIORef True + mode drawArea window + return False + return () + +setupCommandKeyShiftBrick :: String -> Window -> DrawingArea -> State Game Bool -> MVar Game -> IO () +setupCommandKeyShiftBrick chrString window drawArea move gameMVar + = do onKeyPress window $ \Key { eventKeyName = key } -> + do when (key == chrString) $ + do updateWindowWithPlayerAction drawArea gameMVar move + return False + return () + +setupCommandKeyRotateBrick :: String -> Window -> DrawingArea -> State Game Bool -> MVar Game -> IORef (Set String) -> IO () +setupCommandKeyRotateBrick chrString window drawArea move gameMVar keysIORef + = do onKeyPress window $ onKeyDownEvent drawArea chrString keysIORef $ updateWindowWithPlayerAction drawArea gameMVar move + onKeyRelease window $ onKeyUpEvent drawArea chrString keysIORef + return () + +setupCommandKeyPauseResumeGame :: String -> Window -> DrawingArea -> State Game Bool -> MVar Game -> IORef (Set String) -> IO () +setupCommandKeyPauseResumeGame chrString window drawArea move gameMVar keysIORef + = do onKeyPress window $ onKeyDownEvent drawArea chrString keysIORef $ updateWindowWithPlayerAction drawArea gameMVar move + onKeyRelease window $ onKeyUpEvent drawArea chrString keysIORef + return () + + + + + + + diff --git a/Interface/KeyEvents.hs b/Interface/KeyEvents.hs new file mode 100644 --- /dev/null +++ b/Interface/KeyEvents.hs @@ -0,0 +1,31 @@ + +module Interface.KeyEvents ( onKeyDownEvent, + onKeyUpEvent ) + +where + +import Control.Monad.State +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.Events +import qualified Data.Set as Set; import Data.Set (Set) +import Data.IORef; + +------------------------------------------------------------------------------------------------------------------------- +-- Handling OnKeyDown and OnKeyUp workaround as gtk2hs does not provide innate support + +onKeyDownEvent :: DrawingArea -> String -> IORef (Set String) -> IO () -> Event -> IO Bool +onKeyDownEvent drawArea chrString keysIORef eventResponse (Key { eventKeyName = key } ) + = if (chrString == key) + then do keys <- readIORef keysIORef + unless (key `Set.member `keys) $ writeIORef keysIORef (Set.insert key keys) >> eventResponse + return False + else return False + +onKeyUpEvent :: DrawingArea -> String -> IORef (Set String) -> Event -> IO Bool +onKeyUpEvent drawArea chrString keysIORef (Key { eventKeyName = key } ) + = if (chrString == key) + then do keys <- readIORef keysIORef + writeIORef keysIORef (Set.delete key keys) + return False + else return False + diff --git a/Interface/MainWindow.hs b/Interface/MainWindow.hs new file mode 100644 --- /dev/null +++ b/Interface/MainWindow.hs @@ -0,0 +1,53 @@ +module Interface.MainWindow ( mainWindow ) + +where + +import Interface.KeyEvents +import Interface.WindowUpdate +import Interface.OnePlayerModeWindow +import Interface.CommandKeys + +import Rendering.Engine + +import Core.Commands +import Core.Game + +import Control.Monad +import Control.Concurrent +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.Events +import Data.IORef; + +mainWindow :: IO () +mainWindow + = do initGUI + window <- windowNew + set window [ + windowTitle := "4Blocks in Haskell!", + windowDefaultWidth := 500, + windowDefaultHeight := 500 + ] + frame <- frameNew + containerAdd window frame + canvas <- drawingAreaNew + containerAdd frame canvas + widgetModifyBg canvas StateNormal (Color 0 0 0) + widgetShowAll window + + drawin <- widgetGetDrawWindow canvas + onExpose canvas (\x -> do renderWithDrawable drawin $ renderIntroScreen + return (eventSent x)) + + -- Boolean value variable used to check if mode key has already been pressed + modeSelectedIORef <- newIORef (False) + + setupCommandKeyMode "1" window canvas modeSelectedIORef onePlayerMode + + onKeyPress window $ \Key { eventKeyName = key } -> + when (key == "Escape") mainQuit >> return False + + -- redraw window periodically + timeoutAdd (widgetQueueDraw window >> return True) 20 + + onDestroy window mainQuit + mainGUI diff --git a/Interface/OnePlayerModeWindow.hs b/Interface/OnePlayerModeWindow.hs new file mode 100644 --- /dev/null +++ b/Interface/OnePlayerModeWindow.hs @@ -0,0 +1,76 @@ + +module Interface.OnePlayerModeWindow ( onePlayerMode ) + +where + +import Core.Game +import Core.Commands +import Rendering.Engine +import Interface.CommandKeys +import Interface.WindowUpdate + +import Random +import Control.Monad.State +import Control.Concurrent +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Gdk.Events +import qualified Data.Set as Set; import Data.Set (Set) +import Data.IORef; + +------------------------------------------------------------------------------------------------------ +-- Setup one player mode +onePlayerMode :: DrawingArea -> Window -> IO () +onePlayerMode canvas window + = do -- ioref for set of keys pressed + keysIORef <- newIORef (Set.empty) + + -- get global random seed + seed <- newStdGen + + -- mutable variable for game state + gameMVar <- newMVar $ standardRandomGame seed + + -- gravity delay loop + updateWindowWithGravityDelay canvas gameMVar + + drawin <- widgetGetDrawWindow canvas + + onExpose canvas (\x -> do game <- readMVar gameMVar + renderWithDrawable drawin $ renderOnePlayerScreen game + return (eventSent x)) + + -- Shift Left Brick + setupCommandKeyShiftBrick "Left" window canvas shift_brick_left gameMVar + setupCommandKeyShiftBrick "A" window canvas shift_brick_left gameMVar + setupCommandKeyShiftBrick "a" window canvas shift_brick_left gameMVar + + -- Shift Right Brick + setupCommandKeyShiftBrick "Right" window canvas shift_brick_right gameMVar + setupCommandKeyShiftBrick "D" window canvas shift_brick_right gameMVar + setupCommandKeyShiftBrick "d" window canvas shift_brick_right gameMVar + + -- Soft Drop Brick + setupCommandKeyShiftBrick "Down" window canvas soft_drop_brick gameMVar + setupCommandKeyShiftBrick "S" window canvas soft_drop_brick gameMVar + setupCommandKeyShiftBrick "s" window canvas soft_drop_brick gameMVar + + -- Hard Drop Brick + setupCommandKeyShiftBrick "Up" window canvas drop_lock_clear_next_brick gameMVar + setupCommandKeyShiftBrick "W" window canvas drop_lock_clear_next_brick gameMVar + setupCommandKeyShiftBrick "w" window canvas drop_lock_clear_next_brick gameMVar + + -- Rotate Left Brick + setupCommandKeyRotateBrick "q" window canvas rotate_brick_left gameMVar keysIORef + setupCommandKeyRotateBrick "Q" window canvas rotate_brick_left gameMVar keysIORef + setupCommandKeyRotateBrick "comma" window canvas rotate_brick_left gameMVar keysIORef + + -- Rotate Right Brick + setupCommandKeyRotateBrick "e" window canvas rotate_brick_right gameMVar keysIORef + setupCommandKeyRotateBrick "E" window canvas rotate_brick_right gameMVar keysIORef + setupCommandKeyRotateBrick "period" window canvas rotate_brick_right gameMVar keysIORef + + -- Pause/Resume Game + setupCommandKeyPauseResumeGame "p" window canvas pause_resume gameMVar keysIORef + setupCommandKeyPauseResumeGame "P" window canvas pause_resume gameMVar keysIORef + + return () diff --git a/Interface/WindowUpdate.hs b/Interface/WindowUpdate.hs new file mode 100644 --- /dev/null +++ b/Interface/WindowUpdate.hs @@ -0,0 +1,53 @@ + +module Interface.WindowUpdate ( updateWindowWithPlayerAction, + updateWindowWithGravityDelay ) + +where + +import Core.Game +import Core.Commands + +import Control.Monad.State +import Control.Concurrent +import Graphics.UI.Gtk +import Data.IORef + +import Debug.Trace + +------------------------------------------------------------------------------------------------------------------------- +-- Updating of the Game Window with an action performed by the player and with an action performed periodically +updateWindowWithPlayerAction :: DrawingArea -> MVar Game -> State Game Bool -> IO () +updateWindowWithPlayerAction drawArea gameMVar move + = do oldGame <- takeMVar gameMVar + let newGame = execState move oldGame + widgetQueueDraw drawArea + putMVar gameMVar newGame + return () + +updateWindowWithGravityDelay :: DrawingArea -> MVar Game -> IO () +updateWindowWithGravityDelay drawArea gameMVar + = do -- retrieve game state + oldGame <- takeMVar gameMVar + -- attempt to move brick down + let (result,moveDownGame) = runState shift_brick_down oldGame + -- if it is not possible to move brick down lock it in place and... + newGame = if result + then moveDownGame + else execState lock_clear_next_brick moveDownGame + -- calculate new delay + newDelay = (calculateGravityDelay.getGravityFromGame) newGame + -- save new game state + putMVar gameMVar newGame + -- create a new one-time update for the screen by calling oneself + timeoutAdd (updateWindowWithGravityDelay drawArea gameMVar >> return False) newDelay + + return () +------------------------------------------------------------------------------------------------------------------------- +-- Delay Calculations +calculateGravityDelay :: Int -> Int +calculateGravityDelay g + | g > 0 = 1000 `div` g + | otherwise = ((abs g) + 1) * 1000 + +calculateComputerPlayDelay :: Int +calculateComputerPlayDelay = 10 diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,34 @@ +4Blocks is a tetris-like game implemented in Haskell and Gtk2hs for an AI project. + +Some notes: +- The game currently works only with GHC 6.8.3 due to its use of Gtk2hs 0.9.13. +- I haven't tested with anything later but it is likely to fail due the fact that + later versions of Gtk2hs have a different system of handling events. +- To make this project compatible with later versions of GHC and Gtk2hs two changes are required: + - Remove the function "permutations" which was copied from a later GHC base library + - Alter key-event handling to the version used by later Gtk2hs: some functions (in CommandKeys.hs) + were simply introduced in order to disallow some of the keys used in the game (namely rotation) to trigger + continuously when a key is held pressed. I believe this kind of behaviour can be managed automatically + with Gtk2hs' new event handling mechanism, however I haven't had time to recode accordingly myself. +- I hope to write a patch for this in the near future. + +To play: +- [1] Starts a Game +- [P] Pause/Resume Game +- [Esc] Exit Game +- [A]/[Left] Shift Left +- [D]/[Right] Shift Right +- [W]/[Up] Hard Drop +- [S]/[Down] Soft Drop +- [Q]/[,] Rotate Left +- [E]/[.] Rotate Right + +Some gameplay features to add in the future: +- T-spin points +- Wall-kick +- Sounds! + +Finally: +- Feel free to criticize (constructively) my code as this has been my first real forray into Haskell. +- Email me on drewcalleja@gmail.com :) +- Enjoy! diff --git a/Rendering/Background.hs b/Rendering/Background.hs new file mode 100644 --- /dev/null +++ b/Rendering/Background.hs @@ -0,0 +1,11 @@ + +module Rendering.Background ( renderBackground ) + +where + +import Graphics.Rendering.Cairo + +renderBackground :: Render () +renderBackground + = do setSourceRGB 0 0 0 + paint diff --git a/Rendering/Block.hs b/Rendering/Block.hs new file mode 100644 --- /dev/null +++ b/Rendering/Block.hs @@ -0,0 +1,16 @@ + +module Rendering.Block ( renderBlock ) + +where + +import Rendering.RGB +import Rendering.Point +import Rendering.Square + +import Graphics.Rendering.Cairo + +renderBlock :: RGB -> RGB -> RGB -> Point -> Point -> Render () +renderBlock fillRGB shadowRGB outlineRGB (startx,starty) (sizex, sizey) + = do renderSquare outlineRGB (startx,starty) (sizex,sizey) + renderSquare shadowRGB (startx+1,starty+1) (sizex-1,sizey-1) + renderSquare fillRGB (startx+1,starty+1) (sizex-2,sizey-2) diff --git a/Rendering/Brick.hs b/Rendering/Brick.hs new file mode 100644 --- /dev/null +++ b/Rendering/Brick.hs @@ -0,0 +1,38 @@ + +module Rendering.Brick ( renderBrick ) + +where + +import Rendering.RGB +import Rendering.Block +import Rendering.Point + +import Core.ColouredPoint +import Core.Brick +import Core.Well +import Core.Game + +import Graphics.Rendering.Cairo + +renderBrick :: RGB -> RGB -> Point -> Point -> Game -> Render () +renderBrick shadowWellRGB outlineWellRGB offset blockSize game + = do mapM_ (renderBrickBlock shadowWellRGB outlineWellRGB offset blockSize wellSize) brickBlocks + where brick = getBrickFromGame game + well = getWellFromGame game + brickBlocks = getBlocksFromBrick brick + wellSize = getSizeFromWell well + +renderBrickBlock :: RGB -> RGB -> Point -> Point -> Point -> ColouredPoint -> Render () +renderBrickBlock shadowWellRGB outlineWellRGB (offsetX,offsetY) (blockSizeX,blockSizeY) (wellSizeX,wellSizeY) (x,y,c) + = if ((y >= 0) && (y <= (wellSizeY - 3))) + then renderBlock (colourToRGB c) shadowWellRGB outlineWellRGB (actualX,actualY) (blockSizeX,blockSizeY) + else return () + where actualX = renderingBrickX x blockSizeX offsetX + actualY = renderingBrickY y blockSizeY offsetY wellSizeY + +renderingBrickX :: Double -> Double -> Double -> Double +renderingBrickX rawX blockSizeX offsetX = offsetX + (blockSizeX * rawX) + +renderingBrickY :: Double -> Double -> Double -> Double -> Double +renderingBrickY rawY blockSizeY offsetY wellSizeY = offsetY + (blockSizeY * (wellSizeY-3)) - (blockSizeY * rawY) + diff --git a/Rendering/Engine.hs b/Rendering/Engine.hs new file mode 100644 --- /dev/null +++ b/Rendering/Engine.hs @@ -0,0 +1,181 @@ + +module Rendering.Engine ( renderOnePlayerScreen, + renderIntroScreen ) + +where + +import Core.Colour +import Core.Game +import Rendering.RGB +import Rendering.Game +import Rendering.Status +import Rendering.Intro +import Rendering.Background + +import Graphics.Rendering.Cairo + +------------------------------------------------- +-- Block Values +blockX :: Double +blockX = 20 + +blockY :: Double +blockY = 20 + +block :: (Double,Double) +block = (blockX,blockY) +------------------------------------------------- +-- Well Values +wellOffX :: Double +wellOffX = 20 + +wellOffY :: Double +wellOffY = 20 + +wellOff :: (Double,Double) +wellOff = (wellOffX,wellOffY) + +wellBlockX :: Double +wellBlockX = 20 + +wellBlockY :: Double +wellBlockY = 20 + +wellBlock :: (Double,Double) +wellBlock = (wellBlockX,wellBlockY) +------------------------------------------------- +-- Status Values +statusAreaOffsetX :: Double +statusAreaOffsetX = wellOffX + (12 * blockX) + +statusAreaOffsetY :: Double +statusAreaOffsetY = wellOffY + +statusAreaOffset :: (Double,Double) +statusAreaOffset = (statusAreaOffsetX,statusAreaOffsetY) + +statusAreaBlockX :: Double +statusAreaBlockX = wellBlockX + +statusAreaBlockY :: Double +statusAreaBlockY = wellBlockY + +statusAreaBlock :: (Double, Double) +statusAreaBlock = (statusAreaBlockX,statusAreaBlockY) + +statusAreaSizeX :: Double +statusAreaSizeX = 10 + +statusAreaSizeY :: Double +statusAreaSizeY = 22 + +statusAreaSize :: (Double,Double) +statusAreaSize = (statusAreaSizeX,statusAreaSizeY) + +statusNextOffsetX :: Double +statusNextOffsetX = wellOffX + (12.25 * blockX) + +statusNextOffsetY :: Double +statusNextOffsetY = wellOffY + (19 * blockY) + +statusNextOffset :: (Double,Double) +statusNextOffset = (statusNextOffsetX,statusNextOffsetY) + +statusNextBlockX :: Double +statusNextBlockX = blockX / 2 + +statusNextBlockY :: Double +statusNextBlockY = blockY / 2 + +statusNextBlock :: (Double,Double) +statusNextBlock = (statusNextBlockX,statusNextBlockY) + +statusTextOffsetX :: Double +statusTextOffsetX = wellOffX + (11.5 * blockX) + +statusTextOffsetY :: Double +statusTextOffsetY = wellOffY + (3 * blockY) + +statusTextOffset :: (Double,Double) +statusTextOffset = (statusTextOffsetX,statusTextOffsetY) + +statusTextBlockX :: Double +statusTextBlockX = blockX + +statusTextBlockY :: Double +statusTextBlockY = blockY + +statusTextBlock :: (Double,Double) +statusTextBlock = (statusTextBlockX,statusTextBlockY) + +------------------------------------------------- +-- Intro Values +introAreaOffsetX :: Double +introAreaOffsetX = wellOffX + +introAreaOffsetY :: Double +introAreaOffsetY = wellOffY + +introAreaOffset :: (Double,Double) +introAreaOffset = (introAreaOffsetX,introAreaOffsetY) + +introAreaBlockX :: Double +introAreaBlockX = wellBlockX + +introAreaBlockY :: Double +introAreaBlockY = wellBlockY + +introAreaBlock :: (Double,Double) +introAreaBlock = (introAreaBlockX,introAreaBlockY) + +introAreaSizeX :: Double +introAreaSizeX = 22 + +introAreaSizeY :: Double +introAreaSizeY = 22 + +introAreaSize :: (Double,Double) +introAreaSize = (introAreaSizeX,introAreaSizeY) + +introTextOffsetX :: Double +introTextOffsetX = wellOffX + (1 * blockY) + +introTextOffsetY :: Double +introTextOffsetY = wellOffY + (3 * blockY) + +introTextOffset :: (Double,Double) +introTextOffset = (introTextOffsetX,introTextOffsetY) + +introTextBlockX :: Double +introTextBlockX = blockX + +introTextBlockY :: Double +introTextBlockY = blockY + +introTextBlock :: (Double,Double) +introTextBlock = (introTextBlockX,introTextBlockY) +------------------------------------------------- +-- Tetris Colours +outlineWellRGB :: RGB +outlineWellRGB = (0.9, 0.9, 0.9) + +shadowWellRGB :: RGB +shadowWellRGB = (0, 0, 0) + +fillWellColour :: Colour +fillWellColour = Grey_Colour +------------------------------------------------- +renderOnePlayerScreen :: Game -> Render () +renderOnePlayerScreen game + = do save + renderBackground + renderGame shadowWellRGB outlineWellRGB wellOff wellBlock game + renderStatus fillWellColour shadowWellRGB outlineWellRGB statusAreaOffset statusAreaBlock statusAreaSize statusNextOffset statusNextBlock statusTextOffset statusTextBlock game + restore + +renderIntroScreen :: Render () +renderIntroScreen + = do save + renderBackground + renderIntro fillWellColour shadowWellRGB outlineWellRGB introAreaOffset introAreaBlock introAreaSize introTextOffset introTextBlock + restore diff --git a/Rendering/Game.hs b/Rendering/Game.hs new file mode 100644 --- /dev/null +++ b/Rendering/Game.hs @@ -0,0 +1,20 @@ + +module Rendering.Game ( renderGame ) + +where + +import Rendering.RGB +import Rendering.Point +import Rendering.Well +import Rendering.Brick +import Rendering.GhostBrick + +import Core.Game + +import Graphics.Rendering.Cairo + +renderGame :: RGB -> RGB -> Point -> Point -> Game -> Render () +renderGame shadowWellColour outlineWellColour (offX,offY) (blockSizeX,blockSizeY) game + = do renderWell shadowWellColour outlineWellColour (offX,offY) (blockSizeX,blockSizeY) game + renderGhostBrick shadowWellColour (offX,offY) (blockSizeX,blockSizeY) game + renderBrick shadowWellColour outlineWellColour (offX,offY) (blockSizeX,blockSizeY) game diff --git a/Rendering/GhostBrick.hs b/Rendering/GhostBrick.hs new file mode 100644 --- /dev/null +++ b/Rendering/GhostBrick.hs @@ -0,0 +1,44 @@ + +module Rendering.GhostBrick ( renderGhostBrick ) + +where + +import Rendering.RGB +import Rendering.Block +import Rendering.Point + +import Core.ColouredPoint +import Core.Colour +import Core.Brick +import Core.Well +import Core.Game + +import Graphics.Rendering.Cairo + +renderGhostBrick :: RGB -> Point -> Point -> Game -> Render () +renderGhostBrick fillWellColour offset blockSize game + = do mapM_ (renderGhostBrickBlock fillWellColour offset blockSize wellSize) tempBrickBlocks + where (tempGame,_) = hardDrop game + tempBrick = getBrickFromGame tempGame + tempWell = getWellFromGame tempGame + tempBrickBlocks = getBlocksFromBrick tempBrick + wellSize = getSizeFromWell tempWell + +renderGhostBrickBlock :: RGB -> Point -> Point -> Point -> ColouredPoint -> Render () +renderGhostBrickBlock fillWellColour (offsetX,offsetY) (blockSizeX,blockSizeY) (wellSizeX,wellSizeY) (x,y,c) + = if ((y >= 0) && (y <= (wellSizeY - 3))) + then renderBlock fillWellColour (actualC) (actualC) (actualX,actualY) (blockSizeX,blockSizeY) + else return () + where actualX = renderingGhostBrickX x blockSizeX offsetX + actualY = renderingGhostBrickY y blockSizeY offsetY wellSizeY + actualC = renderingGhostBrickC c + +renderingGhostBrickX :: Double -> Double -> Double -> Double +renderingGhostBrickX rawX blockSizeX offsetX = offsetX + (blockSizeX * rawX) + +renderingGhostBrickY :: Double -> Double -> Double -> Double -> Double +renderingGhostBrickY rawY blockSizeY offsetY wellSizeY = offsetY + (blockSizeY * (wellSizeY-3)) - (blockSizeY * rawY) + +renderingGhostBrickC :: Colour -> RGB +renderingGhostBrickC c = colourToRGB c + diff --git a/Rendering/Intro.hs b/Rendering/Intro.hs new file mode 100644 --- /dev/null +++ b/Rendering/Intro.hs @@ -0,0 +1,19 @@ + +module Rendering.Intro ( renderIntro ) + +where + +import Core.Colour +import Core.Game + +import Rendering.RGB +import Rendering.Point +import Rendering.IntroText +import Rendering.IntroArea + +import Graphics.Rendering.Cairo + +renderIntro :: Colour -> RGB -> RGB -> Point -> Point -> Point -> Point -> Point -> Render () +renderIntro fillWellColour shadowWellRGB outlineWellRGB areaOffset areaBlockSize areaSize textStart textInc + = do renderIntroArea fillWellColour shadowWellRGB outlineWellRGB areaOffset areaBlockSize areaSize + renderIntroText textStart textInc diff --git a/Rendering/IntroArea.hs b/Rendering/IntroArea.hs new file mode 100644 --- /dev/null +++ b/Rendering/IntroArea.hs @@ -0,0 +1,40 @@ + +module Rendering.IntroArea ( renderIntroArea ) + +where + +import Core.Colour +import Core.ColouredPoint + +import Rendering.RGB +import Rendering.Point +import Rendering.Block +import Rendering.Text + +import Graphics.Rendering.Cairo + +renderIntroArea :: Colour -> RGB -> RGB -> Point -> Point -> Point -> Render () +renderIntroArea fillWellColour shadowWellRGB outlineWellRGB offset blockSize (areaSizeX,areaSizeY) + = do mapM_ (renderIntroAreaBlock shadowWellRGB outlineWellRGB offset blockSize (areaSizeX,areaSizeY)) introAreaBlocks + where introAreaBlocksBottom = [(x,areaSizeY,fillWellColour) | x <- [0..areaSizeX]] + introAreaBlocksTop = [(x,0,fillWellColour) | x <- [0..areaSizeX]] + introAreaBlocksLeft = [(0,y,fillWellColour) | y <- [1..areaSizeY-1]] + introAreaBlocksRight = [(areaSizeX,y,fillWellColour) | y <- [1..areaSizeY-1]] + introAreaBlocksMiddle = [(x,10,fillWellColour) | x <- [1..areaSizeX-1]] + introAreaBlocks = introAreaBlocksBottom ++ + introAreaBlocksTop ++ + introAreaBlocksLeft ++ + introAreaBlocksRight ++ + introAreaBlocksMiddle + +renderIntroAreaBlock :: RGB -> RGB -> Point -> Point -> Point -> ColouredPoint -> Render () +renderIntroAreaBlock shadowWellRGB outlineWellRGB (offsetX,offsetY) (blockSizeX,blockSizeY) (areaSizeX,areaSizeY) (x,y,c) + = renderBlock (colourToRGB c) shadowWellRGB outlineWellRGB (actualX,actualY) (blockSizeX,blockSizeY) + where actualX = renderingIntroAreaX x blockSizeX offsetX + actualY = renderingIntroAreaY y blockSizeY offsetY + +renderingIntroAreaX :: Double -> Double -> Double -> Double +renderingIntroAreaX rawX blockSizeX offsetX = offsetX + (blockSizeX * rawX) + +renderingIntroAreaY :: Double -> Double -> Double -> Double +renderingIntroAreaY rawY blockSizeY offsetY = offsetY + (blockSizeY * rawY) diff --git a/Rendering/IntroText.hs b/Rendering/IntroText.hs new file mode 100644 --- /dev/null +++ b/Rendering/IntroText.hs @@ -0,0 +1,60 @@ + +module Rendering.IntroText ( renderIntroText ) + +where + +import Core.Colour +import Core.ColouredPoint +import Core.Game + +import Rendering.RGB +import Rendering.Point +import Rendering.Block +import Rendering.Text + +import Graphics.Rendering.Cairo + +renderIntroText :: Point -> Point -> Render () +renderIntroText (startX,startY) (incX,incY) + = do setSourceRGB 0.0 0.0 0.0 + selectFontFace "sans" FontSlantNormal FontWeightNormal + + renderText (startX + incX,startY + (incY * 2)) 40 2 (1,1,1) "Welcome to 4Blocks" + renderText (startX + (incX * 15),startY + (incY * 3) + 5) 20 1 (1,1,1) "in" + renderText (startX + (incX * 13),startY + (incY * 5)) 40 2 (1,1,1) "Haskell!" + renderText (startX + incX, startY + (incY * 9.2)) 15 1 (1,1,1) "Press:" + + renderText (startX + incX, startY + (incY * 10.4)) 15 1 (1,1,1) "[1]" + renderText (startX + incX, startY + (incY * 11.4)) 15 1 (1,1,1) "[Esc]" + renderText (startX + incX, startY + (incY * 12.4)) 15 1 (1,1,1) "[P]" + renderText (startX + incX, startY + (incY * 13.4)) 15 1 (1,1,1) "[A] / [Left]" + renderText (startX + incX, startY + (incY * 14.4)) 15 1 (1,1,1) "[D] / [Right]" + renderText (startX + incX, startY + (incY * 15.4)) 15 1 (1,1,1) "[S] / [Down]" + renderText (startX + incX, startY + (incY * 16.4)) 15 1 (1,1,1) "[W] / [Up]" + renderText (startX + incX, startY + (incY * 17.4)) 15 1 (1,1,1) "[Q] / [,]" + renderText (startX + incX, startY + (incY * 18.4)) 15 1 (1,1,1) "[E] / [.]" + + renderText (startX + (incX * 9), startY + (incY * 10.4)) 15 1 (1,1,1) "---" + renderText (startX + (incX * 9), startY + (incY * 11.4)) 15 1 (1,1,1) "---" + renderText (startX + (incX * 9), startY + (incY * 12.4)) 15 1 (1,1,1) "---" + renderText (startX + (incX * 9), startY + (incY * 13.4)) 15 1 (1,1,1) "---" + renderText (startX + (incX * 9), startY + (incY * 14.4)) 15 1 (1,1,1) "---" + renderText (startX + (incX * 9), startY + (incY * 15.4)) 15 1 (1,1,1) "---" + renderText (startX + (incX * 9), startY + (incY * 16.4)) 15 1 (1,1,1) "---" + renderText (startX + (incX * 9), startY + (incY * 17.4)) 15 1 (1,1,1) "---" + renderText (startX + (incX * 9), startY + (incY * 18.4)) 15 1 (1,1,1) "---" + + renderText (startX + (incX * 12), startY + (incY * 10.4)) 15 1 (1,1,1) "Start Game" + renderText (startX + (incX * 12), startY + (incY * 11.4)) 15 1 (1,1,1) "Exit Game" + renderText (startX + (incX * 12), startY + (incY * 12.4)) 15 1 (1,1,1) "Pause/Resume Game" + renderText (startX + (incX * 12), startY + (incY * 13.4)) 15 1 (1,1,1) "Shift Left" + renderText (startX + (incX * 12), startY + (incY * 14.4)) 15 1 (1,1,1) "Shift Right" + renderText (startX + (incX * 12), startY + (incY * 15.4)) 15 1 (1,1,1) "Soft Drop" + renderText (startX + (incX * 12), startY + (incY * 16.4)) 15 1 (1,1,1) "Hard Drop" + renderText (startX + (incX * 12), startY + (incY * 17.4)) 15 1 (1,1,1) "Rotate Left" + renderText (startX + (incX * 12), startY + (incY * 18.4)) 15 1 (1,1,1) "Rotate Right" + + +-- Grey 0.4,0.4,0.4 +-- Off White 0.8,0.8,0.8 +-- White 1,1,1 diff --git a/Rendering/Point.hs b/Rendering/Point.hs new file mode 100644 --- /dev/null +++ b/Rendering/Point.hs @@ -0,0 +1,6 @@ + +module Rendering.Point ( Point ) + +where + +type Point = (Double, Double) diff --git a/Rendering/RGB.hs b/Rendering/RGB.hs new file mode 100644 --- /dev/null +++ b/Rendering/RGB.hs @@ -0,0 +1,20 @@ + +module Rendering.RGB ( RGB, + colourToRGB ) + +where + +import Core.Colour + +type RGB = (Double, Double, Double) + +colourToRGB :: Colour -> RGB +colourToRGB Yellow_Colour = (1, 1, 0) +colourToRGB Orange_Colour = (1, 0.65, 0) +colourToRGB Blue_Colour = (0, 0, 1) +colourToRGB Purple_Colour = (0.5, 0, 0.5) +colourToRGB Cyan_Colour = (0, 1, 1) +colourToRGB Green_Colour = (0, 1, 0) +colourToRGB Red_Colour = (1, 0, 0) +colourToRGB Grey_Colour = (0.75, 0.75, 0.75) +colourToRGB Dark_Grey_Colour = (0.10, 0.10, 0.10) diff --git a/Rendering/Square.hs b/Rendering/Square.hs new file mode 100644 --- /dev/null +++ b/Rendering/Square.hs @@ -0,0 +1,15 @@ + +module Rendering.Square ( renderSquare ) + +where + +import Rendering.RGB +import Rendering.Point + +import Graphics.Rendering.Cairo + +renderSquare :: RGB -> Point -> Point -> Render () +renderSquare (r,g,b) (x1,y1) (x2,y2) + = do rectangle x1 y1 x2 y2 + setSourceRGB r g b + fill diff --git a/Rendering/Status.hs b/Rendering/Status.hs new file mode 100644 --- /dev/null +++ b/Rendering/Status.hs @@ -0,0 +1,21 @@ + +module Rendering.Status ( renderStatus ) + +where + +import Core.Colour +import Core.Game + +import Rendering.RGB +import Rendering.Point +import Rendering.StatusText +import Rendering.StatusArea +import Rendering.StatusNext + +import Graphics.Rendering.Cairo + +renderStatus :: Colour -> RGB -> RGB -> Point -> Point -> Point -> Point -> Point -> Point -> Point -> Game -> Render () +renderStatus fillWellColour shadowWellRGB outlineWellRGB areaOffset areaBlockSize areaSize nextOffset nextBlockSize textOffset textBlockSize game + = do renderStatusArea fillWellColour shadowWellRGB outlineWellRGB areaOffset areaBlockSize areaSize + renderStatusNext shadowWellRGB outlineWellRGB nextOffset nextBlockSize game + renderStatusText textOffset textBlockSize game diff --git a/Rendering/StatusArea.hs b/Rendering/StatusArea.hs new file mode 100644 --- /dev/null +++ b/Rendering/StatusArea.hs @@ -0,0 +1,36 @@ + +module Rendering.StatusArea ( renderStatusArea ) + +where + +import Core.Colour +import Core.ColouredPoint +import Core.Game + +import Rendering.RGB +import Rendering.Point +import Rendering.Block + +import Graphics.Rendering.Cairo + +renderStatusArea :: Colour -> RGB -> RGB -> Point -> Point -> Point -> Render () +renderStatusArea fillWellColour shadowWellRGB outlineWellRGB offset blockSize (areaSizeX,areaSizeY) + = do mapM_ (renderStatusAreaBlock shadowWellRGB outlineWellRGB offset blockSize (areaSizeX,areaSizeY)) statusAreaBlocks + where statusAreaBlocksBottom = [(x,areaSizeY,fillWellColour) | x <- [0..areaSizeX]] + statusAreaBlocksTop = [(x,0,fillWellColour) | x <- [0..areaSizeX]] + statusAreaBlocksRight = [(areaSizeX,y,fillWellColour) | y <- [1..areaSizeY-1]] + statusAreaBlocks = statusAreaBlocksBottom ++ + statusAreaBlocksTop ++ + statusAreaBlocksRight + +renderStatusAreaBlock :: RGB -> RGB -> Point -> Point -> Point -> ColouredPoint -> Render () +renderStatusAreaBlock shadowWellRGB outlineWellRGB (offsetX,offsetY) (blockSizeX,blockSizeY) (areaSizeX,areaSizeY) (x,y,c) + = renderBlock (colourToRGB c) shadowWellRGB outlineWellRGB (actualX,actualY) (blockSizeX,blockSizeY) + where actualX = renderingStatusAreaX x blockSizeX offsetX + actualY = renderingStatusAreaY y blockSizeY offsetY + +renderingStatusAreaX :: Double -> Double -> Double -> Double +renderingStatusAreaX rawX blockSizeX offsetX = offsetX + (blockSizeX * rawX) + +renderingStatusAreaY :: Double -> Double -> Double -> Double +renderingStatusAreaY rawY blockSizeY offsetY = offsetY + (blockSizeY * rawY) diff --git a/Rendering/StatusNext.hs b/Rendering/StatusNext.hs new file mode 100644 --- /dev/null +++ b/Rendering/StatusNext.hs @@ -0,0 +1,48 @@ + +module Rendering.StatusNext ( renderStatusNext ) + +where + +import Rendering.RGB +import Rendering.Point +import Rendering.Block + +import Core.Shape +import Core.ColouredPoint +import Core.Brick +import Core.Game + +import Graphics.Rendering.Cairo + +renderStatusNext :: RGB -> RGB -> Point -> Point -> Game -> Render () +renderStatusNext shadowWellRGB outlineWellRGB (nextOffsetX,nextOffsetY) (nextBlockSizeX,nextBlockSizeY) game + = do renderStatusNextBrick shadowWellRGB outlineWellRGB (nextOffsetX,nextOffsetY) (nextBlockSizeX,nextBlockSizeY) brick1 + renderStatusNextBrick shadowWellRGB outlineWellRGB (nextOffsetX + (5 * nextBlockSizeX),nextOffsetY) (nextBlockSizeX,nextBlockSizeY) brick2 + renderStatusNextBrick shadowWellRGB outlineWellRGB (nextOffsetX + (10 * nextBlockSizeX),nextOffsetY) (nextBlockSizeX,nextBlockSizeY) brick3 + renderStatusNextBrick shadowWellRGB outlineWellRGB (nextOffsetX + (15 * nextBlockSizeX),nextOffsetY) (nextBlockSizeX,nextBlockSizeY) brick4 + where nextNums = getNextFromGame game + brick1 = createBlocks $ toEnum $ nextNums !! 0 + brick2 = createBlocks $ toEnum $ nextNums !! 1 + brick3 = createBlocks $ toEnum $ nextNums !! 2 + brick4 = createBlocks $ toEnum $ nextNums !! 3 + + +renderStatusNextBrick :: RGB -> RGB -> Point -> Point -> [ColouredPoint] -> Render () +renderStatusNextBrick shadowWellRGB outlineWellRGB offset blockSize brickBlocks + = mapM_ (renderStatusNextBlock shadowWellRGB outlineWellRGB offset blockSize) brickBlocks + +renderStatusNextBlock :: RGB -> RGB -> Point -> Point -> ColouredPoint -> Render () +renderStatusNextBlock shadowWellRGB outlineWellRGB (offsetX,offsetY) (blockSizeX,blockSizeY) (x,y,c) + = renderBlock (colourToRGB c) shadowWellRGB outlineWellRGB (actualX,actualY) (blockSizeX,blockSizeY) + where actualX = renderingStatusNextX x blockSizeX offsetX + actualY = renderingStatusNextY y blockSizeY offsetY + +renderingStatusNextX :: Double -> Double -> Double -> Double +renderingStatusNextX rawX blockSizeX offsetX = offsetX + (blockSizeX * rawX) + +renderingStatusNextY :: Double -> Double -> Double -> Double +renderingStatusNextY rawY blockSizeY offsetY = offsetY + (blockSizeY * (4-rawY)) + + + + diff --git a/Rendering/StatusText.hs b/Rendering/StatusText.hs new file mode 100644 --- /dev/null +++ b/Rendering/StatusText.hs @@ -0,0 +1,39 @@ + +module Rendering.StatusText ( renderStatusText ) + +where + +import Core.Colour +import Core.ColouredPoint +import Core.Game + +import Rendering.RGB +import Rendering.Point +import Rendering.Block +import Rendering.Text + +import Graphics.Rendering.Cairo + +renderStatusText :: Point -> Point -> Game -> Render () +renderStatusText (startX,startY) (incX,incY) game + = do setSourceRGB 0.0 0.0 0.0 + selectFontFace "sans" FontSlantNormal FontWeightNormal + + renderText (startX + incX,startY) 40 2 (1,1,1) "4Blocks" + renderText (startX + (incX * 4),startY + (incY) + 5) 20 1 (1,1,1) "in" + renderText (startX + (incX * 2),startY + (incY * 3)) 40 2 (1,1,1) "Haskell!" + renderText (startX + incX, startY + (incY * 6)) 20 1 (1,1,1) ("Score: " ++ (show scoreValue)) + renderText (startX + incX, startY + (incY * 8)) 20 1 (1,1,1) ("Lines: " ++ (show linesValue)) + renderText (startX + incX, startY + (incY * 10)) 20 1 (1,1,1) ("Level: " ++ (show levelValue)) + renderText (startX + incX, startY + (incY * 12)) 20 1 (1,1,1) ("Goal: " ++ (show goalDiffValue)) + renderText (startX + incX, startY + (incY * 14)) 20 1 (1,1,1) ("Status: " ++ (show statusValue)) + renderText (startX + incX, startY + (incY * 16)) 20 1 (1,1,1) "Next: " + where gravity = getGravityFromGame game + goal = getGoalFromGame game + scoreValue = getScoreFromGame game + linesValue = getLinesFromGame game + statusValue = getStatusFromGame game + goalDiffValue = goal - linesValue + levelValue = gravity - 1 + + diff --git a/Rendering/Text.hs b/Rendering/Text.hs new file mode 100644 --- /dev/null +++ b/Rendering/Text.hs @@ -0,0 +1,21 @@ + +module Rendering.Text ( renderText ) + +where + +import Rendering.Point +import Rendering.RGB + +import Graphics.Rendering.Cairo + +renderText :: Point -> Double -> Double -> RGB -> String -> Render () +renderText (x,y) s w (r,g,b) t + = do setFontSize s + setLineWidth w + save + stroke + moveTo x y + textPath t + setSourceRGBA r g b 0.85 + stroke + restore diff --git a/Rendering/Well.hs b/Rendering/Well.hs new file mode 100644 --- /dev/null +++ b/Rendering/Well.hs @@ -0,0 +1,36 @@ + +module Rendering.Well ( renderWell ) + +where + +import Rendering.RGB +import Rendering.Block +import Rendering.Point + +import Core.Well +import Core.ColouredPoint +import Core.Game + +import Graphics.Rendering.Cairo + +renderWell :: RGB -> RGB -> Point -> Point -> Game -> Render () +renderWell shadowWellRGB outlineWellRGB offset blockSize game + = do mapM_ (renderWellBlock shadowWellRGB outlineWellRGB offset blockSize wellSize) wellBlocks + where + well = getWellFromGame game + wellBlocks = getBlocksFromWell well + wellSize = getSizeFromWell well + +renderWellBlock :: RGB -> RGB -> Point -> Point -> Point -> ColouredPoint -> Render () +renderWellBlock shadowWellRGB outlineWellRGB (offsetX,offsetY) (blockSizeX,blockSizeY) (wellSizeX,wellSizeY) (x,y,c) + = if ((y >= 0) && (y <= (wellSizeY - 3))) + then renderBlock (colourToRGB c) shadowWellRGB outlineWellRGB (actualX,actualY) (blockSizeX,blockSizeY) + else return () + where actualX = renderingWellX x blockSizeX offsetX + actualY = renderingWellY y blockSizeY offsetY wellSizeY + +renderingWellX :: Double -> Double -> Double -> Double +renderingWellX rawX blockSizeX offsetX = offsetX + (blockSizeX * rawX) + +renderingWellY :: Double -> Double -> Double -> Double -> Double +renderingWellY rawY blockSizeY offsetY wellSizeY = offsetY + (blockSizeY * (wellSizeY-3)) - (blockSizeY * rawY)