From: chapman.alex Date: Thu, 19 Oct 2006 22:03:11 +0000 (+0000) Subject: adding contrib/tetris, a simple tetris clone X-Git-Tag: 0.85~3 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=939030904d57f2b96662e2ba43fad6a63057424f adding contrib/tetris, a simple tetris clone --- diff --git a/contrib/tetris/README.txt b/contrib/tetris/README.txt new file mode 100644 index 0000000000..49d3b6a628 --- /dev/null +++ b/contrib/tetris/README.txt @@ -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 diff --git a/contrib/tetris/load.factor b/contrib/tetris/load.factor new file mode 100644 index 0000000000..644b0a4949 --- /dev/null +++ b/contrib/tetris/load.factor @@ -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" +} ; diff --git a/contrib/tetris/test/tetris-board.factor b/contrib/tetris/test/tetris-board.factor new file mode 100644 index 0000000000..2b2fdec855 --- /dev/null +++ b/contrib/tetris/test/tetris-board.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-rows ] unit-test +[ 1 { f f } ] [ 2 3 { 1 1 } board@block ] unit-test +[ f ] [ 2 3 { 1 1 } board-block ] unit-test +[ 2 3 { 2 3 } board-block ] unit-test-fails +red 1array [ 2 3 dup { 1 1 } red board-set-block { 1 1 } board-block ] unit-test +[ t ] [ 2 3 { 1 1 } block-free? ] unit-test +[ f ] [ 2 3 dup { 1 1 } red board-set-block { 1 1 } block-free? ] unit-test +[ t ] [ 2 3 dup { 1 1 } red board-set-block { 1 2 } block-free? ] unit-test +[ t ] [ 2 3 dup { 1 1 } red board-set-block { 0 1 } block-free? ] unit-test +[ t ] [ 2 3 { 0 0 } block-in-bounds? ] unit-test +[ f ] [ 2 3 { -1 0 } block-in-bounds? ] unit-test +[ t ] [ 2 3 { 1 2 } block-in-bounds? ] unit-test +[ f ] [ 2 3 { 2 2 } block-in-bounds? ] unit-test +[ t ] [ 2 3 { 1 1 } location-valid? ] unit-test +[ f ] [ 2 3 dup { 1 1 } red board-set-block { 1 1 } location-valid? ] unit-test +[ t ] [ 10 10 10 piece-valid? ] unit-test +[ f ] [ 2 3 10 { 1 2 } over set-piece-location piece-valid? ] unit-test +[ { { f } { f } } ] [ 1 1 dup add-row board-rows ] unit-test +[ { { f } } ] [ 1 2 dup { 0 1 } red board-set-block dup remove-full-rows board-rows ] unit-test +[ { { f } { f } } ] [ 1 2 dup { 0 1 } red board-set-block dup check-rows drop board-rows ] unit-test diff --git a/contrib/tetris/test/tetris-piece.factor b/contrib/tetris/test/tetris-piece.factor new file mode 100644 index 0000000000..bd3055ecdb --- /dev/null +++ b/contrib/tetris/test/tetris-piece.factor @@ -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-location ] unit-test +[ 0 ] [ 10 piece-rotation ] unit-test + +[ { { 0 0 } { 1 0 } { 2 0 } { 3 0 } } ] +[ tetrominoes get first piece-blocks ] unit-test + +[ { { 0 0 } { 0 1 } { 0 2 } { 0 3 } } ] +[ tetrominoes get first dup 1 rotate-piece piece-blocks ] unit-test + +[ { { 1 1 } { 2 1 } { 3 1 } { 4 1 } } ] +[ tetrominoes get first dup { 1 1 } move-piece piece-blocks ] unit-test + +[ 3 ] [ tetrominoes get second piece-width ] unit-test +[ 2 ] [ tetrominoes get second dup 1 rotate-piece piece-width ] unit-test diff --git a/contrib/tetris/test/tetris.factor b/contrib/tetris/test/tetris.factor new file mode 100644 index 0000000000..247b3e5438 --- /dev/null +++ b/contrib/tetris/test/tetris.factor @@ -0,0 +1,16 @@ +USING: kernel tetris tetris-board tetris-piece test sequences ; + +[ t ] [ dup tetris-current-piece swap tetris-next-piece and t f ? ] unit-test +[ t ] [ { 1 1 } can-move? ] unit-test +[ t ] [ { 1 1 } tetris-move ] unit-test +[ 1 ] [ dup { 1 1 } tetris-move drop tetris-current-piece piece-location second ] unit-test +[ 1 ] [ tetris-level ] unit-test +[ 1 ] [ 9 over set-tetris-rows tetris-level ] unit-test +[ 2 ] [ 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 ] [ dup 3 score-rows dup 3 score-rows dup 3 score-rows tetris-level ] unit-test +[ 2 ] [ dup 4 score-rows dup 4 score-rows dup 2 score-rows tetris-level ] unit-test + diff --git a/contrib/tetris/tetris-board.factor b/contrib/tetris/tetris-board.factor new file mode 100644 index 0000000000..49096add7a --- /dev/null +++ b/contrib/tetris/tetris-board.factor @@ -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 ] 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 + 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> ; + diff --git a/contrib/tetris/tetris-colours.factor b/contrib/tetris/tetris-colours.factor new file mode 100644 index 0000000000..41b70e4115 --- /dev/null +++ b/contrib/tetris/tetris-colours.factor @@ -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 + diff --git a/contrib/tetris/tetris-gadget.factor b/contrib/tetris/tetris-gadget.factor new file mode 100644 index 0000000000..b1b6a9b762 --- /dev/null +++ b/contrib/tetris/tetris-gadget.factor @@ -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 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 ( -- ) dup "Tetris" open-titled-window ; + diff --git a/contrib/tetris/tetris-gl.factor b/contrib/tetris/tetris-gl.factor new file mode 100644 index 0000000000..c6f73ece49 --- /dev/null +++ b/contrib/tetris/tetris-gl.factor @@ -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 ; diff --git a/contrib/tetris/tetris-piece.factor b/contrib/tetris/tetris-piece.factor new file mode 100644 index 0000000000..5182b23b1a --- /dev/null +++ b/contrib/tetris/tetris-piece.factor @@ -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 ; + +: ( board-width -- piece ) + random-tetromino [ swap set-start-location ] keep ; + +: ( board-width -- llist ) + [ [ ] curry ] keep [ ] 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 ; + diff --git a/contrib/tetris/tetris.factor b/contrib/tetris/tetris.factor new file mode 100644 index 0000000000..e04f456f53 --- /dev/null +++ b/contrib/tetris/tetris.factor @@ -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 r> [ set-delegate ] keep + dup board-width 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? ; + +: ( -- tetris ) default-width default-height ; + +: ( old -- new ) + [ board-width ] keep board-height ; + +: 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 ; diff --git a/contrib/tetris/tetromino.factor b/contrib/tetris/tetromino.factor new file mode 100644 index 0000000000..bfd9c34541 --- /dev/null +++ b/contrib/tetris/tetromino.factor @@ -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 ] 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 ; +