hetris-0.1: src/Board.lhs

% vim: set tw=72:

% Part of Hetris

\section{Board: Concrete implementation}

Again, and as always, the header is the same as that of the abstract specification:

\begin{code}
module Board (Board, create_board, get_changes, can_down, next_piece) where

import Data
import Pieces
\end{code}

The concrete implementation we will use here will be based around
Haskell's \hstype{Array} type. This will allow us to write clear, simple
code to get and overwrite the state of a board. We thus also need to
include the \hsmodule{Array} module.

\begin{code}
import Data.Array
\end{code}

In this simplified variant of the game each square of the board either
contains a block or it doesn't; therefore we can use a \hstype{Bool} to
represent whether a square has a block in it or not. The playing area is
then represented by an array of these, indexed by 2-d coordinates of
\hstype{Vector}s. The actual \hstype{Board} type also keeps track of the
current active piece as well as its coordinates. In both cases the $x$
coordinate is the first \hstype{Vector} and $(0, 0)$ is the upper left
corner as usual.

\begin{code}
type Block = Bool
type PlayingArea = Array (Vector, Vector) Block
data Board = Board PlayingArea Piece Vector Vector
\end{code}

We will start the implementation with some utility functions. First we
provide an augmented version of the \hsfunction{blocks} function
exported by the \hsmodule{Pieces} module. This takes the relative block
positions of the piece as returned by \hsfunction{blocks} and adds them
to a position which it also takes as arguments; this gives a list of
absolute positions of blocks. It then filters the list to extract only
the coordinates that are in the range of the playing area array passed;
this means that if a piece is not entirely within the playing area, and
remember that when a piece first appears it may legitimately be off the
top of the playing area, then we won't ask the user interface to draw
blocks outside of the area it has allocated for the playing area.

Next we define a function \hsfunction{alter\_blocks} that builds on
this. It takes the same arguments and additionally a (curried) function
that takes an $x$ and $y$ coordinate and returns a \hstype{Change}; it
then applies this function to all of the coordinate pairs to produce a
list of \hstype{Change}s. It is no coincidence that the
\hsconstructor{On} and \hsconstructor{Off} constructors have this type,
and we further define functions \hsfunction{on} and \hsfunction{off}
which can be used to create the list of changes needed to turn all the
blocks of a given piece at a given location on and off respectively.

\begin{code}
restricted_blocks :: PlayingArea -> Piece -> Vector -> Vector -> [(Vector, Vector)]
restricted_blocks a p x y = filter (inRange (bounds a)) [ (x+off_x, y+off_y) | (off_x, off_y) <- blocks p ]

alter_blocks :: (Vector -> Vector -> Change)
             -> PlayingArea -> Piece -> Vector -> Vector
             -> [Change]
alter_blocks f a p x y = map (uncurry f) (restricted_blocks a p x y)

on :: PlayingArea -> Piece -> Vector -> Vector -> [Change]
on = alter_blocks On
off :: PlayingArea -> Piece -> Vector -> Vector -> [Change]
off = alter_blocks Off
\end{code}

A playing area of width $w$ and height $h$ has squares indexed from
$(0, 0)$ up to $(w-1, h-1)$, and initially none of these contain a
block. The \hsfunction{create\_board} function creates an array with the
appropriate range of indices all containing \hsconstructor{False}. The
first component of the result tuple, the \hstype{Board}, is then built
from this \hstype{Array} and the piece that was passed, which is placed
at the middle of the top row as required by the abstract specification.

The second component of the result tuple, the list of \hstype{Change}s
the user interface will have to perform, is the result of turning on all
of the blocks used by the piece in its initial position.

\begin{code}
create_board :: Vector -> Vector -> Piece -> (Board, [Change])
create_board width height p = (b, on a p (width `div` 2) 0)
    where a = listArray ((0,0), (width-1,height-1)) (repeat False)
          b = Board a p (width `div` 2) 0
\end{code}

The \hsfunction{get\_changes} function performs different tasks
depending on what \hstype{Event} it is passed. Probably the simplest
cases are those where the active piece is just moved one square down,
left or right. In these cases we first check, using functions we will
define shortly, that we can move in the specified direction. If we can
then the changes needed in the user interface are to turn off all the
blocks of the piece where it currently is and then turn on all the
blocks where it moves to. The new \hstype{Board} returned is the same as
the one passed but with the coordinates of the piece suitably updated.
If a \hsconstructor{Tick} event gets this far then it must correspond to
the active piece moving down as it would have been caught earlier if it
signals the next piece.

\begin{code}
get_changes :: Board -> Event -> (Board, [Change])
get_changes b@(Board a p x y) MDown
 | can_down b = (Board a p x (y + 1), off a p x y ++ on a p x (y + 1))
get_changes b@(Board a p x y) MLeft
 | can_left b = (Board a p (x - 1) y, off a p x y ++ on a p (x - 1) y)
get_changes b@(Board a p x y) MRight
 | can_right b = (Board a p (x + 1) y, off a p x y ++ on a p (x + 1) y)
get_changes b Tick = get_changes b MDown
\end{code}

We can handle \hsconstructor{Drop} by, if we can move the piece down,
first acting as if we had been given a \hsconstructor{MDown} event. We
then take the \hstype{Board} this returns and recursively consider what
happens if we deal with a \hsconstructor{Drop} event on it. We return
the \hstype{Board} returned and both lists of changes concatenated in
order.

\begin{code}
get_changes b Drop
 | can_down b = (b'', cs1 ++ cs2)
    where (b', cs1) = get_changes b MDown
          (b'', cs2) = get_changes b' Drop
\end{code}

The code for rotating both left and right is very similar so is best
handled by a generic function; we therefore define \hsfunction{rotate},
as shown shortly, which we pass a function which manipulates a piece in
the appropriate way, i.e., rotates it left or right, and the
\hstype{Board} we were passed.

\begin{code}
get_changes b RotL = rotate rot_left b
get_changes b RotR = rotate rot_right b
\end{code}

%If we get a \hsconstructor{Redraw} event then the board is unchanged.
%There are two parts to the changes we make to the user interface; first
%of all we redraw the information help in the playing area array and then
%we draw the active piece in its current location. The first part updates
%every single square of the playing field, but sometimes with the wrong
%value. The second part corrects any incorrect values.
%
%The first part can be done by taking the list of associations, i.e.,
%pairs whose first component is the coordinates of a square and second
%component is a \hstype{Bool} indicating whether or not it is on, and
%mapping a function that generates the appropriate \hstype{Change} for
%such a pair across it.
%
%The second part simply requires us to turn the blocks for the piece on
%as normal.
%
%\begin{code}
%get_changes b@(Board a p x y) Redraw = (b, cs_board ++ cs_piece)
%    where cs_board = map (\(xy, is_on) -> uncurry (if is_on then On else Off) xy) (assocs a)
%          cs_piece = on a p x y
%\end{code}

We have handled every case where the board change or changes need to be
generated for the user interface. Therefore for any other event we just
return the same board we were passed and the empty list of changes.

\begin{code}
get_changes b _ = (b, [])
\end{code}

We now have some promises to fulfil; let us start with the definition of
\hsfunction{rotate}. We pass it a function that manipulates a piece in
the desired way followed by a \hstype{Board}. If the \hstype{Piece} in
the \hstype{Board} when acted upon by the rotate function `fits', as
defined by a function we, if you'll forgive the nested promise, will
define in just a few lines, then we return the board with the piece in
its new orientation and the changes list turns off the blocks used by
the piece in its previous position and turns on those corresponding to
its new position; all in all it is very similar to the movement events
except the piece also changes.

If it doesn't fit then we do nothing, as \hsfunction{get\_changes} does.

\begin{code}
rotate :: (Piece -> Piece) -> Board -> (Board, [Change])
rotate f (Board a p x y)
 | fits b' = (b', off a p x y ++ on a p' x y)
    where p' = f p
          b' = Board a p' x y
rotate _ b = (b, [])
\end{code}

As promised, we continue with a definition of \hsfunction{fits}. We take
a \hstype{Board} and, in essence, return a \hstype{Bool} indicating
whether or not the \hstype{Piece} in the \hstype{Board} `fits'; that is
to say, we return \hsconstructor{True} if it doesn't lie on top of any
blocks already in the playing area and it doesn't stick out of the top,
left or right of the playing area. We allow it to stick out of the top.
The astute reader will have noticed that we need to make a yet deeper
nested promise, this time to define \hsfunction{not\_collides} that
checks that the \hstype{Piece} in a \hstype{Board} doesn't overlap any
blocks in the \hstype{Board}'s playing area.

\begin{code}
fits :: Board -> Bool
fits b@(Board a p x y) = not_collides b
                    && y + extent_down  p <= (snd $ snd $ bounds a)
                    && x - extent_left  p >= (fst $ fst $ bounds a)
                    && x + extent_right p <= (fst $ snd $ bounds a)
\end{code}

For this latest promise we take the blocks occupied by the
\hstype{Piece}, restricted to the playing area, and take the value of
the array at each coordinate. If any of them are \hsconstructor{True}
then there is a collision so we return \hsconstructor{False}; otherwise
we return \hsconstructor{True}.

\begin{code}
not_collides :: Board -> Bool
not_collides (Board a p x y) = not $ or $ map (a!) $ restricted_blocks a p x y
\end{code}

Having completed this chain of promises we still have one
outstanding---to define the functions to test whether the active piece
can be moved down, left and right. If you've been keeping a close eye on
things then you'll have noticed that one of these is exactly what is
exported to decide which is the applicable behaviour upon getting a
\hsconstructor{Tick} event.

\begin{code}
can_down, can_left, can_right :: Board -> Bool
can_down  (Board a p x y) = fits (Board a p x (y+1))
can_left  (Board a p x y) = fits (Board a p (x-1) y)
can_right (Board a p x y) = fits (Board a p (x+1) y)
\end{code}

This leaves one exported function remaining---the one that deals with
one piece coming to rest, completed lines being removed and the new
active piece being added in.

The first step is to update the playing area with the blocks of the
piece that is coming to rest. To do this we use the $(//)$ operator,
zipping the absolute position of the blocks within the playing area with
an infinite list of \hsconstructor{True}s to produce the list of new
associations to add.

Second we we use the \hsfunction{drop\_complete\_lines}, that (you
guessed it!) we will define next, to produce a tuple of the array after complete
lines have been removed and the changes the user interface will need to
show the user this.

For the returned board we take this final array and put the piece on
with its key point at the initial square. If it doesn't overlap with any
existing blocks in this position then we wrap it with
\hsconstructor{Just} and return it; otherwise we return
\hsconstructor{Nothing}. The second component of the result, the list of
changes, is composed of the changes needed to drop the complete lines
followed by the changes needed to turn on the blocks of the new active
piece.

\begin{code}
next_piece :: Board -> Piece -> (Maybe Board, [Change])
next_piece (Board a p x y) p' = (if not_collides b' then Just b' else Nothing, cs ++ on a'' p' x' y')
    where a' = a // zip (restricted_blocks a p x y) (repeat True)
          (a'', cs) = drop_complete_lines a'
          b' = Board a'' p' x' y'
          ((xmin, ymin), (xmax, _)) = bounds a
          x' = (xmin + xmax) `div` 2
          y' = ymin
\end{code}

All that is left is for us to define \hsfunction{drop\_complete\_lines}.
This is really just a header function for
\hsfunction{drop\_complete\_lines'} which does the hard work; all we do
here is to extract the range of $x$ values we will have to check for
each row and the list of $y$ values corresponding to rows to be checked.
We reverse the second list as we want to drop rows from the bottom up.

\begin{code}
drop_complete_lines :: PlayingArea -> (PlayingArea, [Change])
drop_complete_lines a = drop_complete_lines' xs (reverse ys) a
    where ((xmin, ymin), (xmax, ymax)) = bounds a
          xs = range (xmin, xmax)
          ys = range (ymin, ymax)
\end{code}

Then \hsfunction{drop\_complete\_lines'} recurses down the list of rows
to be checked. If the list is empty then trivially the array is
unchanged and the user interface need perform no changes. Otherwise we
first consider the first row in the list. If for each $x$ value the
array has \hsconstructor{True} for this $y$ value then we need to remove
this row; otherwise we continue with a recursive call on the rest of
the list.

To remove row $y$ we first turn off all of the squares on that row and
then pause for the user to appreciate what has happened. Then we move
all the rows above that row down a row and make the top row empty,
passing the active playing area along and collecting up the changes
lists. Then there is another delay before finally we recursively call
ourselves; note that we need to check row $y$ again as it now contains
what was the row above.

\begin{code}
drop_complete_lines' :: [Vector] -> [Vector] -> PlayingArea
                   -> (PlayingArea, [Change])
drop_complete_lines' _ [] a = (a, [])
drop_complete_lines' xs (y:ys) a = if and [ a!(x, y) | x <- xs ]
                                   then (a''', cs1 ++ [Delay] ++ cs2 ++ cs3 ++ [Delay] ++ cs4)
                                   else drop_complete_lines' xs ys a
    where cs1 = [ Off x y | x <- xs ]
          (a', cs2) = move_down a xs ys
          (a'', cs3) = empty_top_row a' xs
          (a''', cs4) = drop_complete_lines' xs (y:ys) a''
\end{code}

There are two helper functions left undefined; the first,
\hsfunction{move\_down}, is intended to move a region of squares down one
row. The list of changes needed for this is build by considering each
square in the region and generating an on or off event depending on
whether or not it has a block in it; the event acts on the square below,
i.e., with $y$ value on greater, though. The array is overriden in an
analogous way.

\begin{code}
move_down :: PlayingArea -> [Vector] -> [Vector] -> (PlayingArea, [Change])
move_down a xs ys = (a', cs)
    where cs = [ (if a!(x, y) then On else Off) x (y + 1) | y <- ys, x <- xs ]
          a' = a // [ ((x, y + 1), a!(x, y)) | y <- ys, x <- xs ]
\end{code}

The final function to define simple sets the top row to be empty of all
blocks. Thus for each $x$ value it sets the corresponding square in the
top row to be off and updates the array similarly.

\begin{code}
empty_top_row :: PlayingArea -> [Vector] -> (PlayingArea, [Change])
empty_top_row a xs = (a', cs)
    where cs = [ Off x 0 | x <- xs ]
          a' = a // [ ((x, 0), False) | x <- xs ]
\end{code}