[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.

[http://holgerzeinert.gmxhome.de/share/collidingblocks_pocketpc.gif]
----
[HZe] 2006-01-22: added an exit button. Using the x on the top right corner of the window will not stop the program on a Pocket PC, but just close the window.

Also, if the application is running on a Pocket PC, it will only run once. If a second instance is started, it will trigger the first instance to come to the front and then exit. This is more like applications behave on Pocket PCs.

----
 ##+##########################################################################
 #
 # 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
 }

 if {$tcl_platform(os) eq "Windows CE"} {
    # on a Pocket PC, an application usually only runs once. If started a second
    # time, the first instance is brought up again
    # Here, we simulate this
    set socketno 12345 ;# change this, if already used by other applications
    proc MoveWindowUp {args} {
        wm deiconify .
    }
    if { [catch {socket -server MoveWindowUp $socketno}] } {
        # socket is already in use, so connect to the running instance
        # to bring it in front and then exit this instance
        close [socket localhost $socketno]
        exit
    }
 }

 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
    button .exit -text "X" -font {Times 10 bold} -command exit
    .c create window [expr {10}] [expr {$S(h)-10}] -anchor sw \
        -tag a -window .exit

    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

----

[uniquename] 2013jul29

In case the image above at 'external site' gmxhome.de goes dead, here is a
'locally stored' image at wiki.tcl.tk.

[vetter_collidingBlocks_wiki15262_screenshot_568x589.jpg]

(Thanks to 'gnome-screenshot', 'mtpaint', and ImageMagick 'convert' on Linux for,
respectively, capturing the screen to a PNG file, cropping the image, and converting
the resulting PNG file to a JPEG file that is less than one-fifteenth the size of the PNG file.
Thanks to FOSS developers everywhere --- including Linux kernel and Gnu developers.
I used the 'mv' command and the ImageMagick 'identify' command in a shell script
to easily rename the cropped image file to contain the image dimensions in pixels.)

This is an image of the GUI at full size as it initially appears on startup ----
on a monitor set at 1024x768 resolution --- and with a window manager from
Ubuntu 9.10 ('Karmic Koala, 2009 October version).

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