'''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.<<br>>
Shift- or Ctrl-key to control the dial sensitivity of the mouse movement.<<br>>
!!!!!!
[Another (rotated) dials widget]
!!!!!!
----
======
# 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"?
#        ?-textvar|-textvariable varname? ?-bindwheel "up"|"down"|none?
#
# 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: -textvar option added
#  20170518: -bindwheel option added for scrollwheel input
#

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 ""
    
    # 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 "" textvar ""
        orient horizontal
        width 80 height  8
        step  10 value 0.0
        slow 0.1 fast 10
        bindwheel up
        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 "-textvar"
                }
                "-bindweel" {
                    set o $arg
                }
            }
            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 "-textvar"} {
                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 "-textvar"
            }
        }
        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(textvar,$w) ne ""} {
            set vname $opt(textvar,$w)
            uplevel \#0 [list set $vname $val]
        }
    }
    
    # update rdials after value change
    proc rdupdate {w diff mode} {
        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 0}} {
        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 $mode
        
        # store "old" value for diff
        set ovalue($w) $coord
    }
    
    # change by mouse wheel
    proc roll {w up {mode 0}} {
        variable opt
        set diff [expr {$up ? 2.0 : -2.0}]
        if {$mode<0} {
            set diff [expr {$diff*$opt(slow,$w)}]
        } elseif {$mode>0} {
            set diff [expr {$diff*$opt(fast,$w)}]
        }
        rdupdate $w $diff $mode
    }
    
    # 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(textvar,$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 textvar
        
        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 "textvar"
                }
                "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(textvar,$w) ne ""} {
            set vname $opt(textvar,$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]
            bind $canv($w) <ButtonRelease-1> [list ${nsc}::drag %W %x]
            # 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]
            bind $canv($w) <ButtonRelease-1> [list ${nsc}::drag %W %y]
            # 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) eq "down"} {
            bind $canv($w) <ButtonPress-4> [list ${nsc}::roll $w 0 0]
            bind $canv($w) <ButtonPress-5> [list ${nsc}::roll $w 1 0]
            bind $canv($w) <Shift-ButtonPress-4> [list ${nsc}::roll $w 0 -1]
            bind $canv($w) <Shift-ButtonPress-5> [list ${nsc}::roll $w 1 -1]
            bind $canv($w) <Control-ButtonPress-4> [list ${nsc}::roll $w 0 1]
            bind $canv($w) <Control-ButtonPress-5> [list ${nsc}::roll $w 1 1]
        } elseif {$opt(bindwheel,$w) eq "up"} {
            bind $canv($w) <ButtonPress-4> [list ${nsc}::roll $w 1 0]
            bind $canv($w) <ButtonPress-5> [list ${nsc}::roll $w 0 0]
            bind $canv($w) <Shift-ButtonPress-4> [list ${nsc}::roll $w 1 -1]
            bind $canv($w) <Shift-ButtonPress-5> [list ${nsc}::roll $w 0 -1]
            bind $canv($w) <Control-ButtonPress-4> [list ${nsc}::roll $w 1 1]
            bind $canv($w) <Control-ButtonPress-5> [list ${nsc}::roll $w 0 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.<<br>>
BTW: it maybe a good replacement for "sliders" (scale widget) in some cases.<<br>> 
'''Gerhard Reithofer 2010-06-26''' - vertical "optical rotation" bug repaired.<<br>>

----
http://wiki.tcl.tk/25888%|%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.<<br>>
This widget is extensively used by Manfred's http://sourceforge.net/projects/rattlecad/%|%rattleCAD%|%.

----
'''Gerhard Reithofer 2017-05-18''' - added scrollwheel support,
new option -bindwheel included to control mouse wheel direction.<<br>>
-bindwheel options: "up"  - increase moving wheel away from you (e.g. increase size), 
"down" - increase moving wheel towards yourself (e.g. zoom in) and value "" disables wheel support

<<categories>> Example | GUI | Widget