adding contrib/tetris, a simple tetris clone
chapman.alex
parent
fdc18acf5d
commit
939030904d
|
|
@ -0,0 +1,26 @@
|
|||
This is a simple tetris game. To play, open factor (in GUI mode), and run:
|
||||
|
||||
"contrib/tetris" require
|
||||
USING: tetris-gadget tetris ;
|
||||
tetris-window
|
||||
|
||||
This should open a new window with a running tetris game. The commands are:
|
||||
|
||||
left, right arrows: move the current piece left or right
|
||||
up arrow: rotate the piece clockwise
|
||||
down arrow: lower the piece one row
|
||||
space bar: drop the piece
|
||||
p: pause/unpause
|
||||
n: start a new game
|
||||
q: quit (currently just stops updating, see TODO)
|
||||
|
||||
Running tetris-window will leave a tetris-gadget on your stack. To get your
|
||||
current score you can do:
|
||||
|
||||
tetris-gadget-tetris tetris-score
|
||||
|
||||
TODO:
|
||||
- close the window on quit
|
||||
- rotation of pieces when they're on the far right of the board
|
||||
- show the score and level, maybe floating about the screen somewhere
|
||||
- make blocks prettier
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
! Copyright (C) 2006 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
|
||||
REQUIRES: contrib/lazy-lists ;
|
||||
|
||||
PROVIDE: contrib/tetris {
|
||||
"tetris-colours.factor" "tetromino.factor" "tetris-piece.factor"
|
||||
"tetris-board.factor" "tetris.factor" "tetris-gl.factor"
|
||||
"tetris-gadget.factor"
|
||||
} {
|
||||
"test/tetris-piece.factor" "test/tetris-board.factor" "test/tetris.factor"
|
||||
} ;
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
USING: kernel tetris-colours tetris-board tetris-piece test arrays ;
|
||||
|
||||
[ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test
|
||||
[ { { f f } { f f } { f f } } ] [ 2 3 <board> board-rows ] unit-test
|
||||
[ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
|
||||
[ f ] [ 2 3 <board> { 1 1 } board-block ] unit-test
|
||||
[ 2 3 <board> { 2 3 } board-block ] unit-test-fails
|
||||
red 1array [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } board-block ] unit-test
|
||||
[ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test
|
||||
[ f ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } block-free? ] unit-test
|
||||
[ t ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 2 } block-free? ] unit-test
|
||||
[ t ] [ 2 3 <board> dup { 1 1 } red board-set-block { 0 1 } block-free? ] unit-test
|
||||
[ t ] [ 2 3 <board> { 0 0 } block-in-bounds? ] unit-test
|
||||
[ f ] [ 2 3 <board> { -1 0 } block-in-bounds? ] unit-test
|
||||
[ t ] [ 2 3 <board> { 1 2 } block-in-bounds? ] unit-test
|
||||
[ f ] [ 2 3 <board> { 2 2 } block-in-bounds? ] unit-test
|
||||
[ t ] [ 2 3 <board> { 1 1 } location-valid? ] unit-test
|
||||
[ f ] [ 2 3 <board> dup { 1 1 } red board-set-block { 1 1 } location-valid? ] unit-test
|
||||
[ t ] [ 10 10 <board> 10 <random-piece> piece-valid? ] unit-test
|
||||
[ f ] [ 2 3 <board> 10 <random-piece> { 1 2 } over set-piece-location piece-valid? ] unit-test
|
||||
[ { { f } { f } } ] [ 1 1 <board> dup add-row board-rows ] unit-test
|
||||
[ { { f } } ] [ 1 2 <board> dup { 0 1 } red board-set-block dup remove-full-rows board-rows ] unit-test
|
||||
[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } red board-set-block dup check-rows drop board-rows ] unit-test
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
USING: kernel tetromino tetris-piece test sequences arrays namespaces ;
|
||||
|
||||
! Tests for tetromino and tetris-piece, since there's not much to test in tetromino
|
||||
|
||||
! these two tests rely on the first rotation of the first tetromino being the
|
||||
! 'I' tetromino in its vertical orientation.
|
||||
[ 4 ] [ tetrominoes get first tetromino-states first blocks-width ] unit-test
|
||||
[ 1 ] [ tetrominoes get first tetromino-states first blocks-height ] unit-test
|
||||
|
||||
[ { 0 0 } ] [ random-tetromino <piece> piece-location ] unit-test
|
||||
[ 0 ] [ 10 <random-piece> piece-rotation ] unit-test
|
||||
|
||||
[ { { 0 0 } { 1 0 } { 2 0 } { 3 0 } } ]
|
||||
[ tetrominoes get first <piece> piece-blocks ] unit-test
|
||||
|
||||
[ { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } ]
|
||||
[ tetrominoes get first <piece> dup 1 rotate-piece piece-blocks ] unit-test
|
||||
|
||||
[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ]
|
||||
[ tetrominoes get first <piece> dup { 1 1 } move-piece piece-blocks ] unit-test
|
||||
|
||||
[ 3 ] [ tetrominoes get second <piece> piece-width ] unit-test
|
||||
[ 2 ] [ tetrominoes get second <piece> dup 1 rotate-piece piece-width ] unit-test
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
USING: kernel tetris tetris-board tetris-piece test sequences ;
|
||||
|
||||
[ t ] [ <default-tetris> dup tetris-current-piece swap tetris-next-piece and t f ? ] unit-test
|
||||
[ t ] [ <default-tetris> { 1 1 } can-move? ] unit-test
|
||||
[ t ] [ <default-tetris> { 1 1 } tetris-move ] unit-test
|
||||
[ 1 ] [ <default-tetris> dup { 1 1 } tetris-move drop tetris-current-piece piece-location second ] unit-test
|
||||
[ 1 ] [ <default-tetris> tetris-level ] unit-test
|
||||
[ 1 ] [ <default-tetris> 9 over set-tetris-rows tetris-level ] unit-test
|
||||
[ 2 ] [ <default-tetris> 10 over set-tetris-rows tetris-level ] unit-test
|
||||
[ 0 ] [ 3 0 rows-score ] unit-test
|
||||
[ 80 ] [ 1 1 rows-score ] unit-test
|
||||
[ 4800 ] [ 3 4 rows-score ] unit-test
|
||||
[ 1 5 rows-score ] unit-test-fails
|
||||
[ 1 ] [ <default-tetris> dup 3 score-rows dup 3 score-rows dup 3 score-rows tetris-level ] unit-test
|
||||
[ 2 ] [ <default-tetris> dup 4 score-rows dup 4 score-rows dup 2 score-rows tetris-level ] unit-test
|
||||
|
||||
|
|
@ -0,0 +1,59 @@
|
|||
! Copyright (C) 2006 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences arrays tetris-piece math ;
|
||||
IN: tetris-board
|
||||
|
||||
TUPLE: board width height rows ;
|
||||
|
||||
: make-rows ( width height -- rows )
|
||||
[ drop f <array> ] map-with ;
|
||||
|
||||
C: board ( width height -- board )
|
||||
>r 2dup make-rows r>
|
||||
[ set-board-rows ] keep
|
||||
[ set-board-height ] keep
|
||||
[ set-board-width ] keep ;
|
||||
|
||||
#! A block is simply an array of form { x y } where { 0 0 } is the top-left of
|
||||
#! the tetris board, and { 9 19 } is the bottom right on a 10x20 board.
|
||||
|
||||
: board@block ( board block -- n row )
|
||||
[ second swap board-rows nth ] keep first swap ;
|
||||
|
||||
: board-set-block ( board block colour -- ) -rot board@block set-nth ;
|
||||
|
||||
: board-block ( board block -- colour ) board@block nth ;
|
||||
|
||||
: block-free? ( board block -- ? ) board-block not ;
|
||||
|
||||
: block-in-bounds? ( board block -- ? )
|
||||
[ first swap board-width bounds-check? ] 2keep
|
||||
second swap board-height bounds-check? and ;
|
||||
|
||||
: location-valid? ( board block -- ? )
|
||||
2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ;
|
||||
|
||||
: piece-valid? ( board piece -- ? )
|
||||
piece-blocks [ location-valid? ] all-with? ;
|
||||
|
||||
: row-not-full? ( row -- ? ) f swap member? ;
|
||||
|
||||
: add-row ( board -- )
|
||||
dup board-rows over board-width f <array>
|
||||
add* swap set-board-rows ;
|
||||
|
||||
: top-up-rows ( board -- )
|
||||
dup board-height over board-rows length = [
|
||||
drop
|
||||
] [
|
||||
dup add-row top-up-rows
|
||||
] if ;
|
||||
|
||||
: remove-full-rows ( board -- )
|
||||
dup board-rows [ row-not-full? ] subset swap set-board-rows ;
|
||||
|
||||
: check-rows ( board -- n )
|
||||
#! remove full rows, then add blank ones at the top, returning the number
|
||||
#! of rows removed (and added)
|
||||
dup remove-full-rows dup board-height over board-rows length - >r top-up-rows r> ;
|
||||
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2006 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays ;
|
||||
IN: tetris-colours
|
||||
|
||||
: red { 0.941 0 0 1 } ; inline
|
||||
: grey { 0.5 0.5 0.5 1 } ; inline
|
||||
: black { 0 0 0 1 } ; inline
|
||||
: yellow { 0.941 0.941 0 1 } ; inline
|
||||
: orange { 0.941 0.627 0 1 } ; inline
|
||||
: green { 0 0.941 0 1 } ; inline
|
||||
: blue { 0 0 0.941 1 } ; inline
|
||||
: magenta { 0.941 0 0.941 1 } ; inline
|
||||
: cyan { 0 0.941 0.941 1 } ; inline
|
||||
: purple { 0.627 0 0.941 1 } ; inline
|
||||
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! Copyright (C) 2006 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel generic gadgets tetris tetris-gl sequences threads arrays ;
|
||||
IN: tetris-gadget
|
||||
|
||||
TUPLE: tetris-gadget tetris quit? ;
|
||||
|
||||
C: tetris-gadget ( tetris -- gadget )
|
||||
[ set-tetris-gadget-tetris ] keep
|
||||
[ f swap set-tetris-gadget-quit? ] keep
|
||||
[ delegate>gadget ] keep ;
|
||||
|
||||
M: tetris-gadget pref-dim* drop { 200 400 } ;
|
||||
|
||||
M: tetris-gadget draw-gadget* ( gadget -- )
|
||||
! TODO: show score, level, etc.
|
||||
dup rect-dim dup first swap second rot tetris-gadget-tetris draw-tetris ;
|
||||
|
||||
: new-tetris ( gadget -- )
|
||||
dup tetris-gadget-tetris <new-tetris> swap set-tetris-gadget-tetris ;
|
||||
|
||||
tetris-gadget H{
|
||||
{ T{ key-down f f "ESCAPE" } [ t swap set-tetris-gadget-quit? ] }
|
||||
{ T{ key-down f f "q" } [ t swap set-tetris-gadget-quit? ] }
|
||||
{ T{ key-down f f "UP" } [ tetris-gadget-tetris rotate ] }
|
||||
{ T{ key-down f f "LEFT" } [ tetris-gadget-tetris move-left ] }
|
||||
{ T{ key-down f f "RIGHT" } [ tetris-gadget-tetris move-right ] }
|
||||
{ T{ key-down f f "DOWN" } [ tetris-gadget-tetris move-down ] }
|
||||
{ T{ key-down f f " " } [ tetris-gadget-tetris move-drop ] }
|
||||
{ T{ key-down f f "p" } [ tetris-gadget-tetris toggle-pause ] }
|
||||
{ T{ key-down f f "n" } [ new-tetris ] }
|
||||
} set-gestures
|
||||
|
||||
: tetris-process ( gadget -- )
|
||||
dup tetris-gadget-quit? [
|
||||
10 sleep
|
||||
dup tetris-gadget-tetris maybe-update
|
||||
[ relayout-1 ] keep
|
||||
tetris-process
|
||||
] unless ;
|
||||
|
||||
M: tetris-gadget graft* ( gadget -- )
|
||||
f over set-tetris-gadget-quit?
|
||||
[ tetris-process ] in-thread drop ;
|
||||
|
||||
M: tetris-gadget ungraft* ( gadget -- )
|
||||
t swap set-tetris-gadget-quit? ;
|
||||
|
||||
: tetris-window ( -- ) <default-tetris> <tetris-gadget> dup "Tetris" open-titled-window ;
|
||||
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
! Copyright (C) 2006 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences arrays math namespaces opengl gadgets tetris tetris-board tetris-piece tetromino ;
|
||||
IN: tetris-gl
|
||||
|
||||
#! OpenGL rendering for tetris
|
||||
|
||||
: draw-block ( block -- )
|
||||
dup { 1 1 } v+ gl-fill-rect ;
|
||||
|
||||
: draw-piece-blocks ( piece -- )
|
||||
piece-blocks [ draw-block ] each ;
|
||||
|
||||
: draw-piece ( piece -- )
|
||||
dup tetromino-colour gl-color draw-piece-blocks ;
|
||||
|
||||
: draw-next-piece ( piece -- )
|
||||
dup tetromino-colour clone 0.1 3 pick set-nth gl-color draw-piece-blocks ;
|
||||
|
||||
! TODO: move implementation specific stuff into tetris-board
|
||||
: (draw-row) ( y row x -- y )
|
||||
swap dupd nth [ gl-color over 2array draw-block ] [ drop ] if* ;
|
||||
|
||||
: draw-row ( y row -- )
|
||||
dup length [ (draw-row) ] each-with drop ;
|
||||
|
||||
: draw-board ( board -- )
|
||||
board-rows dup length [ tuck swap nth draw-row ] each-with ;
|
||||
|
||||
: scale-tetris ( width height tetris -- )
|
||||
[ board-width swap ] keep board-height / -rot / swap 1 glScalef ;
|
||||
|
||||
: (draw-tetris) ( width height tetris -- )
|
||||
#! width and height are in pixels
|
||||
GL_MODELVIEW [
|
||||
[ scale-tetris ] keep
|
||||
GL_COLOR_BUFFER_BIT glClear
|
||||
dup tetris-board draw-board
|
||||
dup tetris-next-piece draw-next-piece
|
||||
tetris-current-piece draw-piece
|
||||
] do-matrix ;
|
||||
|
||||
: draw-tetris ( width height tetris -- )
|
||||
origin get [ (draw-tetris) ] with-translation ;
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
! Copyright (C) 2006 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel generic arrays tetromino math sequences lazy-lists ;
|
||||
IN: tetris-piece
|
||||
|
||||
#! A piece adds state to the tetromino that is the piece's delegate. The
|
||||
#! rotation is an index into the tetromino's states array, and the position is
|
||||
#! added to the tetromino's blocks to give them their location on the tetris
|
||||
#! board. If the location is f then the piece is not yet on the board.
|
||||
TUPLE: piece rotation location ;
|
||||
|
||||
C: piece ( tetromino -- piece )
|
||||
[ set-delegate ] keep
|
||||
0 over set-piece-rotation
|
||||
{ 0 0 } over set-piece-location ;
|
||||
|
||||
: (piece-blocks) ( piece -- blocks )
|
||||
#! rotates the tetromino
|
||||
dup tetromino-states swap piece-rotation swap nth ;
|
||||
|
||||
: piece-blocks ( piece -- blocks )
|
||||
#! rotates and positions the tetromino
|
||||
dup piece-location swap (piece-blocks) [ v+ ] map-with ;
|
||||
|
||||
: piece-width ( piece -- width )
|
||||
piece-blocks blocks-width ;
|
||||
|
||||
: set-start-location ( piece board-width -- )
|
||||
2 / floor over piece-width 2 / floor - 0 2array swap set-piece-location ;
|
||||
|
||||
: <random-piece> ( board-width -- piece )
|
||||
random-tetromino <piece> [ swap set-start-location ] keep ;
|
||||
|
||||
: <piece-llist> ( board-width -- llist )
|
||||
[ [ <random-piece> ] curry ] keep [ <piece-llist> ] curry lazy-cons ;
|
||||
|
||||
: modulo ( n m -- n )
|
||||
#! -2 7 mod => -2, -2 7 modulo => 5
|
||||
tuck mod over + swap mod ;
|
||||
|
||||
: rotate-piece ( piece inc -- )
|
||||
over piece-rotation + over tetromino-states length modulo swap set-piece-rotation ;
|
||||
|
||||
: move-piece ( piece move -- )
|
||||
over piece-location v+ swap set-piece-location ;
|
||||
|
||||
|
|
@ -0,0 +1,114 @@
|
|||
! Copyright (C) 2006 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel generic sequences math tetris-board tetris-piece tetromino errors lazy-lists ;
|
||||
IN: tetris
|
||||
|
||||
TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
|
||||
|
||||
: default-width 10 ; inline
|
||||
: default-height 20 ; inline
|
||||
|
||||
C: tetris ( width height -- tetris )
|
||||
>r <board> r> [ set-delegate ] keep
|
||||
dup board-width <piece-llist> over set-tetris-pieces
|
||||
0 over set-tetris-last-update
|
||||
0 over set-tetris-rows
|
||||
0 over set-tetris-score
|
||||
f over set-tetris-paused?
|
||||
t over set-tetris-running? ;
|
||||
|
||||
: <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
|
||||
|
||||
: <new-tetris> ( old -- new )
|
||||
[ board-width ] keep board-height <tetris> ;
|
||||
|
||||
: tetris-board ( tetris -- board ) delegate ;
|
||||
|
||||
: tetris-current-piece ( tetris -- piece ) tetris-pieces car ;
|
||||
|
||||
: tetris-next-piece ( tetris -- piece ) tetris-pieces cdr car ;
|
||||
|
||||
: toggle-pause ( tetris -- )
|
||||
dup tetris-paused? not swap set-tetris-paused? ;
|
||||
|
||||
: tetris-level ( tetris -- level )
|
||||
tetris-rows 1+ 10 / ceiling ;
|
||||
|
||||
: tetris-update-interval ( tetris -- interval )
|
||||
tetris-level 1- 60 * 1000 swap - ;
|
||||
|
||||
: add-block ( tetris block -- )
|
||||
over tetris-current-piece tetromino-colour board-set-block ;
|
||||
|
||||
: game-over? ( tetris -- ? )
|
||||
dup dup tetris-next-piece piece-valid? ;
|
||||
|
||||
: new-current-piece ( tetris -- )
|
||||
game-over? [
|
||||
dup tetris-pieces cdr swap set-tetris-pieces
|
||||
] [
|
||||
f swap set-tetris-running?
|
||||
] if ;
|
||||
|
||||
: rows-score ( level n -- score )
|
||||
{
|
||||
{ [ dup 0 = ] [ drop 0 ] }
|
||||
{ [ dup 1 = ] [ drop 40 ] }
|
||||
{ [ dup 2 = ] [ drop 100 ] }
|
||||
{ [ dup 3 = ] [ drop 300 ] }
|
||||
{ [ dup 4 = ] [ drop 1200 ] }
|
||||
{ [ t ] [ "how did you clear that many rows?" throw ] }
|
||||
} cond swap 1+ * ;
|
||||
|
||||
: add-score ( tetris score -- )
|
||||
over tetris-score + swap set-tetris-score ;
|
||||
|
||||
: score-rows ( tetris n -- )
|
||||
2dup >r dup tetris-level r> rows-score add-score
|
||||
over tetris-rows + swap set-tetris-rows ;
|
||||
|
||||
: lock-piece ( tetris -- )
|
||||
[ dup tetris-current-piece piece-blocks [ add-block ] each-with ] keep
|
||||
dup new-current-piece dup check-rows score-rows ;
|
||||
|
||||
: can-rotate? ( tetris -- ? )
|
||||
dup tetris-current-piece clone dup 1 rotate-piece piece-valid? ;
|
||||
|
||||
: (rotate) ( inc tetris -- )
|
||||
dup can-rotate? [ tetris-current-piece swap rotate-piece ] [ 2drop ] if ;
|
||||
|
||||
: rotate ( tetris -- ) 1 swap (rotate) ;
|
||||
|
||||
: can-move? ( tetris move -- ? )
|
||||
>r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
|
||||
|
||||
: tetris-move ( tetris move -- ? )
|
||||
#! moves the piece if possible, returns whether the piece was moved
|
||||
2dup can-move? [
|
||||
>r tetris-current-piece r> move-piece t
|
||||
] [
|
||||
2drop f
|
||||
] if ;
|
||||
|
||||
: move-left ( tetris -- ) { -1 0 } tetris-move drop ;
|
||||
|
||||
: move-right ( tetris -- ) { 1 0 } tetris-move drop ;
|
||||
|
||||
: move-down ( tetris -- )
|
||||
dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ;
|
||||
|
||||
: move-drop ( tetris -- )
|
||||
dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
|
||||
|
||||
: can-move? ( tetris move -- ? )
|
||||
>r dup tetris-current-piece clone dup r> move-piece piece-valid? ;
|
||||
|
||||
: update ( tetris -- )
|
||||
millis over tetris-last-update -
|
||||
over tetris-update-interval > [
|
||||
dup move-down
|
||||
millis swap set-tetris-last-update
|
||||
] [ drop ] if ;
|
||||
|
||||
: maybe-update ( tetris -- )
|
||||
dup tetris-paused? over tetris-running? not or [ drop ] [ update ] if ;
|
||||
|
|
@ -0,0 +1,113 @@
|
|||
! Copyright (C) 2006 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays namespaces sequences math tetris-colours ;
|
||||
IN: tetromino
|
||||
|
||||
TUPLE: tetromino states colour ;
|
||||
|
||||
SYMBOL: tetrominoes
|
||||
|
||||
{
|
||||
[
|
||||
{ {
|
||||
{ 0 0 } { 1 0 } { 2 0 } { 3 0 }
|
||||
}
|
||||
{ { 0 0 }
|
||||
{ 0 1 }
|
||||
{ 0 2 }
|
||||
{ 0 3 }
|
||||
}
|
||||
} cyan
|
||||
] [
|
||||
{
|
||||
{ { 1 0 }
|
||||
{ 0 1 } { 1 1 } { 2 1 }
|
||||
} {
|
||||
{ 0 0 }
|
||||
{ 0 1 } { 1 1 }
|
||||
{ 0 2 }
|
||||
} {
|
||||
{ 0 0 } { 1 0 } { 2 0 }
|
||||
{ 1 1 }
|
||||
} {
|
||||
{ 1 0 }
|
||||
{ 0 1 } { 1 1 }
|
||||
{ 1 2 }
|
||||
}
|
||||
} purple
|
||||
] [
|
||||
{ { { 0 0 } { 1 0 }
|
||||
{ 0 1 } { 1 1 } }
|
||||
} yellow
|
||||
] [
|
||||
{
|
||||
{ { 0 0 } { 1 0 } { 2 0 }
|
||||
{ 0 1 }
|
||||
} {
|
||||
{ 0 0 } { 1 0 }
|
||||
{ 1 1 }
|
||||
{ 1 2 }
|
||||
} {
|
||||
{ 2 0 }
|
||||
{ 0 1 } { 1 1 } { 2 1 }
|
||||
} {
|
||||
{ 0 0 }
|
||||
{ 0 1 }
|
||||
{ 0 2 } { 1 2 }
|
||||
}
|
||||
} orange
|
||||
] [
|
||||
{
|
||||
{ { 0 0 } { 1 0 } { 2 0 }
|
||||
{ 2 1 }
|
||||
} {
|
||||
{ 1 0 }
|
||||
{ 1 1 }
|
||||
{ 0 2 } { 1 2 }
|
||||
} {
|
||||
{ 0 0 }
|
||||
{ 0 1 } { 1 1 } { 2 1 }
|
||||
} {
|
||||
{ 0 0 } { 1 0 }
|
||||
{ 0 1 }
|
||||
{ 0 2 }
|
||||
}
|
||||
} blue
|
||||
] [
|
||||
{
|
||||
{ { 1 0 } { 2 0 }
|
||||
{ 0 1 } { 1 1 }
|
||||
} {
|
||||
{ 0 0 }
|
||||
{ 0 1 } { 1 1 }
|
||||
{ 1 2 }
|
||||
}
|
||||
} green
|
||||
] [
|
||||
{
|
||||
{
|
||||
{ 0 0 } { 1 0 }
|
||||
{ 1 1 } { 2 1 }
|
||||
} {
|
||||
{ 1 0 }
|
||||
{ 0 1 } { 1 1 }
|
||||
{ 0 2 }
|
||||
}
|
||||
} red
|
||||
]
|
||||
} [ call <tetromino> ] map tetrominoes set-global
|
||||
|
||||
: random-tetromino ( -- tetromino )
|
||||
tetrominoes get dup length random-int swap nth ;
|
||||
|
||||
: blocks-max ( blocks quot -- max )
|
||||
! add 1 to each block since they are 0 indexed
|
||||
! [ 1+ ] append map 0 [ max ] reduce ;
|
||||
map [ 1+ ] map 0 [ max ] reduce ;
|
||||
|
||||
: blocks-width ( blocks -- width )
|
||||
[ first ] blocks-max ;
|
||||
|
||||
: blocks-height ( blocks -- height )
|
||||
[ second ] blocks-max ;
|
||||
|
||||
Loading…
Reference in New Issue