{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleInstances #-}
-------------------------------------------------------------------------------
-- |
-- 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 Control.Lens hiding ((:<), (<|), (|>), (:>))
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 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
(Tetrimino -> Tetrimino -> Bool)
-> (Tetrimino -> Tetrimino -> Bool) -> Eq Tetrimino
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
(Int -> Tetrimino -> ShowS)
-> (Tetrimino -> String)
-> ([Tetrimino] -> ShowS)
-> Show Tetrimino
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]
(Tetrimino -> Tetrimino)
-> (Tetrimino -> Tetrimino)
-> (Int -> Tetrimino)
-> (Tetrimino -> Int)
-> (Tetrimino -> [Tetrimino])
-> (Tetrimino -> Tetrimino -> [Tetrimino])
-> (Tetrimino -> Tetrimino -> [Tetrimino])
-> (Tetrimino -> Tetrimino -> Tetrimino -> [Tetrimino])
-> Enum 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
(Block -> Block -> Bool) -> (Block -> Block -> Bool) -> Eq Block
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
(Int -> Block -> ShowS)
-> (Block -> String) -> ([Block] -> ShowS) -> Show Block
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
(Direction -> Direction -> Bool)
-> (Direction -> Direction -> Bool) -> Eq Direction
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
(Int -> Direction -> ShowS)
-> (Direction -> String)
-> ([Direction] -> ShowS)
-> Show Direction
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
(Game -> Game -> Bool) -> (Game -> Game -> Bool) -> Eq Game
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
(Int -> Game -> ShowS)
-> (Game -> String) -> ([Game] -> ShowS) -> Show Game
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 = Int -> Direction -> s -> s
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)  = Int -> Int -> Coord
forall a. a -> a -> V2 a
V2 (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
n) Int
y
  translateBy Int
n Direction
Right (V2 Int
x Int
y) = Int -> Int -> Coord
forall a. a -> a -> V2 a
V2 (Int
xInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
n) Int
y
  translateBy Int
n Direction
Down (V2 Int
x Int
y)  = Int -> Int -> Coord
forall a. a -> a -> V2 a
V2 Int
x (Int
yInt -> Int -> Int
forall 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 Block -> (Block -> Block) -> Block
forall a b. a -> (a -> b) -> b
& (Coord -> Identity Coord) -> Block -> Identity Block
Lens' Block Coord
origin ((Coord -> Identity Coord) -> Block -> Identity Block)
-> (Coord -> Coord) -> Block -> Block
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Int -> Direction -> Coord -> Coord
forall s. Translatable s => Int -> Direction -> s -> s
translateBy Int
n Direction
d
      Block -> (Block -> Block) -> Block
forall a b. a -> (a -> b) -> b
& ([Coord] -> Identity [Coord]) -> Block -> Identity Block
Lens' Block [Coord]
extra  (([Coord] -> Identity [Coord]) -> Block -> Identity Block)
-> ([Coord] -> [Coord]) -> Block -> Block
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Coord -> Coord) -> [Coord] -> [Coord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Direction -> Coord -> Coord
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 ([Coord] -> Block) -> (Tetrimino -> [Coord]) -> Tetrimino -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coord -> Coord) -> [Coord] -> [Coord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Coord -> Coord -> Coord
forall a. Num a => a -> a -> a
+ Coord
startOrigin) ([Coord] -> [Coord])
-> (Tetrimino -> [Coord]) -> Tetrimino -> [Coord]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tetrimino -> [Coord]
relCells (Tetrimino -> Block) -> Tetrimino -> Block
forall a b. (a -> b) -> a -> b
$ Tetrimino
t

relCells :: Tetrimino -> [Coord]
relCells :: Tetrimino -> [Coord]
relCells Tetrimino
I = ((Int, Int) -> Coord) -> [(Int, Int)] -> [Coord]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Coord
forall a. (a, a) -> V2 a
v2 [(-Int
2,Int
0), (-Int
1,Int
0), (Int
1,Int
0)]
relCells Tetrimino
O = ((Int, Int) -> Coord) -> [(Int, Int)] -> [Coord]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Coord
forall a. (a, a) -> V2 a
v2 [(-Int
1,Int
0), (-Int
1,-Int
1), (Int
0,-Int
1)]
relCells Tetrimino
S = ((Int, Int) -> Coord) -> [(Int, Int)] -> [Coord]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Coord
forall a. (a, a) -> V2 a
v2 [(-Int
1,-Int
1), (Int
0,-Int
1), (Int
1,Int
0)]
relCells Tetrimino
Z = ((Int, Int) -> Coord) -> [(Int, Int)] -> [Coord]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Coord
forall a. (a, a) -> V2 a
v2 [(-Int
1,Int
0), (Int
0,-Int
1), (Int
1,-Int
1)]
relCells Tetrimino
L = ((Int, Int) -> Coord) -> [(Int, Int)] -> [Coord]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Coord
forall a. (a, a) -> V2 a
v2 [(-Int
1,-Int
1), (-Int
1,Int
0), (Int
1,Int
0)]
relCells Tetrimino
J = ((Int, Int) -> Coord) -> [(Int, Int)] -> [Coord]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Coord
forall a. (a, a) -> V2 a
v2 [(-Int
1,Int
0), (Int
1,Int
0), (Int
1,-Int
1)]
relCells Tetrimino
T = ((Int, Int) -> Coord) -> [(Int, Int)] -> [Coord]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Int) -> Coord
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 = Int -> Int -> Coord
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 Tetrimino -> Tetrimino -> Bool
forall a. Eq a => a -> a -> Bool
== Tetrimino
O = Block
b -- O doesn't need rotation
  | Tetrimino
s Tetrimino -> Tetrimino -> Bool
forall a. Eq a => a -> a -> Bool
== Tetrimino
I Bool -> Bool -> Bool
&& Int -> Int -> Coord
forall a. a -> a -> V2 a
V2 Int
xo (Int
yoInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) Coord -> [Coord] -> Bool
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 Block -> (Block -> Block) -> Block
forall a b. a -> (a -> b) -> b
& ([Coord] -> Identity [Coord]) -> Block -> Identity Block
Lens' Block [Coord]
extra (([Coord] -> Identity [Coord]) -> Block -> Identity Block)
-> ([Coord] -> [Coord]) -> Block -> Block
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Coord -> Coord) -> [Coord] -> [Coord]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Coord -> Coord
dir
    clockwise :: Coord -> Coord
clockwise        = (Coord -> Coord -> Coord
forall a. Num a => a -> a -> a
+ Coord
o) (Coord -> Coord) -> (Coord -> Coord) -> Coord -> Coord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coord -> Coord
forall a. Num a => V2 a -> V2 a
cwperp (Coord -> Coord) -> (Coord -> Coord) -> Coord -> Coord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coord -> Coord -> Coord
forall a. Num a => a -> a -> a
subtract Coord
o
    counterclockwise :: Coord -> Coord
counterclockwise = (Coord -> Coord -> Coord
forall a. Num a => a -> a -> a
+ Coord
o) (Coord -> Coord) -> (Coord -> Coord) -> Coord -> Coord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coord -> Coord
forall a. Num a => V2 a -> V2 a
LV.perp (Coord -> Coord) -> (Coord -> Coord) -> Coord -> Coord
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Coord -> Coord -> Coord
forall a. Num a => a -> a -> a
subtract Coord
o
    cwperp :: V2 a -> V2 a
cwperp (V2 a
x a
y)  = a -> a -> V2 a
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 Block -> Getting Coord Block Coord -> Coord
forall s a. s -> Getting a s a -> a
^. Getting Coord Block Coord
Lens' Block Coord
origin Coord -> [Coord] -> [Coord]
forall a. a -> [a] -> [a]
: Block
b Block -> Getting [Coord] Block [Coord] -> [Coord]
forall s a. s -> Getting a s a -> a
^. Getting [Coord] Block [Coord]
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 (ViewL Tetrimino -> IO (Tetrimino, Seq Tetrimino))
-> (Seq Tetrimino -> ViewL Tetrimino)
-> Seq Tetrimino
-> IO (Tetrimino, Seq Tetrimino)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Tetrimino -> ViewL Tetrimino
forall a. Seq a -> ViewL a
Seq.viewl
  where
    go :: ViewL Tetrimino -> IO (Tetrimino, Seq Tetrimino)
go (Tetrimino
t :< Seq Tetrimino
ts) = (Tetrimino, Seq Tetrimino) -> IO (Tetrimino, Seq Tetrimino)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tetrimino
t, Seq Tetrimino
ts)
    go ViewL Tetrimino
EmptyL = IO (Seq Tetrimino)
freshList IO (Seq Tetrimino)
-> (Seq Tetrimino -> IO (Tetrimino, Seq Tetrimino))
-> IO (Tetrimino, Seq Tetrimino)
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 = Seq Tetrimino -> IO (Seq Tetrimino)
forall a. Seq a -> IO (Seq a)
shuffle (Seq Tetrimino -> IO (Seq Tetrimino))
-> ([Tetrimino] -> Seq Tetrimino)
-> [Tetrimino]
-> IO (Seq Tetrimino)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tetrimino] -> Seq Tetrimino
forall a. [a] -> Seq a
Seq.fromList ([Tetrimino] -> Seq Tetrimino)
-> ([Tetrimino] -> [Tetrimino]) -> [Tetrimino] -> Seq Tetrimino
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Tetrimino] -> [Tetrimino]
forall a. Int -> [a] -> [a]
take Int
28 ([Tetrimino] -> [Tetrimino])
-> ([Tetrimino] -> [Tetrimino]) -> [Tetrimino] -> [Tetrimino]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Tetrimino] -> [Tetrimino]
forall a. [a] -> [a]
cycle ([Tetrimino] -> IO (Seq Tetrimino))
-> [Tetrimino] -> IO (Seq Tetrimino)
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 Seq Tetrimino
forall a. Monoid a => a
mempty
  (Tetrimino
s2, Seq Tetrimino
bag2) <- Seq Tetrimino -> IO (Tetrimino, Seq Tetrimino)
bagFourTetriminoEach Seq Tetrimino
bag1
  Game -> IO Game
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Game -> IO Game) -> Game -> IO Game
forall a b. (a -> b) -> a -> b
$
    Game :: Int
-> Block
-> Tetrimino
-> Seq Tetrimino
-> Seq Int
-> Int
-> Board
-> Game
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 = Seq Int
forall a. Monoid a => a
mempty
         , _board :: 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 Game -> Getting Block Game Block -> Block
forall s a. s -> Getting a s a -> a
^. Getting Block Game Block
Lens' Game Block
block Block -> Getting Coord Block Coord -> Coord
forall s a. s -> Getting a s a -> a
^. Getting Coord Block Coord
Lens' Block Coord
origin Coord -> Coord -> Bool
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 (Game -> IO Game) -> (Game -> Game) -> Game -> IO Game
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> Game
updateScore (Game -> Game) -> (Game -> Game) -> Game -> Game
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> Game
clearFullRows (Game -> Game) -> (Game -> Game) -> Game -> Game
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> Game
freezeBlock (Game -> IO Game) -> Game -> IO Game
forall a b. (a -> b) -> a -> b
$ Game
g
     else Game -> IO Game
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Game -> IO Game) -> (Game -> Game) -> Game -> IO Game
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Game -> Game
gravitate (Game -> IO Game) -> Game -> IO Game
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 Game -> (Game -> Game) -> Game
forall a b. a -> (a -> b) -> b
& (Board -> Identity Board) -> Game -> Identity Game
Lens' Game Board
board ((Board -> Identity Board) -> Game -> Identity Game)
-> (Board -> Board) -> Game -> Game
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Board -> Board
forall a. Map Coord a -> Map Coord a
clearBoard
                    Game -> (Game -> Game) -> Game
forall a b. a -> (a -> b) -> b
& (Seq Int -> Identity (Seq Int)) -> Game -> Identity Game
Lens' Game (Seq Int)
rowClears ((Seq Int -> Identity (Seq Int)) -> Game -> Identity Game)
-> (Seq Int -> Seq Int) -> Game -> Game
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               = (Coord -> Coord) -> Map Coord a -> Map Coord a
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys Coord -> Coord
shiftCoordAbove (Map Coord a -> Map Coord a)
-> (Map Coord a -> Map Coord a) -> Map Coord a -> Map Coord a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coord -> a -> Bool) -> Map Coord a -> Map Coord a
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey Coord -> a -> Bool
forall p. Coord -> p -> Bool
notInFullRow
    notInFullRow :: Coord -> p -> Bool
notInFullRow (V2 Int
_ Int
y) p
_  = Int
y Int -> [Int] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Int]
fullRowIndices
    rowCount :: Int
rowCount                 = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Int]
fullRowIndices
    fullRowIndices :: [Int]
fullRowIndices           = (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter Int -> Bool
isFullRow [Int
1..Int
boardHeight]
    isFullRow :: Int -> Bool
isFullRow Int
r              = Int
boardWidth Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== (Board -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Board -> Int) -> (Board -> Board) -> Board -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Coord -> Tetrimino -> Bool) -> Board -> Board
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (Int -> Coord -> Tetrimino -> Bool
forall a p. Eq a => a -> V2 a -> p -> Bool
inRow Int
r) (Board -> Int) -> Board -> Int
forall a b. (a -> b) -> a -> b
$ Game
g Game -> Getting Board Game Board -> Board
forall s a. s -> Getting a s a -> a
^. Getting Board Game Board
Lens' Game Board
board)
    inRow :: a -> V2 a -> p -> Bool
inRow a
r (V2 a
_ a
y) p
_       = a
r a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
y
    shiftCoordAbove :: Coord -> Coord
shiftCoordAbove (V2 Int
x Int
y) =
      let offset :: Int
offset = [Int] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Int] -> Int) -> ([Int] -> [Int]) -> [Int] -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Bool) -> [Int] -> [Int]
forall a. (a -> Bool) -> [a] -> [a]
filter (Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
y) ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ [Int]
fullRowIndices
       in Int -> Int -> Coord
forall a. a -> a -> V2 a
V2 Int
x (Int
y Int -> Int -> Int
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 Game -> (Game -> Game) -> Game
forall a b. a -> (a -> b) -> b
& (Int -> Identity Int) -> Game -> Identity Game
Lens' Game Int
score ((Int -> Identity Int) -> Game -> Identity Game)
-> (Int -> Int) -> Game -> Game
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
newPoints)
  where
    newPoints :: Int
newPoints = (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Game
g Game -> Getting Int Game Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Game Int
Lens' Game Int
level) Int -> Int -> Int
forall a. Num a => a -> a -> a
* (Game
g Game -> Getting (Seq Int) Game (Seq Int) -> Seq Int
forall s a. s -> Getting a s a -> a
^. Getting (Seq Int) Game (Seq Int)
Lens' Game (Seq Int)
rowClears Seq Int -> Getting Int (Seq Int) Int -> Int
forall s a. s -> Getting a s a -> a
^. (Seq Int -> Int) -> Getting Int (Seq Int) Int
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Seq Int -> Int
latestOrZero Int -> Getting Int Int Int -> Int
forall s a. s -> Getting a s a -> a
^. (Int -> Int) -> Getting Int Int Int
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Int -> Int
forall a p. (Eq a, Num a, Num p) => a -> p
points)
    points :: a -> p
points a
0 = p
0
    points a
1 = p
40
    points a
2 = p
100
    points a
3 = p
300
    points a
_ = p
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
_  = Seq Int
forall a. Monoid a => a
mempty
addToRowClears Int
n Seq Int
rs = Seq Int
rs Seq Int -> Int -> Seq Int
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 = ViewR Int -> Int
forall p. Num p => ViewR p -> p
go (ViewR Int -> Int) -> (Seq Int -> ViewR Int) -> Seq Int -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seq Int -> ViewR Int
forall a. Seq a -> ViewR a
Seq.viewr
  where go :: ViewR p -> p
go ViewR p
EmptyR = p
0
        go (Seq p
_ :> p
n) = p
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 Game -> (Game -> Game) -> Game
forall a b. a -> (a -> b) -> b
& (Block -> Identity Block) -> Game -> Identity Game
Lens' Game Block
block ((Block -> Identity Block) -> Game -> Identity Game)
-> Block -> Game -> Game
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Block
nextB
  where nextB :: Block
nextB     = Block -> Maybe Block -> Block
forall a. a -> Maybe a -> a
fromMaybe Block
blk (Maybe Block -> Block) -> Maybe Block -> Block
forall a b. (a -> b) -> a -> b
$ First Block -> Maybe Block
forall a. First a -> Maybe a
getFirst (First Block -> Maybe Block)
-> ([First Block] -> First Block) -> [First Block] -> Maybe Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [First Block] -> First Block
forall a. Monoid a => [a] -> a
mconcat ([First Block] -> Maybe Block) -> [First Block] -> Maybe Block
forall a b. (a -> b) -> a -> b
$ Maybe Block -> First Block
forall a. Maybe a -> First a
First (Maybe Block -> First Block) -> [Maybe Block] -> [First Block]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Maybe Block]
bs
        bs :: [Maybe Block]
bs        = ((Block -> Maybe Block) -> Maybe Block)
-> [Block -> Maybe Block] -> [Maybe Block]
forall a b. (a -> b) -> [a] -> [b]
map ((Block -> Maybe Block) -> Block -> Maybe Block
forall a b. (a -> b) -> a -> b
$ Block
blk) [Block -> Maybe Block]
safeFuncs
        safeFuncs :: [Block -> Maybe Block]
safeFuncs = ((Block -> Block) -> Block -> Maybe Block)
-> [Block -> Block] -> [Block -> Maybe Block]
forall a b. (a -> b) -> [a] -> [b]
map (Block -> Maybe Block
mkSafe (Block -> Maybe Block) -> (Block -> Block) -> Block -> Maybe Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) [Block -> Block]
funcs
        mkSafe :: Block -> Maybe Block
mkSafe    = (Block -> Bool) -> Block -> Maybe Block
forall a. (a -> Bool) -> a -> Maybe a
boolMaybe (Board -> Block -> Bool
isValidBlockPosition Board
brd)
        funcs :: [Block -> Block]
funcs     = [Block -> Block
rotate', Block -> Block
rotate' (Block -> Block) -> (Block -> Block) -> Block -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> Block -> Block
forall s. Translatable s => Direction -> s -> s
translate Direction
Left, Block -> Block
rotate' (Block -> Block) -> (Block -> Block) -> Block -> Block
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> Block -> Block
forall s. Translatable s => Direction -> s -> s
translate Direction
Right]
        blk :: Block
blk       = Game
g Game -> Getting Block Game Block -> Block
forall s a. s -> Getting a s a -> a
^. Getting Block Game Block
Lens' Game Block
block
        brd :: Board
brd       = Game
g Game -> Getting Board Game Board -> Board
forall s a. s -> Getting a s a -> a
^. Getting Board Game Board
Lens' Game Board
board

blockStopped :: Game -> Bool
blockStopped :: Game -> Bool
blockStopped Game
g = Board -> Block -> Bool
isStopped (Game
g Game -> Getting Board Game Board -> Board
forall s a. s -> Getting a s a -> a
^. Getting Board Game Board
Lens' Game Board
board) (Game
g Game -> Getting Block Game Block -> Block
forall s a. s -> Getting a s a -> a
^. Getting Block Game Block
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 = (Coord -> Bool) -> [Coord] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Coord -> Bool
cStopped ([Coord] -> Bool) -> (Block -> [Coord]) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Coord]
coords
  where cStopped :: Coord -> Bool
cStopped     = Bool -> Bool -> Bool
(||) (Bool -> Bool -> Bool) -> (Coord -> Bool) -> Coord -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Coord -> Bool
forall a. (Eq a, Num a) => V2 a -> Bool
inRow1 (Coord -> Bool -> Bool) -> (Coord -> Bool) -> Coord -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Coord -> Board -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`M.member` Board
brd) (Coord -> Bool) -> (Coord -> Coord) -> Coord -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Direction -> Coord -> Coord
forall s. Translatable s => Direction -> s -> s
translate Direction
Down
        inRow1 :: V2 a -> Bool
inRow1 (V2 a
_ a
y) = a
y a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1

hardDrop :: Game -> Game
hardDrop :: Game -> Game
hardDrop Game
g = Game
g Game -> (Game -> Game) -> Game
forall a b. a -> (a -> b) -> b
& (Block -> Identity Block) -> Game -> Identity Game
Lens' Game Block
block  ((Block -> Identity Block) -> Game -> Identity Game)
-> Block -> Game -> Game
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 = Int -> Direction -> Block -> Block
forall s. Translatable s => Int -> Direction -> s -> s
translateBy Int
n Direction
Down (Block -> Block) -> Block -> Block
forall a b. (a -> b) -> a -> b
$ Game
g Game -> Getting Block Game Block -> Block
forall s a. s -> Getting a s a -> a
^. Getting Block Game Block
Lens' Game Block
block
  where n :: Int
n = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int
forall a. Num a => a -> a -> a
subtract Int
1 (Int -> Int) -> [Int] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int
minY Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
diffs)
        diffs :: [Int]
diffs = [Int
y Int -> Int -> Int
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 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
x, Int
yo Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
y]
        brdCs :: [Coord]
brdCs = Game
g Game -> Getting Board Game Board -> Board
forall s a. s -> Getting a s a -> a
^. Getting Board Game Board
Lens' Game Board
board Board -> Getting [Coord] Board [Coord] -> [Coord]
forall s a. s -> Getting a s a -> a
^. (Board -> [Coord]) -> Getting [Coord] Board [Coord]
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Board -> [Coord]
forall k a. Map k a -> [k]
M.keys
        blkCs :: [Coord]
blkCs = Game
g Game -> Getting Block Game Block -> Block
forall s a. s -> Getting a s a -> a
^. Getting Block Game Block
Lens' Game Block
block Block -> Getting [Coord] Block [Coord] -> [Coord]
forall s a. s -> Getting a s a -> a
^. (Block -> [Coord]) -> Getting [Coord] Block [Coord]
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Block -> [Coord]
coords
        minY :: Int
minY = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum ((Coord -> Int) -> [Coord] -> [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Coord -> Getting Int Coord Int -> Int
forall s a. s -> Getting a s a -> a
^. Getting Int Coord Int
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 Game -> (Game -> Game) -> Game
forall a b. a -> (a -> b) -> b
& (Board -> Identity Board) -> Game -> Identity Game
Lens' Game Board
board ((Board -> Identity Board) -> Game -> Identity Game)
-> (Board -> Board) -> Game -> Game
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ Board -> Board -> Board
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Board
blkMap
  where blk :: Block
blk    = Game
g Game -> Getting Block Game Block -> Block
forall s a. s -> Getting a s a -> a
^. Getting Block Game Block
Lens' Game Block
block
        blkMap :: Board
blkMap = [(Coord, Tetrimino)] -> Board
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Coord
c, Block
blk Block -> Getting Tetrimino Block Tetrimino -> Tetrimino
forall s a. s -> Getting a s a -> a
^. Getting Tetrimino Block Tetrimino
Lens' Block Tetrimino
shape) | Coord
c <- Block
blk Block -> Getting [Coord] Block [Coord] -> [Coord]
forall s a. s -> Getting a s a -> a
^. (Block -> [Coord]) -> Getting [Coord] Block [Coord]
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f 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 Game
-> Getting (Seq Tetrimino) Game (Seq Tetrimino) -> Seq Tetrimino
forall s a. s -> Getting a s a -> a
^. Getting (Seq Tetrimino) Game (Seq Tetrimino)
Lens' Game (Seq Tetrimino)
nextShapeBag)
  Game -> IO Game
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Game -> IO Game) -> Game -> IO Game
forall a b. (a -> b) -> a -> b
$
    Game
g Game -> (Game -> Game) -> Game
forall a b. a -> (a -> b) -> b
& (Block -> Identity Block) -> Game -> Identity Game
Lens' Game Block
block        ((Block -> Identity Block) -> Game -> Identity Game)
-> Block -> Game -> Game
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Tetrimino -> Block
initBlock (Game
g Game -> Getting Tetrimino Game Tetrimino -> Tetrimino
forall s a. s -> Getting a s a -> a
^. Getting Tetrimino Game Tetrimino
Lens' Game Tetrimino
nextShape)
      Game -> (Game -> Game) -> Game
forall a b. a -> (a -> b) -> b
& (Tetrimino -> Identity Tetrimino) -> Game -> Identity Game
Lens' Game Tetrimino
nextShape    ((Tetrimino -> Identity Tetrimino) -> Game -> Identity Game)
-> Tetrimino -> Game -> Game
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Tetrimino
t
      Game -> (Game -> Game) -> Game
forall a b. a -> (a -> b) -> b
& (Seq Tetrimino -> Identity (Seq Tetrimino))
-> Game -> Identity Game
Lens' Game (Seq Tetrimino)
nextShapeBag ((Seq Tetrimino -> Identity (Seq Tetrimino))
 -> Game -> Identity Game)
-> Seq Tetrimino -> Game -> Game
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 Game -> (Game -> Game) -> Game
forall a b. a -> (a -> b) -> b
& (Block -> Identity Block) -> Game -> Identity Game
Lens' Game Block
block ((Block -> Identity Block) -> Game -> Identity Game)
-> (Block -> Block) -> Game -> Game
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 Game -> Getting Board Game Board -> Board
forall s a. s -> Getting a s a -> a
^. Getting Board Game Board
Lens' Game Board
board) (Direction -> Block -> Block
forall s. Translatable s => Direction -> s -> s
translate Direction
d Block
b)
                          then Direction -> Block -> Block
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     = (Coord -> Board -> Bool) -> Board -> Coord -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Coord -> Board -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.notMember
isOccupied :: Board -> Coord -> Bool
isOccupied = (Coord -> Board -> Bool) -> Board -> Coord -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Coord -> Board -> Bool
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 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
x Bool -> Bool -> Bool
&& Int
x Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
boardWidth Bool -> Bool -> Bool
&& Int
1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
y
isOutOfBounds :: Coord -> Bool
isOutOfBounds = Bool -> Bool
not (Bool -> Bool) -> (Coord -> Bool) -> Coord -> Bool
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 = (Coord -> Bool) -> [Coord] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Coord -> Bool
validCoord ([Coord] -> Bool) -> (Block -> [Coord]) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> [Coord]
coords
  where validCoord :: Coord -> Bool
validCoord = Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> (Coord -> Bool) -> Coord -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Board -> Coord -> Bool
isFree Board
brd (Coord -> Bool -> Bool) -> (Coord -> Bool) -> Coord -> Bool
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 :: Seq a -> IO (Seq a)
shuffle Seq a
xs
  | Seq a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Seq a
xs   = IO (Seq a)
forall a. Monoid a => a
mempty
  | Bool
otherwise = do
      Int
randomPosition <- (StdGen -> (Int, StdGen)) -> IO Int
forall (m :: * -> *) a. MonadIO m => (StdGen -> (a, StdGen)) -> m a
getStdRandom ((Int, Int) -> StdGen -> (Int, StdGen)
forall a g. (Random a, RandomGen g) => (a, a) -> g -> (a, g)
randomR (Int
0, Seq a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Seq a
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      let (Seq a
left, Seq a
right) = Int -> Seq a -> (Seq a, Seq a)
forall a. Int -> Seq a -> (Seq a, Seq a)
Seq.splitAt Int
randomPosition Seq a
xs
          (a
y :< Seq a
ys)     = Seq a -> ViewL a
forall a. Seq a -> ViewL a
Seq.viewl Seq a
right
      (Seq a -> Seq a) -> IO (Seq a) -> IO (Seq a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (a
y a -> Seq a -> Seq a
forall a. a -> Seq a -> Seq a
<|) (Seq a -> IO (Seq a)
forall a. Seq a -> IO (Seq a)
shuffle (Seq a -> IO (Seq a)) -> Seq a -> IO (Seq a)
forall a b. (a -> b) -> a -> b
$ Seq a
left Seq a -> Seq a -> Seq a
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 :: (a -> Bool) -> a -> Maybe a
boolMaybe a -> Bool
p a
a = if a -> Bool
p a
a then a -> Maybe a
forall a. a -> Maybe a
Just a
a else Maybe a
forall a. Maybe a
Nothing

v2 :: (a, a) -> V2 a
v2 :: (a, a) -> V2 a
v2 (a
x, a
y) = a -> a -> V2 a
forall a. a -> a -> V2 a
V2 a
x a
y