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

• Home
• Recent changes
• Help
• WhoAmI/Logout
• Create new page
• Random page
• Previous page
• Next page
• 
  
• Add comments
• Edit
• History
• Edit summary
• References