1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
#
# This software is Copyright by the Board of Trustees of Michigan
# State University (c) Copyright 2005.
#
# You may use this software under the terms of the GNU public license
# (GPL) ir the Tcl BSD derived license The terms of these licenses
# are described at:
#
# GPL: http://www.gnu.org/licenses/gpl.txt
# Tcl: http://www.tcl.tk/softare/tcltk/license.html
# Start with the second paragraph under the Tcl/Tk License terms
# as ownership is solely by Board of Trustees at Michigan State University.
#
# Author:
# Ron Fox
# NSCL
# Michigan State University
# East Lansing, MI 48824-1321
#
# Adjusted by Arjen Markus
#
#
# This package provides an LED
# widget. LED widgets are one color when on
# and another when off.
# Implementation is just a filled circle on a
# canvas.
# Options recognized:
# (all standard options for a frame).
# -size - Radius of the led.
# -on - Color of on state.
# -off - Color of off state.
# -variable - on color when variable is nonzero else off.
# Methods
# on - Turn led on.
# off - Turn led off.
#
# TODO:
# Add a label
#
package provide led 1.0
package require Tk
package require snit
package require bindDown
namespace eval controlwidget {
namespace export led
}
snit::widget controlwidget::led {
delegate option * to hull
option -size {17}
option -on green
option -off black
option -variable {}
constructor args {
$self configurelist $args
canvas $win.led -width $options(-size) -height $options(-size)
set border [expr [$win cget -borderwidth] + 2]
set end [expr $options(-size) - $border]
$win.led create oval $border $border $end $end -fill $options(-off)
grid $win.led -sticky nsew
bindDown $win $win
}
# Process the -variable configuration by killing off prior traces
# and setting an new trace:
#
onconfigure -variable name {
if {$options(-variable) ne ""} {
trace remove variable ::$options(-variable) write [mymethod varTrace]
}
trace add variable ::$name write [mymethod varTrace]
set options(-variable) $name
# set our initial state to the current value of the var:
# the after is because we could be constructing an need to give
# the widgets a chance to get built:
after 10 [list $self varTrace $name "" write]
}
# Trace for the led variable..
#
method varTrace {name index op} {
set name ::$name
set value [set $name]
if {[string is boolean -strict $value]} {
$self setstate $value
}
}
#
# Set the led on.
#
method on {} {
if {$options(-variable) ne ""} {
set ::$options(-variable) 1
} else {
$self setstate 1
}
}
# set the led off
#
method off {} {
if {$options(-variable) ne ""} {
set ::$options(-variable) 0
} else {
$self setstate 0
}
}
#
# Set the led state
#
method setstate {value} {
if {$value} {
$win.led itemconfigure 1 -fill $options(-on)
} else {
$win.led itemconfigure 1 -fill $options(-off)
}
}
}
|
