Paste: the tetris game
Author: | anon |
Mode: | factor |
Date: | Sun, 19 Apr 2009 18:11:38 |
Plain Text |
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 } ;
CONSTANT: default-width 10
CONSTANT: default-height 20
: <tetris>
dupd <board> swap <piece-llist>
tetris new swap >>pieces swap >>board ;
: <default-tetris> default-width default-height <tetris> ;
: <new-tetris>
board>> [ width>> ] [ height>> ] bi <tetris> ;
: current-piece pieces>> car ;
: next-piece pieces>> cdr car ;
: toggle-pause
[ not ] change-paused? drop ;
: level>>
rows>> 1+ 10 / ceiling ;
: update-interval
level>> 1- 60 * 1000 swap - ;
: add-block
over board>> spin current-piece tetromino>> colour>> set-block ;
: game-over?
[ board>> ] [ next-piece ] bi piece-valid? not ;
: new-current-piece
dup game-over? [
f >>running?
] [
[ cdr ] change-pieces
] if ;
: rows-score
{
{ 0 [ 0 ] }
{ 1 [ 40 ] }
{ 2 [ 100 ] }
{ 3 [ 300 ] }
{ 4 [ 1200 ] }
} case swap 1+ * ;
: add-score
over level>> swap rows-score swap [ + ] change-score ;
: add-rows
swap [ + ] change-rows ;
: score-rows
[ add-score ] keep add-rows drop ;
: lock-piece
[ dup current-piece piece-blocks [ add-block ] with each ] keep
new-current-piece dup board>> check-rows score-rows ;
: can-rotate?
[ board>> ] [ current-piece clone 1 rotate-piece ] bi piece-valid? ;
: (rotate)
dup can-rotate? [ current-piece swap rotate-piece drop ] [ 2drop ] if ;
: rotate-left -1 swap (rotate) ;
: rotate-right 1 swap (rotate) ;
: can-move?
[ drop board>> ] [ [ current-piece clone ] dip move-piece ] 2bi piece-valid? ;
: tetris-move
2dup can-move? [
[ current-piece ] dip move-piece drop t
] [
2drop f
] if ;
: move-left { -1 0 } tetris-move drop ;
: move-right { 1 0 } tetris-move drop ;
: move-down
dup { 0 1 } tetris-move [ drop ] [ lock-piece ] if ;
: move-drop
dup { 0 1 } tetris-move [ move-drop ] [ lock-piece ] if ;
: update
millis over last-update>> -
over update-interval > [
dup move-down
millis >>last-update
] when drop ;
: ?update
dup [ paused?>> ] [ running?>> not ] bi or [ drop ] [ update ] if ;
Author: | anon |
Mode: | factor |
Date: | Sun, 19 Apr 2009 18:14:00 |
Plain Text |
USING: accessors arrays kernel math sequences tetris.piece ;
IN: tetris.board
TUPLE: board { width integer } { height integer } rows ;
: make-rows
[ drop f <array> ] with map ;
: <board>
2dup make-rows board boa ;
: board@block
[ second swap rows>> nth ] keep first swap ;
: set-block -rot board@block set-nth ;
: block board@block nth ;
: block-free? block not ;
: block-in-bounds?
[ first swap width>> bounds-check? ] 2keep
second swap height>> bounds-check? and ;
: location-valid?
2dup block-in-bounds? [ block-free? ] [ 2drop f ] if ;
: piece-valid?
piece-blocks [ location-valid? ] with all? ;
: row-not-full? f swap member? ;
: add-row
dup rows>> over width>> f <array> prefix >>rows ;
: top-up-rows
dup height>> over rows>> length = [
drop
] [
add-row top-up-rows
] if ;
: remove-full-rows
[ [ row-not-full? ] filter ] change-rows ;
: check-rows
remove-full-rows dup height>> over rows>> length - swap top-up-rows ;
Author: | anon |
Mode: | factor |
Date: | Sun, 19 Apr 2009 18:14:25 |
Plain Text |
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 colors ;
IN: tetris.gl
: draw-block
{ 1 1 } gl-fill-rect ;
: draw-piece-blocks
piece-blocks [ draw-block ] each ;
: draw-piece
dup tetromino>> colour>> gl-color draw-piece-blocks ;
: draw-next-piece
dup tetromino>> colour>>
>rgba-components drop 0.2 <rgba> gl-color draw-piece-blocks ;
: (draw-row)
[ over ] dip nth dup
[ gl-color 2array draw-block ] [ 3drop ] if ;
: draw-row
dup length -rot [ (draw-row) ] 2curry each ;
: draw-board
rows>> dup length swap
[ dupd nth draw-row ] curry each ;
: scale-board
[ width>> ] [ height>> ] bi swapd [ / ] dup 2bi* 1 glScalef ;
: draw-tetris
[
{
[ board>> scale-board ]
[ board>> draw-board ]
[ next-piece draw-next-piece ]
[ current-piece draw-piece ]
} cleave
] do-matrix ;
Author: | anon |
Mode: | factor |
Date: | Sun, 19 Apr 2009 18:14:42 |
Plain Text |
USING: accessors arrays kernel math math.vectors sequences tetris.tetromino lists.lazy ;
IN: tetris.piece
TUPLE: piece
{ tetromino tetromino }
{ rotation integer initial: 0 }
{ location array initial: { 0 0 } } ;
: <piece>
piece new swap >>tetromino ;
: (piece-blocks)
[ rotation>> ] [ tetromino>> states>> ] bi nth ;
: piece-blocks
[ (piece-blocks) ] [ location>> ] bi [ v+ ] curry map ;
: piece-width
piece-blocks blocks-width ;
: set-start-location
over piece-width [ 2 /i ] bi@ - 0 2array >>location ;
: <random-piece>
random-tetromino <piece> swap set-start-location ;
: <piece-llist>
[ [ <random-piece> ] curry ] keep [ <piece-llist> ] curry lazy-cons ;
: modulo
tuck mod over + swap mod ;
: (rotate-piece)
[ + ] dip modulo ;
: rotate-piece
over tetromino>> states>> length
[ (rotate-piece) ] 2curry change-rotation ;
: move-piece
[ v+ ] curry change-location ;
Author: | anon |
Mode: | factor |
Date: | Sun, 19 Apr 2009 18:15:02 |
Plain Text |
USING: accessors alarms arrays calendar kernel make math math.rectangles 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 new swap >>tetris ;
M: tetris-gadget pref-dim* drop { 200 400 } ;
: update-status
dup tetris>> [
"Level: " % dup level>> #
" Score: " % score>> #
] "" make swap show-status ;
M: tetris-gadget draw-gadget*
[
[ dim>> first2 ] [ tetris>> ] bi draw-tetris
] keep update-status ;
: new-tetris
[ <new-tetris> ] change-tetris ;
tetris-gadget H{
{ T{ button-down f f 1 } [ request-focus ] }
{ 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 ] }
{ T{ key-down f f "u" } [ tetris>> rotate-right ] }
{ 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
[ tetris>> ?update ] [ relayout-1 ] bi ;
M: tetris-gadget graft*
[ [ tick ] curry 100 milliseconds every ] keep (>>alarm) ;
M: tetris-gadget ungraft*
[ cancel-alarm f ] change-alarm drop ;
: tetris-window
[
<default-tetris> <tetris-gadget>
"Tetris" open-status-window
] with-ui ;
MAIN: tetris-window
Author: | anon |
Mode: | factor |
Date: | Sun, 19 Apr 2009 18:15:19 |
Plain Text |
USING: kernel arrays namespaces sequences math math.order
math.vectors colors colors.constants 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 }
}
} COLOR: 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 }
}
} COLOR: purple
] [
{ { { 0 0 } { 1 0 }
{ 0 1 } { 1 1 } }
} COLOR: 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 }
}
} COLOR: 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 }
}
} COLOR: blue
] [
{
{ { 1 0 } { 2 0 }
{ 0 1 } { 1 1 }
} {
{ 0 0 }
{ 0 1 } { 1 1 }
{ 1 2 }
}
} COLOR: green
] [
{
{
{ 0 0 } { 1 0 }
{ 1 1 } { 2 1 }
} {
{ 1 0 }
{ 0 1 } { 1 1 }
{ 0 2 }
}
} COLOR: red
]
} [ first2 <tetromino> ] map tetrominoes set-global
: random-tetromino
tetrominoes get random ;
: blocks-max
map [ 1+ ] [ max ] map-reduce ; inline
: blocks-width
[ first ] blocks-max ;
: blocks-height
[ second ] blocks-max ;
New Annotation