Context Navigation

imageresult.tcl @ 5044

Last change on this file since 5044 was 5044, checked in by mmc, 10 years ago

Fixed the Panes widget to handle fractional sizes better. Instead of
adjusting the fractions internally after each change, it keeps the
requested fractions, but normalizes them before the layout. This keeps
the behavior of the widget consistent, and keeps sizes closer to what
was requested for each pane. Also, fixed the -orientation option so
that the widget can switch back and forth between orientations.

File size: 20.4 KB

Line
1	# -- mode: tcl; indent-tabs-mode: nil --
2	# ----------------------------------------------------------------------
3	# COMPONENT: imageresult - picture image in a ResultSet
4	#
5	# This widget displays an image found in the output of a Rappture
6	# tool run. Use the "add" and "delete" methods to control the images
7	# showing in the widget.
8	# ======================================================================
9	# AUTHOR: Michael McLennan, Purdue University
10	# Copyright (c) 2004-2012 HUBzero Foundation, LLC
11	#
12	# See the file "license.terms" for information on usage and
13	# redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES.
14	# ======================================================================
15	package require Itk
16	package require BLT
17	package require Img
18
19	option add *ImageResult.width 3i widgetDefault
20	option add *ImageResult.height 3i widgetDefault
21	option add *ImageResult.controlBackground gray widgetDefault
22	option add *ImageResult.font \
23	--helvetica-medium-r-normal--12-* widgetDefault
24
25	itcl::class Rappture::ImageResult {
26	inherit itk::Widget
27
28	constructor {args} { # defined below }
29	destructor { # defined below }
30
31	public method add {image {settings ""}}
32	public method get {}
33	public method delete {args}
34	public method scale {args}
35	public method parameters {title args} { # do nothing }
36	public method download {option args}
37
38	protected method _rebuild {args}
39	protected method _top {what}
40	protected method _zoom {option args}
41	protected method _move {option args}
42
43	private variable _dispatcher "" ;# dispatcher for !events
44	private variable _dlist "" ;# list of data objects
45	private variable _topmost "" ;# topmost image in _dlist
46	private variable _max ;# max size of all images
47	private variable _scale ;# info related to zoom
48	private variable _image ;# image buffers used for scaling
49	}
50
51	itk::usual ImageResult {
52	keep -background -foreground -cursor -font
53	}
54
55	# ----------------------------------------------------------------------
56	# CONSTRUCTOR
57	# ----------------------------------------------------------------------
58	itcl::body Rappture::ImageResult::constructor {args} {
59	Rappture::dispatcher _dispatcher
60	$_dispatcher register !rebuild
61	$_dispatcher dispatch $this !rebuild [itcl::code $this _rebuild]
62
63	array set _scale {
64	max 1.0
65	current 1.0
66	default 1
67	x 0
68	y 0
69	}
70
71	option add hull.width hull.height
72	pack propagate $itk_component(hull) no
73
74	Rappture::Panes $itk_interior.panes \
75	-sashwidth 2 -sashrelief solid -sashpadding 1
76
77	pack $itk_interior.panes -expand yes -fill both
78	set main [$itk_interior.panes pane 0]
79	$itk_interior.panes fraction 0 1
80
81	itk_component add controls {
82	frame $main.cntls
83	} {
84	usual
85	rename -background -controlbackground controlBackground Background
86	}
87	pack $itk_component(controls) -side right -fill y
88
89	itk_component add reset {
90	button $itk_component(controls).reset \
91	-borderwidth 1 -padx 1 -pady 1 \
92	-bitmap [Rappture::icon reset] \
93	-command [itcl::code $this _zoom reset]
94	} {
95	usual
96	ignore -borderwidth
97	rename -highlightbackground -controlbackground controlBackground Background
98	}
99	pack $itk_component(reset) -padx 4 -pady 4
100	Rappture::Tooltip::for $itk_component(reset) "Reset the view to the default zoom level"
101
102	itk_component add zoomin {
103	button $itk_component(controls).zin \
104	-borderwidth 1 -padx 1 -pady 1 \
105	-bitmap [Rappture::icon zoomin] \
106	-command [itcl::code $this _zoom in]
107	} {
108	usual
109	ignore -borderwidth
110	rename -highlightbackground -controlbackground controlBackground Background
111	}
112	pack $itk_component(zoomin) -padx 4 -pady 4
113	Rappture::Tooltip::for $itk_component(zoomin) "Zoom in"
114
115	itk_component add zoomout {
116	button $itk_component(controls).zout \
117	-borderwidth 1 -padx 1 -pady 1 \
118	-bitmap [Rappture::icon zoomout] \
119	-command [itcl::code $this _zoom out]
120	} {
121	usual
122	ignore -borderwidth
123	rename -highlightbackground -controlbackground controlBackground Background
124	}
125	pack $itk_component(zoomout) -padx 4 -pady 4
126	Rappture::Tooltip::for $itk_component(zoomout) "Zoom out"
127
128
129	set _image(zoom) [image create photo]
130	set _image(final) [image create photo]
131
132	itk_component add image {
133	label $main.image -image $_image(final) -anchor c
134	} {
135	keep -background -foreground -cursor -font
136	}
137	pack $itk_component(image) -expand yes -fill both
138
139	#
140	# Add bindings for resize/move
141	#
142	bind $itk_component(image) <Configure> \
143	[list $_dispatcher event -idle !rebuild resize 1]
144
145	bind $itk_component(image) <ButtonPress-1> \
146	[itcl::code $this _move click %x %y]
147	bind $itk_component(image) <B1-Motion> \
148	[itcl::code $this _move drag %x %y]
149	bind $itk_component(image) <ButtonRelease-1> \
150	[itcl::code $this _move release %x %y]
151
152	#
153	# Add area at the bottom for notes.
154	#
155	set notes [$itk_interior.panes insert end -fraction 0.15]
156	$itk_interior.panes visibility 1 off
157	Rappture::Scroller $notes.scr -xscrollmode auto -yscrollmode auto
158	pack $notes.scr -expand yes -fill both
159	itk_component add notes {
160	Rappture::HTMLviewer $notes.scr.html
161	}
162	$notes.scr contents $notes.scr.html
163
164	eval itk_initialize $args
165	}
166
167	# ----------------------------------------------------------------------
168	# DESTRUCTOR
169	# ----------------------------------------------------------------------
170	itcl::body Rappture::ImageResult::destructor {} {
171	foreach name [array names _image] {
172	image delete $_image($name)
173	}
174	}
175
176	# ----------------------------------------------------------------------
177	# USAGE: add <image> ?<settings>?
178	#
179	# Clients use this to add an image to the plot. The optional <settings>
180	# are used to configure the image. Allowed settings are -color,
181	# -brightness, -width, -linestyle and -raise.
182	# ----------------------------------------------------------------------
183	itcl::body Rappture::ImageResult::add {image {settings ""}} {
184	array set params {
185	-color auto
186	-brightness 0
187	-width 1
188	-raise 0
189	-linestyle solid
190	-description ""
191	-param ""
192	}
193	array set params $settings
194
195	if {$params(-raise)} {
196	set _topmost $image
197	$_dispatcher event -idle !rebuild
198	}
199
200	set pos [lsearch -exact $_dlist $image]
201	if {$pos < 0} {
202	lappend _dlist $image
203	$_dispatcher event -idle !rebuild
204	}
205	}
206
207	# ----------------------------------------------------------------------
208	# USAGE: get
209	#
210	# Clients use this to query the list of images being displayed, in
211	# order from bottom to top of this result.
212	# ----------------------------------------------------------------------
213	itcl::body Rappture::ImageResult::get {} {
214	# put the dataobj list in order according to -raise options
215	set dlist $_dlist
216
217	set i [lsearch $_dlist $_topmost]
218	if {$i >= 0} {
219	set dlist [lreplace $dlist $i $i]
220	set dlist [linsert $dlist 0 $_topmost]
221	}
222	return $dlist
223	}
224
225	# ----------------------------------------------------------------------
226	# USAGE: delete ?<image1> <image2> ...?
227	#
228	# Clients use this to delete an image from the plot. If no images
229	# are specified, then all images are deleted.
230	# ----------------------------------------------------------------------
231	itcl::body Rappture::ImageResult::delete {args} {
232	if {[llength $args] == 0} {
233	set args $_dlist
234	}
235
236	# delete all specified curves
237	set changed 0
238	foreach image $args {
239	set pos [lsearch -exact $_dlist $image]
240	if {$pos >= 0} {
241	set _dlist [lreplace $_dlist $pos $pos]
242	set changed 1
243
244	if {$image == $_topmost} {
245	set _topmost ""
246	}
247	}
248	}
249
250	# if anything changed, then rebuild the plot
251	if {$changed} {
252	$_dispatcher event -idle !rebuild
253	}
254	}
255
256	# ----------------------------------------------------------------------
257	# USAGE: scale ?<image1> <image2> ...?
258	#
259	# Sets the default limits for the overall plot according to the
260	# limits of the data for all of the given <image> objects. This
261	# accounts for all images--even those not showing on the screen.
262	# Because of this, the limits are appropriate for all images as
263	# the user scans through data in the ResultSet viewer.
264	# ----------------------------------------------------------------------
265	itcl::body Rappture::ImageResult::scale {args} {
266	set _max(w) 0
267	set _max(h) 0
268	foreach image $args {
269	set imh [$image tkimage]
270
271	set w [image width $imh]
272	if {$w > $_max(w)} { set _max(w) $w }
273
274	set h [image height $imh]
275	if {$h > $_max(h)} { set _max(h) $h }
276	}
277
278	# scale is unknown for now... scale later at next _rebuild
279	set _scale(max) "?"
280	set _scale(current) "?"
281
282	$_dispatcher event -idle !rebuild
283	}
284
285	# ----------------------------------------------------------------------
286	# USAGE: download coming
287	# USAGE: download controls <downloadCommand>
288	# USAGE: download now
289	#
290	# Clients use this method to create a downloadable representation
291	# of the plot. Returns a list of the form {ext string}, where
292	# "ext" is the file extension (indicating the type of data) and
293	# "string" is the data itself.
294	# ----------------------------------------------------------------------
295	itcl::body Rappture::ImageResult::download {option args} {
296	switch $option {
297	coming {
298	# nothing to do
299	}
300	controls {
301	# no controls for this download yet
302	return ""
303	}
304	now {
305	set top [_top image]
306	if {$top == ""} {
307	return ""
308	}
309	# Get the image data (as base64) and decode it back to binary.
310	# This is better than writing to temporary files. When we switch
311	# to the BLT picture image it won't be necessary to decode the
312	# image data.
313	set bytes [$top data -format "jpeg -quality 100"]
314	set bytes [Rappture::encoding::decode -as b64 $bytes]
315	return [list .jpg $bytes]
316	}
317	default {
318	error "bad option \"$option\": should be coming, controls, now"
319	}
320	}
321	}
322
323	# ----------------------------------------------------------------------
324	# USAGE: _rebuild ?<eventData>...?
325	#
326	# Called automatically whenever something changes that affects the
327	# data in the widget. Clears any existing data and rebuilds the
328	# widget to display new data.
329	# ----------------------------------------------------------------------
330	itcl::body Rappture::ImageResult::_rebuild {args} {
331	array set event $args
332	if {[info exists event(resize)] && $event(resize)} {
333	# window changed size -- recompute max scale below
334	set _scale(max) "?"
335	}
336
337	if {$_scale(max) == "?"} {
338	if {![_zoom rescale]} {
339	return
340	}
341	}
342	if {$_scale(current) == "?" \|\| $_scale(default)} {
343	set _scale(current) $_scale(max)
344	set _scale(x) 0.5
345	set _scale(y) 0.5
346	}
347
348	set w [winfo width $itk_component(image)]
349	set h [winfo height $itk_component(image)]
350	set bg [$itk_component(image) cget -background]
351
352	set imh [_top image]
353	if {$imh != ""} {
354	set iw [image width $imh]
355	set ih [image height $imh]
356	set wz [expr {round($w*$_scale(current))}]
357	set hz [expr {round($h*$_scale(current))}]
358
359	if {$wz < $iw \|\| $hz < $ih} {
360	#
361	# Scale the image up by creating a "zoom" image which
362	# is smaller than the current image. Sample a small
363	# part of the original image by copying into the "zoom"
364	# image, then scale that part up to the full "view" area.
365	#
366	if {$wz > $iw} {
367	set wz $iw
368	}
369	if {$hz > $ih} {
370	set hz $ih
371	}
372
373	set sx [expr {round($_scale(x)$_max(w)-0.5$wz)}]
374	if {$sx+$wz > $iw} {
375	set sx [expr {$iw-$wz}]
376	}
377	if {$sx < 0} {
378	set sx 0
379	}
380
381	set sy [expr {round($_scale(y)$_max(h)-0.5$hz)}]
382	if {$sy+$hz > $ih} {
383	set sy [expr {$ih-$hz}]
384	}
385	if {$sy < 0} {
386	set sy 0
387	}
388
389	if {$wz > 1 && $hz > 1} {
390	$_image(zoom) configure -width $wz -height $hz
391	set wf [expr {round(double($wz)/$_scale(current))}]
392	set hf [expr {round(double($hz)/$_scale(current))}]
393	$_image(final) configure -width $wf -height $hf
394	$_image(zoom) copy $imh -from $sx $sy
395	blt::winop resample $_image(zoom) $_image(final) sinc
396	}
397	} else {
398	#
399	# Scale the image down by creating a "zoom" image which
400	# is smaller than the current image. Resize the original
401	# image to the smaller size, then copy into the current
402	# view.
403	#
404	set wz [expr {round(double($iw)/$_scale(current))}]
405	set hz [expr {round(double($ih)/$_scale(current))}]
406	if {$wz > 1 && $hz > 1} {
407	$_image(zoom) configure -width $wz -height $hz
408	$_image(zoom) put $bg -to 0 0 $wz $hz
409	blt::winop resample $imh $_image(zoom) sinc
410
411	$_image(final) configure -width $wz -height $hz
412	$_image(final) copy $_image(zoom) -from 0 0
413	}
414	}
415	}
416
417	set note [_top note]
418	if {[string length $note] > 0} {
419	if {[regexp {^html://} $note]} {
420	set note [string range $note 7 end]
421	} else {
422	regexp {&} $note {\007} note
423	regexp {<} $note {\<} note
424	regexp {>} $note {\>} note
425	regexp {\007} $note {\&} note
426	regexp "\n\n" $note {<br/>} note
427	set note "<html><body>$note</body></html>"
428	}
429	set notes [$itk_interior.panes pane 1]
430	$itk_component(notes) load $note -in [file join [_top tooldir] docs]
431	$itk_interior.panes visibility 1 on
432	} else {
433	$itk_interior.panes visibility 1 off
434	}
435	}
436
437	# ----------------------------------------------------------------------
438	# USAGE: _top image\|note\|tooldir
439	#
440	# Used internally to get the topmost image currently being displayed.
441	# ----------------------------------------------------------------------
442	itcl::body Rappture::ImageResult::_top {option} {
443	set top $_topmost
444	if {"" == $top} {
445	set top [lindex $_dlist 0]
446	}
447	if {"" != $top} {
448	switch -- $option {
449	image { return [$top tkimage] }
450	note { return [$top hints note] }
451	tooldir { return [$top hints tooldir] }
452	default { error "bad option \"$option\": should be image, note, tooldir" }
453	}
454	}
455	return ""
456	}
457
458	# ----------------------------------------------------------------------
459	# USAGE: _zoom reset
460	# USAGE: _zoom in
461	# USAGE: _zoom out
462	#
463	# Called automatically when the user clicks on one of the zoom
464	# controls for this widget. Changes the zoom for the current view.
465	# ----------------------------------------------------------------------
466	itcl::body Rappture::ImageResult::_zoom {option args} {
467	switch -- $option {
468	rescale {
469	# empty list? then reset w/h max size
470	if {[llength $_dlist] == 0} {
471	set _max(w) 0
472	set _max(h) 0
473	set _scale(max) 1.0
474	} else {
475	set w [winfo width $itk_component(image)]
476	set h [winfo height $itk_component(image)]
477	if {$w == 1 && $h == 1} {
478	return 0
479	}
480
481	if {$w < $h} {
482	if {$_max(w)/double($_max(h)) > $w/double($h)} {
483	set _scale(max) [expr {$_max(w)/double($w)}]
484	} else {
485	set _scale(max) [expr {$_max(h)/double($h)}]
486	}
487	} else {
488	if {$_max(w)/double($_max(h)) < $w/double($h)} {
489	set _scale(max) [expr {$_max(h)/double($h)}]
490	} else {
491	set _scale(max) [expr {$_max(w)/double($w)}]
492	}
493	}
494	}
495	return 1
496	}
497	reset {
498	set _scale(current) $_scale(max)
499	set _scale(default) 1
500	set _scale(x) 0.5
501	set _scale(y) 0.5
502	Rappture::Logger::log image zoom -reset
503	}
504	in {
505	set _scale(current) [expr {$_scale(current)*0.8}]
506	set _scale(default) 0
507	Rappture::Logger::log image zoom -in
508	}
509	out {
510	set w [winfo width $itk_component(image)]
511	set h [winfo height $itk_component(image)]
512	if {$_max(w)/$_scale(current) > $w
513	\|\| $_max(h)/$_scale(current) > $h} {
514	# must be room left to zoom -- zoom out, but not beyond max
515	set _scale(current) [expr {$_scale(current)*1.25}]
516	if {$_scale(current) > $_scale(max)} {
517	set _scale(current) $_scale(max)
518	}
519	} else {
520	# no room left to zoom -- zoom out max
521	set _scale(current) $_scale(max)
522	}
523
524	# fix the center of view, in case it is now out of bounds
525	if {$_scale(current) > 1.0} {
526	set _scale(x) 0.5
527	set _scale(y) 0.5
528	}
529
530	# keep this zoom setting now that we've zoomed out
531	set _scale(default) 0
532
533	Rappture::Logger::log image zoom -out
534	}
535	}
536	$_dispatcher event -idle !rebuild
537	}
538
539	# ----------------------------------------------------------------------
540	# USAGE: _move click <x> <y>
541	# USAGE: _move drag <x> <y>
542	# USAGE: _move release <x> <y>
543	#
544	# Called automatically when the user clicks and drags on the image
545	# to pan the view. Adjusts the (x,y) offset for the scaling info
546	# and redraws the widget.
547	# ----------------------------------------------------------------------
548	itcl::body Rappture::ImageResult::_move {option args} {
549	switch -- $option {
550	click {
551	foreach {x y} $args break
552	$itk_component(image) configure -cursor fleur
553	set _scale(x0) $_scale(x)
554	set _scale(y0) $_scale(y)
555	set _scale(xclick) $x
556	set _scale(yclick) $y
557	}
558	drag {
559	foreach {x y} $args break
560	if {[info exists _scale(xclick)] && [info exists _scale(yclick)]} {
561	set w [winfo width $itk_component(image)]
562	set h [winfo height $itk_component(image)]
563	set wx [expr {round($_max(w)/$_scale(current))}]
564	set hy [expr {round($_max(h)/$_scale(current))}]
565	if {$wx > $w \|\| $hy > $h} {
566	set x [expr {$_scale(x0)-($x-$_scale(xclick))/double($wx)}]
567	set y [expr {$_scale(y0)-($y-$_scale(yclick))/double($hy)}]
568	if {$x$_max(w) < 0.5$w*$_scale(current)} {
569	set x [expr {0.5$w$_scale(current)/$_max(w)}]
570	}
571	if {$x$_max(w) > $_max(w) - 0.5$w*$_scale(current)} {
572	set x [expr {1 - 0.5$w$_scale(current)/$_max(w)}]
573	}
574	if {$y$_max(h) < 0.5$h*$_scale(current)} {
575	set y [expr {0.5$h$_scale(current)/$_max(h)}]
576	}
577	if {$y$_max(h) > $_max(h) - 0.5$h*$_scale(current)} {
578	set y [expr {1 - 0.5$h$_scale(current)/$_max(h)}]
579	}
580	set _scale(x) $x
581	set _scale(y) $y
582	} else {
583	set _scale(x) 0.5
584	set _scale(y) 0.5
585	}
586	$_dispatcher event -idle !rebuild
587	}
588	}
589	release {
590	eval _move drag $args
591	$itk_component(image) configure -cursor ""
592	catch {unset _scale(xclick)}
593	catch {unset _scale(yclick)}
594
595	Rappture::Logger::log image moveto $_scale(x),$_scale(y)
596	}
597	default {
598	error "bad option \"$option\": should be click, drag, release"
599	}
600	}
601	}

Note: See TracBrowser for help on using the repository browser.

Context Navigation

source: trunk/gui/scripts/imageresult.tcl @ 5044

Download in other formats: