OUTPUT BUFFER:
# 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 step? # ?-callback script? ?-scale "degrees"|"radians"|factor? # ?-slow sfact? ?-fast ffact? ?-orient horizontal|vertical? # # History: # 20100526: -scale option added # package provide rdials 0.2 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 "" orient horizontal width 80 height 8 step 10 value 0.0 slow 0.1 fast 10 scale 1.0 } proc err_out {err {msg ""}} { if {$msg eq ""} { set msg "must be -bg, -background, -fg, -foreground, -value, -width,\ -height, -callback, -scale, -slow, -fast -orient or -step" } error "$err: $msg" } # configure method - writeonly proc configure {w nopt val args} { 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)}] } } set okey [string range $o 1 end] if {[info exists opt($okey,$w)]<0} { 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)}] } } draw $w $opt(value,$w) } # cget method proc cget {w nopt} { variable opt switch -- $nopt { "-bg" {set nopt "-background"} "-fg" {set nopt "-foreground"} } set okey [string range $nopt 1 end] if {[info exists opt($okey,$w)]<0 && [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 # every value is maped to the visible sector set mod [expr {$val-$sector*int($val/$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"} { $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 { $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 } 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)}] } else { set diff [expr {$diff}] } set opt(value,$w) [expr {$opt(value,$w)+$diff}] # call callback if defined... if {$opt(callback,$w) ne ""} { {*}$opt(callback,$w) [expr {$opt(value,$w)*$opt(scale,$w)}] } # draw knob with new angle draw $w $opt(value,$w) # store "old" value for diff set ovalue($w) $coord } proc create {w args} { variable def variable d2r variable opt variable canv variable ssize variable sfact variable sector 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} "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 } # 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)