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