1# -*- tcl -*- 2# 3# ruler.tcl 4# 5# ruler widget and screenruler dialog 6# 7# Copyright (c) 2005 Jeffrey Hobbs. All Rights Reserved. 8# 9# RCS: @(#) $Id: ruler.tcl,v 1.13 2008/02/21 20:11:16 hobbs Exp $ 10# 11 12### 13# Creation and Options - widget::ruler $path ... 14# -foreground -default black 15# -font -default {Helvetica 14} 16# -interval -default [list 5 25 100] 17# -sizes -default [list 4 8 12] 18# -showvalues -default 1 19# -outline -default 1 20# -grid -default 0 21# -measure -default pixels ; {pixels points inches mm cm} 22# -zoom -default 1 23# all other options inherited from canvas 24# 25# Methods 26# All methods passed to canvas 27# 28# Bindings 29# <Configure> redraws 30# 31 32### 33# Creation and Options - widget::screenruler $path ... 34# -alpha -default 0.8 35# -title -default "" 36# -topmost -default 0 37# -reflect -default 0 ; reflect desktop screen 38# -zoom -default 1 39# 40# Methods 41# $path display 42# $path hide 43# All 44# 45# Bindings 46# 47 48if 0 { 49 # Samples 50 package require widget::screenruler 51 set dlg [widget::screenruler .r -grid 1 -title "Screen Ruler"] 52 $dlg menu add separator 53 $dlg menu add command -label "Exit" -command { exit } 54 $dlg display 55} 56 57package require widget 3 58 59snit::widgetadaptor widget::ruler { 60 delegate option * to hull 61 delegate method * to hull 62 63 option -foreground -default black -configuremethod C-redraw 64 option -font -default {Helvetica 14} 65 option -interval -default [list 5 25 100] -configuremethod C-redraw \ 66 -type [list snit::listtype -type {snit::double} -minlen 3 -maxlen 3] 67 option -sizes -default [list 4 8 12] -configuremethod C-redraw \ 68 -type [list snit::listtype -type {snit::double} -minlen 3 -maxlen 3] 69 option -showvalues -default 1 -configuremethod C-redraw \ 70 -type [list snit::boolean] 71 option -outline -default 1 -configuremethod C-redraw \ 72 -type [list snit::boolean] 73 option -grid -default 0 -configuremethod C-redraw \ 74 -type [list snit::boolean] 75 option -measure -default pixels -configuremethod C-measure \ 76 -type [list snit::enum -values [list pixels points inches mm cm]] 77 option -zoom -default 1 -configuremethod C-redraw \ 78 -type [list snit::integer -min 1] 79 80 variable shade -array {small gray medium gray large gray} 81 82 constructor {args} { 83 installhull using canvas -width 200 -height 50 \ 84 -relief flat -bd 0 -background white -highlightthickness 0 85 86 $hull xview moveto 0 87 $hull yview moveto 0 88 89 $self _reshade 90 91 bind $win <Configure> [mymethod _resize %W %X %Y] 92 93 #bind $win <Key-minus> [mymethod _adjustinterval -1] 94 #bind $win <Key-plus> [mymethod _adjustinterval 1] 95 #bind $win <Key-equal> [mymethod _adjustinterval 1] 96 97 $self configurelist $args 98 99 $self redraw 100 } 101 102 destructor { 103 catch {after cancel $redrawID} 104 } 105 106 ######################################## 107 ## public methods 108 109 ######################################## 110 ## configure methods 111 112 variable width 0 113 variable height 0 114 variable measure -array { 115 what "" 116 valid {pixels points inches mm cm} 117 cm c mm m inches i points p pixels "" 118 } 119 variable redrawID {} 120 121 method C-redraw {option value} { 122 if {$value ne $options($option)} { 123 set options($option) $value 124 if {$option eq "-foreground"} { $self _reshade } 125 $self redraw 126 } 127 } 128 129 method C-measure {option value} { 130 if {[set idx [lsearch -glob $measure(valid) $value*]] == -1} { 131 return -code error "invalid $option value \"$value\":\ 132 must be one of [join $measure(valid) {, }]" 133 } 134 set value [lindex $measure(valid) $idx] 135 set measure(what) $measure($value) 136 set options($option) $value 137 $self redraw 138 } 139 140 ######################################## 141 ## private methods 142 143 method _reshade {} { 144 set bg [$hull cget -bg] 145 set fg $options(-foreground) 146 set shade(small) [$self shade $bg $fg 0.15] 147 set shade(medium) [$self shade $bg $fg 0.4] 148 set shade(large) [$self shade $bg $fg 0.8] 149 } 150 151 method redraw {} { 152 after cancel $redrawID 153 set redrawID [after idle [mymethod _redraw]] 154 } 155 156 method _redraw {} { 157 $hull delete ruler 158 set width [winfo width $win] 159 set height [winfo height $win] 160 $self _redraw_x 161 $self _redraw_y 162 if {$options(-outline) || $options(-grid)} { 163 if {[tk windowingsystem] eq "aqua"} { 164 # Aqua has an odd off-by-one drawing 165 set coords [list 0 0 $width $height] 166 } else { 167 set coords [list 0 0 [expr {$width-1}] [expr {$height-1}]] 168 } 169 $hull create rect $coords -width 1 -outline $options(-foreground) \ 170 -tags [list ruler outline] 171 } 172 if {$options(-showvalues) && $height > 20} { 173 if {$measure(what) ne ""} { 174 set m [winfo fpixels $win 1$measure(what)] 175 set txt "[format %.2f [expr {$width / $m}]] x\ 176 [format %.2f [expr {$height / $m}]] $options(-measure)" 177 } else { 178 set txt "$width x $height" 179 } 180 if {$options(-zoom) > 1} { 181 append txt " (x$options(-zoom))" 182 } 183 $hull create text 15 [expr {$height/2.}] \ 184 -text $txt \ 185 -anchor w -tags [list ruler value label] \ 186 -fill $options(-foreground) 187 } 188 $hull raise large 189 $hull raise value 190 } 191 192 method _redraw_x {} { 193 foreach {sms meds lgs} $options(-sizes) { break } 194 foreach {smi medi lgi} $options(-interval) { break } 195 for {set x 0} {$x < $width} {set x [expr {$x + $smi}]} { 196 set dx [winfo fpixels $win \ 197 [expr {$x * $options(-zoom)}]$measure(what)] 198 if {fmod($x, $lgi) == 0.0} { 199 # draw large tick 200 set h $lgs 201 set tags [list ruler tick large] 202 if {$x && $options(-showvalues) && $height > $lgs} { 203 $hull create text [expr {$dx+1}] $h -anchor nw \ 204 -text [format %g $x]$measure(what) \ 205 -tags [list ruler value] 206 } 207 set fill $shade(large) 208 } elseif {fmod($x, $medi) == 0.0} { 209 set h $meds 210 set tags [list ruler tick medium] 211 set fill $shade(medium) 212 } else { 213 set h $sms 214 set tags [list ruler tick small] 215 set fill $shade(small) 216 } 217 if {$options(-grid)} { 218 $hull create line $dx 0 $dx $height -width 1 -tags $tags \ 219 -fill $fill 220 } else { 221 $hull create line $dx 0 $dx $h -width 1 -tags $tags \ 222 -fill $options(-foreground) 223 $hull create line $dx $height $dx [expr {$height - $h}] \ 224 -width 1 -tags $tags -fill $options(-foreground) 225 } 226 } 227 } 228 229 method _redraw_y {} { 230 foreach {sms meds lgs} $options(-sizes) { break } 231 foreach {smi medi lgi} $options(-interval) { break } 232 for {set y 0} {$y < $height} {set y [expr {$y + $smi}]} { 233 set dy [winfo fpixels $win \ 234 [expr {$y * $options(-zoom)}]$measure(what)] 235 if {fmod($y, $lgi) == 0.0} { 236 # draw large tick 237 set w $lgs 238 set tags [list ruler tick large] 239 if {$y && $options(-showvalues) && $width > $lgs} { 240 $hull create text $w [expr {$dy+1}] -anchor nw \ 241 -text [format %g $y]$measure(what) \ 242 -tags [list ruler value] 243 } 244 set fill $shade(large) 245 } elseif {fmod($y, $medi) == 0.0} { 246 set w $meds 247 set tags [list ruler tick medium] 248 set fill $shade(medium) 249 } else { 250 set w $sms 251 set tags [list ruler tick small] 252 set fill $shade(small) 253 } 254 if {$options(-grid)} { 255 $hull create line 0 $dy $width $dy -width 1 -tags $tags \ 256 -fill $fill 257 } else { 258 $hull create line 0 $dy $w $dy -width 1 -tags $tags \ 259 -fill $options(-foreground) 260 $hull create line $width $dy [expr {$width - $w}] $dy \ 261 -width 1 -tags $tags -fill $options(-foreground) 262 } 263 } 264 } 265 266 method _resize {w X Y} { 267 if {$w ne $win} { return } 268 $self redraw 269 } 270 271 method _adjustinterval {dir} { 272 set newint {} 273 foreach i $options(-interval) { 274 if {$dir < 0} { 275 lappend newint [expr {$i/2.0}] 276 } else { 277 lappend newint [expr {$i*2.0}] 278 } 279 } 280 set options(-interval) $newint 281 $self redraw 282 } 283 284 method shade {orig dest frac} { 285 if {$frac >= 1.0} {return $dest} elseif {$frac <= 0.0} {return $orig} 286 foreach {oR oG oB} [winfo rgb $win $orig] \ 287 {dR dG dB} [winfo rgb $win $dest] { 288 set color [format "\#%02x%02x%02x" \ 289 [expr {int($oR+double($dR-$oR)*$frac)}] \ 290 [expr {int($oG+double($dG-$oG)*$frac)}] \ 291 [expr {int($oB+double($dB-$oB)*$frac)}]] 292 return $color 293 } 294 } 295 296} 297 298snit::widget widget::screenruler { 299 hulltype toplevel 300 301 component ruler -public ruler 302 component menu -public menu 303 304 delegate option * to ruler 305 delegate method * to ruler 306 307 option -alpha -default 0.8 -configuremethod C-alpha; 308 option -title -default "" -configuremethod C-title; 309 option -topmost -default 0 -configuremethod C-topmost; 310 option -reflect -default 0 -configuremethod C-reflect; 311 # override ruler zoom for reflection control as well 312 option -zoom -default 1 -configuremethod C-zoom; 313 option -showgeometry -default 0 -configuremethod C-showgeometry; 314 315 variable alpha 0.8 ; # internal opacity value 316 variable curinterval 5; 317 variable curmeasure ""; 318 variable grid 0; 319 variable reflect -array {ok 0 image "" id ""} 320 variable curdim -array {x 0 y 0 w 0 h 0} 321 322 constructor {args} { 323 wm withdraw $win 324 wm overrideredirect $win 1 325 $hull configure -bg white 326 327 install ruler using widget::ruler $win.ruler -width 200 -height 50 \ 328 -relief flat -bd 0 -background white -highlightthickness 0 329 install menu using menu $win.menu -tearoff 0 330 331 # avoid 1.0 because we want to maintain layered class 332 if {$::tcl_platform(platform) eq "windows" && $alpha >= 1.0} { 333 set alpha 0.999 334 } 335 catch {wm attributes $win -alpha $alpha} 336 catch {wm attributes $win -topmost $options(-topmost)} 337 338 grid $ruler -sticky news 339 grid columnconfigure $win 0 -weight 1 340 grid rowconfigure $win 0 -weight 1 341 342 set reflect(ok) [expr {![catch {package require treectrl}] 343 && [llength [info commands loupe]]}] 344 if {$reflect(ok)} { 345 set reflect(do) 0 346 set reflect(x) -1 347 set reflect(y) -1 348 set reflect(w) [winfo width $win] 349 set reflect(h) [winfo height $win] 350 set reflect(image) [image create photo [myvar reflect] \ 351 -width $reflect(w) -height $reflect(h)] 352 $ruler create image 0 0 -anchor nw -image $reflect(image) 353 354 # Don't use options(-reflect) because it isn't 0/1 355 $menu add checkbutton -label "Reflect Desktop" \ 356 -accelerator "r" -underline 0 \ 357 -variable [myvar reflect(do)] \ 358 -command "[list $win configure -reflect] \$[myvar reflect(do)]" 359 bind $win <Key-r> [list $menu invoke "Reflect Desktop"] 360 } 361 $menu add checkbutton -label "Show Grid" \ 362 -accelerator "d" -underline 8 \ 363 -variable [myvar grid] \ 364 -command "[list $ruler configure -grid] \$[myvar grid]" 365 bind $win <Key-d> [list $menu invoke "Show Grid"] 366 $menu add checkbutton -label "Show Geometry" \ 367 -accelerator "g" -underline 5 \ 368 -variable [myvar options(-showgeometry)] \ 369 -command "[list $win configure -showgeometry] \$[myvar options(-showgeometry)]" 370 bind $win <Key-g> [list $menu invoke "Show Geometry"] 371 if {[tk windowingsystem] ne "x11"} { 372 $menu add checkbutton -label "Keep on Top" \ 373 -underline 8 -accelerator "t" \ 374 -variable [myvar options(-topmost)] \ 375 -command "[list $win configure -topmost] \$[myvar options(-topmost)]" 376 bind $win <Key-t> [list $menu invoke "Keep on Top"] 377 } 378 set m [menu $menu.interval -tearoff 0] 379 $menu add cascade -label "Interval" -menu $m -underline 0 380 foreach interval { 381 {2 10 50} {4 20 100} {5 25 100} {10 50 100} 382 } { 383 $m add radiobutton -label [lindex $interval 0] \ 384 -variable [myvar curinterval] -value [lindex $interval 0] \ 385 -command [list $ruler configure -interval $interval] 386 } 387 set m [menu $menu.zoom -tearoff 0] 388 $menu add cascade -label "Zoom" -menu $m -underline 0 389 foreach zoom {1 2 3 4 5 8 10} { 390 set lbl ${zoom}x 391 $m add radiobutton -label $lbl \ 392 -underline 0 \ 393 -variable [myvar options(-zoom)] -value $zoom \ 394 -command "[list $win configure -zoom] \$[myvar options(-zoom)]" 395 bind $win <Key-[string index $zoom end]> \ 396 [list $m invoke [string map {% %%} $lbl]] 397 } 398 set m [menu $menu.measure -tearoff 0] 399 $menu add cascade -label "Measurement" -menu $m -underline 0 400 foreach {val und} {pixels 0 points 1 inches 0 mm 0 cm 0} { 401 $m add radiobutton -label $val \ 402 -underline $und \ 403 -variable [myvar curmeasure] -value $val \ 404 -command [list $ruler configure -measure $val] 405 } 406 set m [menu $menu.opacity -tearoff 0] 407 $menu add cascade -label "Opacity" -menu $m -underline 0 408 for {set i 10} {$i <= 100} {incr i 10} { 409 set aval [expr {$i/100.}] 410 $m add radiobutton -label "${i}%" \ 411 -variable [myvar alpha] -value $aval \ 412 -command [list $win configure -alpha $aval] 413 } 414 415 if {[tk windowingsystem] eq "aqua"} { 416 bind $win <Control-ButtonPress-1> [list tk_popup $menu %X %Y] 417 # Aqua switches 2 and 3 ... 418 bind $win <ButtonPress-2> [list tk_popup $menu %X %Y] 419 } else { 420 bind $win <ButtonPress-3> [list tk_popup $menu %X %Y] 421 } 422 bind $win <Configure> [mymethod _resize %W %x %y %w %h] 423 bind $win <ButtonPress-1> [mymethod _dragstart %W %X %Y] 424 bind $win <B1-Motion> [mymethod _drag %W %X %Y] 425 bind $win <Motion> [mymethod _edgecheck %W %x %y] 426 427 #$hull configure -menu $menu 428 429 $self configurelist $args 430 431 set grid [$ruler cget -grid] 432 set curinterval [lindex [$ruler cget -interval] 0] 433 set curmeasure [$ruler cget -measure] 434 } 435 436 destructor { 437 catch { 438 after cancel $reflect(id) 439 image delete $reflect(image) 440 } 441 } 442 443 ######################################## 444 ## public methods 445 446 method display {} { 447 wm deiconify $win 448 raise $win 449 focus $win 450 } 451 452 method hide {} { 453 wm withdraw $win 454 } 455 456 ######################################## 457 ## configure methods 458 459 method C-alpha {option value} { 460 if {![string is double -strict $value] 461 || $value < 0.0 || $value > 1.0} { 462 return -code error "invalid $option value \"$value\":\ 463 must be a double between 0 and 1" 464 } 465 set options($option) $value 466 set alpha $value 467 # avoid 1.0 because we want to maintain layered class 468 if {$::tcl_platform(platform) eq "windows" && $alpha >= 1.0} { 469 set alpha 0.999 470 } 471 catch {wm attributes $win -alpha $alpha} 472 } 473 method C-title {option value} { 474 wm title $win $value 475 wm iconname $win $value 476 set options($option) $value 477 } 478 method C-topmost {option value} { 479 set options($option) $value 480 catch {wm attributes $win -topmost $value} 481 } 482 483 method C-reflect {option value} { 484 if {($value > 0) && !$reflect(ok)} { 485 return -code error "no reflection possible" 486 } 487 after cancel $reflect(id) 488 if {$value > 0} { 489 if {$value < 50} { 490 set value 50 491 } 492 set reflect(id) [after idle [mymethod _reflect]] 493 } else { 494 catch {$reflect(image) blank} 495 } 496 set options($option) $value 497 } 498 499 method C-zoom {option value} { 500 if {![string is integer -strict $value] || $value < 1} { 501 return -code error "invalid $option value \"$value\":\ 502 must be a valid integer >= 1" 503 } 504 $ruler configure -zoom $value 505 set options($option) $value 506 } 507 508 method C-showgeometry {option value} { 509 if {![string is boolean -strict $value]} { 510 return -code error "invalid $option value \"$value\":\ 511 must be a valid boolean" 512 } 513 set options($option) $value 514 $ruler delete geoinfo 515 if {$value} { 516 set opts [list -borderwidth 1 -highlightthickness 1 -width 4] 517 set x 20 518 set y 20 519 foreach d {x y w h} { 520 set w $win._$d 521 destroy $w 522 eval [linsert $opts 0 entry $w -textvar [myvar curdim($d)]] 523 $ruler create window $x $y -window $w -tags geoinfo 524 bind $w <Return> [mymethod _placecmd] 525 # Avoid toplevel bindings 526 bindtags $w [list $w Entry all] 527 incr x [winfo reqwidth $w] 528 } 529 } 530 } 531 532 ######################################## 533 ## private methods 534 535 method _placecmd {} { 536 wm geometry $win $curdim(w)x$curdim(h)+$curdim(x)+$curdim(y) 537 } 538 539 method _resize {W x y w h} { 540 if {$W ne $win} { return } 541 set curdim(x) $x 542 set curdim(y) $y 543 set curdim(w) $w 544 set curdim(h) $h 545 } 546 547 method _reflect {} { 548 if {!$reflect(ok)} { return } 549 set w [winfo width $win] 550 set h [winfo height $win] 551 set x [winfo pointerx $win] 552 set y [winfo pointery $win] 553 if {($reflect(w) != $w) || ($reflect(h) != $h)} { 554 $reflect(image) configure -width $w -height $h 555 set reflect(w) $w 556 set reflect(h) $h 557 } 558 if {($reflect(x) != $x) || ($reflect(y) != $y)} { 559 loupe $reflect(image) $x $y $w $h $options(-zoom) 560 set reflect(x) $x 561 set reflect(y) $y 562 } 563 if {$options(-reflect)} { 564 set reflect(id) [after $options(-reflect) [mymethod _reflect]] 565 } 566 } 567 568 variable edge -array { 569 at 0 570 left 1 571 right 2 572 top 3 573 bottom 4 574 } 575 method _edgecheck {w x y} { 576 if {$w ne $ruler} { return } 577 set edge(at) 0 578 set cursor "" 579 if {$x < 4 || $x > ([winfo width $win] - 4)} { 580 set cursor sb_h_double_arrow 581 set edge(at) [expr {$x < 4 ? $edge(left) : $edge(right)}] 582 } elseif {$y < 4 || $y > ([winfo height $win] - 4)} { 583 set cursor sb_v_double_arrow 584 set edge(at) [expr {$y < 4 ? $edge(top) : $edge(bottom)}] 585 } 586 $win configure -cursor $cursor 587 } 588 589 variable drag -array {} 590 method _dragstart {w X Y} { 591 set drag(X) [expr {$X - [winfo rootx $win]}] 592 set drag(Y) [expr {$Y - [winfo rooty $win]}] 593 set drag(w) [winfo width $win] 594 set drag(h) [winfo height $win] 595 $self _edgecheck $ruler $drag(X) $drag(Y) 596 raise $win 597 focus $ruler 598 } 599 method _drag {w X Y} { 600 if {$edge(at) == 0} { 601 set dx [expr {$X - $drag(X)}] 602 set dy [expr {$Y - $drag(Y)}] 603 wm geometry $win +$dx+$dy 604 } elseif {$edge(at) == $edge(left)} { 605 # need to handle moving root - currently just moves 606 set dx [expr {$X - $drag(X)}] 607 set dy [expr {$Y - $drag(Y)}] 608 wm geometry $win +$dx+$dy 609 } elseif {$edge(at) == $edge(right)} { 610 set relx [expr {$X - [winfo rootx $win]}] 611 set width [expr {$relx - $drag(X) + $drag(w)}] 612 set height $drag(h) 613 if {$width > 5} { 614 wm geometry $win ${width}x${height} 615 } 616 } elseif {$edge(at) == $edge(top)} { 617 # need to handle moving root - currently just moves 618 set dx [expr {$X - $drag(X)}] 619 set dy [expr {$Y - $drag(Y)}] 620 wm geometry $win +$dx+$dy 621 } elseif {$edge(at) == $edge(bottom)} { 622 set rely [expr {$Y - [winfo rooty $win]}] 623 set width $drag(w) 624 set height [expr {$rely - $drag(Y) + $drag(h)}] 625 if {$height > 5} { 626 wm geometry $win ${width}x${height} 627 } 628 } 629 } 630} 631 632######################################## 633## Ready for use 634 635package provide widget::ruler 1.1 636package provide widget::screenruler 1.2 637 638if {[info exist ::argv0] && $::argv0 eq [info script]} { 639 # We are the main script being run - show ourselves 640 wm withdraw . 641 set dlg [widget::screenruler .r -grid 1 -title "Screen Ruler"] 642 $dlg menu add separator 643 $dlg menu add command -label "Exit" -command { exit } 644 $dlg display 645} 646