Keith Vetter 2006-01-13 : Here's a simple but fun little game.
Click on the red square and move it around trying to avoid colliding into the wall or the other blocks. Things start to speed up quickly and if you can last more than 20 seconds you've done very well.
##+##########################################################################
#
# Colliding Blocks -- simple arcade type game
# by Keith Vetter, January 2006
#
# http://www.anvari.org/fun/Games/One_Red_and_Four_Blue_Squares.html
#
package require Tk
array set S {title "Colliding Blocks" w 560 h 560 b 60}
array set B {me {256 256 306 306}
0 {337 74 412 138} 1 {374 413 499 443}
2 {90 400 128 474} 3 {90 90 165 165}}
array set SPEED {0 {-10 12} 1 {-12 -20} 2 {15 -13} 3 {17 11} me {}}
array set C {border black field white me \#9c0204 them \#04029c}
proc DoDisplay {} {
global S B P C
set S(lm) $S(b)
set S(tm) $S(b)
set S(rm) [expr {$S(w)-$S(b)}]
set S(bm) [expr {$S(h)-$S(b)}]
wm title . $S(title)
canvas .c -width $S(w) -height $S(h) -highlightthickness 0 -bd 2 \
-bg $C(border) -bd 2 -relief ridge
.c create text [expr {$S(w)/2}] [expr {$S(b)/2}] -anchor c \
-text $S(title) -font {Helvetica 18 bold} -fill yellow
.c create text [expr {$S(w)/2}] [expr {$S(h)-10}] -anchor s -tag ttime \
-font {Helvetica 18 bold} -fill white
button .about -text "?" -font {Times 10 bold} -command About
.c create window [expr {$S(w)-10}] [expr {$S(h)-10}] -anchor se \
-tag a -window .about
pack .c -side top
}
proc DrawBlocks {} {
global S B C P
if {[.c find withtag border] != {}} { ;# Already exists--reposition
foreach id {0 1 2 3 me} {
.c coords id,$id $B($id)
set P(speed,$id) $::SPEED($id)
}
return
}
.c create rect $S(lm) $S(tm) $S(rm) $S(bm) -fill $C(field) \
-outline $C(field)
foreach id {0 1 2 3 me} {
set clr [expr {$id eq "me" ? $C(me) : $C(them)}]
.c create rect $B($id) -fill $clr -outline $clr -tag id,$id
set P(speed,$id) $::SPEED($id)
}
.c bind id,me <ButtonPress-1> [list BDown]
#.c bind id,me <B1-Motion> [list BMotion %x %y]
}
proc BDown {} {
global P
if {$P(state) eq "idle"} {
set P(state) play
set P(start) [clock clicks -milliseconds]
MoveAllBlocks
.c bind id,me <Motion> [list BMotion %x %y]
}
foreach {x0 y0 x1 y1} [.c bbox id,me] break
set x [expr {($x0+$x1)/2}]
set y [expr {($y0+$y1)/2}]
event generate . <Motion> -warp 1 -x $x -y $y
set P(mouse) [list $x $y]
}
proc BMotion {x y} {
global S P
if {$P(state) ne "play"} return
foreach {x0 y0} $P(mouse) break
set dx [expr {$x-$x0}]
set dy [expr {$y-$y0}]
set P(mouse) [list $x $y]
.c move id,me $dx $dy
foreach {x0 y0 x1 y1} [.c coords id,me] break
if {[CheckCollisions]} Collide
}
proc Collide {} {
set ::P(state) "over"
.c bind id,me <Motion> {}
set txt "You lasted [format %.1f $::P(ttime)] seconds"
tk_messageBox -message $txt -icon warning -title "$::S(title) Score"
NewGame
}
proc CheckCollisions {} {
global S
foreach {x0 y0 x1 y1} [.c coords id,me] break
if {$x0 <= $S(lm) || $x1 >= $S(rm) || $y0 <= $S(tm) || $y1 >= $S(bm)} {
return 1
}
foreach who {0 1 2 3} {
foreach {X0 Y0 X1 Y1} [.c coords id,$who] break
if {$x0 > $X1 || $x1 < $X0 || $y0 > $Y1 || $y1 < $Y0} continue
return 1
}
return 0
}
proc NewGame {} {
DrawBlocks
set ::P(cnt) 0
set ::P(state) idle
set ::P(ttime) 0
Timer
}
proc Timer {} {
.c itemconfig ttime -text [format "%.1f seconds" $::P(ttime)]
}
proc About {} {
set txt "$::S(title)\nby Keith Vetter, January 2006\n\n"
append txt "Click and move the red block.\n"
append txt "See how long you go without\n"
append txt "hitting a blue block or the wall.\n\n"
append txt "My best time is around 24 seconds."
tk_messageBox -title "About $::S(title)" -message $txt
}
proc MoveAllBlocks {} {
if {$::P(state) ne "play"} return
set ::P(ttime) [expr {([clock clicks -milliseconds]-$::P(start))/1000.0}]
Timer
foreach id {0 1 2 3} {
MoveBlock $id
}
incr ::P(cnt)
set DELAYS {100 80 200 60 300 40 400 30 500 20 0x7FFFffff 10}
foreach {total delay} $DELAYS {
if {$::P(cnt) < $total} break
}
if {[CheckCollisions]} Collide
after $delay MoveAllBlocks
}
proc MoveBlock {who} {
foreach {dx dy} $::P(speed,$who) break
foreach {x0 y0 x1 y1} [.c bbox id,$who] break
# Check for bouncing off the wall
if {$x0 + $dx < 0 || $x1 + $dx > $::S(w)} {
set dx [expr {-$dx + int(rand()*1.2)}]
}
if {$y0 + $dy < 0 || $y1 + $dy > $::S(h)} {
set dy [expr {-$dy + int(rand()*1.2)}]
}
.c move id,$who $dx $dy
set ::P(speed,$who) [list $dx $dy]
}
DoDisplay
NewGame
return