Shapes and Lights - a simple canvas script

SO While working on a set of indicator lights for one of my current projects, it occurred to me that I could make a simple sample, using the canvas widget, that could prove extremely useful to beginners and newbies. (I know I could have used such an example not so long ago.)

Among other things, it contains a simple sample of a global array, accessing the array via the use of upvar, creating some simple shapes on a canvas, a simple switch proc, a simple proc for generating a pseudo-random int, and a simple example of using after, to drive the demonstration. All of these are questions are regularly asked on clt.

I sincerely hope that someone finds it useful. Comments are welcome and appreciated.

 #Wednesday, May 29, 2002 22:33:52

 #define a global array of colors
 #feel free to edit the colors, as my colorvision is
 #rather unique...
 set colorAr(dkblue) #160071
 set colorAr(brtblue) #7ef4fe
 set colorAr(dkgreen) #3e532b
 set colorAr(brtgreen) #92fe7e
 set colorAr(dkyellow) #b9bd1a
 set colorAr(brtyellow) #ffff4f
 set colorAr(dkred) #75222b
 set colorAr(brtred) #ff004d

 #create a canvas
 pack [canvas .c -width 180 -height 30 -bg grey -relief groove -bd 2]

 #draw some ojbects in the canvas, give them a tag name 
 #and default fill color
 .c create oval 20 28 40 8 -tag blueled -fill $colorAr(dkblue)
 .c create rectangle 60 28 80 8 -tag greenled -fill $colorAr(dkgreen)
 .c create polygon 100 28  115 8 130 28  -outline black \
        -tag yellowled -fill $colorAr(dkyellow)
 .c create line 144 18 168 18 -arrow last -width 12 \
             -tag redled -fill $colorAr(dkred)

 #turn on the lights...
 proc greenlight { arrayname } {
        
        upvar #0 $arrayname thisArray
        .c itemconfigure blueled -fill $thisArray(dkblue)
        .c itemconfigure yellowled -fill $thisArray(dkyellow)
        .c itemconfigure  redled -fill $thisArray(dkred)
        .c itemconfigure greenled -fill $thisArray(brtgreen)
 }

 proc bluelight { arrayname } {

        upvar #0 $arrayname thisArray        
        .c itemconfigure yellowled -fill $thisArray(dkyellow)
        .c itemconfigure  redled -fill $thisArray(dkred)
        .c itemconfigure greenled -fill $thisArray(dkgreen)
        .c itemconfigure blueled -fill $thisArray(brtblue)
 }

 proc yellowlight { arrayname } {
        
        upvar #0 $arrayname thisArray                
        .c itemconfigure  redled -fill $thisArray(dkred)
        .c itemconfigure greenled -fill $thisArray(dkgreen)
        .c itemconfigure blueled -fill $thisArray(dkblue)
        .c itemconfigure yellowled -fill $thisArray(brtyellow)
 }

 proc redlight { arrayname } {
        
        upvar #0 $arrayname thisArray        
        .c itemconfigure greenled -fill $thisArray(dkgreen)
        .c itemconfigure blueled -fill $thisArray(dkblue)
        .c itemconfigure yellowled -fill $thisArray(dkyellow)
        .c itemconfigure  redled -fill $thisArray(brtred)
 }

 #a simple pseudo-random int proc - returns a value from
 #1 to upper limit
 proc random_int { upper_limit } {        
        set myrand [expr int(rand() * $upper_limit + 1)]        
        }

 #a proc to switch which light is on
 proc randomlight { } {        
        set int [random_int 4]
        switch $int {
                1 {greenlight colorAr}
                
                2 {bluelight colorAr}

                3 {yellowlight colorAr}

                4 {redlight colorAr}
                }        
 }

 #an after callback to drive this thing
 #un-commenting the bell line will help to show
 #how often the random_int proc repeats in such a limited range
 proc run { } {
        after 1000 run
        randomlight
        #bell
        }

 #set the window title
 wm title .  "Shapes and Lights"

 wm deiconify .
 #call the run proc
 run

 proc light { color arrayname } {
     set colors [ list dkyellow dkred dkgreen dkblue ]
     set i [ lsearch $colors dk$color ]
     set colors [ lreplace $colors $i ]
     lappend colors brt$color
     upvar #0 $arrayname thisArray
     foreach color $colors {
        .c itemconfigure  ${color}led -fill $thisArray($color)
     }   
 }

SOAs suggested by the above edit, we can certainly improve our little script by replacing four procs (bluelight, greenlight, yellowlight and redlight) with just one proc, light. I would go about it a little differently...

 proc light {color arrayname} {
        set colorlist {blue green yellow red}
        upvar #0 $arrayname thisArray
        foreach index $colorlist {
                .c itemconfigure ${index}led -fill $thisArray(dk$index)
                }
        .c itemconfigure ${color}led -fill $thisArray(brt$color)
 }

 #which requires us to change our randomlight proc just a little


 proc randomlight { } {        
        set int [random_int 4]
        switch $int {
                1 {light green colorAr}
                
                2 {light blue colorAr}

                3 {light yellow colorAr}

                4 {light red colorAr}
                }        
 }

Perhaps someone else would care to comment on improving the original script?

RS: What you want here, is a random color from a list, so here's how I would do that - if such a proc is needed at all (and the function of colorAr is dubious):

 proc randomlight {} {light [lpick {green blue yellow red}] colorAr}

where

 proc lpick list {lindex $list [expr {int(rand()*[llength $list])}]}