Demo 2 of 2 in category tcl3dGauges
 |
# Copyright: 2005-2024 Paul Obermeier (obermeier@tcl3d.org)
#
# See the file "Tcl3D_License.txt" for information on usage
# and redistribution of this file, and for a
# DISCLAIMER OF ALL WARRANTIES.
#
# Module: Tcl3D -> tcl3dGauges
# Filename: gaugetest.tcl
#
# Author: Paul Obermeier
#
# Description: Test program for the Tcl3D extension package gauge.
# The program allows to show the 4 gauges at different sizes.
package require Tk
package require Img
package require tcl3d
tcl3dConsoleCreate .tcl3dOutputConsole "# " "gaugetest output"
set numWidgets 4
set numTests 500
set stopWatch [tcl3dNewSwatch]
tcl3dStartSwatch $stopWatch
proc bgerror { msg } {
tk_messageBox -icon error -type ok -message "Error: $msg\n\n$::errorInfo"
exit
}
# Print info message into widget a the bottom of the window.
proc PrintInfo { msg } {
if { [winfo exists .fr.info] } {
.fr.info configure -text $msg
}
}
proc TestWidget { toglWidget ind minVal maxVal } {
global gStopTest
set gStopTest 0
set startTime [tcl3dLookupSwatch $::stopWatch]
set inc [expr ($maxVal - $minVal) / double ($::numTests)]
for { set val $minVal } { $val <= $maxVal } { set val [expr $val + $inc] } {
set ::myValue($ind) $val
update
if { $gStopTest } {
return
}
}
for { set val $maxVal } { $val >= $minVal } { set val [expr $val - $inc] } {
set ::myValue($ind) $val
update
if { $gStopTest } {
return
}
}
set endTime [tcl3dLookupSwatch $::stopWatch]
set elapsedTime [expr $endTime - $startTime]
set fps [expr 2*$::numTests / $elapsedTime]
wm title . [format "%s %.1f seconds (%.0f fps)" \
$::appTitle $elapsedTime $fps]
puts [format "%s-%d: %.1f seconds (%.0f fps)" \
$::cmdType $ind $elapsedTime $fps]
}
proc GetValue { toglWidget labelWidget scaleVal } {
set cmd [format "::%s::getValue" $::cmdType]
set val [$cmd $toglWidget]
$labelWidget configure -text $val
}
proc Cleanup {} {
global numWidgets
global gStopTest
set gStopTest 1
set cmdDel [format "::%s::delete" $::cmdType]
for { set i 0 } { $i < $numWidgets } { incr i } {
$cmdDel .fr.toglwin_$i
}
}
proc CreateWidgets { resMin resMax resIncr } {
global numWidgets
global gStopTest
set gStopTest 1
set size 64
set colors { red green blue magenta }
set cmdNew [format "::%s::new" $::cmdType]
set cmdReset [format "::%s::reset" $::cmdType]
set cmdDel [format "::%s::delete" $::cmdType]
for { set i 0 } { $i < $numWidgets } { incr i } {
$cmdDel .fr.toglwin_$i
destroy .fr.label_$i
destroy .fr.scale_$i
destroy .fr.test_$i
}
destroy .fr.info
for { set i 0 } { $i < $numWidgets } { incr i } {
set actSize [expr $size * ($i + 1)]
set tcl3dWidget [$cmdNew .fr.toglwin_$i \
-width $actSize -height $actSize \
-background [lindex $colors $i] \
-variable ::myValue($i)]
grid $tcl3dWidget -row 1 -column $i -sticky se
$cmdReset $tcl3dWidget
set ::myValue($i) $resMin
set labelWidget [label .fr.label_$i]
grid $labelWidget -row 2 -column $i -sticky news
set scaleWidget [scale .fr.scale_$i -variable ::myValue($i) \
-from $resMin -to $resMax -resolution $resIncr \
-orient horizontal -showvalue 0 \
-command "GetValue $tcl3dWidget $labelWidget"]
grid $scaleWidget -row 3 -column $i -sticky news
set testWidget [button .fr.test_$i -text "Test" \
-command "TestWidget $tcl3dWidget $i $resMin $resMax"]
grid $testWidget -row 4 -column $i -sticky news
}
label .fr.info
grid .fr.info -row 5 -columnspan $numWidgets
PrintInfo [tcl3dOglGetInfoString]
}
frame .fr
pack .fr -fill both -expand 1
set appTitle "Tcl3D demo: Gauge test"
wm title . $appTitle
wm minsize . 100 100
set i 0
foreach { cmd resMin resMax resIncr } { \
airspeed 0 750 0.25 \
altimeter 0 10000 10 \
compass 0 360 0.25 \
tiltmeter -90 90 0.25 } {
radiobutton .fr.b_$cmd -command "CreateWidgets $resMin $resMax $resIncr" \
-text $cmd -value $cmd -variable cmdType
grid .fr.b_$cmd -row 0 -column $i -sticky ew
incr i
}
if { [string compare $tcl_platform(os) "windows"] == 0 } {
bind . <Alt-F4> exit
}
bind . <Escape> exit
wm protocol . WM_DELETE_WINDOW exit
set cmdType "airspeed"
.fr.b_airspeed invoke
|
