if 0 {
[Richard Suchenwirth] 2001-03-26 - No trains this weekend, but yes, more 
canvas animations. From a ski trip to Laax, Switzerland, 
here's with due delay my best greetings to all Tcl friends in the world: 
a mountain resort with funicular, skiers, and snowboarders. 
Accidents happen: some tumble down and have to rest a few seconds. 
Sun and stars have also been taken (some) care of. 
Runs as a Tclet too. Enjoy!

[SS] - Hey! this is really nice :) I'll show it to my son that usually
likes this kind of animations.

[WikiDbImage postcard.jpg]
----
}

 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

----
[[ [Category Toys] | [Category Animation]| [Arts and crafts of Tcl-Tk programming] ]]