[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.
----
[HZe] 2006-01-14: Great! This is really fun. And it perfectly is scaleable to a [PocketPC]. I've added a scale variable, which scales the whole user interface. Default is 1, which will leave everything as it was before. But setting to 0.42 it will fit on the screen of the [PocketPC]. I tested it with [eTcl]. Since size and speed is scaled, the timing on different scales should be compareable. 

[KPV] Changed the default scaling back to 1. Also added random initial direction for the blue blocks.

[HZe] yes, sorry, my fault. I wanted to leave the default 1, but then copied the version one time too often from my test version.

[HZe] now, the scale factor is calculated from the size of the display, but only if the display x or y does not allow 560 pixel. This should not only work for PDA-like PocketPCs (240x320), but also for [Windows CE] devices with kind of wide-screen display.

----
 ##+##########################################################################
 #
 # 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
 
 # calculate a scale factor for small displays,
 # e.g. for PocketPC 0.42
 set maxsize [wm maxsize .]
 set maxsizex [lindex $maxsize 0]
 set maxsizey [lindex $maxsize 1]
 if {$maxsizex < $maxsizey} {
    set min $maxsizex
 } else {
    set min $maxsizey
 }
 if {$min < 560} {
    # small display
    set scale [expr $min / 560.0]
 } else {
    # normal displays
    set scale 1
 }

 
 array set S [list title "Colliding Blocks" w [expr 560*$scale] \
                 h [expr 560*$scale] b [expr 60*$scale]]
 array set B [list me [list [expr 256*$scale] [expr 256*$scale] [expr 306*$scale] [expr 306*$scale]] \
                 0 [list [expr 337*$scale] [expr 74*$scale] [expr 412*$scale] [expr 138*$scale]] \
                 1 [list [expr 374*$scale] [expr 413*$scale] [expr 499*$scale] [expr 443*$scale]] \
                 2 [list [expr 90*$scale] [expr 400*$scale] [expr 128*$scale] [expr 474*$scale]] \
                 3 [list [expr 90*$scale] [expr 90*$scale] [expr 165*$scale] [expr 165*$scale]]]
 array set SPEED [list 0 [list [expr -10*$scale] [expr 12*$scale]] \
                     1 [list [expr -12*$scale] [expr -20*$scale]] \
                     2 [list [expr 15*$scale] [expr -13*$scale]] \
                     3 [list [expr 17*$scale] [expr 11*$scale]] \
                     me {0 0}]
 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 [expr int(18*$::scale)] bold" -fill yellow
    .c create text [expr {$S(w)/2}] [expr {$S(h)-10}] -anchor s -tag ttime \
        -font "Helvetica [expr int(18*$::scale)] 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) [RandomDir $::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) [RandomDir $::SPEED($id)]
    }
    .c bind id,me <ButtonPress-1> [list BDown]
    #.c bind id,me <B1-Motion> [list BMotion %x %y]
 }
 proc RandomDir {dxy} {
    foreach {dx dy} $dxy break
    set dx [expr {rand() < .5 ? $dx : -$dx}]
    set dy [expr {rand() < .5 ? $dy : -$dy}]
    return [list $dx $dy]
 }
 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]