--- /dev/null
+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
--- /dev/null
+! 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"
+} ;
--- /dev/null
+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
--- /dev/null
+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
--- /dev/null
+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
+
--- /dev/null
+! 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> ;
+
--- /dev/null
+! 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
+
--- /dev/null
+! 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 ;
+
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
+
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
+
projects / factor.git / commitdiff