{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
module Game.Tetris
( Game
, Direction(..)
, boardWidth, boardHeight
, initGame, isGameOver
, timeStep, rotate, shift, hardDrop
, Translatable(..)
, board, shape, origin, score, block, coords, nextShape, initBlock
) where
import Data.Bool (bool)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Monoid (First (..))
import Data.Sequence (ViewL (..), ViewR (..), (<|), (><), (|>))
import qualified Data.Sequence as Seq
import Lens.Micro hiding ((:<), (:>), (<|), (|>))
import Lens.Micro.TH (makeLenses)
import Linear.V2 (V2 (..), _x, _y)
import qualified Linear.V2 as LV
import Prelude hiding (Left, Right)
import System.Random (getStdRandom, randomR)
data Tetrimino = I | O | T | S | Z | J | L
deriving (Tetrimino -> Tetrimino -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tetrimino -> Tetrimino -> Bool
$c/= :: Tetrimino -> Tetrimino -> Bool
== :: Tetrimino -> Tetrimino -> Bool
$c== :: Tetrimino -> Tetrimino -> Bool
Eq, Int -> Tetrimino -> ShowS
[Tetrimino] -> ShowS
Tetrimino -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tetrimino] -> ShowS
$cshowList :: [Tetrimino] -> ShowS
show :: Tetrimino -> String
$cshow :: Tetrimino -> String
showsPrec :: Int -> Tetrimino -> ShowS
$cshowsPrec :: Int -> Tetrimino -> ShowS
Show, Int -> Tetrimino
Tetrimino -> Int
Tetrimino -> [Tetrimino]
Tetrimino -> Tetrimino
Tetrimino -> Tetrimino -> [Tetrimino]
Tetrimino -> Tetrimino -> Tetrimino -> [Tetrimino]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Tetrimino -> Tetrimino -> Tetrimino -> [Tetrimino]
$cenumFromThenTo :: Tetrimino -> Tetrimino -> Tetrimino -> [Tetrimino]
enumFromTo :: Tetrimino -> Tetrimino -> [Tetrimino]
$cenumFromTo :: Tetrimino -> Tetrimino -> [Tetrimino]
enumFromThen :: Tetrimino -> Tetrimino -> [Tetrimino]
$cenumFromThen :: Tetrimino -> Tetrimino -> [Tetrimino]
enumFrom :: Tetrimino -> [Tetrimino]
$cenumFrom :: Tetrimino -> [Tetrimino]
fromEnum :: Tetrimino -> Int
$cfromEnum :: Tetrimino -> Int
toEnum :: Int -> Tetrimino
$ctoEnum :: Int -> Tetrimino
pred :: Tetrimino -> Tetrimino
$cpred :: Tetrimino -> Tetrimino
succ :: Tetrimino -> Tetrimino
$csucc :: Tetrimino -> Tetrimino
Enum)
type Coord = V2 Int
data Block = Block
{ Block -> Tetrimino
_shape :: Tetrimino
, Block -> Coord
_origin :: Coord
, :: [Coord]
} deriving (Block -> Block -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Block -> Block -> Bool
$c/= :: Block -> Block -> Bool
== :: Block -> Block -> Bool
$c== :: Block -> Block -> Bool
Eq, Int -> Block -> ShowS
[Block] -> ShowS
Block -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Block] -> ShowS
$cshowList :: [Block] -> ShowS
show :: Block -> String
$cshow :: Block -> String
showsPrec :: Int -> Block -> ShowS
$cshowsPrec :: Int -> Block -> ShowS
Show)
data Direction = Left | Right | Down
deriving (Direction -> Direction -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Direction -> Direction -> Bool
$c/= :: Direction -> Direction -> Bool
== :: Direction -> Direction -> Bool
$c== :: Direction -> Direction -> Bool
Eq, Int -> Direction -> ShowS
[Direction] -> ShowS
Direction -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Direction] -> ShowS
$cshowList :: [Direction] -> ShowS
show :: Direction -> String
$cshow :: Direction -> String
showsPrec :: Int -> Direction -> ShowS
$cshowsPrec :: Int -> Direction -> ShowS
Show)
type Board = Map Coord Tetrimino
data Game = Game
{ Game -> Int
_level :: Int
, Game -> Block
_block :: Block
, Game -> Tetrimino
_nextShape :: Tetrimino
, Game -> Seq Tetrimino
_nextShapeBag :: Seq.Seq Tetrimino
, Game -> Seq Int
_rowClears :: Seq.Seq Int
, Game -> Int
_score :: Int
, Game -> Board
_board :: Board
} deriving (Game -> Game -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Game -> Game -> Bool
$c/= :: Game -> Game -> Bool
== :: Game -> Game -> Bool
$c== :: Game -> Game -> Bool
Eq, Int -> Game -> ShowS
[Game] -> ShowS
Game -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Game] -> ShowS
$cshowList :: [Game] -> ShowS
show :: Game -> String
$cshow :: Game -> String
showsPrec :: Int -> Game -> ShowS
$cshowsPrec :: Int -> Game -> ShowS
Show)
makeLenses ''Game
class Translatable s where
translate :: Direction -> s -> s
translate = forall s. Translatable s => Int -> Direction -> s -> s
translateBy Int
1
translateBy :: Int -> Direction -> s -> s
instance Translatable Coord where
translateBy :: Int -> Direction -> Coord -> Coord
translateBy Int
n Direction
Left (V2 Int
x Int
y) = forall a. a -> a -> V2 a
V2 (Int
xforall a. Num a => a -> a -> a
-Int
n) Int
y
translateBy Int
n Direction
Right (V2 Int
x Int
y) = forall a. a -> a -> V2 a
V2 (Int
xforall a. Num a => a -> a -> a
+Int
n) Int
y
translateBy Int
n Direction
Down (V2 Int
x Int
y) = forall a. a -> a -> V2 a
V2 Int
x (Int
yforall a. Num a => a -> a -> a
-Int
n)
instance Translatable Block where
translateBy :: Int -> Direction -> Block -> Block
translateBy Int
n Direction
d Block
b =
Block
b forall a b. a -> (a -> b) -> b
& Lens' Block Coord
origin forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall s. Translatable s => Int -> Direction -> s -> s
translateBy Int
n Direction
d
forall a b. a -> (a -> b) -> b
& Lens' Block [Coord]
extra forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s. Translatable s => Int -> Direction -> s -> s
translateBy Int
n Direction
d)
initBlock :: Tetrimino -> Block
initBlock :: Tetrimino -> Block
initBlock Tetrimino
t = Tetrimino -> Coord -> [Coord] -> Block
Block Tetrimino
t Coord
startOrigin forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Num a => a -> a -> a
+ Coord
startOrigin) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tetrimino -> [Coord]
relCells forall a b. (a -> b) -> a -> b
$ Tetrimino
t
relCells :: Tetrimino -> [Coord]
relCells :: Tetrimino -> [Coord]
relCells Tetrimino
I = forall a b. (a -> b) -> [a] -> [b]
map forall a. (a, a) -> V2 a
v2 [(-Int
2,Int
0), (-Int
1,Int
0), (Int
1,Int
0)]
relCells Tetrimino
O = forall a b. (a -> b) -> [a] -> [b]
map forall a. (a, a) -> V2 a
v2 [(-Int
1,Int
0), (-Int
1,-Int
1), (Int
0,-Int
1)]
relCells Tetrimino
S = forall a b. (a -> b) -> [a] -> [b]
map forall a. (a, a) -> V2 a
v2 [(-Int
1,-Int
1), (Int
0,-Int
1), (Int
1,Int
0)]
relCells Tetrimino
Z = forall a b. (a -> b) -> [a] -> [b]
map forall a. (a, a) -> V2 a
v2 [(-Int
1,Int
0), (Int
0,-Int
1), (Int
1,-Int
1)]
relCells Tetrimino
L = forall a b. (a -> b) -> [a] -> [b]
map forall a. (a, a) -> V2 a
v2 [(-Int
1,-Int
1), (-Int
1,Int
0), (Int
1,Int
0)]
relCells Tetrimino
J = forall a b. (a -> b) -> [a] -> [b]
map forall a. (a, a) -> V2 a
v2 [(-Int
1,Int
0), (Int
1,Int
0), (Int
1,-Int
1)]
relCells Tetrimino
T = forall a b. (a -> b) -> [a] -> [b]
map forall a. (a, a) -> V2 a
v2 [(-Int
1,Int
0), (Int
0,-Int
1), (Int
1,Int
0)]
boardWidth, boardHeight :: Int
boardWidth :: Int
boardWidth = Int
10
boardHeight :: Int
boardHeight = Int
20
startOrigin :: Coord
startOrigin :: Coord
startOrigin = forall a. a -> a -> V2 a
V2 Int
6 Int
22
rotate' :: Block -> Block
rotate' :: Block -> Block
rotate' b :: Block
b@(Block Tetrimino
s o :: Coord
o@(V2 Int
xo Int
yo) [Coord]
cs)
| Tetrimino
s forall a. Eq a => a -> a -> Bool
== Tetrimino
O = Block
b
| Tetrimino
s forall a. Eq a => a -> a -> Bool
== Tetrimino
I Bool -> Bool -> Bool
&& forall a. a -> a -> V2 a
V2 Int
xo (Int
yoforall a. Num a => a -> a -> a
+Int
1) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Coord]
cs = (Coord -> Coord) -> Block
rotateWith Coord -> Coord
clockwise
| Bool
otherwise = (Coord -> Coord) -> Block
rotateWith Coord -> Coord
counterclockwise
where
rotateWith :: (Coord -> Coord) -> Block
rotateWith :: (Coord -> Coord) -> Block
rotateWith Coord -> Coord
dir = Block
b forall a b. a -> (a -> b) -> b
& Lens' Block [Coord]
extra forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Coord -> Coord
dir
clockwise :: Coord -> Coord
clockwise = (forall a. Num a => a -> a -> a
+ Coord
o) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Num a => V2 a -> V2 a
cwperp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract Coord
o
counterclockwise :: Coord -> Coord
counterclockwise = (forall a. Num a => a -> a -> a
+ Coord
o) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Num a => V2 a -> V2 a
LV.perp forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Num a => a -> a -> a
subtract Coord
o
cwperp :: V2 a -> V2 a
cwperp (V2 a
x a
y) = forall a. a -> a -> V2 a
V2 a
y (-a
x)
coords :: Block -> [Coord]
coords :: Block -> [Coord]
coords Block
b = Block
b forall s a. s -> Getting a s a -> a
^. Lens' Block Coord
origin forall a. a -> [a] -> [a]
: Block
b forall s a. s -> Getting a s a -> a
^. Lens' Block [Coord]
extra
bagFourTetriminoEach :: Seq.Seq Tetrimino -> IO (Tetrimino, Seq.Seq Tetrimino)
bagFourTetriminoEach :: Seq Tetrimino -> IO (Tetrimino, Seq Tetrimino)
bagFourTetriminoEach = ViewL Tetrimino -> IO (Tetrimino, Seq Tetrimino)
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Seq a -> ViewL a
Seq.viewl
where
go :: ViewL Tetrimino -> IO (Tetrimino, Seq Tetrimino)
go (Tetrimino
t :< Seq Tetrimino
ts) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tetrimino
t, Seq Tetrimino
ts)
go ViewL Tetrimino
EmptyL = IO (Seq Tetrimino)
freshList forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Seq Tetrimino -> IO (Tetrimino, Seq Tetrimino)
bagFourTetriminoEach
freshList :: IO (Seq Tetrimino)
freshList = forall a. Seq a -> IO (Seq a)
shuffle forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Seq a
Seq.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Int -> [a] -> [a]
take Int
28 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
cycle forall a b. (a -> b) -> a -> b
$ [Tetrimino
I ..]
initGame :: Int -> IO Game
initGame :: Int -> IO Game
initGame Int
lvl = do
(Tetrimino
s1, Seq Tetrimino
bag1) <- Seq Tetrimino -> IO (Tetrimino, Seq Tetrimino)
bagFourTetriminoEach forall a. Monoid a => a
mempty
(Tetrimino
s2, Seq Tetrimino
bag2) <- Seq Tetrimino -> IO (Tetrimino, Seq Tetrimino)
bagFourTetriminoEach Seq Tetrimino
bag1
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Game { _level :: Int
_level = Int
lvl
, _block :: Block
_block = Tetrimino -> Block
initBlock Tetrimino
s1
, _nextShape :: Tetrimino
_nextShape = Tetrimino
s2
, _nextShapeBag :: Seq Tetrimino
_nextShapeBag = Seq Tetrimino
bag2
, _score :: Int
_score = Int
0
, _rowClears :: Seq Int
_rowClears = forall a. Monoid a => a
mempty
, _board :: Board
_board = forall a. Monoid a => a
mempty }
isGameOver :: Game -> Bool
isGameOver :: Game -> Bool
isGameOver Game
g = Game -> Bool
blockStopped Game
g Bool -> Bool -> Bool
&& Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Block
block forall s a. s -> Getting a s a -> a
^. Lens' Block Coord
origin forall a. Eq a => a -> a -> Bool
== Coord
startOrigin
timeStep :: Game -> IO Game
timeStep :: Game -> IO Game
timeStep Game
g =
if Game -> Bool
blockStopped Game
g
then Game -> IO Game
nextBlock forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> Game
updateScore forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> Game
clearFullRows forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> Game
freezeBlock forall a b. (a -> b) -> a -> b
$ Game
g
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> Game
gravitate forall a b. (a -> b) -> a -> b
$ Game
g
clearFullRows :: Game -> Game
clearFullRows :: Game -> Game
clearFullRows Game
g = Game
g forall a b. a -> (a -> b) -> b
& Lens' Game Board
board forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall {a}. Map Coord a -> Map Coord a
clearBoard
forall a b. a -> (a -> b) -> b
& Lens' Game (Seq Int)
rowClears forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Seq Int -> Seq Int
addToRowClears Int
rowCount
where
clearBoard :: Map Coord a -> Map Coord a
clearBoard = forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys Coord -> Coord
shiftCoordAbove forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey forall {p}. Coord -> p -> Bool
notInFullRow
notInFullRow :: Coord -> p -> Bool
notInFullRow (V2 Int
_ Int
y) p
_ = Int
y forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
fullRowIndices
rowCount :: Int
rowCount = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fullRowIndices
fullRowIndices :: [Int]
fullRowIndices = forall a. (a -> Bool) -> [a] -> [a]
filter Int -> Bool
isFullRow [Int
1..Int
boardHeight]
isFullRow :: Int -> Bool
isFullRow Int
r = Int
boardWidth forall a. Eq a => a -> a -> Bool
== (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (forall {a} {p}. Eq a => a -> V2 a -> p -> Bool
inRow Int
r) forall a b. (a -> b) -> a -> b
$ Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Board
board)
inRow :: a -> V2 a -> p -> Bool
inRow a
r (V2 a
_ a
y) p
_ = a
r forall a. Eq a => a -> a -> Bool
== a
y
shiftCoordAbove :: Coord -> Coord
shiftCoordAbove (V2 Int
x Int
y) =
let offset :: Int
offset = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Ord a => a -> a -> Bool
< Int
y) forall a b. (a -> b) -> a -> b
$ [Int]
fullRowIndices
in forall a. a -> a -> V2 a
V2 Int
x (Int
y forall a. Num a => a -> a -> a
- Int
offset)
updateScore :: Game -> Game
updateScore :: Game -> Game
updateScore Game
g = Game
g forall a b. a -> (a -> b) -> b
& Lens' Game Int
score forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Num a => a -> a -> a
+ Int
newPoints)
where
newPoints :: Int
newPoints = (Int
1 forall a. Num a => a -> a -> a
+ Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Int
level) forall a. Num a => a -> a -> a
* (Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game (Seq Int)
rowClears forall s a. s -> Getting a s a -> a
^. forall s a. (s -> a) -> SimpleGetter s a
to Seq Int -> Int
latestOrZero forall s a. s -> Getting a s a -> a
^. forall s a. (s -> a) -> SimpleGetter s a
to forall {a} {a}. (Eq a, Num a, Num a) => a -> a
points)
points :: a -> a
points a
0 = a
0
points a
1 = a
40
points a
2 = a
100
points a
3 = a
300
points a
_ = a
800
addToRowClears :: Int -> Seq.Seq Int -> Seq.Seq Int
addToRowClears :: Int -> Seq Int -> Seq Int
addToRowClears Int
0 Seq Int
_ = forall a. Monoid a => a
mempty
addToRowClears Int
n Seq Int
rs = Seq Int
rs forall a. Seq a -> a -> Seq a
|> Int
n
latestOrZero :: Seq.Seq Int -> Int
latestOrZero :: Seq Int -> Int
latestOrZero = forall {a}. Num a => ViewR a -> a
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Seq a -> ViewR a
Seq.viewr
where go :: ViewR a -> a
go ViewR a
EmptyR = a
0
go (Seq a
_ :> a
n) = a
n
rotate :: Game -> Game
rotate :: Game -> Game
rotate Game
g = Game
g forall a b. a -> (a -> b) -> b
& Lens' Game Block
block forall s t a b. ASetter s t a b -> b -> s -> t
.~ Block
nextB
where nextB :: Block
nextB = forall a. a -> Maybe a -> a
fromMaybe Block
blk forall a b. (a -> b) -> a -> b
$ forall a. First a -> Maybe a
getFirst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> First a
First forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe Block]
bs
bs :: [Maybe Block]
bs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> a -> b
$ Block
blk) [Block -> Maybe Block]
safeFuncs
safeFuncs :: [Block -> Maybe Block]
safeFuncs = forall a b. (a -> b) -> [a] -> [b]
map (Block -> Maybe Block
mkSafe forall b c a. (b -> c) -> (a -> b) -> a -> c
.) [Block -> Block]
funcs
mkSafe :: Block -> Maybe Block
mkSafe = forall a. (a -> Bool) -> a -> Maybe a
boolMaybe (Board -> Block -> Bool
isValidBlockPosition Board
brd)
funcs :: [Block -> Block]
funcs = [Block -> Block
rotate', Block -> Block
rotate' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Translatable s => Direction -> s -> s
translate Direction
Left, Block -> Block
rotate' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Translatable s => Direction -> s -> s
translate Direction
Right]
blk :: Block
blk = Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Block
block
brd :: Board
brd = Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Board
board
blockStopped :: Game -> Bool
blockStopped :: Game -> Bool
blockStopped Game
g = Board -> Block -> Bool
isStopped (Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Board
board) (Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Block
block)
isStopped :: Board -> Block -> Bool
isStopped :: Board -> Block -> Bool
isStopped Board
brd = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Coord -> Bool
cStopped forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Coord]
coords
where cStopped :: Coord -> Bool
cStopped = Bool -> Bool -> Bool
(||) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {a}. (Eq a, Num a) => V2 a -> Bool
inRow1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall k a. Ord k => k -> Map k a -> Bool
`M.member` Board
brd) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s. Translatable s => Direction -> s -> s
translate Direction
Down
inRow1 :: V2 a -> Bool
inRow1 (V2 a
_ a
y) = a
y forall a. Eq a => a -> a -> Bool
== a
1
hardDrop :: Game -> Game
hardDrop :: Game -> Game
hardDrop Game
g = Game
g forall a b. a -> (a -> b) -> b
& Lens' Game Block
block forall s t a b. ASetter s t a b -> b -> s -> t
.~ Game -> Block
hardDroppedBlock Game
g
hardDroppedBlock :: Game -> Block
hardDroppedBlock :: Game -> Block
hardDroppedBlock Game
g = forall s. Translatable s => Int -> Direction -> s -> s
translateBy Int
n Direction
Down forall a b. (a -> b) -> a -> b
$ Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Block
block
where n :: Int
n = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum forall a b. (a -> b) -> a -> b
$ forall a. Num a => a -> a -> a
subtract Int
1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int
minY forall a. a -> [a] -> [a]
: [Int]
diffs)
diffs :: [Int]
diffs = [Int
y forall a. Num a => a -> a -> a
- Int
yo | (V2 Int
xo Int
yo) <- [Coord]
brdCs, (V2 Int
x Int
y) <- [Coord]
blkCs, Int
xo forall a. Eq a => a -> a -> Bool
== Int
x, Int
yo forall a. Ord a => a -> a -> Bool
< Int
y]
brdCs :: [Coord]
brdCs = Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Board
board forall s a. s -> Getting a s a -> a
^. forall s a. (s -> a) -> SimpleGetter s a
to forall k a. Map k a -> [k]
M.keys
blkCs :: [Coord]
blkCs = Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Block
block forall s a. s -> Getting a s a -> a
^. forall s a. (s -> a) -> SimpleGetter s a
to Block -> [Coord]
coords
minY :: Int
minY = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall s a. s -> Getting a s a -> a
^. forall (t :: * -> *) a. R2 t => Lens' (t a) a
_y) [Coord]
blkCs)
freezeBlock :: Game -> Game
freezeBlock :: Game -> Game
freezeBlock Game
g = Game
g forall a b. a -> (a -> b) -> b
& Lens' Game Board
board forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Board
blkMap
where blk :: Block
blk = Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Block
block
blkMap :: Board
blkMap = forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Coord
c, Block
blk forall s a. s -> Getting a s a -> a
^. Lens' Block Tetrimino
shape) | Coord
c <- Block
blk forall s a. s -> Getting a s a -> a
^. forall s a. (s -> a) -> SimpleGetter s a
to Block -> [Coord]
coords]
nextBlock :: Game -> IO Game
nextBlock :: Game -> IO Game
nextBlock Game
g = do
(Tetrimino
t, Seq Tetrimino
ts) <- Seq Tetrimino -> IO (Tetrimino, Seq Tetrimino)
bagFourTetriminoEach (Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game (Seq Tetrimino)
nextShapeBag)
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
Game
g forall a b. a -> (a -> b) -> b
& Lens' Game Block
block forall s t a b. ASetter s t a b -> b -> s -> t
.~ Tetrimino -> Block
initBlock (Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Tetrimino
nextShape)
forall a b. a -> (a -> b) -> b
& Lens' Game Tetrimino
nextShape forall s t a b. ASetter s t a b -> b -> s -> t
.~ Tetrimino
t
forall a b. a -> (a -> b) -> b
& Lens' Game (Seq Tetrimino)
nextShapeBag forall s t a b. ASetter s t a b -> b -> s -> t
.~ Seq Tetrimino
ts
shift :: Direction -> Game -> Game
shift :: Direction -> Game -> Game
shift Direction
d Game
g = Game
g forall a b. a -> (a -> b) -> b
& Lens' Game Block
block forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Block -> Block
shiftBlock
where shiftBlock :: Block -> Block
shiftBlock Block
b = if Board -> Block -> Bool
isValidBlockPosition (Game
g forall s a. s -> Getting a s a -> a
^. Lens' Game Board
board) (forall s. Translatable s => Direction -> s -> s
translate Direction
d Block
b)
then forall s. Translatable s => Direction -> s -> s
translate Direction
d Block
b
else Block
b
isFree, isOccupied :: Board -> Coord -> Bool
isFree :: Board -> Coord -> Bool
isFree = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Bool
M.notMember
isOccupied :: Board -> Coord -> Bool
isOccupied = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k a. Ord k => k -> Map k a -> Bool
M.member
isInBounds, isOutOfBounds :: Coord -> Bool
isInBounds :: Coord -> Bool
isInBounds (V2 Int
x Int
y) = Int
1 forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x forall a. Ord a => a -> a -> Bool
<= Int
boardWidth Bool -> Bool -> Bool
&& Int
1 forall a. Ord a => a -> a -> Bool
<= Int
y
isOutOfBounds :: Coord -> Bool
isOutOfBounds = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coord -> Bool
isInBounds
gravitate :: Game -> Game
gravitate :: Game -> Game
gravitate = Direction -> Game -> Game
shift Direction
Down
isValidBlockPosition :: Board -> Block -> Bool
isValidBlockPosition :: Board -> Block -> Bool
isValidBlockPosition Board
brd = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Coord -> Bool
validCoord forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Coord]
coords
where validCoord :: Coord -> Bool
validCoord = Bool -> Bool -> Bool
(&&) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Board -> Coord -> Bool
isFree Board
brd forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Coord -> Bool
isInBounds
shuffle :: Seq.Seq a -> IO (Seq.Seq a)
shuffle :: forall a. Seq a -> IO (Seq a)
shuffle Seq a
xs
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq a
xs = forall a. Monoid a => a
mempty
| Bool
otherwise = do
Int
randomPosition <- forall (m :: * -> *) a. MonadIO m => (StdGen -> (a, StdGen)) -> m a
getStdRandom (forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq a
xs forall a. Num a => a -> a -> a
- Int
1))
let (Seq a
left, Seq a
right) = forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
randomPosition Seq a
xs
(a
y :< Seq a
ys) = forall a. Seq a -> ViewL a
Seq.viewl Seq a
right
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
y forall a. a -> Seq a -> Seq a
<|) (forall a. Seq a -> IO (Seq a)
shuffle forall a b. (a -> b) -> a -> b
$ Seq a
left forall a. Seq a -> Seq a -> Seq a
>< Seq a
ys)
boolMaybe :: (a -> Bool) -> a -> Maybe a
boolMaybe :: forall a. (a -> Bool) -> a -> Maybe a
boolMaybe a -> Bool
p a
a = if a -> Bool
p a
a then forall a. a -> Maybe a
Just a
a else forall a. Maybe a
Nothing
v2 :: (a, a) -> V2 a
v2 :: forall a. (a, a) -> V2 a
v2 (a
x, a
y) = forall a. a -> a -> V2 a
V2 a
x a
y