--- /dev/null
+This is a simple tetris game. To play, open factor (in GUI mode), and run:
+
+"tetris" run
+
+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
+
+TODO:
+- rotation of pieces when they're on the far right of the board
+- make blocks prettier
+- possibly make piece inherit from tetromino
--- /dev/null
+Alex Chapman
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: accessors arrays colors kernel tetris.board tetris.piece tools.test ;
+
+[ { { f f } { f f } { f f } } ] [ 2 3 make-rows ] unit-test
+[ { { f f } { f f } { f f } } ] [ 2 3 <board> rows>> ] unit-test
+[ 1 { f f } ] [ 2 3 <board> { 1 1 } board@block ] unit-test
+[ f ] [ 2 3 <board> { 1 1 } block ] unit-test
+[ 2 3 <board> { 2 3 } block ] must-fail
+red 1array [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block ] unit-test
+[ t ] [ 2 3 <board> { 1 1 } block-free? ] unit-test
+[ f ] [ 2 3 <board> dup { 1 1 } red set-block { 1 1 } block-free? ] unit-test
+[ t ] [ 2 3 <board> dup { 1 1 } red set-block { 1 2 } block-free? ] unit-test
+[ t ] [ 2 3 <board> dup { 1 1 } red 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 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 } >>location piece-valid? ] unit-test
+[ { { f } { f } } ] [ 1 1 <board> add-row rows>> ] unit-test
+[ { { f } } ] [ 1 2 <board> dup { 0 1 } red set-block remove-full-rows rows>> ] unit-test
+[ { { f } { f } } ] [ 1 2 <board> dup { 0 1 } red set-block dup check-rows drop rows>> ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel math sequences tetris.piece ;
+IN: tetris.board
+
+TUPLE: board { width integer } { height integer } rows ;
+
+: make-rows ( width height -- rows )
+ [ drop f <array> ] with map ;
+
+: <board> ( width height -- board )
+ 2dup make-rows board boa ;
+
+#! 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 rows>> nth ] keep first swap ;
+
+: set-block ( board block colour -- ) -rot board@block set-nth ;
+
+: block ( board block -- colour ) board@block nth ;
+
+: block-free? ( board block -- ? ) block not ;
+
+: block-in-bounds? ( board block -- ? )
+ [ first swap width>> bounds-check? ] 2keep
+ second swap 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? ] with all? ;
+
+: row-not-full? ( row -- ? ) f swap member? ;
+
+: add-row ( board -- board )
+ dup rows>> over width>> f <array> prefix >>rows ;
+
+: top-up-rows ( board -- )
+ dup height>> over rows>> length = [
+ drop
+ ] [
+ add-row top-up-rows
+ ] if ;
+
+: remove-full-rows ( board -- board )
+ [ [ row-not-full? ] filter ] change-rows ;
+
+: check-rows ( board -- n )
+ #! remove full rows, then add blank ones at the top, returning the number
+ #! of rows removed (and added)
+ remove-full-rows dup height>> over rows>> length - swap top-up-rows ;
+
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-compiler? t }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Tetris" }
+}
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: accessors kernel tetris.game tetris.board tetris.piece tools.test
+sequences ;
+
+[ t ] [ <default-tetris> [ current-piece ] [ next-piece ] bi 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 current-piece location>> second ] unit-test
+[ 1 ] [ <default-tetris> level>> ] unit-test
+[ 1 ] [ <default-tetris> 9 >>rows level>> ] unit-test
+[ 2 ] [ <default-tetris> 10 >>rows 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 ] [ <default-tetris> dup 3 score-rows dup 3 score-rows dup 3 score-rows level>> ] unit-test
+[ 2 ] [ <default-tetris> dup 4 score-rows dup 4 score-rows dup 2 score-rows level>> ] unit-test
+
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators kernel lists math math.functions sequences system tetris.board tetris.piece tetris.tetromino ;
+IN: tetris.game
+
+TUPLE: tetris
+ { board board }
+ { pieces }
+ { last-update integer initial: 0 }
+ { rows integer initial: 0 }
+ { score integer initial: 0 }
+ { paused? initial: f }
+ { running? initial: t } ;
+
+: default-width 10 ; inline
+: default-height 20 ; inline
+
+: <tetris> ( width height -- tetris )
+ dupd <board> swap <piece-llist>
+ tetris new swap >>pieces swap >>board ;
+
+: <default-tetris> ( -- tetris ) default-width default-height <tetris> ;
+
+: <new-tetris> ( old -- new )
+ board>> [ width>> ] [ height>> ] bi <tetris> ;
+
+: current-piece ( tetris -- piece ) pieces>> car ;
+
+: next-piece ( tetris -- piece ) pieces>> cdr car ;
+
+: toggle-pause ( tetris -- )
+ [ not ] change-paused? drop ;
+
+: level>> ( tetris -- level )
+ rows>> 1+ 10 / ceiling ;
+
+: update-interval ( tetris -- interval )
+ level>> 1- 60 * 1000 swap - ;
+
+: add-block ( tetris block -- )
+ over board>> spin current-piece tetromino>> colour>> set-block ;
+
+: game-over? ( tetris -- ? )
+ [ board>> ] [ next-piece ] bi piece-valid? not ;
+
+: new-current-piece ( tetris -- tetris )
+ dup game-over? [
+ f >>running?
+ ] [
+ [ cdr ] change-pieces
+ ] if ;
+
+: rows-score ( level n -- score )
+ {
+ { 0 [ 0 ] }
+ { 1 [ 40 ] }
+ { 2 [ 100 ] }
+ { 3 [ 300 ] }
+ { 4 [ 1200 ] }
+ } case swap 1+ * ;
+
+: add-score ( tetris n-rows -- tetris )
+ over level>> swap rows-score swap [ + ] change-score ;
+
+: add-rows ( tetris rows -- tetris )
+ swap [ + ] change-rows ;
+
+: score-rows ( tetris n -- )
+ [ add-score ] keep add-rows drop ;
+
+: lock-piece ( tetris -- )
+ [ dup current-piece piece-blocks [ add-block ] with each ] keep
+ new-current-piece dup board>> check-rows score-rows ;
+
+: can-rotate? ( tetris -- ? )
+ [ board>> ] [ current-piece clone 1 rotate-piece ] bi piece-valid? ;
+
+: (rotate) ( inc tetris -- )
+ dup can-rotate? [ current-piece swap rotate-piece drop ] [ 2drop ] if ;
+
+: rotate-left ( tetris -- ) -1 swap (rotate) ;
+
+: rotate-right ( tetris -- ) 1 swap (rotate) ;
+
+: can-move? ( tetris move -- ? )
+ [ drop board>> ] [ [ current-piece clone ] dip move-piece ] 2bi piece-valid? ;
+
+: tetris-move ( tetris move -- ? )
+ #! moves the piece if possible, returns whether the piece was moved
+ 2dup can-move? [
+ >r current-piece r> move-piece drop 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 ;
+
+: update ( tetris -- )
+ millis over last-update>> -
+ over update-interval > [
+ dup move-down
+ millis >>last-update
+ ] when drop ;
+
+: ?update ( tetris -- )
+ dup [ paused?>> ] [ running?>> not ] bi or [ drop ] [ update ] if ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators kernel math math.vectors namespaces opengl opengl.gl sequences tetris.board tetris.game tetris.piece ui.render tetris.tetromino ui.gadgets ;
+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>> set-color draw-piece-blocks ;
+
+: draw-next-piece ( piece -- )
+ dup tetromino>> colour>>
+ clone 0.2 >>alpha set-color draw-piece-blocks ;
+
+! TODO: move implementation specific stuff into tetris-board
+: (draw-row) ( x y row -- )
+ >r over r> nth dup
+ [ set-color 2array draw-block ] [ 3drop ] if ;
+
+: draw-row ( y row -- )
+ dup length -rot [ (draw-row) ] 2curry each ;
+
+: draw-board ( board -- )
+ rows>> dup length swap
+ [ dupd nth draw-row ] curry each ;
+
+: scale-board ( width height board -- )
+ [ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ;
+
+: (draw-tetris) ( width height tetris -- )
+ #! width and height are in pixels
+ GL_MODELVIEW [
+ {
+ [ board>> scale-board ]
+ [ board>> draw-board ]
+ [ next-piece draw-next-piece ]
+ [ current-piece draw-piece ]
+ } cleave
+ ] do-matrix ;
+
+: draw-tetris ( width height tetris -- )
+ origin get [ (draw-tetris) ] with-translation ;
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: accessors kernel tetris.tetromino tetris.piece tools.test sequences arrays namespaces ;
+
+! Tests for tetris.tetromino and tetris.piece, since there's not much to test in tetris.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 states>> first blocks-width ] unit-test
+[ 1 ] [ tetrominoes get first states>> first blocks-height ] unit-test
+
+[ { 0 0 } ] [ random-tetromino <piece> location>> ] unit-test
+[ 0 ] [ 10 <random-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> 1 rotate-piece piece-blocks ] unit-test
+
+[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ]
+[ tetrominoes get first <piece> { 1 1 } move-piece piece-blocks ] unit-test
+
+[ 3 ] [ tetrominoes get second <piece> piece-width ] unit-test
+[ 2 ] [ tetrominoes get second <piece> 1 rotate-piece piece-width ] unit-test
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel math math.vectors sequences tetris.tetromino lists.lazy ;
+IN: tetris.piece
+
+#! 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
+ { tetromino tetromino }
+ { rotation integer initial: 0 }
+ { location array initial: { 0 0 } } ;
+
+: <piece> ( tetromino -- piece )
+ piece new swap >>tetromino ;
+
+: (piece-blocks) ( piece -- blocks )
+ #! rotates the piece
+ [ rotation>> ] [ tetromino>> states>> ] bi nth ;
+
+: piece-blocks ( piece -- blocks )
+ #! rotates and positions the piece
+ [ (piece-blocks) ] [ location>> ] bi [ v+ ] curry map ;
+
+: piece-width ( piece -- width )
+ piece-blocks blocks-width ;
+
+: set-start-location ( piece board-width -- piece )
+ over piece-width [ 2 /i ] bi@ - 0 2array >>location ;
+
+: <random-piece> ( board-width -- piece )
+ random-tetromino <piece> swap set-start-location ;
+
+: <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) ( rotation inc n-states -- rotation' )
+ [ + ] dip modulo ;
+
+: rotate-piece ( piece inc -- piece )
+ over tetromino>> states>> length
+ [ (rotate-piece) ] 2curry change-rotation ;
+
+: move-piece ( piece move -- piece )
+ [ v+ ] curry change-location ;
--- /dev/null
+Graphical Tetris game
--- /dev/null
+demos
+applications
+games
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alarms arrays calendar kernel make math math.geometry.rect math.parser namespaces sequences system tetris.game tetris.gl ui.gadgets ui.gadgets.labels ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui ;
+IN: tetris
+
+TUPLE: tetris-gadget < gadget { tetris tetris } { alarm } ;
+
+: <tetris-gadget> ( tetris -- gadget )
+ tetris-gadget new-gadget swap >>tetris ;
+
+M: tetris-gadget pref-dim* drop { 200 400 } ;
+
+: update-status ( gadget -- )
+ dup tetris>> [
+ "Level: " % dup level>> #
+ " Score: " % score>> #
+ ] "" make swap show-status ;
+
+M: tetris-gadget draw-gadget* ( gadget -- )
+ [
+ dup rect-dim [ first ] [ second ] bi rot tetris>> draw-tetris
+ ] keep update-status ;
+
+: new-tetris ( gadget -- gadget )
+ [ <new-tetris> ] change-tetris ;
+
+tetris-gadget H{
+ { T{ key-down f f "UP" } [ tetris>> rotate-right ] }
+ { T{ key-down f f "d" } [ tetris>> rotate-left ] }
+ { T{ key-down f f "f" } [ tetris>> rotate-right ] }
+ { T{ key-down f f "e" } [ tetris>> rotate-left ] } ! dvorak d
+ { T{ key-down f f "u" } [ tetris>> rotate-right ] } ! dvorak f
+ { T{ key-down f f "LEFT" } [ tetris>> move-left ] }
+ { T{ key-down f f "RIGHT" } [ tetris>> move-right ] }
+ { T{ key-down f f "DOWN" } [ tetris>> move-down ] }
+ { T{ key-down f f " " } [ tetris>> move-drop ] }
+ { T{ key-down f f "p" } [ tetris>> toggle-pause ] }
+ { T{ key-down f f "n" } [ new-tetris drop ] }
+} set-gestures
+
+: tick ( gadget -- )
+ [ tetris>> ?update ] [ relayout-1 ] bi ;
+
+M: tetris-gadget graft* ( gadget -- )
+ [ [ tick ] curry 100 milliseconds every ] keep (>>alarm) ;
+
+M: tetris-gadget ungraft* ( gadget -- )
+ [ cancel-alarm f ] change-alarm drop ;
+
+: tetris-window ( -- )
+ [
+ <default-tetris> <tetris-gadget>
+ "Tetris" open-status-window
+ ] with-ui ;
+
+MAIN: tetris-window
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2006, 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel arrays namespaces sequences math math.vectors
+colors random ;
+IN: tetris.tetromino
+
+TUPLE: tetromino states colour ;
+
+C: <tetromino> tetromino
+
+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 random ;
+
+: blocks-max ( blocks quot -- max )
+ map [ 1+ ] map supremum ; inline
+
+: blocks-width ( blocks -- width )
+ [ first ] blocks-max ;
+
+: blocks-height ( blocks -- height )
+ [ second ] blocks-max ;
+
+++ /dev/null
-This is a simple tetris game. To play, open factor (in GUI mode), and run:
-
-"tetris" run
-
-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
-
-TODO:
-- rotation of pieces when they're on the far right of the board
-- make blocks prettier
+++ /dev/null
-Alex Chapman
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: kernel tetris.board tetris.piece tools.test arrays
-colors ;
-
-[ { { 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 ] must-fail
-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
-! Copyright (C) 2006, 2007 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> ] with map ;
-
-: <board> ( width height -- board )
- 2dup make-rows board boa ;
-
-#! 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? ] with all? ;
-
-: row-not-full? ( row -- ? ) f swap member? ;
-
-: add-row ( board -- )
- dup board-rows over board-width f <array>
- prefix 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? ] filter 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
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Tetris" }
-}
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: kernel tetris.game tetris.board tetris.piece tools.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 ] [ <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, 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math math.functions tetris.board
-tetris.piece tetris.tetromino lists combinators system ;
-IN: tetris.game
-
-TUPLE: tetris pieces last-update update-interval rows score game-state paused? running? ;
-
-: default-width 10 ; inline
-: default-height 20 ; inline
-
-: <tetris> ( width height -- tetris )
- <board> tetris construct-delegate
- 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 tetris-next-piece piece-valid? not ;
-
-: new-current-piece ( tetris -- )
- dup game-over? [
- f swap set-tetris-running?
- ] [
- dup tetris-pieces cdr swap set-tetris-pieces
- ] if ;
-
-: rows-score ( level n -- score )
- {
- { 0 [ 0 ] }
- { 1 [ 40 ] }
- { 2 [ 100 ] }
- { 3 [ 300 ] }
- { 4 [ 1200 ] }
- } case 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 ] with each ] 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-left ( tetris -- ) -1 swap (rotate) ;
-
-: rotate-right ( 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 ;
-
-: 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
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2006, 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences arrays math math.vectors namespaces
-opengl opengl.gl ui.render ui.gadgets tetris.game tetris.board
-tetris.piece tetris.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.2 3 pick set-nth gl-color draw-piece-blocks ;
-
-! TODO: move implementation specific stuff into tetris-board
-: (draw-row) ( x y row -- )
- >r over r> nth dup
- [ gl-color 2array draw-block ] [ 3drop ] if ;
-
-: draw-row ( y row -- )
- dup length -rot [ (draw-row) ] 2curry each ;
-
-: draw-board ( board -- )
- board-rows dup length swap
- [ dupd nth draw-row ] curry each ;
-
-: 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
- 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
-Alex Chapman
+++ /dev/null
-USING: kernel tetris.tetromino tetris.piece tools.test sequences arrays namespaces ;
-
-! Tests for tetris.tetromino and tetris.piece, since there's not much to test in tetris.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
-! Copyright (C) 2006, 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays tetris.tetromino math math.vectors
-sequences quotations lists.lazy ;
-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 ;
-
-: <piece> ( tetromino -- piece )
- piece construct-delegate
- 0 over set-piece-rotation
- { 0 0 } over set-piece-location ;
-
-: (piece-blocks) ( piece -- blocks )
- #! rotates the tetromino
- dup piece-rotation swap tetromino-states nth ;
-
-: piece-blocks ( piece -- blocks )
- #! rotates and positions the tetromino
- dup (piece-blocks) swap piece-location [ v+ ] curry map ;
-
-: piece-width ( piece -- width )
- piece-blocks blocks-width ;
-
-: set-start-location ( piece board-width -- )
- 2 /i over piece-width 2 /i - 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
-Graphical Tetris game
+++ /dev/null
-demos
-applications
-games
+++ /dev/null
-! Copyright (C) 2006, 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: alarms arrays calendar kernel ui.gadgets ui.gadgets.labels
-ui.gadgets.worlds ui.gadgets.status-bar ui.gestures ui.render ui
-tetris.game tetris.gl sequences system math math.parser namespaces
-math.geometry.rect ;
-IN: tetris
-
-TUPLE: tetris-gadget tetris alarm ;
-
-: <tetris-gadget> ( tetris -- gadget )
- tetris-gadget construct-gadget
- [ set-tetris-gadget-tetris ] keep ;
-
-M: tetris-gadget pref-dim* drop { 200 400 } ;
-
-: update-status ( gadget -- )
- dup tetris-gadget-tetris [
- "Level: " % dup tetris-level #
- " Score: " % tetris-score #
- ] "" make swap show-status ;
-
-M: tetris-gadget draw-gadget* ( gadget -- )
- [
- dup rect-dim dup first swap second rot tetris-gadget-tetris draw-tetris
- ] keep update-status ;
-
-: new-tetris ( gadget -- )
- dup tetris-gadget-tetris <new-tetris> swap set-tetris-gadget-tetris ;
-
-tetris-gadget H{
- { T{ key-down f f "UP" } [ tetris-gadget-tetris rotate-right ] }
- { T{ key-down f f "d" } [ tetris-gadget-tetris rotate-left ] }
- { T{ key-down f f "f" } [ tetris-gadget-tetris rotate-right ] }
- { T{ key-down f f "e" } [ tetris-gadget-tetris rotate-left ] } ! dvorak d
- { T{ key-down f f "u" } [ tetris-gadget-tetris rotate-right ] } ! dvorak f
- { 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
-
-: tick ( gadget -- )
- dup tetris-gadget-tetris maybe-update relayout-1 ;
-
-M: tetris-gadget graft* ( gadget -- )
- dup [ tick ] curry 100 milliseconds every
- swap set-tetris-gadget-alarm ;
-
-M: tetris-gadget ungraft* ( gadget -- )
- [ tetris-gadget-alarm cancel-alarm f ] keep set-tetris-gadget-alarm ;
-
-: tetris-window ( -- )
- [
- <default-tetris> <tetris-gadget>
- "Tetris" open-status-window
- ] with-ui ;
-
-MAIN: tetris-window
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2006, 2007 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays namespaces sequences math math.vectors
-colors random ;
-IN: tetris.tetromino
-
-TUPLE: tetromino states colour ;
-
-C: <tetromino> tetromino
-
-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 random ;
-
-: blocks-max ( blocks quot -- max )
- map [ 1+ ] map supremum ; inline
-
-: blocks-width ( blocks -- width )
- [ first ] blocks-max ;
-
-: blocks-height ( blocks -- height )
- [ second ] blocks-max ;
-
projects / factor.git / commitdiff