// initialize state
fall-timer 5 . default-fall-timer 5 . block-id 0 . falling-shape-id 0 . max-width 10 . max-height 20
// spawn a shape that will fall, if one doesn't already exist
#update . !shape _X _Y _BLOCKS . falling-shape-id ID . + ID 1 ID' = falling-shape-id ID' . #new-shape
#update . $shape _X _Y _BLOCKS = #input-u
// define available shapes and where they spawn
#new-shape . $max-height H = new-shape 4 H ((block -1 0) ((block 0 0) ((block 1 0) ((block 0 1) (cons))))) . #shape-to-blocks (#input-lr)
#new-shape . $max-height H = new-shape 4 H ((block 0 -2) ((block 0 -1) ((block 0 0) ((block 0 1) (cons))))) . #shape-to-blocks (#input-lr)
#new-shape . $max-height H = new-shape 4 H ((block 0 -1) ((block 0 0) ((block 0 1) ((block 1 1) (cons))))) . #shape-to-blocks (#input-lr)
// this stage is the beginning of the sequence of stages that places the blocks defined by a shape.
// placing these blocks is either the result of a new shape being spawned at the top of the screen,
// or an existing falling shape being moved or rotated. in the second case we move and rotate by
// clearing any existing blocks and spawning a new set of blocks at updated positions.
#shape-to-blocks RETURN: {
// clear existing falling blocks
block-falling _ID _X _Y = ()
// prepare to spawn new blocks defined by the shape
$new-shape _X _Y BLOCKS . !BLOCKS = BLOCKS
() = #shape-to-blocks-create RETURN
}
// this stage spawns 'falling' blocks defined by the shape
#shape-to-blocks-create RETURN: {
$new-shape X Y _ . (block DX DY) BLOCK . block-id ID . + ID 1 ID' . + X DX X' . + Y DY Y' = block-falling ID X' Y' . block-id ID' . BLOCK
() = #shape-to-blocks-check RETURN
}
// this stage aborts the placement of blocks if any constraint is violated
#shape-to-blocks-check RETURN . block-falling _ X Y . $block-set _ _ X Y = #shape-to-blocks-fail RETURN
#shape-to-blocks-check RETURN . block-falling _ X _ . < X 0 = #shape-to-blocks-fail RETURN
#shape-to-blocks-check RETURN . block-falling _ X _ . $max-width W . >= X W = #shape-to-blocks-fail RETURN
#shape-to-blocks-check RETURN . () = #shape-to-blocks-ok RETURN
// in this stage placement of blocks succeeded, so the new shape becomes a falling shape
#shape-to-blocks-ok RETURN: {
shape _ _ _ = ()
new-shape X Y BLOCKS . () = shape X Y BLOCKS . RETURN
}
// in this stage placement of blocks from the new shape failed, so we return to the previous falling shape
#shape-to-blocks-fail RETURN: {
new-shape _ _ _ = ()
$shape X Y BLOCKS . () = new-shape X Y BLOCKS . #shape-to-blocks RETURN
}
// rotate the shape if the up arrow key is pressed
#input-u . ^key-pressed up = #rotate-shape
#input-u . () = #input-lr
#rotate-shape: {
$shape X Y BLOCKS . !new-shape X Y _ = new-shape X Y BLOCKS . new-blocks (cons)
new-shape X Y ((block DX DY) BLOCKS) . new-blocks BLOCKS2 . + DX2 DX 0 = new-shape X Y BLOCKS . new-blocks ((block DY DX2) BLOCKS2)
new-shape X Y _ . new-blocks BLOCKS . () = new-shape X Y BLOCKS . #shape-to-blocks (#input-d)
}
// move the shape horizontally if the left or right arrow key is pressed
#input-lr . ^key-pressed left . $shape X Y BLOCKS . - X 1 X' = new-shape X' Y BLOCKS . #shape-to-blocks (#input-d)
#input-lr . ^key-pressed right . $shape X Y BLOCKS . + X 1 X' = new-shape X' Y BLOCKS . #shape-to-blocks (#input-d)
#input-lr . () = #input-d
// move the shape down faster than normal if the down arrow key is pressed
#input-d: {
^key-down down . default-fall-timer 5 . fall-timer _ = default-fall-timer 1 . fall-timer 0
^key-up down . default-fall-timer 1 . fall-timer _ = default-fall-timer 5 . fall-timer 0
() = #collision
}
// if any falling blocks are about to collide with any set blocks or the bottom of the screen, the
// falling blocks should become set blocks.
#collision: {
block-falling ID X Y . + Y' 1 Y . $block-set _ _ X Y' = block-setting ID X Y
block-falling ID X Y . + Y' 1 Y . < Y' 0 = block-setting ID X Y
$block-setting _ _ _ . block-falling ID X' Y' = block-setting ID X' Y'
$block-setting _ _ _ . shape _ _ _ = ()
() = #set
}
#set: {
block-setting ID X Y . $falling-shape-id SHAPE_ID = block-set ID SHAPE_ID X Y
$max-width W . () = #score-x . score-counter W 0
}
// mark completed rows for clearing
#score-x . score-counter X Y . + X' 1 X . $block-set _ _ X' Y = score-counter X' Y . #score-x
#score-x . score-counter 0 Y = #clear . clear-y Y
#score-x . $score-counter _ _ . () = #score-y
#score-y . score-counter _ Y . + Y 1 Y' . $max-width W . $max-height H . < Y' H = score-counter W Y' . #score-x
#score-y . score-counter _ _ . () = #fall-tick
// this stage clears blocks in any completed rows
#clear: {
$clear-y Y . block-set _ _ _ Y = ()
block-clear-move _ = ()
() = #clear-move
}
// this stage moves down any blocks hanging in space as a result of clearing completed rows
#clear-move: {
$clear-y Y . block-set ID SHAPE_ID X Y' . !block-clear-move ID . > Y' Y . - Y' 1 Y'' = block-set ID SHAPE_ID X Y'' . block-clear-move ID
$max-width W . clear-y _ . () = #score-x . score-counter W 0
}
// move blocks down every TIMER frames
#fall-tick . fall-timer TIMER . >= TIMER 0 . + TIMER2 1 TIMER . >= TIMER2 0 = fall-timer TIMER2 . #clean
#fall-tick . fall-timer TIMER . >= TIMER 0 . + TIMER2 1 TIMER . < TIMER2 0 . $default-fall-timer D = fall-timer D . #fall
#fall . shape X Y BLOCKS . + Y' 1 Y = new-shape X Y' BLOCKS . #shape-to-blocks #clean
#fall . () = #clean
#clean: {
cons = ()
}