BHE - Tetris in 375 lines. This was the first game engine I came up with so I'm sure it can be shortened quite a bit more. No real frills here.
I originally added this as an easter egg into a program at work which is why the code footprint is small as well as the game itself, =).
Controls:
namespace eval tetris {
variable grid
variable run
variable step 0
variable level 0
variable score 0
variable lines 0
variable piece
variable blocksize 10
variable pieces
array set pieces {
0 {lightblue 4 0 2 2 {1 1 1 1}}
1 {yellow 4 0 4 3 {0 1 0 0 1 0 0 1 0 0 1 0}}
2 {purple 4 0 3 3 {0 1 0 1 1 0 1 0 0}}
3 {green 4 0 3 3 {0 1 0 0 1 1 0 0 1}}
4 {red 4 0 3 3 {0 1 0 1 1 1 0 0 0}}
5 {blue 4 0 3 3 {0 0 1 1 1 1 0 0 0}}
6 {orange 4 0 3 3 {1 0 0 1 1 1 0 0 0}}
}
proc build {} {
variable blocksize
wm title . "TinyTetris"
# canvas should be 15x20 blocks
# the game table is 10x20
# the right 5 blocks are for the nextpiece
canvas .c -width [expr {$blocksize*15 + 2}] -height [expr {$blocksize*20 + 2}]
.c create rectangle 0 0 [expr {$blocksize*10 + 2}] [expr {$blocksize*20 + 2}] -fill black -outline red
label .l1 -text "POINTS" -font {courier 8}
label .l2 -anchor n -font {courier 8} -textvariable tetris::score
label .l3 -text "LEVEL" -font {courier 8}
label .l4 -anchor n -font {courier 8} -textvariable tetris::level
label .l5 -text "LINES" -font {courier 8}
label .l6 -anchor n -font {courier 8} -textvariable tetris::lines
grid .l1 .c -sticky w
grid .l2 ^ -sticky nw
grid .l3 ^ -sticky w
grid .l4 ^ -sticky nw
grid .l5 ^ -sticky w
grid .l6 ^ -sticky nw
grid rowconfigure . 1 -weight 1
grid rowconfigure . 3 -weight 1
grid rowconfigure . 5 -weight 1
set f [frame .debug]
label $f.d1 -text "step : "
label $f.d2 -textvariable tetris::step
label $f.d3 -text "score: "
label $f.d4 -textvariable tetris::score
label $f.d5 -text "piece: "
label $f.d6 -textvariable tetris::piece
# etc
button $f.next -text "next" -command tetris::nextStep
grid $f.d1 $f.d2
grid $f.d3 $f.d4
grid $f.d5 $f.d6
grid $f.next
#pack $f -side top
bind . <Up> "tetris::rotateCW"
bind . <Left> "tetris::move left"
bind . <Right> "tetris::move right"
bind . <space> "tetris::drop"
bind . <Down> "tetris::nextStep"
bind . <F2> "tetris::restart"
restart
}
proc restart {} {
clearGrid
variable run 1
after 1000 tetris::newPiece
}
proc endGame {} {
variable run 0
}
proc clearGrid {} {
variable lines 0
variable score 0
variable step 0
variable level 0
variable run 1
variable nextpiece
variable grid
foreach i {0 1 2 3 4 5 6 7 8 9} {
for {set j 0} {$j < 20} {incr j} {
set grid($i,$j) ""
}
}
.c delete block
set nextpiece [randomPiece]
cycle
}
proc cycle {} {
variable level
variable run
if {!$run} { return }
nextStep
set speed [expr {100 - 8*$level}]
if {$speed < 20} { set speed 20 }
after $speed tetris::cycle
}
proc newPiece {} {
variable piece
variable nextpiece
variable step 0
variable blocksize
set piece $nextpiece
set nextpiece [randomPiece]
if {[checkPiece] == 0} {
endGame
return
}
drawPiece
.c delete nextpiece
foreach {color X Y h w piecegrid} $nextpiece {}
for {set j 0} {$j < $h} {incr j} {
for {set i 0} {$i < $w} {incr i} {
if {[lindex $piecegrid [expr {$i + $j*$w}]] != 0} {
set x [expr {12*$blocksize + $i*$blocksize}]
set y [expr {3*$blocksize + $j*$blocksize}]
set ID [.c create rectangle $x $y [expr {$x+$blocksize}] [expr {$y+$blocksize}] \
-fill $color -outline gray25 -tags {block nextpiece}]
lset nextpiece 5 [expr {$i + $j*$w}] $ID
}
}
}
}
proc randomPiece {} {
variable pieces
return $pieces([expr {int(rand()*7)}])
}
proc checkPiece {} {
variable piece
variable grid
foreach {color X Y h w piecegrid} $piece {}
for {set j 0} {$j < $h} {incr j} {
for {set i 0} {$i < $w} {incr i} {
if {[lindex $piecegrid [expr {$i + $j*$w}]] == 0} { continue }
set x [expr {$X+$i}]
set y [expr {$Y+$j}]
if {$x < 0} { return 0 }
if {$x > 9} { return 0 }
if {$grid($x,$y) != ""} { return 0 }
}
}
return 1
}
proc drawPiece {} {
variable grid
variable piece
variable step
variable blocksize
.c delete piece
foreach {color X Y h w piecegrid} $piece {}
for {set j 0} {$j < $h} {incr j} {
for {set i 0} {$i < $w} {incr i} {
if {[lindex $piecegrid [expr {$i + $j*$w}]] != 0} {
set x [expr {($X+$i)*$blocksize + 1}]
set y [expr {($Y+$j)*$blocksize}]
if {[expr {$step%$blocksize}] > 0} {
incr y [expr {$step%$blocksize - $blocksize}]
}
set ID [.c create rectangle $x $y [expr {$x+$blocksize}] [expr {$y+$blocksize}] \
-fill $color -outline gray25 -tags {block piece}]
lset piece 5 [expr {$i + $j*$w}] $ID
}
}
}
}
proc rotateCCW {} {
variable grid
variable piece
if {$piece == ""} { return }
set oldpiece $piece
foreach {color X Y h w piecegrid} $piece {}
set newgrid $piecegrid
set s [expr {$h-1}]
for {set j 0} {$j < $h} {incr j} {
for {set i 0} {$i < $w} {incr i} {
set id [lindex $piecegrid [expr {$i + $j*$w}]]
set p $j
set q [expr {$s-$i}]
lset newgrid [expr {$p + $q*$h}] $id
}
}
set piece [list $color $X $Y $w $h $newgrid]
if {[checkPiece]} {
drawPiece
} else {
set piece $oldpiece
}
}
proc rotateCW {} {
variable grid
variable piece
if {$piece == ""} { return }
set oldpiece $piece
foreach {color X Y h w piecegrid} $piece {}
set newgrid $piecegrid
set s [expr {$h-1}]
for {set j 0} {$j < $h} {incr j} {
for {set i 0} {$i < $w} {incr i} {
set id [lindex $piecegrid [expr {$i + $j*$w}]]
set p [expr {$s-$j}]
set q $i
lset newgrid [expr {$p + $q*$h}] $id
}
}
set piece [list $color $X $Y $w $h $newgrid]
if {[checkPiece]} {
drawPiece
} else {
set piece $oldpiece
}
}
proc drop {} {
variable piece
while {$piece != ""} { nextStep }
}
proc move {dir} {
variable piece
variable blocksize
if {$piece == ""} { return }
foreach {color X Y h w piecegrid} $piece {}
switch $dir {
left { set dx -1 }
right { set dx 1 }
}
lset piece 1 [expr {$X + $dx}]
if {[checkPiece] == 0} {
lset piece 1 $X
return
}
.c move piece [expr {$dx*$blocksize}] 0
}
proc nextStep {} {
variable step
variable piece
variable grid
variable blocksize
if {$piece == ""} { return }
foreach {color X Y h w piecegrid} $piece {}
incr step
.c move piece 0 1
set offset [expr {$step%$blocksize}]
if {$offset == 1} { lset piece 2 [incr Y] }
if {$offset != 0} {
return
}
# foreach block in piece
# if Y+1 is a block, call finish
# else incr Y
for {set i 0} {$i < $w} {incr i} {
for {set j [expr {$h-1}]} {$j >= 0} {incr j -1} {
if {[lindex $piecegrid [expr {$i + $j*$w}]] != 0} {
set x [expr {$X+$i}]
set y [expr {$Y+$j+1}]
if {$y == 20 || $grid($x,$y) != ""} {
finishPiece
return
}
break
}
}
}
}
proc finishPiece {} {
variable grid
variable piece
variable level
variable score
variable lines
foreach {color X Y h w piecegrid} $piece {}
for {set j 0} {$j < $h} {incr j} {
for {set i 0} {$i < $w} {incr i} {
set id [lindex $piecegrid [expr {$i + $j*$w}]]
if {$id != 0} {
set grid([expr {$X+$i}],[expr {$Y+$j}]) $id
}
}
}
.c itemconfig piece -tags {block}
set nlines 0
for {set y $Y} {$y < [expr {$Y+$h}]} {incr y} {
incr nlines [checkLine $y]
}
incr score [expr {($level+1)*[lindex {0 40 100 300 1200} $nlines]}]
incr lines $nlines
set level [expr {$lines/10}]
set piece {}
after 500 "tetris::newPiece"
}
proc checkLine {y} {
variable grid
variable blocksize
if {$y == 20} { return 0 }
set ids {}
for {set x 0} {$x < 10} {incr x} {
lappend ids $grid($x,$y)
if {$grid($x,$y) == ""} { return 0 }
}
foreach id $ids { .c delete $id }
while {$y > 0} {
for {set x 0} {$x < 10} {incr x} {
set id $grid($x,[expr {$y-1}])
set grid($x,$y) $id
.c move $id 0 $blocksize
}
incr y -1
}
for {set x 0} {$x < 10} {incr x} {
set grid($x,0) ""
}
return 1
}
}
tetris::build