#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