% 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}