An implementation of the classic 80s computer game TETЯIS, written in the programming language Forml.
Tetris.forml is an example of literate programming - the source when compiled generates this page. You can run the test suite to see the Jasmine test report, or just play Tetris.
The entire application will live in the tetris module in the global namespace. We're going to need forml's standard library, the prelude, as well as a number of sub modules: the data representation for the game will need additional functions from array module, and the html module for manipulating the UI.
module tetris
open prelude.string
open prelude
open prelude.html
open prelude.array
The order of import here is important - each open statement defines a new section, where subsequent opens shadow already imported symbols. Because some symbols in prelude.html are shadowed by those in prelude.array, we can bind the prelude.html to a record- typed symbol. This allows us to access all the symbols from prelude.html, as well as use the array symbol as a function parameter.
open prelude.html as html
Some basic constants describing the physical laws of Tetris.
n_rows = 19
n_columns = 9The Piece type is a type synonym - it declares a local alias which can be used to make the type signatures easier to read.
Piece = Array (Array Num)The classic Tetris pieces.
pieces: Array Piece =
let x = 0
o = -1
[ [ [ x ]
[ x ]
[ x ]
[ x ] ]
[ [ x, o ]
[ x, o ]
[ x, x ] ]
[ [ o, x ]
[ o, x ]
[ x, x ] ]
[ [ x, x ]
[ x, x ] ]
[ [ o, x, o ]
[ x, x, x ] ]
[ [ x, x, o ]
[ o, x, x ] ]
[ [ o, x, x ]
[ x, x, o ] ] ]
The valid piece colors.
colors = [ [ "#0C3555", "#08789E", "#76F61E", "#F7D909", "#E11E6A" ]
[ "#320010", "#74220F", "#B8A04E", "#E1D46C", "#80611D" ]
[ "#542437", "#53777A", "#C02942", "#D95B43", "#53777A" ] ]
The game state.
Board =
{ piece: Piece
board: Array (Array Num)
score: Num
timer: Num
level: Num
x: Num
y: Num }
When the Play Tetris button is clicked, the action bound to the symbol play is realized: the application's HTML UI is appended to the page, the game's state is initialized, and handlers are configured for the game's keyboard events & timing loop.
play = do
game <- game_template
board <- new_board
"body" $+ game
draw_board board
board 'move (-1) 0 'on_key 37
board 'rot 'on_key 38
board 'move 1 0 'on_key 39
board 'move 0 1 'on_key 40
There are a few pieces which currently require shelling out to Javascript.game_template is an action which fetches the blank HTML for the board background from an embedded script template (see source)
game_template = `jQuery("#game").html()`for controlling the tick rate, we'll need a way to interface with the javascript setInterval and clearInterval. set_timer is necessary because the prelude currently lacks a library for implementing type safe mutations.
every: Num -> JS _ -> JS Num
every n action = `setInterval(action, n)`
set_timer ref board = `board.timer = ref`
stop_timer { timer = x, _ } = `clearInterval(x)`
to_commas pretty prints the current score, using the the regex wrappers from the prelude.string module
to_commas: Num -> String | x =
let r = "(\\d)(?=(\\d\\d\\d)+(?!\\d))"
in x 'to_string 'replace (regex r "g") "$1,"
to_commas 1000 == "1,000"
new_board is a factory for generating a Board records representing a new game. New games need a random piece, so its type is JS Board to encapsulate this lack of referential transparency, though it performs no mutations.
new_board: JS Board = do
let new_row = yield -1 'times (n_columns + 1)
piece <- random_piece 0
board <- new_row 'times (n_rows + 1) 'sequence
return {
piece = piece
board = board
score = 0
timer = 0
level = 1
x = 3
y = 0
}Each instance of Board returned by new_board should have a clean state which matches the expected parameters of the game world.
(n_rows + 1) * (n_columns + 1) == do!
new_board 'fmap (sum .: map length .: .board)
For the main game loop, we simply thread this gamestate through each function which needs it. This makes testing convenient, since we can trivially recreate intermediate game states. The with_board combinator introduces a new gamestate into scope, and isolates test behavior by clearing timers which may have been created in f.
private
with_board f = do!
board <- new_board
let result = f board
stop_timer board
yield result
which lets us write quick tests that are guaranteed a clean gamestate:
with_board λ b = b.board 'length == n_rows + 1
with_board λ b = b.board 'get 0 'length == n_columns + 1It would be helpful to have a function for quickly asserting whether a point has a block.
inline at x y b = b 'get y 'get x /= -1Determining whether a particular game state is valid involves testing whether the current piece is within the dimensions of the game board, and whether it intersects any previously laid block. For clarity, these predicates are arranged as let bindings in the definition of is_valid, lazily evaluated inline annotations actually change the behavior of the function. If the predicates defined in the let block were not inline, is_valid would throw array-out-of-bounds exceptions on bounded-ness violating game states, since these predicates to && depend on the lazy evaluation of this function (as in javascript).
is_valid {board: board, piece: piece, x: x, y: y, _} =
x >= 0 && x_bound? && y_bound? && intersect?
where inline intersect? =
piece 'length 'by λ r =
piece 'get r 'length 'by λ c =
let piece? = piece 'at c r
board? = board 'at (x + c) (y + r)
not (piece? && board?)
inline x_bound? =
x + length (get 0 piece) <= n_columns + 1
inline y_bound? =
y + length piece <= n_rows + 1
by f n = 0 .. (n - 1) |> map f |> all?
We can use these in combination with tick to verify its expected behavior.
with_board is_valid
with_board λ board = do!
tick board 'times 45 'sequence
yield is_valid board
with_board λ board = do!
new_piece board
yield not (is_valid board)
with_board λ board = do!
tick board 'times 400 'sequence
yield not (is_valid board) draw_board board = do
"#score" $= to_commas board.score
"#level" $= board.level
"#board" $| "background-color" <: colors 'get (board.level - 1) 'get 0
"#board" $| "border-color" <: colors 'get (board.level - 1) 'get 1
stop_timer board
ref <- board 'tick 'every (0.7 ^ board.level * 400)
board 'set_timer refThe tick function itself is quite simple, and represents the game state update invoked at the game's speed interval.
tick board = do
`board.y += 1`
if not (is_valid board) then do
`board.y = board.y - 1`
new_piece board
clear_lines board
"#board" $= draw board
with_board λ board = do!
tick board
tick board
yield board.y == 2
with_board λ board =
let board_sim n = do
sequence (tick board 'times n)
yield sum <| map sum board.board
in do! before <- board_sim 16
after <- board_sim 5
yield before == -200 and after > -200Generate a random piece by selecting from pieces, then color it with a random color from the current palette.
random_piece: Num -> JS Piece | level = do
r <- rand (length pieces)
c <- rand (length (get level colors) - 2)
let piece = get r pieces
yield piece 'map (map λ 0 = c | _ = -1)
4 <= do! random_piece 0 'fmap (sum .: map sum .: map (map ((+) 1)))Rotate a piece 90 degrees. Although this function is pure, internally it mutates arrays for construction, so we've just left its return type JS Piece to reflect these side-effects.
rotate: Piece -> JS Piece | x =
var new_row acc piece index col =
if index < length piece then do
acc <- put (get col (get index piece)) acc
new_row acc piece (index + 1) col
else return do! reverse acc
sequence <| map (new_row [] x 0) (0 .. length (get 0 x) - 1)
get 3 pieces is
do! pieces 'get 3 'rotate
get 1 pieces is
do! pieces 'get 1 'rotate >>= rotate >>= rotate >>= rotate
get 4 pieces isnt
do! pieces 'get 4 'rotate >>= rotateMoving left, right and down is handled by move.
move:
Num -> Num -> Board -> JS Board
| x y board = do
`board.x += x`
`board.y += y`
if is_valid board
"#board" $= draw board
else do
`board.x = board.x - x`
`board.y = board.y - y`
yield board
with_board λ board = do!
board 'move 1 0
yield board.x == 4
with_board λ board = do!
board 'move 1 0 >>= tick 'times 20 'sequence
yield is_valid boardThe up key rotates the current piece
rot board = do
let old_piece = board.piece
rotated_piece <- rotate board.piece
`board.piece = rotated_piece`
if is_valid board
"#board" $= draw board
else
`board.piece = old_piece`
with_board λ board = do!
orig <- clone board
rot board 'times 4 'sequence
yield orig == boardOnce a piece has hit the bottom, we need to cement it to the game board, then generate a new game piece and update the game's state.
new_piece board = do
board.piece 'for_each λ row = do!
get row board.piece 'for_each λ col = do!
if board.piece 'at col row
&& (board.y + row <= n_rows + 1)
&& (board.x + col <= n_columns + 1)
board.piece 'get row 'get col 'paint board (board.y + row) (board.x + col)
new_piece <- random_piece (board.level - 1)
`board.piece = new_piece`
`board.x = 3`
`board.y = 0`Check for lines, and update the game state if the player has made a line.
clear_lines board =
board.board 'for_each λ row = do!
if reduce (&&) (map (λx = x != -1) (get row board.board))
clear_row board row
with_board λ board = do!
let line = 5 'times (n_columns + 1)
`board.board[9] = line`
clear_lines board
yield board.score == 100
&& sum (map sum board.board) == -200Once a full row has been found, we call clear_row to update the state of the board, moving all of the blocks above down and incrementing the score.
clear_row: Board -> Num -> JS {} | board x = do
`board.score += 100`
if board.score % 1000 == 0
`board.level += 1`
draw_board board
ignore <: sequence <: x .. 1 'map λ row =
board.board 'get row 'for_each λ col = do!
board.board 'get (row - 1)
'get col
'paint board row col
with_board λ board = do!
let line = 5 'times (n_columns + 1)
`board.board[9] = line`
clear_row board 9
yield board.score == 100
&& sum (map sum board.board) == -200
The paint function encapsulates the mutation of a single cell on the board. Forml currently does not support mutation natively in any way except through the Javascript FFI, and these calls are tracked through the type system as the JS a type.
inline paint board x y color =
`board.board[x][y] = color`
inline
block_string:
Num -> Num -> String -> String
| x y color =
let style =
"top:`y*30`px;
left:`x*30`px;
background-color:`color`;"
in "<div style='`style`' class='cell'></div>"
draw: Board -> String
draw { board: board, piece: piece, x: bx, y: by, level = level, _ } =
0 .. n_rows
'map λ_ = 0 .. n_columns
'zip_with draw_row (0 .. n_rows)
'concat
where draw_row x = concat .: map ((') x) .: map draw_block
draw_block x y when board 'at x y =
let color = colors 'get (level - 1) 'get (2 + (board 'get y 'get x))
block_string x y color
draw_block x y when piece_bounds? x y =
let c_idx = piece 'get (y - by) 'get (x - bx)
color = colors 'get (level - 1) 'get (c_idx + 2)
block_string x y color
draw_block _ _ = ""
inline piece_bounds? x y =
x - bx >= 0
&& x - bx < piece 'get 0 'length
&& y - by >= 0
&& y - by < length piece
&& piece 'at (x - bx) (y - by)