if 0 {[Richard Suchenwirth] 2005-01-22 - After seeing KPV's [Collapse] in the Tk Game Pack, I wanted to have it on the [iPaq] too. This just needed some tweaking of geometry and font sizes, reducing the number of defined levels etc.; and here it is:

[http://mini.net/files/collapse.jpg]
----
}
 ##################
 #
 # Collapse
 # http://www.gamehouse.com/affiliates/template.jsp?AID=1406
 # by Keith Vetter -- October 2003
 #
 # KPV  Oct 30, 2003 - Initial revision starting with gemgame code
 # KPV  Nov 04, 2003 - EOR bonus, new row count down display, new levels
 # male Nov 21, 2003 - Game Over canvas items with tags, delete
 #                     in NewGame
 # suchenwi Jan 22, 2003 - adapted for iPaq
 # TODO:
 #   bombs

 package require Tk 8.4

 array set S {title "Collapse" version 1.0 cols 7 rows 10 cell 25
    delay 10 mute 0 numSteps 4 level 1 ticks 13}
 set S(rowsX) [expr {$S(rows) - 1}]

 array set LEVEL {
    1 {srows 3 tiles 3 newRow 4000 lines 25}
    2 {srows 4 tiles 3 newRow 3000 lines 30}
    3 {srows 5 tiles 3 newRow 2500 lines 30}
    4 {srows 6 tiles 3 newRow 2000 lines 30}
    5 {srows 7 tiles 3 newRow 2000 lines 35}
    6 {srows 7 tiles 3 newRow 1500 lines 40}
 }

 proc DoDisplay {} {
    global S
    wm title . $S(title)
    set w [expr {$S(cell) * $S(cols) + 5}]
    set h [expr {$S(cell) * $S(rows) + 5}]

    CompressImages

    option add *Label.background black
    frame .ctrl -relief ridge -bd 2 -bg black
    canvas .c -relief ridge -bg black -height $h -width $w \
        -highlightthickness 0 -bd 1 -relief raised
    canvas .cc -relief ridge -bg black -height [expr {5 + $S(cell)}] -width $w \
        -highlightthickness 0 -bd 1 -relief raised

    label .score -text Score: -fg white
    .score configure  -font "[font actual [.score cget -font]] -weight bold"
    #option add *font [.score cget -font]

    label .vscore -textvariable S(score) -fg yellow
    label .vscore2 -textvariable S(score2) -fg yellow
    label .level -text Level: -fg white
    label .vlevel -textvariable S(level) -fg yellow
    label .lines -text "lines left" -fg white
    label .vlines -textvariable S(lines) -fg yellow
    button .new -text "New" -command NewGame

    set levels {}
    foreach a [lsort -integer [array names ::LEVEL]] {
        lappend levels "L. $a"
    }
    eval tk_optionMenu .optlvl S(strlvl) $levels
    .optlvl config -highlightthickness 0
    trace variable ::S(strlvl) w Tracer

    checkbutton .pause -text Pause -variable S(pause) \
        -command {Pause 0} -relief raised -anchor w
    button .about -text About -command About
    button .x -text X -command exit

    pack .ctrl -side right -fill y ;#-ipady 5 -ipadx 5
    pack .c -side top -fill both -expand 1
    pack .cc -side top -fill both -expand 1
    grid .score -in .ctrl -sticky ew -row 1
    grid .vscore -in .ctrl -sticky ew
    grid .vscore2 -in .ctrl -sticky ew
    grid .level -in .ctrl -sticky ew
    grid .vlevel -in .ctrl -sticky ew
    grid .lines -in .ctrl -sticky ew
    grid .vlines -in .ctrl -sticky ew
    grid rowconfigure .ctrl 20 -minsize 10
    grid .new -in .ctrl -sticky ew -row 25 -pady 1
    grid .optlvl -in .ctrl -sticky ew -pady 1
    grid .pause -in .ctrl -sticky ew -pady 1
    grid rowconfigure .ctrl 50 -weight 1
    grid .about -in .ctrl -row 100 -sticky ew -pady 5
    grid .x -in .ctrl -sticky ew

    for {set row 0} {$row < $S(rows)} {incr row} {
        for {set col 0} {$col < $S(cols)} {incr col} {
            .c create image [GetXY $row $col] -tag [list c$row,$col cell]
            .c bind "c$row,$col" <Button-1> [list DoClick $row $col]
        }
    }
    for {set col 0} {$col < $S(cols)} {incr col} {
        .cc create image [GetXY 0 $col] -tag [list c$col cell]
    }
 }
 proc CompressImages {} {
    image create photo ::img::img(0)            ;# Blank image
    foreach id {1 2 3 4} {                      ;# Each image we have
        foreach a {2 3 4} {                     ;# We need narrower images
            image create photo ::img::img($id,$a)
            if {$a == 4} continue
            ::img::img($id,$a) copy ::img::img($id) -subsample $a $a
        }
    }
 }
 proc Tracer {var1 var2 op} {                    ;# Handles level optionMenu
    if {$var2 == "strlvl"} {
        scan $::S(strlvl) "L. %d" level
        if {$level == $::S(level)} return
        set ::S(level) $level
        NewGame
    }
 }
 proc NewGame {} {
    array set ::S {score 0 state 0 score2 "" best 0}
    catch {eval .c delete gameOver;}
    StartLevel
    Banner "CLICK TO START"
    WaitClick
 }
 proc StartLevel {} {
    global S B BB LEVEL
    StartStop 0
    array set S {busy 0 needRow 0 pause 0}
    if {! [info exists LEVEL($S(level))]} {     ;# Above set levels
        set lvl [expr {$S(level) % 10}]
        if {$lvl == 0} {set lvl 10}
        if ![info exi LEVEL($lvl)] {set lvl [expr 1+$lvl%7]}
        array set S $LEVEL($lvl)
        set S(tiles) 4                          ;# Always use 4 tiles
    } else {
        array set S $LEVEL($S(level))
        set S(strlvl) "L. $S(level)"
    }
    set S(newRowX) [expr {$S(newRow) / $S(ticks)}] ;# Tick mark interval

    .c delete banner
    .c itemconfig cell -image {}
    array unset B
    set row1 [expr {$S(rowsX) - 4}]

    for {set row -1} {$row < $S(rows)} {incr row} {
        for {set col -1} {$col <= $S(cols)} {incr col} {
            if {$row < 0 || $row == $S(rows) || $col < 0 || $col == $S(cols)} {
                set B($row,$col) -1
            } else {
                set B($row,$col) 0
            }
        }
    }
    for {set col 0} {$col < $S(cols)} {incr col} {
        set BB($col) 0
    }

    DrawBoard
    for {set i 0} {$i < $S(srows)} {incr i} {
        UpRow
    }
 }
 proc DrawBoard {} {
    global S B
    for {set row 0} {$row < $S(rows)} {incr row} {
        for {set col 0} {$col < $S(cols)} {incr col} {
            .c itemconfig "c$row,$col" -image ::img::img($B($row,$col))
        }
    }
 }
 proc DrawBoard2 {} {                            ;# The new row board
    global S BB
    for {set col 0} {$col < $S(cols)} {incr col} {
        .cc itemconfig c$col -image ::img::img($BB($col))
    }
 }
 proc GetXY {r c} {
    global S
    set x [expr {5 + $c * $S(cell) + $S(cell)/2}]
    set y [expr {5 + $r * $S(cell) + $S(cell)/2}]
    return [list $x $y]
 }
 proc DoClick {row col} {                        ;# Handles mouse clicks
    global S
    if {$S(state) == 0} {
        Banner ""
        StartStop 1
        set S(state) 1
        if {$row == -1} return
    }

    if {$S(state) != 1} return
    if {$S(busy)} return
    set S(busy) 1
    Explode $row $col
    set S(busy) 0
    if {$S(needRow)} NewRow
 }
 proc Explode {r c} {
    set cells [FindNeighbors $r $c]             ;# Find who should explode
    if {$cells == {}} return
    if {! $::S(mute)} {catch { snd_ok play }}

    # Update our score
    set cnt [llength $cells]
    set n [expr {$cnt * $cnt}]
    incr ::S(score) $n
    set ::S(score2) ""                          ;# Show special scores
    if {$cnt > 3} {set ::S(score2) "($n)"}

    ExplodeCells $cells                         ;# Do the explosion affect
    CollapseCells                               ;# Move cells down
    CompactCells                                ;# Move cells inward
    if {[IsEmpty]} {
        incr ::S(score) 1000
        Banner "1000 POINT BONUS"
        after 500 [list Banner ""]
    }
 }
 proc FindNeighbors {row col} {                  ;# Find all triplets and up
    global S B

    # We'll do a flood fill (bfs) to find connected components
    set q [list $row $col]                      ;# Our BFS queue
    set qhead 0                                 ;# Head of the queue

    array unset neighbors                       ;# Whose in our neighborhood
    set neighbors($row,$col) 1                  ;# We're in our own neighborhood
    set type $B($row,$col)                      ;# Type of our neighborhood
    set cnt 1
    while {[llength $q] > $qhead} {             ;# While stuff in the queue
        foreach {r c} [lrange $q $qhead [incr qhead]] break
        incr qhead

        foreach {dr dc} {-1 0 1 0 0 -1 0 1} {   ;# Look n,s,e & w
            set r1 [expr {$r + $dr}]
            set c1 [expr {$c + $dc}]
            if {[info exists neighbors($r1,$c1)]} continue ;# Already seen
            if {$B($r1,$c1) != $type} continue  ;# Wrong type

            set neighbors($r1,$c1) 1            ;# Another neighbor
            lappend q $r1 $c1                   ;# Add to our BFS
            incr cnt
        }
    }
    if {$cnt < 3} {return {}}
    return [array names neighbors]
 }
 proc ExplodeCells {cells} {
    foreach stage {2 3 4} {
        foreach who $cells {
            .c itemconfig c$who -image ::img::img($::B($who),$stage)
            if {$stage == 4} {set ::B($who) 0}
        }
        update
        after [expr {$::S(delay)}]
    }
 }
 proc CollapseCells {} {
    global B S

    while {1} {                                 ;# Stop when nothing slides
        set sliders {}
        for {set col 0} {$col < $S(cols)} {incr col} {
            set collapse 0
            for {set row $S(rowsX)} {$row >= 0} {incr row -1} {
                if {$B($row,$col) == -1} break
                if {$B($row,$col) == 0} {
                    set collapse 1
                } elseif {$collapse} {
                    lappend sliders $row $col y
                }
            }
        }
        if {$sliders == {}} break
        SlideCells $sliders
    }
 }
 proc CompactCells {} {
    global B S
    array set ::BB [array get B]
    set ROW $S(rowsX)
    set COL [expr {int($S(cols) / 2)}]
    while {1} {                                 ;# Stop when nothing slides
        set sliders {}

        # Check the slide to the right columns
        set cols {}
        for {set col 0} {$col < $COL} {incr col} {
            if {$B($ROW,$col) <= 0} {
                foreach c $cols {
                    for {set row $ROW} {$row >= 0} {incr row -1} {
                        if {$B($row,$c) <= 0} break
                        lappend sliders $row $c x
                    }
                }
                set cols {}
            } else {
                lappend cols $col
            }
        }
        # Check slide to the left columns
        set cols {}
        for {set col [expr {$S(cols) - 1}]} {$col >= $COL} {incr col -1} {
            if {$B($ROW,$col) <= 0} {
                foreach c $cols {
                    for {set row $ROW} {$row >= 0} {incr row -1} {
                        if {$B($row,$c) <= 0} break
                        lappend sliders $row $c xx
                    }
                }
                set cols {}
            } else {
                lappend cols $col
            }
        }
        if {$sliders == {}} break
        SlideCells $sliders
    }
 }
 ##+##########################################################################
 #
 # SlideCells -- move a set of cells one unit in a specified direction.
 #
 # Tricky part is NOT losing the correct binding for cell X,Y. Thus we
 # first blank the real image and replace it with a temporary one which
 # we slide. DrawBoard will put the correct image back in place.
 #
 proc SlideCells {cells} {
    foreach {r c dir} $cells {
        .c itemconfig c$r,$c -image {}
        set M($r,$c) $::B($r,$c)
        set ::B($r,$c) 0
        .c create image [GetXY $r $c] -image ::img::img($M($r,$c)) \
            -tag slider$dir
    }
    .c raise banner
    set dx [expr {double($::S(cell)) / $::S(numSteps)}]
    set dy [expr {double($::S(cell)) / $::S(numSteps)}]
    for {set step 0} {$step < $::S(numSteps)} {incr step} {
        .c move slidery 0 $dy
        .c move slideryy 0 -$dy
        .c move sliderx $dx 0
        .c move sliderxx -$dx 0
        update
        after $::S(delay)
    }
    foreach {r c dir} $cells {                  ;# Update board data
        if {$dir == "y"} {
            set ::B([expr {$r+1}],$c) $M($r,$c)
        } elseif {$dir == "yy"} {
            set ::B([expr {$r-1}],$c) $M($r,$c)
        } elseif {$dir == "x"} {
            set ::B($r,[expr {$c+1}]) $M($r,$c)
        } elseif {$dir == "xx"} {
            set ::B($r,[expr {$c-1}]) $M($r,$c)
        }
    }
    DrawBoard
    .c delete slidery slideryy sliderx sliderxx
 }
 proc NewRow {} {
    global S B
    StartStop 0
    if {$S(busy)} {                             ;# Busy handling mouse click
        set S(needRow) 1                        ;# ...so set flag and leave
        return
    }
    set S(busy) 1
    incr S(lines) -1
    if {$S(lines) == 0} {                       ;# Is the level over yet???
        return [LevelOver]
    }
    # Check for game over
    for {set col 0} {$col < $S(cols)} {incr col} {
        if {$B(0,$col) > 0} {
            return [GameOver]
        }
    }
    UpRow
    StartStop 1
    set S(needRow) 0
    set S(busy) 0
 } 

##+##########################################################################
 #
 # UpRow -- Scrolls the screen up one row and adds in another row
 #
 proc UpRow {} {
    global B S BB
    for {set col 0} {$col < $S(cols)} {incr col} {
        if {$BB($col) == 0} {set BB($col) [expr {1 + int(rand() * $S(tiles))}]}
    }
    set sliders {}
    for {set row 1} {$row < $S(rows)} {incr row} {
        for {set col 0} {$col < $S(cols)} {incr col} {
            if {$B($row,$col) == -1} continue
            lappend sliders $row $col yy
        }
    }
    for {set col 0} {$col < $S(cols)} {incr col} {
        set n $BB($col)
        if {$n == 0} {set n [expr {1 + int(rand() * $S(tiles))}]}
        set B($S(rows),$col) $n
        set BB($col) 0
        lappend sliders $S(rows) $col yy
    }
    SlideCells $sliders
    for {set col 0} {$col < $S(cols)} {incr col} {
        set B($S(rows),$col) -1
    }
 }
 proc IsEmpty {} {
    for {set row $::S(rowsX)} {$row >= 0} {incr row -1} {
        for {set col 0} {$col < $::S(cols)} {incr col} {
            if {$::B($row,$col) > 0} {return 0}
        }
    }
    return 1
 }
 proc About {} {
    set msg "$::S(title) v$::S(version)\nby Keith Vetter, Oct. 2003 - "
    append msg "Based on a program by GameHouse\n"

    append msg " Collapse the rising blocks "
    append msg "to get as many points as possible.\n"

    append msg "Score points by clicking on a block that has "
    append msg "two or more neighbors of same color. Blocks above "
    append msg "the explosion will collapse on blocks "
    append msg "below. The more blocks exploded the higher your score.\n"

    append msg "As you play, new lines of blocks will appear. When "
    append msg "\"Lines Left\" reaches 0, the next level will start."

    tk_messageBox -message $msg
 }
 proc GameOver {{txt "Game Over"}} {
    set ::S(state) 2
    StartStop 0
    .c create rect 0 0 [winfo width .c] [winfo height .c] \
        -fill white -stipple gray25 -tag gameOver
    .c create text [GetXY 4 3] -text $txt -font {Helvetica 18 bold} \
        -fill white -tag gameOver
 }
 proc StartStop {onoff} {
    foreach aid [after info] {after cancel $aid}
    .cc itemconfig cell -image {}
    if {! $onoff} return

    set ::S(tcnt) $::S(ticks)
    after $::S(newRowX) ticker
 }
 proc ticker {} {
    global S BB

    incr S(tcnt) -1
    set col [expr {$S(ticks) - 1 - $S(tcnt)}]

    set BB($col) [expr {1 + int(rand() * $S(tiles))}]
    DrawBoard2

    if {$S(tcnt) <= 0} {
        NewRow
    } else {
        after $S(newRowX) ticker
    }
 }
 proc LevelOver {} {
    global S B

    set S(state) 3                              ;# Level over state
    StartStop 0
    Banner "LEVEL COMPLETE"
    update
    after 3000
    LevelOverAnimation
    incr S(level)
    StartLevel
    set S(state) 1
    StartStop 1
 }
 proc LevelOverAnimation {} {
    global S B
    Banner ""
    for {set row 0} {$row < $S(rows)} {incr row} {
        set bonus [expr {100 + $row*10}]
        incr S(score) $bonus
        Banner "$bonus POINT BONUS"
        for {set col 0} {$col < $S(cols)} {incr col} {
            if {$B($row,$col) > 0} break
            set B($row,$col) 4
            DrawBoard
            update
            after [expr {$S(delay)}]
        }
        if {$B($row,$col) > 0} break
    }
    after 2000
 }
 ##+##########################################################################
 #
 # WaitClick -- waits for a click to begin
 #
 proc WaitClick {} {
    set w [winfo width .c]
    set h [winfo height .c]
    .c create rect -10 -10 $w $h -tag scrim -fill black
    .c lower scrim
    .c raise banner
    .c bind banner <Button-1> {DoClick -1 -1}
    .c bind scrim <Button-1> {DoClick -1 -1}
 }
 proc Banner {msg} {
    global S
    .c delete banner scrim
    if {$msg == ""} return
    set x [expr {[winfo width .c] / 2}]
    .c create rect [expr {$x - 100}] 100 [expr {$x + 100}] 200 \
        -tag banner -fill black -outline gold -stipple gray50
    .c create text $x 175 -tag banner -font {Helvetica 12 bold} \
        -text $msg -anchor c -fill white

    for {set i 0} {$i < 6} {incr i} {
        set xx [expr {$x - (2.5-$i)*$S(cell)}]
        set yy [expr {120 + rand()*$S(cell)}]
        set who [expr {1 + int(rand() * $S(tiles))}]
        .c create image $xx $yy -image ::img::img($who) -tag banner
    }
 }
 proc Pause {byBinding} {
    global S

    if {$byBinding} {                           ;# Button toggles for us
        set S(pause) [expr {! $S(pause)}]
    }

    if {$S(pause) == 1} {                       ;# Pause on
        if {$S(state) != 1} return              ;# Not in play mode
        foreach aid [after info] {after cancel $aid}

        .c create rect 0 0 [winfo width .c] [winfo height .c] \
            -fill black -tag pause
        .c create text [GetXY 4 3] -font {Helvetica 14 bold} \
            -fill white -tag pause -text "PAUSED" -justify center
        .c create text [GetXY 6 3] -font {Helvetica 10 bold} \
            -fill white -tag pause -text "Press p to continue" -justify center
    } else {                                    ;# Pause off
        .c delete pause
        after $::S(newRowX) ticker
    }
 }
 image create photo ::img::img(-1)
 image create photo ::img::img(0)
 image create photo ::img::img(1) -data {
    R0lGODdhGwAcANUAABwaKSopKi4nGAocdQYdswUhzw0jjRcgTDBr+HCX+iGX+2aG+156+hx58E5s
    +CZQ+BQ68gQo7K3p+5bV+5rF+nCr/JKs+D2p/BMy2RkYFyRBsCVC2T1b8hdT0j5Y0Yme90JVr1Rs
    0qG5+BRPlh80bjI2TBc9kP//////////////////////////////////////////////////////
    /////////////////////////////////////////////ywAAAAAGwAcAAAG/0AAICAEBIQCgEAA
    EAACAkBAABAAAgJAIDAAEoRDYrFAKBAKhgNAACggEooFo+FAIB6PxwMIEQ6HkQPAgJBIJpSK5ZJY
    MBAIxOPxgDyIEIKAkJA0IMCIUIiJFIbDIQQCKQAIFUqkUCgQCIQCAVgQDoER4RBSEBAulUiBUCgQ
    gAXhsBApRAqRSAQCKQAIiUqEUCAQiUNgRDiEFDIERSJSKBQwwIJQiClEMBFMJBKBRCCYDGGRwAwL
    mAIGg4lgIphIJAKJQCCQAoCgSECEQIxQGMFAMECIcCh8PAoCzWIBxAiHGMgGCBEOiZDHAxMgLBQQ
    DAazEW6GD+ED8ng8HhwOJv+jWSwgGMxms9k8II8HBPgQDjkcB2Ij0CwYj81ms3lshkIgRzgUOhib
    jGbBeGw2m8fm8Xg8iA6Ow+FwMBYbgYaxeGw2nI3wQQQ6hEMHY7HoZDQMB4ez8Xg4HA6HyHAAGUJh
    IuEBaBwOjofj4XA4Do7DMRwOEx8PQONwcDwejofDcTgcjiFjwVgwFh+LJwPiODgejocTAjqEDAZj
    wVgwFozF4mPxCDRCB8cT4giFQIZQuGAsFoyFpRICgBwOB4fj4DgcjiFjwVgsFowFwyIKZTRAh3A4
    ZDAYwIVwOEyIRB7AyMFwOBgMhjCRSHw+H4vFYhGJKBQLKHPwOIAMoXCxWCQzEonEp/KpVCwV0cdB
    ygBKJqBHOCQWQ8QRKSPIZASATCYDyAAEGYAgA8gAMoAMQAAQZABBADs=}
 image create photo ::img::img(2) -data {
    R0lGODdhGwAcANUAABkYFyopKhwaKS4nGFYnEasSB8oLBWkoKvE0I/hmWPhXTPVTO/VFOuw5MOgj
    EtkZD6gZH+QpH/CnldnHtveXjfGYcfeFdfh4b/dsZmwHBVsXE+x3Wa0mD+AqLk8ZKaU2HvVMRJ8t
    LqA4M6JKR/x+hPaKh+mdnf//////////////////////////////////////////////////////
    /////////////////////////////////////////////ywAAAAAGwAcAAAG/0BAABAACAYCgGAg
    GAgCgkBAEBAEBIGBYDAIEAqGgqFgKBiABeGwYCgYDAbDYSAQFBCJREKhWDAYDQQCAXQIh47H4wEJ
    HCKSiYRSsVwwCcWC0UAgIhGi4/EAZBiTCyIScUSIjsfD8Xg4Ho/Hw/EAZBaSBtAgFBYMBUPhYXgY
    HoaH4fF4PACZBSUiLAgLhoKwIHwYgA/h8KHJNCoPg8FQKBQehUfhASESHQ9ApmFxGAwFYWEIIQ4d
    D4fDockgNg9DQQiJPCCPiNDheAAjDocjEokAMoiEw2B4QCIPTuQRiTgckYgjEnF0EBFNBpFwGCAP
    DjAiHAo7RCGCgfBkEAqHgf/z6HwiHUQH0UEgEB0EooNogBqDDELheDiEnUYH2BAOEQ1EA9FgJBqa
    TEMRcYQiIsRwKGQwGIwGA4RhADIIRSQS6TRGDUYDyBAOiQwFhuHJMECIiKjRIIIYQJBwyAAxFBfQ
    INNYNDoNEYMxHAoVQwZIQQJpNA1GoyNqMEbDIUgxBDEYCpLCkwE2hMIRAwQCKUAgkAKkAIFAIIai
    pBhoOsMRYwQECYcKkGLIYDASJYVHg2gwGg3GcDgcghiMhoKi0GgQjU6jwWCAgAzhkNhoNBAKkwKQ
    6SAQwIZQyGgAGcJhg9FoNBgXCsijiSAiiEYDBAIpFIpEIgHECIcXSqkxGDxCEB1Eo8EAgRSJRCIh
    vFwuFlLJoogAAJ4CxwGMCIfDRqSD6CAiCEQEEgAAAAMBQAAACAAAwUAAGAAEA8AAIAAMAIAgADs=}
 image create photo ::img::img(3) -data {
    R0lGODdhGwAcANUAACopKi4nGBwaKTZ4LhyoBSG4BSCcBzNqLyaIFVP8E337T4z8Olz3NT71FDXo
    DT9FMC3YCZb8aOX7kbz9birICSF0EFLrFsj8VyRDFUXYGRxtDh04DljoNkjHLFHYMGroSlfKMWrZ
    UWXKTDQyNEaYMk6LRxkYF0CHNUa4Lf//////////////////////////////////////////////
    /////////////////////////////////////////////ywAAAAAGwAcAAAG/0AAICAICAKCAEAA
    CAgCgoAgIAgIAoKAACAADAiFQqFAIBQIBgKBUCAQCoVCgXAABACIhEKxWCyADGBCKGw0HA2gQzh0
    IAQPSEQyiUQUigUjkUgkGg0ikQKoWCQLBwQCpAiHRCEEAoE4HJBAxTJxFAgGgsFgMAAJQmGhUKBQ
    IBAIJFCxRBxCg2E4JBQKhQKFQoFAHJBAxXGBDIcFArAgHBYoFAoE4oBgKg5FhkAgEoEU4ZACgTgc
    EIzGsoAUCIWCsEAcAiFCocPhwFQaCkehUChQKBAKhDIcQhwORwOCqVgWEEqhAKQIhUCIcAhxOByO
    RsOBqVgWGUqBQqFQMkNHBv/oEA4bjYYDU7EwLECKUJiBZCAZh8PRcAAbQmHCsqlwGBkKpUPJZDIZ
    jsPBcTQ4wwaD4cBUOAwPpUPpUDIeR8bBcTCEjAajkWBYMBUOI9MBUjoUTybDsXAsDU6D0WA0GAwG
    B1PxcDwdSqfTyXgyHAuDw+AAGcKhwoOpeDieTqfT8Xg8HA6HMxwOFRzMwcPxADtCocfD4XA4QIZw
    KFQoPpgKKOQBdToijyfE4Qw/Q4VQofhgDh6OBwQCgTweDofzYXyECqIi8sFUPB+gRzj0cDgMDoPB
    +DAYCgZDEflgBh4OhyPkcDgfDuPDUDAYCgaDwYhEPpgDCMgRCj8fBQOoEA5GIwpgRDj0jAQkDufD
    +HwYH8UHqBAOiREFpxQwAU5AlHAI7AiHoA5KiBKiTgCBKWASmEwBk8AkMJkEJoEpYBIEBCaBKWAK
    AgA7}
 image create photo ::img::img(4) -data {
    R0lGODdhGwAcAMQAACspKzQyNExISbi4t8q7x6qpq6qnlOnp6fv8+tnY1mVnZtTZ8srJyXmId/Lp
    1Ih6iLPEzHZ3dbbItLa6zDhRUYp8dHN6jZuZlB8bKCsoFf///////////////////////ywAAAAA
    GwAcAAAF/yAgjkAgBkBAjgEZiIIwEMNQDEMxFEVRgIM4DkURAIFxgIg4goc4IuOBHAiSJIGygIg4
    kiJ4iOOBHAjCBM2BIEeSJEzCMAyTMEmSLKCzHAeSAM+BHNAwFEMxFMMwDBDDMElygAfiANGBJMRQ
    DMVQDMMwSATBMEmyHMcCBtGBJMNQDMMgDQMxEBDDMEySHEgiRAeIJOAgisRAMBDIiGKSJMlxJEJ0
    IAkxTBIBMdAoJkySJOBxIIkQHUgiDRIBMqKYMGAiistxHEgiRAeSQATBMAw0juAhjgeSUJWYMAzE
    MGAiigt4iKOIIIcQHcjBMEzCJEmSkCJyIAiCJKAQHUeSMMkMkyTJcRwHciAHiIjjIUQHsiQMAyVJ
    Ah7iCCLiKB5CdBwOwzBJkhzHcZDkeAjRcSwJmDBMkhzHgRwgIo7kQUXHkTAMkyTLcSAHSY6HEB1H
    koBMwiTJcRwHiIgjiRxClBxJwjBJchxHWY6HUB3HkjBgIh7HcYCIOJLiQVnJcSRJkhzHUZbkIUTg
    IY4kiIgjSR5ClCDgIYogIo5kKSZCYBymaY7HBQCCUICDOIoEMzCQREASARVNAAAABmQAkAFABgJA
    JmZiJmaiGAIAOw==}

 DoDisplay
 NewGame
 wm geometry . 240x305+0+0
 bind . <Up> {exec wish $argv0 &; exit} ;# rapid dev helper