Merge branch 'master' into new_codegen
Slava Pestov
commit
b99ac7045a
|
|
@ -3,7 +3,9 @@ IN: digraphs.tests
|
|||
|
||||
: test-digraph ( -- digraph )
|
||||
<digraph>
|
||||
{ { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } } [ first2 pick add-vertex ] each
|
||||
{ { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } } [ first2 pick add-edge ] each ;
|
||||
{ { "one" 1 } { "two" 2 } { "three" 3 } { "four" 4 } { "five" 5 } }
|
||||
[ first2 pick add-vertex ] each
|
||||
{ { "one" "three" } { "one" "four" } { "two" "three" } { "two" "one" } { "three" "four" } }
|
||||
[ first2 pick add-edge ] each ;
|
||||
|
||||
[ 5 ] [ test-digraph topological-sort length ] unit-test
|
||||
|
|
@ -1,19 +1,20 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs kernel sequences vectors ;
|
||||
USING: accessors assocs hashtables hashtables.private kernel sequences vectors ;
|
||||
IN: digraphs
|
||||
|
||||
TUPLE: digraph ;
|
||||
TUPLE: vertex value edges ;
|
||||
TUPLE: digraph < hashtable ;
|
||||
|
||||
: <digraph> ( -- digraph )
|
||||
digraph new H{ } clone over set-delegate ;
|
||||
0 digraph new [ reset-hash ] keep ;
|
||||
|
||||
TUPLE: vertex value edges ;
|
||||
|
||||
: <vertex> ( value -- vertex )
|
||||
V{ } clone vertex boa ;
|
||||
|
||||
: add-vertex ( key value digraph -- )
|
||||
>r <vertex> swap r> set-at ;
|
||||
[ <vertex> swap ] dip set-at ;
|
||||
|
||||
: children ( key digraph -- seq )
|
||||
at edges>> ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
|
||||
IN: jamshred.game
|
||||
|
|
@ -1,9 +1,6 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types colors jamshred.game
|
||||
jamshred.oint jamshred.player jamshred.tunnel kernel math
|
||||
math.constants math.functions math.vectors opengl opengl.gl
|
||||
opengl.glu sequences float-arrays ;
|
||||
USING: accessors alien.c-types jamshred.game jamshred.oint jamshred.player jamshred.tunnel kernel math math.constants math.functions math.vectors opengl opengl.gl opengl.glu sequences float-arrays ;
|
||||
IN: jamshred.gl
|
||||
|
||||
: min-vertices 6 ; inline
|
||||
|
|
@ -44,8 +41,9 @@ IN: jamshred.gl
|
|||
: equally-spaced-radians ( n -- seq )
|
||||
#! return a sequence of n numbers between 0 and 2pi
|
||||
dup [ / pi 2 * * ] curry map ;
|
||||
|
||||
: draw-segment-vertex ( segment theta -- )
|
||||
over segment-color gl-color segment-vertex-and-normal
|
||||
over color>> set-color segment-vertex-and-normal
|
||||
gl-normal gl-vertex ;
|
||||
|
||||
: draw-vertex-pair ( theta next-segment segment -- )
|
||||
|
|
@ -61,8 +59,8 @@ IN: jamshred.gl
|
|||
1 over length pick subseq swap [ draw-segment ] 2each ;
|
||||
|
||||
: segments-to-render ( player -- segments )
|
||||
dup player-nearest-segment segment-number dup n-segments-behind -
|
||||
swap n-segments-ahead + rot player-tunnel sub-tunnel ;
|
||||
dup nearest-segment>> number>> dup n-segments-behind -
|
||||
swap n-segments-ahead + rot tunnel>> sub-tunnel ;
|
||||
|
||||
: draw-tunnel ( player -- )
|
||||
segments-to-render draw-segments ;
|
||||
|
|
@ -1,15 +1,12 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alarms arrays calendar jamshred.game jamshred.gl
|
||||
jamshred.player jamshred.log kernel math math.constants namespaces
|
||||
sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds
|
||||
ui.gestures ui.render math.vectors math.geometry.rect ;
|
||||
USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.geometry.rect math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
|
||||
IN: jamshred
|
||||
|
||||
TUPLE: jamshred-gadget jamshred last-hand-loc alarm ;
|
||||
TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
|
||||
|
||||
: <jamshred-gadget> ( jamshred -- gadget )
|
||||
jamshred-gadget construct-gadget swap >>jamshred ;
|
||||
jamshred-gadget new-gadget swap >>jamshred ;
|
||||
|
||||
: default-width ( -- x ) 800 ;
|
||||
: default-height ( -- y ) 600 ;
|
||||
|
|
@ -26,7 +23,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- )
|
|||
] [
|
||||
[ jamshred>> jamshred-update ]
|
||||
[ relayout-1 ]
|
||||
[ yield jamshred-loop ] tri
|
||||
[ 10 sleep yield jamshred-loop ] tri
|
||||
] if ;
|
||||
|
||||
: fullscreen ( gadget -- )
|
||||
|
|
@ -39,7 +36,7 @@ M: jamshred-gadget draw-gadget* ( gadget -- )
|
|||
[ fullscreen? not ] keep set-fullscreen* ;
|
||||
|
||||
M: jamshred-gadget graft* ( gadget -- )
|
||||
[ jamshred-loop ] in-thread drop ;
|
||||
[ jamshred-loop ] curry in-thread ;
|
||||
|
||||
M: jamshred-gadget ungraft* ( gadget -- )
|
||||
jamshred>> t swap (>>quit) ;
|
||||
|
|
@ -91,7 +88,7 @@ jamshred-gadget H{
|
|||
{ T{ mouse-scroll } [ handle-mouse-scroll ] }
|
||||
} set-gestures
|
||||
|
||||
: jamshred-window ( -- jamshred )
|
||||
[ <jamshred> dup <jamshred-gadget> "Jamshred" open-window ] with-ui ;
|
||||
: jamshred-window ( -- gadget )
|
||||
[ <jamshred> <jamshred-gadget> dup "Jamshred" open-window ] with-ui ;
|
||||
|
||||
MAIN: jamshred-window
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays float-arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
|
||||
IN: jamshred.oint
|
||||
|
|
@ -1,12 +1,15 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors colors combinators jamshred.log jamshred.oint
|
||||
jamshred.sound jamshred.tunnel kernel locals math math.constants
|
||||
math.order math.ranges math.vectors math.matrices shuffle
|
||||
sequences system float-arrays ;
|
||||
USING: accessors colors combinators float-arrays jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle strings system ;
|
||||
IN: jamshred.player
|
||||
|
||||
TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
|
||||
TUPLE: player < oint
|
||||
{ name string }
|
||||
{ sounds sounds }
|
||||
tunnel
|
||||
nearest-segment
|
||||
{ last-move integer }
|
||||
{ speed float } ;
|
||||
|
||||
! speeds are in GL units / second
|
||||
: default-speed ( -- speed ) 1.0 ;
|
||||
|
|
@ -14,7 +17,7 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
|
|||
|
||||
: <player> ( name sounds -- player )
|
||||
[ F{ 0 0 5 } F{ 0 0 -1 } F{ 0 1 0 } F{ -1 0 0 } ] 2dip
|
||||
f f f default-speed player boa ;
|
||||
f f 0 default-speed player boa ;
|
||||
|
||||
: turn-player ( player x-radians y-radians -- )
|
||||
>r over r> left-pivot up-pivot ;
|
||||
|
|
@ -72,6 +75,9 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
|
|||
: distance-to-collision ( player -- distance )
|
||||
dup nearest-segment>> (distance-to-collision) ;
|
||||
|
||||
: almost-to-collision ( player -- distance )
|
||||
distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
|
||||
|
||||
: from ( player -- radius distance-from-centre )
|
||||
[ nearest-segment>> dup radius>> swap ] [ location>> ] bi
|
||||
distance-from-centre ;
|
||||
|
|
@ -96,14 +102,17 @@ TUPLE: player < oint name sounds tunnel nearest-segment last-move speed ;
|
|||
heading player update-nearest-segment2
|
||||
d-left d-to-move - player ] ;
|
||||
|
||||
: move-toward-wall ( d-left player d-to-wall -- d-left' player )
|
||||
over [ forward>> ] keep distance-to-heading-segment-area min
|
||||
over forward>> move-player-on-heading ;
|
||||
: distance-to-move-freely ( player -- distance )
|
||||
[ almost-to-collision ]
|
||||
[ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
|
||||
|
||||
: ?move-player-freely ( d-left player -- d-left' player )
|
||||
over 0 > [
|
||||
dup distance-to-collision dup 0.2 > [ ! bug! should be 0, not 0.2
|
||||
move-toward-wall ?move-player-freely
|
||||
! must make sure we are moving a significant distance, otherwise
|
||||
! we can recurse endlessly due to floating-point imprecision.
|
||||
! (at least I /think/ that's what causes it...)
|
||||
dup distance-to-move-freely dup 0.1 > [
|
||||
over forward>> move-player-on-heading ?move-player-freely
|
||||
] [ drop ] if
|
||||
] when ;
|
||||
|
||||
|
|
@ -1,3 +1,5 @@
|
|||
! Copyright (C) 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors io.files kernel openal sequences ;
|
||||
IN: jamshred.sound
|
||||
|
||||
|
|
@ -1,20 +1,20 @@
|
|||
! Copyright (C) 2007 Alex Chapman
|
||||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test float-arrays ;
|
||||
USING: accessors arrays float-arrays jamshred.oint jamshred.tunnel kernel math.vectors sequences tools.test ;
|
||||
IN: jamshred.tunnel.tests
|
||||
|
||||
[ 0 ] [ T{ segment f { 0 0 0 } f f f 0 }
|
||||
T{ segment f { 1 1 1 } f f f 1 }
|
||||
T{ oint f { 0 0 0.25 } }
|
||||
nearer-segment segment-number ] unit-test
|
||||
nearer-segment number>> ] unit-test
|
||||
|
||||
[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
|
||||
[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
|
||||
[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment segment-number ] unit-test
|
||||
[ 0 ] [ T{ oint f { 0 0 0 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
|
||||
[ 1 ] [ T{ oint f { 0 0 -1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
|
||||
[ 2 ] [ T{ oint f { 0 0.1 -2.1 } } <straight-tunnel> find-nearest-segment number>> ] unit-test
|
||||
|
||||
[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward segment-number ] unit-test
|
||||
[ 3 ] [ <straight-tunnel> T{ oint f { 0 0 -3.25 } } 0 nearest-segment-forward number>> ] unit-test
|
||||
|
||||
[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment oint-location ] unit-test
|
||||
[ F{ 0 0 0 } ] [ <straight-tunnel> T{ oint f { 0 0 -0.25 } } over first nearest-segment location>> ] unit-test
|
||||
|
||||
: test-segment-oint ( -- oint )
|
||||
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
|
||||
|
|
@ -32,14 +32,14 @@ IN: jamshred.tunnel.tests
|
|||
{ 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
|
||||
initial-segment ;
|
||||
|
||||
[ { 0 0 0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
|
||||
[ { 0 0 0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
|
||||
[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
|
||||
[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
|
||||
|
||||
: simple-collision-up ( -- oint segment )
|
||||
{ 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
|
||||
initial-segment ;
|
||||
|
||||
[ { 0 1 0 } ] [ simple-collision-up sideways-heading ] unit-test
|
||||
[ { 0 0 0 } ] [ simple-collision-up sideways-relative-location ] unit-test
|
||||
[ { 0 1 0 } ]
|
||||
[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
|
||||
[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
|
||||
[ { 0.0 1.0 0.0 } ]
|
||||
[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
|
||||
USING: accessors arrays colors combinators float-arrays kernel jamshred.oint locals math math.constants math.matrices math.order math.ranges math.vectors math.quadratic random sequences vectors ;
|
||||
USE: tools.walker
|
||||
IN: jamshred.tunnel
|
||||
|
||||
|
|
@ -13,7 +13,7 @@ C: <segment> segment
|
|||
[ number>> 1+ ] keep (>>number) ;
|
||||
|
||||
: random-color ( -- color )
|
||||
{ 100 100 100 } [ random 100 / >float ] map { 1.0 } append ;
|
||||
{ 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
|
||||
|
||||
: tunnel-segment-distance ( -- n ) 0.4 ;
|
||||
: random-rotation-angle ( -- theta ) pi 20 / ;
|
||||
|
|
@ -21,7 +21,7 @@ C: <segment> segment
|
|||
: random-segment ( previous-segment -- segment )
|
||||
clone dup random-rotation-angle random-turn
|
||||
tunnel-segment-distance over go-forward
|
||||
random-color over set-segment-color dup segment-number++ ;
|
||||
random-color >>color dup segment-number++ ;
|
||||
|
||||
: (random-segments) ( segments n -- segments )
|
||||
dup 0 > [
|
||||
|
|
@ -77,7 +77,7 @@ C: <segment> segment
|
|||
: nearest-segment ( segments oint start-segment -- segment )
|
||||
#! find the segment nearest to 'oint', and return it.
|
||||
#! start looking at segment 'start-segment'
|
||||
segment-number over >r
|
||||
number>> over >r
|
||||
[ nearest-segment-forward ] 3keep
|
||||
nearest-segment-backward r> nearer-segment ;
|
||||
|
||||
|
|
@ -14,3 +14,4 @@ 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
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
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
|
||||
|
|
@ -1,9 +1,9 @@
|
|||
! Copyright (C) 2006, 2007 Alex Chapman
|
||||
! Copyright (C) 2006, 2007, 2008 Alex Chapman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences arrays tetris.piece math ;
|
||||
USING: accessors arrays kernel math sequences tetris.piece ;
|
||||
IN: tetris.board
|
||||
|
||||
TUPLE: board width height rows ;
|
||||
TUPLE: board { width integer } { height integer } rows ;
|
||||
|
||||
: make-rows ( width height -- rows )
|
||||
[ drop f <array> ] with map ;
|
||||
|
|
@ -15,17 +15,17 @@ TUPLE: board width height rows ;
|
|||
#! 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 ;
|
||||
[ second swap rows>> nth ] keep first swap ;
|
||||
|
||||
: board-set-block ( board block colour -- ) -rot board@block set-nth ;
|
||||
: set-block ( board block colour -- ) -rot board@block set-nth ;
|
||||
|
||||
: board-block ( board block -- colour ) board@block nth ;
|
||||
: block ( board block -- colour ) board@block nth ;
|
||||
|
||||
: block-free? ( board block -- ? ) board-block not ;
|
||||
: block-free? ( board block -- ? ) block not ;
|
||||
|
||||
: block-in-bounds? ( board block -- ? )
|
||||
[ first swap board-width bounds-check? ] 2keep
|
||||
second swap board-height bounds-check? and ;
|
||||
[ 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 ;
|
||||
|
|
@ -35,22 +35,21 @@ TUPLE: board width height rows ;
|
|||
|
||||
: row-not-full? ( row -- ? ) f swap member? ;
|
||||
|
||||
: add-row ( board -- )
|
||||
dup board-rows over board-width f <array>
|
||||
prefix swap set-board-rows ;
|
||||
: add-row ( board -- board )
|
||||
dup rows>> over width>> f <array> prefix >>rows ;
|
||||
|
||||
: top-up-rows ( board -- )
|
||||
dup board-height over board-rows length = [
|
||||
dup height>> over rows>> length = [
|
||||
drop
|
||||
] [
|
||||
dup add-row top-up-rows
|
||||
add-row top-up-rows
|
||||
] if ;
|
||||
|
||||
: remove-full-rows ( board -- )
|
||||
dup board-rows [ row-not-full? ] filter swap set-board-rows ;
|
||||
: 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)
|
||||
dup remove-full-rows dup board-height over board-rows length - >r top-up-rows r> ;
|
||||
remove-full-rows dup height>> over rows>> length - swap top-up-rows ;
|
||||
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
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
|
||||
|
||||
|
|
@ -0,0 +1,114 @@
|
|||
! 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 ;
|
||||
|
|
@ -1,8 +1,6 @@
|
|||
! Copyright (C) 2006, 2007 Alex Chapman
|
||||
! Copyright (C) 2006, 2007, 2008 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 ;
|
||||
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
|
||||
|
|
@ -14,33 +12,36 @@ IN: tetris.gl
|
|||
piece-blocks [ draw-block ] each ;
|
||||
|
||||
: draw-piece ( piece -- )
|
||||
dup tetromino-colour gl-color draw-piece-blocks ;
|
||||
dup tetromino>> colour>> set-color draw-piece-blocks ;
|
||||
|
||||
: draw-next-piece ( piece -- )
|
||||
dup tetromino-colour clone 0.2 3 pick set-nth gl-color draw-piece-blocks ;
|
||||
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
|
||||
[ gl-color 2array draw-block ] [ 3drop ] if ;
|
||||
[ set-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
|
||||
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 ;
|
||||
: 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 [
|
||||
[ scale-tetris ] keep
|
||||
dup tetris-board draw-board
|
||||
dup tetris-next-piece draw-next-piece
|
||||
tetris-current-piece draw-piece
|
||||
{
|
||||
[ board>> scale-board ]
|
||||
[ board>> draw-board ]
|
||||
[ next-piece draw-next-piece ]
|
||||
[ current-piece draw-piece ]
|
||||
} cleave
|
||||
] do-matrix ;
|
||||
|
||||
: draw-tetris ( width height tetris -- )
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
! 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 ;
|
||||
|
|
@ -0,0 +1,56 @@
|
|||
! 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
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2007 Alex Chapman
|
||||
! 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 ;
|
||||
|
|
@ -1,24 +0,0 @@
|
|||
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
|
||||
|
|
@ -1,16 +0,0 @@
|
|||
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
|
||||
|
||||
|
|
@ -1,113 +0,0 @@
|
|||
! 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 ;
|
||||
|
|
@ -1,23 +0,0 @@
|
|||
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
|
||||
|
|
@ -1,47 +0,0 @@
|
|||
! 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 ;
|
||||
|
||||
|
|
@ -1,61 +0,0 @@
|
|||
! 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
|
||||
Loading…
Reference in New Issue