{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell   #-}
-------------------------------------------------------------------------------
-- |
-- Module      :  Game.Tetris
-- Copyright   :  (c) 2017 Samuel Tay <sam.chong.tay@gmail.com>
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Mario Lang <mlang@blind.guru>
--
-- A library implementation of Tetris.
--
-- This module has been taken from https://github.com/SamTay/tetris
--
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)

-- Types and instances

-- | Tetris shape types
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)

-- | Coordinates
type Coord = V2 Int

-- | Tetris shape in location context
data Block = Block
  { Block -> Tetrimino
_shape  :: Tetrimino -- ^ block type
  , Block -> Coord
_origin :: Coord -- ^ origin
  , Block -> [Coord]
_extra  :: [Coord] -- ^ extraneous cells
  } 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)

makeLenses ''Block

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)

-- | Board
--
-- If coordinate not present in map, yet in bounds, then it is empty,
-- otherwise its value is the type of tetrimino occupying it.
type Board = Map Coord Tetrimino

-- | Game state
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

-- Translate class for direct translations, without concern for boundaries
-- 'shift' concerns safe translations with boundaries
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)

-- Low level functions on blocks and coordinates

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)]

-- | Visible, active board size
boardWidth, boardHeight :: Int
boardWidth :: Int
boardWidth = Int
10
boardHeight :: Int
boardHeight = Int
20

-- | Starting block origin
startOrigin :: Coord
startOrigin :: Coord
startOrigin = forall a. a -> a -> V2 a
V2 Int
6 Int
22

-- | Rotate block counter clockwise about origin
-- *Note*: Strict unsafe rotation not respecting boundaries
-- Safety can only be assured within Game context
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 -- O doesn't need rotation
  | 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 -- I only has two orientations
  | 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)

-- | Get coordinates of entire block
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

-- Higher level functions on game and board

-- | Facilitates cycling through at least 4 occurences of each shape
-- before next bag (random permutation of 4*each tetrimino) is created. If input is empty,
-- generates new bag, otherwise just unshifts the first value and returns pair.
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 ..]

-- | Initialize a game with a given level
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

-- TODO check if mapKeysMonotonic works
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)

-- | This updates game points with respect to the current
-- _rowClears value (thus should only be used ONCE per step)
--
-- Note I'm keeping rowClears as a sequence in case I want to award
-- more points for back to back clears, right now the scoring is more simple
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

-- | Empties row on 0, otherwise appends value (just keeps consecutive information)
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

-- | Get last value of sequence or 0 if empty
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

-- | Handle counterclockwise block rotation (if possible)
-- Allows wallkicks: http://tetris.wikia.com/wiki/TGM_rotation
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)

-- | Check if a block on a board is stopped from further gravitation
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)

-- | Freeze current block
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]

-- | Replace block with next block
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

-- | Try to shift current block; if shifting not possible, leave block where it is
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

-- | Check if coordinate is already occupied or free in board
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

-- | Check if coordinate is in or out of bounds
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 current block, i.e. shift down
gravitate :: Game -> Game
gravitate :: Game -> Game
gravitate = Direction -> Game -> Game
shift Direction
Down

-- | Checks if block's potential new location is valid
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

-- General utilities

-- | Shuffle a sequence (random permutation)
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)

-- | Take predicate and input and transform to Maybe
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