Commit 647853fd authored by trehm001's avatar trehm001
Browse files

almost done

parent ffa5998e
# Revision history for haskelltetris
## 0.1.0.0 -- YYYY-mm-dd
* First version. Released on an unsuspecting world.
module Main where
import Data.Map (Map, fromList, insert, (!))
import qualified Data.Map as Map
import Data.Maybe
import Graphics.Gloss
import Graphics.Gloss.Data.ViewPort
import Graphics.Gloss.Interface.Pure.Game (Event)
import Data.Map (Map,(!),fromList,insert)
import qualified Data.Map as Map
import Graphics.Gloss.Interface.Pure.Game (Event (EventKey), Key (SpecialKey), KeyState (Down), SpecialKey (KeyLeft, KeyRight))
import Piece
import System.Random (getStdGen, randomRs)
width, height :: Int
width = 400
height = 800
window :: Display
window = InWindow "Tetris" (width, height) (0,0)
window :: Display
window = InWindow "Tetris" (width, height) (0, 0)
background :: Color
background = black
background :: Color
background = azure
fps :: Int
fps = 60
fps :: Int
fps = 3
type Grid = Map (Integer,Integer) Color
dimension :: Float
dimension = 40
data TetrisGame = Game {
activePiece :: Piece,
grid :: Grid
}
data Direction = Left | Right
newGrid :: Grid
newGrid = fromList [((x,y),c x)|x <- [0..10],y<- [0..21]]
where c x = if even x then yellow else green
type Grid = Map (Integer, Integer) Color
initialState :: TetrisGame
initialState = Game {activePiece = PieceCoords (6,6) blue
, grid = newGrid}
data TetrisGame = Game
{ activePiece :: Piece,
grid :: Grid,
upcomingTetros :: [Shape]
}
insertActivePiece :: Piece -> TetrisGame -> TetrisGame
insertActivePiece (PieceCoords (x,y) col) game = game{grid = insert (toInteger x,toInteger y) col (grid game)}
render :: TetrisGame -> Picture
render game
= pictures [ translate (fromInteger x * dimension)
(fromInteger y * dimension)
(color (c x y) (rectangleSolid dimension dimension))
| let c = chooseColor(grid game)
, x <- [0..9]
, y<- [0..21] ]
where
chooseColor :: Map (Integer,Integer) Color -> Integer -> Integer -> Color
chooseColor m x y = m ! (x,y)
newGrid :: Grid
newGrid = fromList [((x, y), background) | x <- [0 .. 10], y <- [0 .. 21]]
initialState :: [Shape] -> TetrisGame
initialState ts =
Game
{ activePiece = Piece (head ts) (4, 21) (getTetroColor (head ts)),
grid = newGrid,
upcomingTetros = tail ts
}
--Stolen from https://github.com/llllllllll/hTetris/blob/de0213268e0e27a9bdd2454e99e010167520c180/src/HTetris/Data.hs#L133
getRandomTypes :: IO [Shape]
getRandomTypes =
map intToType
<$> fmap (randomRs (0 :: Int, 6 :: Int)) getStdGen
where
intToType c
| c == 0 = TetrominoI
| c == 1 = TetrominoJ
| c == 2 = TetrominoL
| c == 3 = TetrominoO
| c == 4 = TetrominoS
| c == 5 = TetrominoZ
| c == 6 = TetrominoT
| otherwise = undefined
nextPiece :: TetrisGame -> TetrisGame
nextPiece game = insertActivePiece (Piece nextTetroShape (4, 21) (getTetroColor nextTetroShape)) game {upcomingTetros = tail (upcomingTetros game)}
where
nextTetroShape = head (upcomingTetros game)
getTetroColor :: Shape -> Color
getTetroColor TetrominoI = aquamarine
getTetroColor TetrominoJ = blue
getTetroColor TetrominoL = orange
getTetroColor TetrominoO = yellow
getTetroColor TetrominoS = green
getTetroColor TetrominoT = violet
getTetroColor TetrominoZ = red
insertActivePiece :: Piece -> TetrisGame -> TetrisGame
insertActivePiece p@(Piece shape (x, y) col) game = foldl (\g (x', y') -> g {activePiece = p, grid = insert (toInteger (x + x'), toInteger (y + y')) col (grid g)}) game (getCoords shape)
step :: TetrisGame -> TetrisGame
step game = game{grid = insert (5,5) white (grid game)}
randomPiece :: Piece
randomPiece = undefined
dimension :: Float
dimension = 20
render :: TetrisGame -> Picture
render game =
pictures $
[ translate
(fromInteger x * dimension - 200)
(fromInteger y * dimension - 400)
(color (c x y) (rectangleSolid dimension dimension))
| let c = chooseColor (grid game),
x <- [0 .. 10],
y <- [0 .. 21]
]
where
chooseColor :: Map (Integer, Integer) Color -> Integer -> Integer -> Color
chooseColor m x y = m ! (x, y)
gravitateActivePiece :: TetrisGame -> Piece -> TetrisGame
gravitateActivePiece game p@(Piece shape (x, y) col)
| freeSpot game = insertActivePiece (Piece shape (x, y -1) col) (removePiece p game)
| y == 21 = game
| otherwise = nextPiece game
-- Return if the Piece can fall down
freeSpot :: TetrisGame -> Bool
freeSpot g@(Game p@(Piece TetrominoI (x, y) col) grid _) = testField (Map.lookup (toInteger x, toInteger y -3) grid)
freeSpot g@(Game p@(Piece TetrominoJ (x, y) col) grid _) =
testField (Map.lookup (toInteger x -1, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x + 1, toInteger y -1) grid)
freeSpot g@(Game p@(Piece TetrominoL (x, y) col) grid _) =
testField (Map.lookup (toInteger x -1, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x + 1, toInteger y -1) grid)
freeSpot g@(Game p@(Piece TetrominoO (x, y) col) grid _) =
testField (Map.lookup (toInteger x -1, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x, toInteger y -1) grid)
freeSpot g@(Game p@(Piece TetrominoS (x, y) col) grid _) =
testField (Map.lookup (toInteger x -1, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x + 1, toInteger y) grid)
freeSpot g@(Game p@(Piece TetrominoT (x, y) col) grid _) =
testField (Map.lookup (toInteger x -1, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x + 1, toInteger y -1) grid)
freeSpot g@(Game p@(Piece TetrominoZ (x, y) col) grid _) =
testField (Map.lookup (toInteger x -1, toInteger y) grid)
&& testField (Map.lookup (toInteger x, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x + 1, toInteger y -1) grid)
-- Test if Color Matches free Field
testField :: Maybe Color -> Bool
testField col = Data.Maybe.fromMaybe black col == background
canMove :: Direction -> TetrisGame -> Bool
--TetrominoI
canMove Main.Left g@(Game p@(Piece TetrominoI (x, y) col) grid _) =
testField (Map.lookup (toInteger x -1, toInteger y + 1) grid)
&& testField (Map.lookup (toInteger x -1, toInteger y) grid)
&& testField (Map.lookup (toInteger x - 1, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x - 1, toInteger y -2) grid)
canMove Main.Right g@(Game p@(Piece TetrominoI (x, y) col) grid _) =
testField (Map.lookup (toInteger x + 1, toInteger y + 1) grid)
&& testField (Map.lookup (toInteger x + 1, toInteger y) grid)
&& testField (Map.lookup (toInteger x + 1, toInteger y -1) grid)
&& testField (Map.lookup (toInteger x + 1, toInteger y -2) grid)
--TetrominoJ
canMove Main.Left g@(Game p@(Piece TetrominoJ (x, y) col) grid _) =
testField (Map.lookup (toInteger x - 2, toInteger y + 1) grid)
&& testField (Map.lookup (toInteger x - 2, toInteger y) grid)
canMove Main.Right g@(Game p@(Piece TetrominoJ (x, y) col) grid _) =
testField (Map.lookup (toInteger x, toInteger y + 1) grid)
&& testField (Map.lookup (toInteger x + 2, toInteger y) grid)
--TetrominoL
canMove Main.Left g@(Game p@(Piece TetrominoL (x, y) col) grid _) =
testField (Map.lookup (toInteger x - 2, toInteger y) grid)
&& testField (Map.lookup (toInteger x, toInteger y -1) grid)
canMove Main.Right g@(Game p@(Piece TetrominoL (x, y) col) grid _) =
testField (Map.lookup (toInteger x + 2, toInteger y) grid)
&& testField (Map.lookup (toInteger x + 2, toInteger y + 1) grid)
--TetrominoO
canMove Main.Left g@(Game p@(Piece TetrominoO (x, y) col) grid _) =
testField (Map.lookup (toInteger x -2, toInteger y) grid)
&& testField (Map.lookup (toInteger x -2, toInteger y + 1) grid)
canMove Main.Right g@(Game p@(Piece TetrominoO (x, y) col) grid _) =
testField (Map.lookup (toInteger x + 1, toInteger y) grid)
&& testField (Map.lookup (toInteger x + 1, toInteger y + 1) grid)
--TetrmonioS
canMove Main.Left g@(Game p@(Piece TetrominoS (x, y) col) grid _) =
testField (Map.lookup (toInteger x -2, toInteger y) grid)
&& testField (Map.lookup (toInteger x -1, toInteger y + 1) grid)
canMove Main.Right g@(Game p@(Piece TetrominoS (x, y) col) grid _) =
testField (Map.lookup (toInteger x + 1, toInteger y) grid)
&& testField (Map.lookup (toInteger x + 2, toInteger y + 1) grid)
--TetrominoT
canMove Main.Left g@(Game p@(Piece TetrominoT (x, y) col) grid _) =
testField (Map.lookup (toInteger x -2, toInteger y) grid)
&& testField (Map.lookup (toInteger x -1, toInteger y + 1) grid)
canMove Main.Right g@(Game p@(Piece TetrominoT (x, y) col) grid _) =
testField (Map.lookup (toInteger x + 2, toInteger y) grid)
&& testField (Map.lookup (toInteger x + 1, toInteger y + 1) grid)
--TetrmonioZ
canMove Main.Left g@(Game p@(Piece TetrominoZ (x, y) col) grid _) =
testField (Map.lookup (toInteger x - 2, toInteger y + 1) grid)
&& testField (Map.lookup (toInteger x - 1, toInteger y) grid)
canMove Main.Right g@(Game p@(Piece TetrominoZ (x, y) col) grid _) =
testField (Map.lookup (toInteger x + 2, toInteger y) grid)
&& testField (Map.lookup (toInteger x + 1, toInteger y + 1) grid)
movePiece :: SpecialKey -> TetrisGame -> TetrisGame
movePiece KeyLeft g@(Game p@(Piece shape (x, y) col) grid _) = if canMove Main.Left g then insertActivePiece (Piece shape (x -1, y) col) (removePiece p g) else g
movePiece KeyRight g@(Game p@(Piece shape (x, y) col) grid _) = if canMove Main.Right g then insertActivePiece (Piece shape (x + 1, y) col) (removePiece p g) else g
movePiece _ game = game
removePiece :: Piece -> TetrisGame -> TetrisGame
removePiece p@(Piece shape (x, y) col) game = foldl (\g (x', y') -> g {activePiece = p, grid = insert (toInteger (x + x'), toInteger (y + y')) background (grid g)}) game (getCoords shape)
removeRow :: Int -> TetrisGame -> TetrisGame
removeRow y game = foldl (\g x -> g {grid = insert (toInteger x, toInteger y) background (grid g)}) game [0 .. 10]
shiftDownFields :: TetrisGame -> TetrisGame
shiftDownFields game = foldl (\g (y, x) -> g {grid = insert (toInteger x, toInteger y) black (grid g)}) game [(x, y) | x <- [0 .. 21], y <- [0 .. 10]]
where
color g x y = Data.Maybe.fromMaybe black (Map.lookup (toInteger x, toInteger (y + 1)) (grid g))
testDownFields :: Int -> Int -> TetrisGame -> TetrisGame
testDownFields _ 22 game = game
testDownFields 11 y game = testDownFields 0 (y + 1) game
testDownFields x y game = game {grid = insert (toInteger x, toInteger y) (color game x y) (grid (testDownFields (x + 1) y game))}
where
color g x y = Data.Maybe.fromMaybe background (Map.lookup (toInteger x, toInteger (y + 1)) (grid g))
tryClearRows :: TetrisGame -> TetrisGame
tryClearRows game
| b = nextPiece $ testDownFields 0 y $ removeRow y game
| otherwise = game
where
(b, y) = rowClearable game 0 0
rowClearable :: TetrisGame -> Int -> Int -> (Bool, Int)
rowClearable g@(Game p grid _) 0 22 = (False, -1)
rowClearable g@(Game p grid _) 11 y = (True, y)
rowClearable g@(Game p grid _) x y =
if Data.Maybe.fromMaybe black (Map.lookup (toInteger x, toInteger y) grid) /= background
then rowClearable g (x + 1) y
else rowClearable g 0 (y + 1)
inputHandler :: Event -> TetrisGame -> TetrisGame
inputHandler event game = undefined
inputHandler (EventKey (SpecialKey KeyLeft) Down _ _) game = movePiece KeyLeft game
inputHandler (EventKey (SpecialKey KeyRight) Down _ _) game = movePiece KeyRight game
inputHandler _ game = game
update :: Float -> TetrisGame -> TetrisGame
update _ game = undefined
update seconds game = tryClearRows $ gravitateActivePiece game piece
where
piece = activePiece game
main :: IO ()
main = display
window
background
(render (insertActivePiece (activePiece initialState) (step initialState)))
\ No newline at end of file
main =
getRandomTypes >>= \ts -> play window background fps (initialState ts) render inputHandler update
\ No newline at end of file
module Piece where
module Piece where
import Graphics.Gloss
data Shape = TetrominoI | TetrominoJ | TetrominoL | TetrominoO | TetrominoS | TetrominoT | TetrominoZ deriving (Show)
-- (0,0) Origin & rotaion point
data Piece = PieceCoords (Int, Int) Color deriving Show
\ No newline at end of file
data Piece = Piece Shape (Int, Int) Color deriving (Show)
getCoords :: Shape -> [(Int, Int)]
getCoords TetrominoI = [(0, 0), (0, 1), (0, -1), (0, -2)]
getCoords TetrominoJ = [(0, 0), (-1, 0), (-1, 1), (1, 0)]
getCoords TetrominoL = [(0, 0), (-1, 0), (1, 0), (1, 1)]
getCoords TetrominoO = [(0, 0), (-1, 0), (-1, 1), (0, 1)]
getCoords TetrominoS = [(0, 0), (-1, 0), (0, 1), (1, 1)]
getCoords TetrominoT = [(0, 0), (-1, 0), (0, 1), (1, 0)]
getCoords TetrominoZ = [(0, 0), (0, 1), (-1, 1), (1, 0)]
\ No newline at end of file
......@@ -21,6 +21,6 @@ executable haskelltetris
main-is: Main.hs
other-modules: Piece
-- other-extensions:
build-depends: base >=4.14 && <4.15, gloss==1.13.*, containers
build-depends: base >=4.14 && <4.15, gloss==1.13.*, containers,random
-- hs-source-dirs:
default-language: Haskell2010
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment