Version 0 of Shapes and Lights - a simple canvas script

Updated 2002-05-30 03:39:58

#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