Context Navigation

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

Last change on this file since 1406 was 1406, checked in by gah, 15 years ago

File size: 16.3 KB

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

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

Download in other formats: