Another dials widget
Gerhard Reithofer 2010-05-24 - Years ago I've seen an implementation of dials on a SGI workstation, which was very easy to use, because it is not necessary to target as exact as for hand based dials. Also simple linear mouse movements can be used instead of circular ones.
Use Shift- or Ctrl-key to control the dial sensitivity of the mouse movement.
# rdial.tcl --
# Rotated dial widget, part of controlwidget package
#
# Contents: a "rotated" dial widget or thumbnail "roller" dial
# Date: Son May 23, 2010
#
# Abstract
# A mouse dragable "dial" widget from the side view - visible
# is the knurled area - Shift & Ctrl changes the sensitivity
#
# Copyright (c) Gerhard Reithofer, Tech-EDV 2010-05
#
# 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.
#
# Syntax:
# rdial::create w ?-width wid? ?-height hgt? ?-value floatval?
# ?-bg|-background bcol? ?-fg|-foreground fcol? ?-step density?
# ?-callback script? ?-scale "degrees"|"radians"|factor?
# ?-slow sfact? ?-fast ffact? ?-orient "horizontal"|"vertical"?
# ?-variable|-textvariable varname? ?-bindwheel step?
#
# History:
# 20100526: -scale option added
# 20100629: incorrect "roatation direction" in vertical mode repaired
# 20101020: bug {[info exists ...]<0} => {![info exists ...]} repaired
# 20101112: drag: set opt(value,$w) depending on scale - thank's Manfred R.
# 20101118: -variable option added
# 20170518: -bindwheel option added for scrollwheel input
# 20170523: boolean variable buttonwheel controls Button/Wheel binding.
# if false the <BindWheel> event is used (by default in Windows),
# the event <ButtonPress-4/5> if it is false (other systems).
#
# Known bugs: MouseWheel combinations with Shift and Control (sensitivity) only
# work in buttonwheel mode (i. e. default for Linux).
package provide rdials 0.7
package require Tk 8.5
namespace eval rdial {
variable d2r
variable canv
variable sfact
variable ssize
variable ovalue
variable sector 88
variable callback ""
variable buttonwheel 1
variable wheelfactor 15.0
# I could not find a platform independent behavior :-(
if {$tcl_platform(platform) eq "windows"} {
set buttonwheel 0
}
# a few constants to reduce expr
set d2r [expr {atan(1.0)/45.0}]
set ssize [expr {sin($sector*$d2r)}]
# widget default values
array set def {
background "#dfdfdf"
foreground "black"
callback "" variable ""
orient horizontal
width 80 height 8
step 10 value 0.0
slow 0.1 fast 10
bindwheel 2.0
scale 1.0
}
proc err_out {err {msg ""}} {
if {$msg eq ""} {
set msg "must be -bg, -background, -fg, -foreground, -value, -width -height,\
-bindwheel, -callback, -textvariable, -scale, -slow, -fast, -orient or -step"
}
error "$err: $msg"
}
# configure method - writeonly
proc configure {w nopt val args} {
variable def
variable d2r
variable opt
variable canv
variable ssize
variable sfact
if {[llength $args]%2} {
err_out "invalid syntax" \
"must be \"configure opt arg ?opt arg? ...\""
}
set args [linsert $args 0 $nopt $val]
foreach {o arg} $args {
if {[string index $o 0] ne "-"} {
err_out "invalid option \"$nopt\""
}
switch -- $o {
"-bg" {set o "-background"}
"-fg" {set o "-foreground"}
"-scale" {
switch -glob -- $arg {
"d*" {set arg 1.0}
"r*" {set arg $d2r}
}
# numeric check
set arg [expr {$arg*1.0}]
}
"-value" {
set arg [expr {$arg/$opt(scale,$w)}]
}
"-textvariable" {
set o "-variable"
}
}
set okey [string range $o 1 end]
if {![info exists opt($okey,$w)]} {
err_out "unknown option \"$o\""
}
# canvas resize isn't part of draw method
if {$o eq "-width" || $o eq "-height"} {
$canv($w) configure $o $arg
}
set opt($okey,$w) $arg
# sfact depends on width
if {$o eq "-width"} {
set sfact($w) [expr {$ssize*2/$opt(width,$w)}]
} elseif {$o eq "-variable"} {
set vname $arg
if {[info exists $vname]} {
set opt(value,$w) [set $vname]
} else {
uplevel \#0 [list set $vname $def(value)]
}
mktrace $w $vname
}
}
draw $w $opt(value,$w)
}
# cget method
proc cget {w nopt} {
variable opt
switch -- $nopt {
"-bg" {set nopt "-background"}
"-fg" {set nopt "-foreground"}
"-textvariable" {
set nopt "-variable"
}
}
set okey [string range $nopt 1 end]
if {![info exists opt($okey,$w)] &&
[string index $nopt 0] ne "-"} {
err_out "unknown option \"$nopt\""
}
if {$nopt eq "-value"} {
return [expr {$opt($okey,$w)*$opt(scale,$w)}]
} else {
return $opt($okey,$w)
}
}
# draw the thumb wheel view
proc draw {w val} {
variable opt
variable d2r
variable canv
variable ssize
variable sfact
variable sector
set stp $opt(step,$w)
set wid $opt(width,$w)
set hgt $opt(height,$w)
set dfg $opt(foreground,$w)
set dbg $opt(background,$w)
$canv($w) delete all
if {$opt(orient,$w) eq "horizontal"} {
# every value is mapped to the visible sector
set mod [expr {$val-$sector*int($val/$sector)}]
$canv($w) create rectangle 0 0 $wid $hgt -fill $dbg
# from normalized value to left end
for {set ri $mod} {$ri>=-$sector} {set ri [expr {$ri-$stp}]} {
set offs [expr {($ssize+sin($ri*$d2r))/$sfact($w)}]
$canv($w) create line $offs 0 $offs $hgt -fill $dfg
}
# from normalized value to right end
for {set ri [expr {$mod+$stp}]} {$ri<=$sector} {set ri [expr {$ri+$stp}]} {
set offs [expr {($ssize+sin($ri*$d2r))/$sfact($w)}]
$canv($w) create line $offs 0 $offs $hgt -fill $dfg
}
} else {
# every value is mapped to the visible sector
set mod [expr {$sector*int($val/$sector)-$val}]
$canv($w) create rectangle 0 0 $hgt $wid -fill $dbg
# from normalized value to upper end
for {set ri $mod} {$ri>=-$sector} {set ri [expr {$ri-$stp}]} {
set offs [expr {($ssize+sin($ri*$d2r))/$sfact($w)}]
$canv($w) create line 0 $offs $hgt $offs -fill $dfg
}
# from normalized value to lower end
for {set ri [expr {$mod+$stp}]} {$ri<=$sector} {set ri [expr {$ri+$stp}]} {
set offs [expr {($ssize+sin($ri*$d2r))/$sfact($w)}]
$canv($w) create line 0 $offs $hgt $offs -fill $dfg
}
}
# let's return the widget/canvas
set opt(value,$w) $val
if {$opt(variable,$w) ne ""} {
set vname $opt(variable,$w)
uplevel \#0 [list set $vname $val]
}
}
# update rdials after value change
proc rdupdate {w diff} {
variable opt
# calculate "new" calue
set opt(value,$w) [expr {$opt(value,$w)+$diff*$opt(scale,$w)}]
# call callback if defined...
if {$opt(callback,$w) ne ""} {
{*}$opt(callback,$w) $opt(value,$w)
}
# draw knob with new angle
draw $w $opt(value,$w)
}
# change by mouse dragging
proc drag {w coord mode} {
variable opt
variable ovalue
# calculate new value
if {$opt(orient,$w) eq "horizontal"} {
set diff [expr {$coord-$ovalue($w)}]
} else {
set diff [expr {$ovalue($w)-$coord}]
}
if {$mode<0} {
set diff [expr {$diff*$opt(slow,$w)}]
} elseif {$mode>0} {
set diff [expr {$diff*$opt(fast,$w)}]
}
rdupdate $w $diff
# store "old" value for diff
set ovalue($w) $coord
}
# change by mouse wheel
proc roll {w diff mode} {
variable opt
variable buttonwheel
variable wheelfactor
if {! $buttonwheel} {
set diff [expr {$diff/$wheelfactor/$opt(bindwheel)}]
}
if {$mode<0} {
set diff [expr {$diff*$opt(slow,$w)}]
} elseif {$mode>0} {
set diff [expr {$diff*$opt(fast,$w)}]
}
rdupdate $w $diff
}
# update value/sync textvariable
proc vupdate {w var idx op} {
variable opt
set vname $var
if {$idx ne ""} {
append vname "(" $idx ")"
}
if {$op eq "unset"} {
uplevel \#0 [unset $vname]
set opt(variable,$w) ""
rmtrace $w $vname
} else {
set opt(value,$w) [uplevel \#0 [list set $vname]]
}
draw $w $opt(value,$w)
}
proc mktrace {w var} {
upvar \#0 $var locvar
trace add variable locvar {write unset} "[namespace current]::vupdate $w"
}
proc rmtrace {w var} {
upvar \#0 $var locvar
trace remove variable locvar {write unset} "[namespace current]::vupdate $w"
}
# main setup
proc create {w args} {
variable def
variable d2r
variable opt
variable canv
variable ssize
variable sfact
variable sector
variable variable
variable buttonwheel
set opt_list [array names def]
# set default values
foreach {d} $opt_list {
set opt($d,$w) $def($d)
}
# handle command paramters
foreach {tmp arg} $args {
set o [string range $tmp 1 end]
switch -- $o {
"bg" {set o background}
"fg" {set o foreground}
"textvariable" {
set o "variable"
}
"scale" {
switch -glob -- $arg {
"d*" {set arg 1.0}
"r*" {set arg $d2r}
}
# numeric check
set arg [expr {$arg*1.0}]
}
}
if {[lsearch $opt_list $o]<0 ||
[string index $tmp 0] ne "-"} {
err_out "bad option \"$o\""
}
set opt($o,$w) $arg
}
if {$opt(variable,$w) ne ""} {
set vname $opt(variable,$w)
if {[info exists $vname]} {
set opt(value,$w) [set $vname]
} else {
uplevel \#0 [list set $vname $def(value)]
}
mktrace $w $vname
}
# width specific scale constant
set sfact($w) [expr {$ssize*2/$opt(width,$w)}]
# just for laziness ;)
set nsc [namespace current]
set wid $opt(width,$w)
set hgt $opt(height,$w)
set bgc $opt(background,$w)
# create canvas and bindings
if {$opt(orient,$w) eq "horizontal"} {
set canv($w) [canvas $w -width $wid -height $hgt]
# standard bindings
bind $canv($w) <ButtonPress-1> [list set ${nsc}::ovalue(%W) %x]
bind $canv($w) <B1-Motion> [list ${nsc}::drag %W %x 0]
bind $canv($w) <ButtonRelease-1> [list ${nsc}::drag %W %x 0]
# fine movement
bind $canv($w) <Shift-ButtonPress-1> [list set ${nsc}::ovalue(%W) %x]
bind $canv($w) <Shift-B1-Motion> [list ${nsc}::drag %W %x 1]
bind $canv($w) <Shift-ButtonRelease-1> [list ${nsc}::drag %W %x 1]
# course movement
bind $canv($w) <Control-ButtonPress-1> [list set ${nsc}::ovalue(%W) %x]
bind $canv($w) <Control-B1-Motion> [list ${nsc}::drag %W %x -1]
bind $canv($w) <Control-ButtonRelease-1> [list ${nsc}::drag %W %x -1]
} else {
set canv($w) [canvas $w -width $hgt -height $wid]
# standard bindings
bind $canv($w) <ButtonPress-1> [list set ${nsc}::ovalue(%W) %y]
bind $canv($w) <B1-Motion> [list ${nsc}::drag %W %y 0]
bind $canv($w) <ButtonRelease-1> [list ${nsc}::drag %W %y 0]
# course movement
bind $canv($w) <Shift-ButtonPress-1> [list set ${nsc}::ovalue(%W) %y]
bind $canv($w) <Shift-B1-Motion> [list ${nsc}::drag %W %y 1]
bind $canv($w) <Shift-ButtonRelease-1> [list ${nsc}::drag %W %y 1]
# fine movement
bind $canv($w) <Control-ButtonPress-1> [list set ${nsc}::ovalue(%W) %y]
bind $canv($w) <Control-B1-Motion> [list ${nsc}::drag %W %y -1]
bind $canv($w) <Control-ButtonRelease-1> [list ${nsc}::drag %W %y -1]
}
if {$opt(bindwheel,$w) != 0} {
if {$buttonwheel} {
set up $opt(bindwheel,$w)
set dn [expr {0.0 - $up}]
# standard binding
bind $canv($w) <ButtonPress-4> [list ${nsc}::roll %W $up 0]
bind $canv($w) <ButtonPress-5> [list ${nsc}::roll %W $dn 0]
# course movement
bind $canv($w) <Shift-ButtonPress-4> [list ${nsc}::roll %W $up 1]
bind $canv($w) <Shift-ButtonPress-5> [list ${nsc}::roll %W $dn 1]
# fine movement
bind $canv($w) <Control-ButtonPress-4> [list ${nsc}::roll %W $up -1]
bind $canv($w) <Control-ButtonPress-5> [list ${nsc}::roll %W $dn -1]
} else {
# it seem that Shift+Control doesn't work :-(
bind $canv($w) <MouseWheel> [list ${nsc}::roll %W %D 0]
bind $canv($w) <Shift-MouseWheel> [list ${nsc}::roll %W %D 1]
bind $canv($w) <Control-MouseWheel> [list ${nsc}::roll %W %D -1]
}
}
draw $w $opt(value,$w)
return $w
}
}
#-------- test & demo ... disable it for package autoloading -> {0}
if {1} {
if {[info script] eq $argv0} {
array set disp_value {rs -30.0 rh 120.0 rv 10.0}
proc rndcol {} {
set col "#"
for {set i 0} {$i<3} {incr i} {
append col [format "%02x" [expr {int(rand()*230)+10}]]
}
return $col
}
proc set_rand_col {} {
rdial::configure .rs -fg [rndcol] -bg [rndcol]
}
proc show_value {which val} {
set ::disp_value($which) [format "%.1f" $val]
switch -- $which {
"rh" {
if {abs($val)<30} return
rdial::configure .rs -width [expr {abs($val)}]
}
"rv" {
if {abs($val)<5} return
rdial::configure .rs -height [expr {abs($val)}]
}
"rs" {
if {!(int($val)%10)} set_rand_col
}
}
}
set help "Use mouse button with Shift &"
append help "\nControl for dragging the dials"
append help "\nwith Mouswheel support"
label .lb -text $help
label .lv -textvariable disp_value(rv)
rdial::create .rv -callback {show_value rv} -value $disp_value(rv)\
-width 200 -step 5 -bg blue -fg white
label .lh -textvariable disp_value(rh)
rdial::create .rh -callback {show_value rh} -value $disp_value(rh)\
-width $disp_value(rh) -height 20 -fg blue -bg yellow -orient vertical
label .ls -textvariable disp_value(rs)
rdial::create .rs -callback {show_value rs} -value $disp_value(rs)\
-width $disp_value(rh) -height $disp_value(rv)
pack {*}[winfo children .]
wm minsize . 220 300
wm title . "rdials 0.7"
}
}
arjen - 2010-05-26 03:56:17
This is rather cute! I like it - I do not have an immediate use for it, but it certainly deserves attention.
Gerhard Reithofer 2010-05-24 - added "-scale" option for better adjusting ranges or inverting direction.
BTW: it maybe a good replacement for "sliders" (scale widget) in some cases.
Gerhard Reithofer 2010-06-26 - vertical "optical rotation" bug repaired.
SeS (3-7-2010)
Cute indeed! I found a few minutes time to hack into your code to make it also happy in tcl/tk v8.4.19.
Replace : package require Tk 8.5
With : package require Tk
Replace : {*}$opt(callback,$w) [expr {$opt(value,$w)*$opt(scale,$w)}]
With : uplevel 1 $opt(callback,$w) [expr {$opt(value,$w)*$opt(scale,$w)}]
Replace : pack {*}[winfo children .]
With : foreach w [winfo children .] {pack $w}AMG: Using eval and uplevel together is redundant.
arjen - 2010-08-12 05:15:42
I have put this code and several other related packages into the "controlwidget" module in Tklib.
Gerhard Reithofer 2010-11-18 - added "-textvariable" option, arjen's version in Tklib already includes this option.
This widget is extensively used by Manfred's rattleCAD .
Gerhard Reithofer 2017-05-18 - added scrollwheel support, new option -bindwheel included to control mouse wheel direction and sensitivity.
-bindwheel values:
a positive value - increase value moving wheel away from you (e.g. increase size),
a negative value - increase value moving wheel towards yourself (e.g. zoom in) and
the value 0 disables mouse wheel support. The default value is 2.0.
Remark: The logic for higher (hold Shift) and lower sensitivity (hold Control) has been reversed.
Gerhard Reithofer 2017-05-24 - bug repaired, the wheel should now work on Windows and Linux and hopefully on Mac. Control and Shift is honored only when using the wheel functionality and if the variable "buttonwheel" is set to 1, this is default if the system is not "windows". This seems to be a TCL limitation.