[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 id,0] != {}} {       ;# 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


----
[Category Games] | [Tcl/Tk Games]