Flashing light simulation

if 0 {Richard Suchenwirth 2004-10-28 - Another evening fun project on canvas animation: at least in Germany, ambulances, fire dept. and police cars have rotating alarm lights on the top, where a bright lamp with a round concave mirror rotates around a vertical axis under a colored glass (or plastic) cover, to draw everybody's attention. With the thought of maybe using this in toy cars, I thought how to simulate this effect in Tcl.

Let the cover just be a rectangle. When the light rotates, you first see it as part of a circle on one side (say, the left); then it moves to the middle, the bright center appears, follows by another part of the circle - all move in the same direction and disappear on the other side. This repeats until stopped. So we need three kinds of canvas items: the left and right circular parts (easily done with arc -style chord items), and the center, for simplicity as a rectangle. And we need them in three positions: at left, middle, and right of the cover. My solution was to create nine items for all possible combinations, labeled (in a tag) with the kind (L, M, R) and position (0, 1, 2) - plus the ID of the cover, so one can have several alarm lights concurrently without interference. For example, of lamp 123, the left part-circle in the middle would be named L1.123. }

 proc strobe {w x0 y0 x1 y1 color} {
    set color2 [color'dim $color 0.95]
    set bgcolor [color'dim $color 0.66]
    set id [$w create rect $x0 $y0 $x1 $y1 -fill $bgcolor]
    set dx [expr {($x1-$x0)/3.}]
    set x2 [expr {$x0+$dx}]
    set x3 [expr {$x0-2*$dx}]
    foreach i {0 1 2} {
        $w create arc $x0 $y0 $x1 $y1 -style chord \
            -start 115 -extent 130 -fill $color2 \
            -outline $color2 -tag [list L$i.$id X.$id]]
        $w create rect $x0 $y0 $x2 $y1 -fill $color \
            -outline $color -tag [list M$i.$id X.$id]
        $w create arc $x3 $y0 $x2 $y1 -style chord \
            -start 295 -extent 130 -fill $color2 \
            -outline $color2 -tag [list R$i.$id X.$id]
        if $i {
            foreach shape {L M R} {
                $w move $shape$i.$id [expr {$dx*$i}] 0
            }
        }
    }
    strobe'animate $w $id {R0 {M0 R1} {L0 M1 R2} {L1 M2} L2}
 } 

if 0 {The animation happens by lowering all these items below the cover, then raising a set of items (specified as a "phase" in a "script") above it, so they become visible. The script is then cycled, so the first item is moved to the end of the script, and after some interval this repeats again - normally I love to use the every timer, but then the script would have to be in a global variable to survive. With the solution below, the script is strictly encapsulated in the after calls.}

 proc strobe'animate {w id phases} {
    $w raise $id
    set phase [lindex $phases 0]
    foreach tag $phase {$w raise $tag.$id}
    set phases [concat [lrange $phases 1 end] [list $phase]]
    after 100 [list strobe'animate $w $id $phases]

 }

#-- making a color darker by a certain factor:

 proc color'dim {color factor} {
    foreach {rmax gmax bmax} [winfo rgb . white] break ;# "calibration"
    foreach {r    g    b}    [winfo rgb . $color] break
    foreach var {r g b} {
        set $var [expr {round([set $var]*$factor*255./[set ${var}max])}]
    }
    format #%02X%02X%02X $r $g $b
 }

if 0 {Now testing with two instances, to verify they don't interfere:}

 pack [canvas .c -width 100 -height 50]
 strobe .c 10 10 40 40 blue
 strobe .c 60 10 90 40 orange

#-- Little dev helpers:

 bind . <Escape> {exec wish $argv0 &; exit}
 bind . <F1> {console show}

if 0 {

Category Animation - Arts and crafts of Tcl-Tk programming }