PWQ 17 Sep 2003, My version of Rain Storm which I coded up to see why the original version leaked memory (big time!)
package require Tk
set S(delay) 80
set S(rain) 3
set S(id) 0
set MODE 1
array set SIZES {0 1 1 2 2 4 3 6 4 8 5 10 6 12 7 14 8 20}
set COUNT {10 20 30 60 100 230 400}
foreach {i x} [array get SIZES] {
lappend new $i [expr $x * 1.5]
}
for {set i 5} {$i < 20 } {incr i 1} {
lappend new $i [expr $i * 1.5 ]
}
array set SIZES $new
set n [llength [array names SIZES]]
for { set i 0 } {$i < $n } {incr i} {
set x E[format %1x [expr {15 * $i / $n}]]
set COLOUR([expr $n - $i -1]) #$x$x$x
}
array set DROPS {0 {Mist 500} 1 {Sprinkles 200} 2 {Shower 100}
3 {Rain 50} 4 {Storm 25} 5 {Down\ Pour 10} 6 {Deluge 1}}
wm protocol . WM_DELETE_WINDOW exit
wm title . "Rain Storm"
canvas .c -relief raised -borderwidth 0 -height 500 -width 500 -bg #E0E0E0
scale .rain -orient h -variable S(rain) -command {after idle Rain} -showvalue 0 -from 0 -to 6
image create photo ::img::blank -width 1 -height 1
button .about -image ::img::blank -highlightthickness 0 -command \
[list tk_messageBox -message "Rain Storm\nby Keith Vetter, May 2003"]
pack .c -side top -fill both -expand 1
place .rain -in .c -relx 1 -rely 1 -anchor se
place .about -in .c -relx 1 -rely 1 -anchor se
bind all <Alt-c> {console show}
pack [checkbutton .mode -variable MODE -command {Rain 0}] -anc nw
proc Rain {num} {
.c delete all
foreach a [after info] {after cancel $a}
update
.rain config -label [lindex $::DROPS($::S(rain)) 0]
set max [lindex $::COUNT $::S(rain)]
set ::S(rand) 0.6
if { $max > 50 } {set ::S(rand) 0.75}
if { $max > 100 } {set ::S(rand) 0.8}
if { $max > 200 } {set ::S(rand) 0.9}
if { $max > 300 } {set ::S(rand) 0.95}
for {set i 0} {$i < $max } {incr i} {
#update
set x [expr {round([winfo width .c] * rand())}]
set y [expr {round([winfo height .c] * rand())}]
if { $::MODE } {
set id [.c create oval [box $x $y 0] -fill #e0e0e0 -outline {}]
} else {
set id [.c create oval [box $x $y 0] -outline #e0e0e0 -fill {} ]
#set id [.c create oval [box $x $y 0] -fill red -outline {}]
}
SetDrop $id
}
}
proc SetDrop {id} {
set x [expr {round([winfo width .c] * rand())}]
set y [expr {round([winfo height .c] * rand())}]
.c raise $id
.c coords $id $x $y $x $y
#.c itemconfig $id -tag [expr $::S(rain) -1]
.c itemconfig $id -tag -1
set d [lindex $::DROPS($::S(rain)) 1]
set d [expr {int(rand() * 100 + $d)}]
after $d RainDrop $id
}
proc RainDrop {id} {
set t1 [clock clicks -milli]
set n [lindex [.c gettags $id] 0] ;# Trash current
if {$n == ""} {return} ; # I've been deleted
incr n
#puts "$id -> $n"
if {! [info exists ::SIZES($n)] || rand() > $::S(rand)} {
after idle SetDrop $id
} else {
set x1 ""
foreach {x1 y1 x2 y2} [.c coords $id] {}
if {$x1 == "" } {return}
set x [expr {($x2 + $x1) / 2}]
set y [expr {($y2 + $y1) / 2}]
.c coords $id [box $x $y $::SIZES($n)]
if {$::MODE} {
.c itemconfig $id -fill $::COLOUR($n)
} else {
.c itemconfig $id -outline $::COLOUR($n) -width [expr $n / 3]
}
.c itemconfig $id -tag $n
set time [expr {([clock clicks -milli] - $t1)}]
after [expr int(($time > $::S(delay) ? $time : $::S(delay)) + rand() * 3)] RainDrop $id
if { $::S(rain) > 3 } { update idletasks }
}
}
proc box {x y r} {
list [expr {$x-$r}] [expr {$y-$r}] [expr {$x+$r}] [expr {$y+$r}]
}Category Application | Category Graphics | Category Whizzlet | Category Animation