4Blocks 0.1 → 0.2
raw patch · 36 files changed
+2159/−2 lines, 36 files
Files
- 4Blocks.cabal +42/−2
- Core/Brick.hs +157/−0
- Core/Colour.hs +25/−0
- Core/ColouredPoint.hs +108/−0
- Core/Commands.hs +168/−0
- Core/Direction.hs +16/−0
- Core/Game.hs +416/−0
- Core/Level.hs +67/−0
- Core/Shape.hs +24/−0
- Core/SimplePoint.hs +30/−0
- Core/Status.hs +33/−0
- Core/Well.hs +91/−0
- Interface/CommandKeys.hs +64/−0
- Interface/KeyEvents.hs +31/−0
- Interface/MainWindow.hs +53/−0
- Interface/OnePlayerModeWindow.hs +76/−0
- Interface/WindowUpdate.hs +53/−0
- README +34/−0
- Rendering/Background.hs +11/−0
- Rendering/Block.hs +16/−0
- Rendering/Brick.hs +38/−0
- Rendering/Engine.hs +181/−0
- Rendering/Game.hs +20/−0
- Rendering/GhostBrick.hs +44/−0
- Rendering/Intro.hs +19/−0
- Rendering/IntroArea.hs +40/−0
- Rendering/IntroText.hs +60/−0
- Rendering/Point.hs +6/−0
- Rendering/RGB.hs +20/−0
- Rendering/Square.hs +15/−0
- Rendering/Status.hs +21/−0
- Rendering/StatusArea.hs +36/−0
- Rendering/StatusNext.hs +48/−0
- Rendering/StatusText.hs +39/−0
- Rendering/Text.hs +21/−0
- Rendering/Well.hs +36/−0
4Blocks.cabal view
@@ -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 + +
+ Core/Brick.hs view
@@ -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
+ Core/Colour.hs view
@@ -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)
+ Core/ColouredPoint.hs view
@@ -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)
+ Core/Commands.hs view
@@ -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
+ Core/Direction.hs view
@@ -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)
+ Core/Game.hs view
@@ -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
+ Core/Level.hs view
@@ -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
+ Core/Shape.hs view
@@ -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)+ +
+ Core/SimplePoint.hs view
@@ -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)
+ Core/Status.hs view
@@ -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"
+ Core/Well.hs view
@@ -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+++ +
+ Interface/CommandKeys.hs view
@@ -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 () + + + + + + +
+ Interface/KeyEvents.hs view
@@ -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 +
+ Interface/MainWindow.hs view
@@ -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
+ Interface/OnePlayerModeWindow.hs view
@@ -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 ()
+ Interface/WindowUpdate.hs view
@@ -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
+ README view
@@ -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!
+ Rendering/Background.hs view
@@ -0,0 +1,11 @@+ +module Rendering.Background ( renderBackground ) + +where + +import Graphics.Rendering.Cairo + +renderBackground :: Render () +renderBackground + = do setSourceRGB 0 0 0 + paint
+ Rendering/Block.hs view
@@ -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)
+ Rendering/Brick.hs view
@@ -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)+
+ Rendering/Engine.hs view
@@ -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
+ Rendering/Game.hs view
@@ -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
+ Rendering/GhostBrick.hs view
@@ -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 +
+ Rendering/Intro.hs view
@@ -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
+ Rendering/IntroArea.hs view
@@ -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)
+ Rendering/IntroText.hs view
@@ -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
+ Rendering/Point.hs view
@@ -0,0 +1,6 @@+ +module Rendering.Point ( Point ) + +where + +type Point = (Double, Double)
+ Rendering/RGB.hs view
@@ -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)
+ Rendering/Square.hs view
@@ -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
+ Rendering/Status.hs view
@@ -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
+ Rendering/StatusArea.hs view
@@ -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)
+ Rendering/StatusNext.hs view
@@ -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)) + + + +
+ Rendering/StatusText.hs view
@@ -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 + +
+ Rendering/Text.hs view
@@ -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
+ Rendering/Well.hs view
@@ -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)