Updated 2013-07-31 06:10:14 by uniquename ▲
 # tachometer.tcl --
 # 
 # Part of: The TCL'ers Wiki
 # Contents: a tachometer-like widget
 # Date: Fri Jun 13, 2003
 # 
 # Abstract
 # 
 # 
 # 
 # Copyright (c) 2003 Marco Maggi
 # 
 # The author  hereby grant permission to use,  copy, modify, distribute,
 # and  license this  software  and its  documentation  for any  purpose,
 # provided that  existing copyright notices  are retained in  all copies
 # and that  this notice  is included verbatim  in any  distributions. No
 # written agreement, license, or royalty  fee is required for any of the
 # authorized uses.  Modifications to this software may be copyrighted by
 # their authors and need not  follow the licensing terms described here,
 # provided that the new terms are clearly indicated on the first page of
 # each file where they apply.
 # 
 # IN NO  EVENT SHALL THE AUTHOR  OR DISTRIBUTORS BE LIABLE  TO ANY PARTY
 # FOR  DIRECT, INDIRECT, SPECIAL,  INCIDENTAL, OR  CONSEQUENTIAL DAMAGES
 # ARISING OUT  OF THE  USE OF THIS  SOFTWARE, ITS DOCUMENTATION,  OR ANY
 # DERIVATIVES  THEREOF, EVEN  IF THE  AUTHOR  HAVE BEEN  ADVISED OF  THE
 # POSSIBILITY OF SUCH DAMAGE.
 # 
 # THE  AUTHOR  AND DISTRIBUTORS  SPECIFICALLY  DISCLAIM ANY  WARRANTIES,
 # INCLUDING,   BUT   NOT  LIMITED   TO,   THE   IMPLIED  WARRANTIES   OF
 # MERCHANTABILITY,    FITNESS   FOR    A    PARTICULAR   PURPOSE,    AND
 # NON-INFRINGEMENT.  THIS  SOFTWARE IS PROVIDED  ON AN "AS  IS" BASIS,
 # AND  THE  AUTHOR  AND  DISTRIBUTORS  HAVE  NO  OBLIGATION  TO  PROVIDE
 # MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 # 
 # $Id: 9108,v 1.6 2003-07-12 08:00:49 jcw Exp $
 #
 
 package require Tcl 8
 package require Tk  8
 
 option add *borderWidth                                        1
 
 option add *Scale.from                                 0
 option add *Scale.to                                   105
 option add *Scale.orient                               vertical
 option add *Scale.label                                        speed
 option add *Scale.resolution                           1
 option add *Scale.showValue                            1
 
 proc main { argc argv } {
     global     forever
 
     wm withdraw .
     wm title   . "A tachometer-like widget"
     wm geometry . +10+10
 
     tachometer::constructor .t1 ::value1 { 0 10 20 30 40 50 60 70 80 90 100 }
     scale .s1 -command "set ::value1"
 
     tachometer::constructor .t2 ::value2 { 0 {} {} 5 {} {} 10 }
     scale .s2 -command "set ::value2"
 
     button .b -text Quit -command "set ::forever 1"
 
     grid .t1 .s1 .t2 .s2 .b -padx 2 -pady 2
     wm deiconify .
     vwait forever
     tachometer::destructor .t1
     tachometer::destructor .t2
     exit 0
 }
 
 namespace eval tachometer {
     option add *Tachometer.min                         0.0
     option add *Tachometer.max                         100.0
     option add *Tachometer.indexid                     {}
 
     option add *Tachometer.relief                      flat
     option add *Tachometer.borderWidth                 0
 
     option add *Tachometer.Canvas.background           gray
     option add *Tachometer.Canvas.width                        50m
     option add *Tachometer.Canvas.height               50m
     option add *Tachometer.Canvas.foreground           black
     option add *Tachometer.Canvas.highlightThickness   0
     option add *Tachometer.Canvas.borderWidth          1
     option add *Tachometer.Canvas.relief               raised
 
     variable   pi [expr {3.14159265359/180.0}]
 }
 
 proc tachometer::constructor { widget varname labels } {
     variable   pi
     upvar      $varname value
 
     frame $widget -class Tachometer
     canvas [set c $widget.canvas]
     grid $c -sticky news
 
     option add ${widget}.varname $varname
 
     set width  [$c cget -width]
     set height [$c cget -height]
     set num    [llength $labels]
     set delta  [expr {(360.0-40.0)/($num-1)}]
 
     # display
     set x1 [expr {$width/50.0*2.0}]
     set y1 [expr {$width/50.0*2.0}]
     set x2 [expr {$width/50.0*48.0}]
     set y2 [expr {$width/50.0*48.0}]
     $c create oval $x1 $y1 $x2 $y2 -fill white -width 1 -outline lightgray
     set xc [expr {($x2-$x1)/2.0}]
     shadowcircle $c $x1 $y1 $x2 $y2 40 0.7m 135.0
 
     # pin
     set x1 [expr {$width/50.0*23.0}]
     set y1 [expr {$width/50.0*23.0}]
     set x2 [expr {$width/50.0*27.0}]
     set y2 [expr {$width/50.0*27.0}]
     $c create oval $x1 $y1 $x2 $y2 -width 1 -outline lightgray -fill red
     set xc [expr {($x2-$x1)/2.0}]
     shadowcircle $c $x1 $y1 $x2 $y2 40 0.7m -45.0
 
     # danger marker
     $c create arc \
            [expr {$width/50.0*4.0}]    [expr {$width/50.0*4.0}] \
            [expr {$width/50.0*44.5}]   [expr {$width/50.0*44.5}] \
            -start -70 -extent $delta -style arc \
            -outline red -fill red -width 3m
 
     # graduate line
     $c create arc \
            [expr {$width/50.0*4.0}]    [expr {$width/50.0*4.0}] \
            [expr {$width/50.0*46.0}]   [expr {$width/50.0*46.0}] \
            -start -70 -extent 320    -style arc \
            -outline black -width 0.5m
 
     set half   [expr {$width/2.0}]
     set l1     [expr {$half*0.85}]
     set l2     [expr {$half*0.74}]
     set l3     [expr {$half*0.62}]
 
     set angle  110.0
     for {set i 0} {$i < $num} {incr i} {
        set a [expr {($angle+$delta*$i)*$pi}]
 
        set x1 [expr {$half+$l1*cos($a)}]
        set y1 [expr {$half+$l1*sin($a)}]
        set x2 [expr {$half+$l2*cos($a)}]
        set y2 [expr {$half+$l2*sin($a)}]
        $c create line $x1 $y1 $x2 $y2 -fill black -width 0.5m
 
        set x1 [expr {$half+$l3*cos($a)}]
        set y1 [expr {$half+$l3*sin($a)}]
 
        set label [lindex $labels $i]
        if { [string length $label] } {
            $c create text $x1 $y1 \
                    -anchor center -justify center -fill black \
                    -text $label -font { Helvetica 10 }
        }
     }
 
     rivet $c 10 10
     rivet $c [expr {$width-10}] 10
     rivet $c 10 [expr {$height-10}]
     rivet $c [expr {$width-10}] [expr {$height-10}]
 
     set value 0
     drawline $widget $value
 
     trace add variable $varname write \
            [namespace code "tracer $widget $varname"]
     return $widget
 }
 
 proc tachometer::destructor { widget } {
     set varname [option get $widget varname {}]
     trace remove variable $varname write \
            [namespace code "tracer $widget $varname"]
     return
 }
 
 proc tachometer::tracer { widget varname args } {
     upvar      $varname value
     drawline $widget $value
     return
 }
 
 proc tachometer::drawline { widget value } {
     variable   pi
     set id     [option get $widget indexid {}]
     set min    [option get $widget min {}]
     set max    [option get $widget max {}]
 
     set c $widget.canvas
 
     set v [expr { ($value <= ($max*1.02))? $value : ($max*1.02) }]
 
     set angle [expr {((($v-$min)/($max-$min))*320.0+20.0)*$pi}]
 
     set width  [$c cget -width]
     set half   [expr {$width/2.0}]
     set length [expr {$half*0.8}]
 
     set xl [expr {$half-$length*sin($angle)}]
     set yl [expr {$half+$length*cos($angle)}]
 
     set xs [expr {$half+0.2*$length*sin($angle)}]
     set ys [expr {$half-0.2*$length*cos($angle)}]
 
     catch {$c delete $id}
     set id [$c create line $xs $ys $xl $yl -fill red -width 0.6m]
     option add *[string trimleft $widget .].indexid $id
     return
 }
 
 proc tachometer::rivet { c xc yc } {
     shadowcircle $c \
            [expr {$xc-4}] [expr {$yc-4}] [expr {$xc+4}] [expr {$yc+4}] \
            5 0.5m -45.0
 }
 
 proc shadowcircle { canvas x1 y1 x2 y2 ticks width orient } {
     set angle $orient
     set delta [expr {180.0/$ticks}]
     for {set i 0} {$i <= $ticks} {incr i} {
        set a [expr {($angle+$i*$delta)}]
        set b [expr {($angle-$i*$delta)}]
 
        set color [expr {40+$i*(200/$ticks)}]
        set color [format "#%x%x%x" $color $color $color]
 
        $canvas create arc $x1 $y1 $x2 $y2 -start $a -extent $delta \
                -style arc -outline $color -width $width
        $canvas create arc $x1 $y1 $x2 $y2 -start $b -extent $delta \
                -style arc -outline $color -width $width
     }
 }
 
 main $argc $argv
 
 ### end of file
 # Local Variables:
 # mode: tcl
 # page-delimiter: "^#PAGE"
 # End:

ulis, 2003-06-14: Very nice!

ulis, 2003-07-11: Added the ability to drag the needle.
 # tachometer.tcl --
 #
 # Part of: The TCL'ers Wiki
 # Contents: a tachometer-like widget
 # Date: Fri Jun 13, 2003
 #
 # Abstract
 #
 #
 #
 # Copyright (c) 2003 Marco Maggi
 #
 # The author  hereby grant permission to use,  copy, modify, distribute,
 # and  license this  software  and its  documentation  for any  purpose,
 # provided that  existing copyright notices  are retained in  all copies
 # and that  this notice  is included verbatim  in any  distributions. No
 # written agreement, license, or royalty  fee is required for any of the
 # authorized uses.  Modifications to this software may be copyrighted by
 # their authors and need not  follow the licensing terms described here,
 # provided that the new terms are clearly indicated on the first page of
 # each file where they apply.
 #
 # IN NO  EVENT SHALL THE AUTHOR  OR DISTRIBUTORS BE LIABLE  TO ANY PARTY
 # FOR  DIRECT, INDIRECT, SPECIAL,  INCIDENTAL, OR  CONSEQUENTIAL DAMAGES
 # ARISING OUT  OF THE  USE OF THIS  SOFTWARE, ITS DOCUMENTATION,  OR ANY
 # DERIVATIVES  THEREOF, EVEN  IF THE  AUTHOR  HAVE BEEN  ADVISED OF  THE
 # POSSIBILITY OF SUCH DAMAGE.
 #
 # THE  AUTHOR  AND DISTRIBUTORS  SPECIFICALLY  DISCLAIM ANY  WARRANTIES,
 # INCLUDING,   BUT   NOT  LIMITED   TO,   THE   IMPLIED  WARRANTIES   OF
 # MERCHANTABILITY,    FITNESS   FOR    A    PARTICULAR   PURPOSE,    AND
 # NON-INFRINGEMENT.  THIS  SOFTWARE IS PROVIDED  ON AN "AS  IS" BASIS,
 # AND  THE  AUTHOR  AND  DISTRIBUTORS  HAVE  NO  OBLIGATION  TO  PROVIDE
 # MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
 #
 # $Id: 9108,v 1.6 2003-07-12 08:00:49 jcw Exp $
 #

 package require Tcl 8
 package require Tk  8

 option add *borderWidth          1

 option add *Scale.label          speed
 option add *Scale.resolution     1
 option add *Scale.showValue      1

 proc main { argc argv } \
 {
     global forever

     wm withdraw .
     wm title . "A tachometer-like widget"
     wm geometry . +10+10

     tachometer::constructor .t1 ::value1 { 0 10 20 30 40 50 60 70 80 90 100 }
     scale .s1 -command "set ::value1" -variable ::value1

     tachometer::constructor .t2 ::value2 { 0 {} {} 5 {} {} 10 }
     scale .s2 -command "set ::value2" -variable ::value2

     button .b -text Quit -command "set ::forever 1"

     grid .t1 .s1 .t2 .s2 .b -padx 2 -pady 2
     wm deiconify .
     vwait forever
     tachometer::destructor .t1
     tachometer::destructor .t2
     exit 0
 }

 namespace eval tachometer \
 {
     option add *Tachometer.min                       0.0
     option add *Tachometer.max                       100.0
     option add *Tachometer.indexid                   {}

     option add *Tachometer.relief                    flat
     option add *Tachometer.borderWidth               0

     option add *Tachometer.Canvas.background         gray
     option add *Tachometer.Canvas.width              50m
     option add *Tachometer.Canvas.height             50m
     option add *Tachometer.Canvas.foreground         black
     option add *Tachometer.Canvas.highlightThickness 0
     option add *Tachometer.Canvas.borderWidth        1
     option add *Tachometer.Canvas.relief             raised

     variable pi [expr {3.14159265359/180.0}]
 }

 proc tachometer::constructor { widget varname labels } \
 {
     variable pi
     upvar  $varname value

     frame $widget -class Tachometer
     canvas [set c $widget.canvas]
     grid $c -sticky news

     option add ${widget}.varname $varname

     set width  [$c cget -width]
     set height [$c cget -height]
     set num  [llength $labels]
     set delta  [expr {(360.0-40.0)/($num-1)}]

     # display
     set x1 [expr {$width/50.0*2.0}]
     set y1 [expr {$width/50.0*2.0}]
     set x2 [expr {$width/50.0*48.0}]
     set y2 [expr {$width/50.0*48.0}]
     $c create oval $x1 $y1 $x2 $y2 -fill white -width 1 -outline lightgray
     shadowcircle $c $x1 $y1 $x2 $y2 40 0.7m 135.0

     # pin
     set x1 [expr {$width/50.0*23.0}]
     set y1 [expr {$width/50.0*23.0}]
     set x2 [expr {$width/50.0*27.0}]
     set y2 [expr {$width/50.0*27.0}]
     $c create oval $x1 $y1 $x2 $y2 -width 1 -outline lightgray -fill red
     shadowcircle $c $x1 $y1 $x2 $y2 40 0.7m -45.0

     # danger marker
     $c create arc \
      [expr {$width/50.0*4.0}]  [expr {$width/50.0*4.0}] \
      [expr {$width/50.0*44.5}] [expr {$width/50.0*44.5}] \
      -start -70 -extent $delta -style arc \
      -outline red -fill red -width 3m

     # graduate line
     set x1 [expr {$width/50.0*4.0}]
     set y1 [expr {$width/50.0*4.0}]
     set x2 [expr {$width/50.0*46.0}]
     set y2 [expr {$width/50.0*46.0}]
     $c create arc $x1 $y1 $x2 $y2 \
      -start -70 -extent 320 -style arc \
      -outline black -width 0.5m
     set xc [expr {($x2+$x1)/2.0}]
     set yc [expr {($y2+$y1)/2.0}]
     variable {}
     set ($c:xc) $xc
     set ($c:yc) $yc
     set ($c:motion) 0
     set ($c:varname) $varname
     bind $c <ButtonRelease>  [namespace code {needleRelease %W}]
     bind $c <Motion>         [namespace code {needleMotion %W %x %y}]

     set half [expr {$width/2.0}]
     set l1 [expr {$half*0.85}]
     set l2 [expr {$half*0.74}]
     set l3 [expr {$half*0.62}]

     set angle  110.0
     for {set i 0} {$i < $num} {incr i} \
     {
        set a [expr {($angle+$delta*$i)*$pi}]

        set x1 [expr {$half+$l1*cos($a)}]
        set y1 [expr {$half+$l1*sin($a)}]
        set x2 [expr {$half+$l2*cos($a)}]
        set y2 [expr {$half+$l2*sin($a)}]
        $c create line $x1 $y1 $x2 $y2 -fill black -width 0.5m

        set x1 [expr {$half+$l3*cos($a)}]
        set y1 [expr {$half+$l3*sin($a)}]

        set label [lindex $labels $i]
        if { [string length $label] } \
        {
            $c create text $x1 $y1 \
              -anchor center -justify center -fill black \
              -text $label -font { Helvetica 10 }
        }
     }

     rivet $c 10 10
     rivet $c [expr {$width-10}] 10
     rivet $c 10 [expr {$height-10}]
     rivet $c [expr {$width-10}] [expr {$height-10}]

     set value 0
     drawline $widget $value

     trace add variable $varname write \
      [namespace code "tracer $widget $varname"]
     return $widget
 }

 proc tachometer::destructor { widget } \
 {
     set varname [option get $widget varname {}]
     trace remove variable $varname write \
      [namespace code "tracer $widget $varname"]
     return
 }

 proc tachometer::tracer { widget varname args } \
 {
     upvar  $varname value
     drawline $widget $value
     return
 }

 proc tachometer::drawline { widget value } \
 {
     set c $widget.canvas

     variable pi
     set min  [option get $widget min {}]
     set max  [option get $widget max {}]
     set id [option get $widget indexid {}]

     set v [expr { ($value <= ($max*1.02))? $value : ($max*1.02) }]
     set angle [expr {((($v-$min)/($max-$min))*320.0+20.0)*$pi}]

     set width  [$c cget -width]
     set half [expr {$width/2.0}]
     set length [expr {$half*0.8}]

     set xl [expr {$half-$length*sin($angle)}]
     set yl [expr {$half+$length*cos($angle)}]

     set xs [expr {$half+0.2*$length*sin($angle)}]
     set ys [expr {$half-0.2*$length*cos($angle)}]

     catch {$c delete $id}
     set id [$c create line $xs $ys $xl $yl -fill red -width 0.6m]
     $c bind $id <ButtonPress> [namespace code {needlePress %W}]
     option add *[string trimleft $widget .].indexid $id
     return
 }

 proc tachometer::needlePress {w} \
 {
   variable {}
   set ($w:motion) 1
 }

 proc tachometer::needleRelease {w} \
 {
   variable {}
   set ($w:motion) 0
 }

 proc tachometer::needleMotion {w x y} \
 {
   variable pi
   variable {}
   if {!$($w:motion)} { return }
   if {$y == $($w:yc) && $x == $($w:xc)} { return }
   set angle [expr {180.0 + atan2($($w:yc) - $y,$($w:xc) - $x) / $pi}]
   if {$angle >= 110.0} { set angle [expr {$angle - 110.0}] } \
   else { set angle [expr {250.0 + $angle}] }
   if {$angle >= 0.0 && $angle <= 320.0} \
   { set $($w:varname) [expr {$angle / 3.2}] }
 }

 proc tachometer::rivet { c xc yc } \
 {
   set width 5
   set bevel 0.5m
   set angle -45.0
   set ticks 7
     shadowcircle $c \
      [expr {$xc-$width}] [expr {$yc-$width}] [expr {$xc+$width}] [expr {$yc+$width}] \
      $ticks $bevel $angle
 }

 proc shadowcircle { canvas x1 y1 x2 y2 ticks width orient } \
 {
     set angle $orient
     set delta [expr {180.0/$ticks}]
     for {set i 0} {$i <= $ticks} {incr i} \
     {
        set a [expr {($angle+$i*$delta)}]
        set b [expr {($angle-$i*$delta)}]

        set color [expr {40+$i*(200/$ticks)}]
        set color [format "#%x%x%x" $color $color $color]

        $canvas create arc $x1 $y1 $x2 $y2 -start $a -extent $delta \
          -style arc -outline $color -width $width
        $canvas create arc $x1 $y1 $x2 $y2 -start $b -extent $delta \
          -style arc -outline $color -width $width
     }
 }

 main $argc $argv

 ### end of file
 # Local Variables:
 # mode: tcl
 # page-delimiter: "^#PAGE"
 # End:

See also Canvas dials

uniquename 2013jul28

This code has been here 10 years without a screenshot to show how nice this tachometer looks. So here is an image.

Also see Marco Maggi's voltmeter widget at A voltmeter-like widget: type 1. And see his code at A needlemeter widget: type 1.

Note that a 'rivet' proc is used to make the 4 rivets around each dial. And a 'shadowcircle' proc is used to put nice circular shading on the rivets and the big circle in the meters. These are nice features that make these meters rather unique, compared to other Tk code for meters on this site.

Category GUICategory Widget