linguist/samples/Tcl/filenames/starfield

#!/usr/bin/env wish
# http://wiki.tcl.tk/14140

proc stars'go {c factor} {
    set w [winfo width $c]
    set h [winfo height $c] 
    $c scale all [expr {$w/2}] [expr {$h/2}] $factor $factor 
    foreach item [$c find all] {
        if {[llength [$c bbox $item]] == 0} {$c delete $item; continue} ;# (1)
        foreach {x0 y0 x1 y1} [$c bbox $item] break
        if {$x1<0 || $x0>$w || $y1<0 || $y0>$h} {$c delete $item}
    }
    time {
        set x [expr {rand()*$w}]
        set y [expr {rand()*$h}]
        set col [lpick {white yellow beige bisque cyan}]
        $c create oval $x $y [expr {$x+1}] [expr {$y+1}] -fill $col \
                -outline $col
    } 10
    after $::ms [info level 0]
}
proc lpick list {lindex $list [expr {int(rand()*[llength $list])}]}
#-- Let's go!
pack [canvas .c -bg black] -fill both -expand 1
set ms 40
bind . <Up> {incr ms -5}
bind . <Down> {incr ms 5}
stars'go .c 1.05