}
proc poly args {eval .c create polygon $args}
proc sun {x y r} {
.c create oval $x $y [expr $x+$r] [expr $y+$r] -fill red -tag sun
set ::g(sun,dy) -1
sun'
.c lower sun
}
proc sun' {} {
.c lower star
.c move sun 1 $::g(sun,dy)
upvar #0 g(bright) bright
foreach {x0 y0 x1 y1} [.c bbox sun] break
set bright [expr 256-$y0]
set bgcolor [color [expr $bright/1.5] [expr $bright/1.5] $bright]
.c config -background $bgcolor
if {$bright<100} {
.c itemconfig star -fill grey[expr 100-$bright/3]
} else {
.c itemconfig star -fill $bgcolor
}
set suncolor [color 255 [expr {$bright*1}] 0]
.c itemconfig sun -fill $suncolor -outline $suncolor
set dt 1000
if {[lindex [.c bbox sun] 3]<0} {
set dt 10000
.c move sun 200 0
set ::g(sun,dy) 1
}
if {[lindex [.c bbox sun] 1]>200} {
set dt 5000
.c move sun -700 0
set ::g(sun,dy) -1
}
after $dt sun'
}
proc stars {n} {
for {set i 0} {$i<$n} {incr i} {
set x [expr rand()*640]
set y [expr rand()*200]
.c create oval $x $y [expr $x+2] [expr $y+2] -fill white \
-outline {} -tag star
}
}
proc color {r g b} {
foreach i {r g b} {
if [set $i]<0 {set $i 0}
if [set $i]>255 {set $i 255}
}
format #%02x%02x%02x [expr round($r)] [expr round($g)] [expr round($b)]
}
proc funicular {x0 y0 x1 y1} {
.c create line $x0 $y0 $x1 $y1
.c create rect $x0 [expr $y0+4] [expr $x0+30] [expr $y0+18] \
-fill red -tag fcar
.c create rect [expr $x0+14] [expr $y0-10] [expr $x0+16] [expr $y0+5]\
-fill grey -tag fcar
poly [expr $x0+8] [expr $y0-4] [expr $x0+6] [expr $y0-2] \
[expr $x0+20] [expr $y0-14] [expr $x0+22] [expr $y0-12]\
-fill black -tag fcar
set x [expr $x0+2]
set y [expr $y0+7]
foreach i {1 2 3} {
.c create rect $x $y [expr $x+8] [expr $y+6] -fill white\
-tag fcar
incr x 9
}
poly 5 388 5 360 42 332 42 388 -fill tan -outline black
.c create rect 9 370 16 380 -fill white
.c create rect 19 370 26 380 -fill white
.c create rect 29 370 36 380 -fill white
poly 445 60 475 65 475 100 445 120 -fill grey80 \
-outline black -tag mountain
set ::g(funicular,dir) 1
after 0 funicular'
}
proc funicular' {} {
set dir $::g(funicular,dir)
.c move fcar [expr {3*$dir}] [expr {-2*$dir}]
set bbox [.c bbox fcar]
set dt 100
if {[lindex $bbox 0]<10 || [lindex $bbox 2]>470} {
set ::g(funicular,dir) [expr {$dir*-1}]
set dt 6000
if {[lindex $bbox 2]>470} {
foreach i {0 2000 4100 6200 8500 10100 12345 14567 16789} {
after $i skier
}
} elseif {$dir==1 && $::g(bright)<180} {set dt 20000}
}
after $dt funicular'
}
proc flag {x y h} {
set y1 [expr $y-$h]
.c create line $x $y $x $y1
.c create rect $x $y1 [expr $x+12] [expr $y1+12] -fill red
.c create text [expr $x+6] [expr $y1+6] -text + \
-font {Helvetica 12 bold} -fill white
}
proc random:select L {lindex $L [expr {int(rand()*[llength $L])}]}
proc somecolor {} {
random:select {red yellow blue green purple pink orange grey black}
}
proc skier {} {
set id s:[expr {int(rand()*10000)}]
set ski [somecolor]
if {rand()<0.6} {
.c create line 0 -10 10 0 11 0 -fill $ski -width 2 -tag $id
.c create line 4 -14 14 -4 15 -4 -fill $ski -width 2 -tag $id
.c create line 2 -15 -5 -15 -tag $id
.c create line 12 -19 0 -19 -tag $id
set ::g($id,dx) 1
} else {
poly 1 -3 12 -13 15 -10 2 0 -fill $ski -outline [somecolor] -tag $id
set ::g($id,dx) -1
}
.c create line 5 -5 6 -16 7 -16 9 -9 -fill [somecolor] -width 2 -tag $id
set shoes [random:select {black blue purple red}]
.c create line 5 -5 6 -3 -fill $shoes -width 2 -tag $id
.c create line 9 -9 10 -7 -fill $shoes -width 2 -tag $id
.c create line 2 -15 6 -21 6 -16 8 -16 8 -21 12 -19\
-fill [somecolor] -width 2 -tag $id
.c create oval 6 -24 8 -21 -fill orange -tag $id
.c move $id 478 107
.c raise $id mountain
set ::g($id,n) 0
set ::g($id,accident) 0
skier' $id
}
proc skier' {id} {
upvar #0 ::g($id,accident) acc
upvar #0 ::g($id,dx) dx
upvar #0 ::g($id,n) n
set dt 40; set dy 1
if {[lindex [.c bbox $id] 1]>400} {.c delete $id; return}
if {rand()<0.001} {incr acc}
if $acc {
set dt 200
flip $id -1 -1 ;# accident: turn upside-down
incr acc; set dy 6
if {$acc>8} {set dt 5000; set acc 0}
} else {
incr n
if {$n>10 && rand()<0.05} {flip $id; set n 0}
}
.c move $id $dx $dy
after $dt skier' $id
}
proc flip {tag {xflip -1.05} {yflip 1.05}} {
foreach {x0 y0 x1 y1} [.c bbox $tag] break
if ![info exists x0] return
set xm [expr {($x0+$x1)/2.}]
set ym [expr {($y0+$y1)/2.}]
.c scale $tag $xm $ym $xflip $yflip
set ::g($tag,dx) [expr {$::g($tag,dx)*-1}]
}
#---------------------------------------------------------
if ![winfo exists .c] {
canvas .c -width 640 -height 400 -background lightblue
pack .c
bind .c <1> [list source [info script]]
}
.c delete all
foreach i [after info] {after cancel $i}
stars 50
sun 0 100 40
poly 0 400 0 100 40 120 100 150 160 130 200 150 250 110 300 130 350 80\
700 500 -fill grey95
poly 0 400 0 370 170 380 330 200 360 120 420 70 540 90 570 60 700 200\
700 400 -fill white -tag mountain
funicular 20 360 470 60
flag 160 380 40
skier