Context Navigation

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

Last change on this file since 822 was 822, checked in by gah, 17 years ago

File size: 18.4 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
312	#
313	# Hack alert! Need data in binary format,
314	# so we'll save to a file and read it back.
315	#
316	set tmpfile /tmp/image[pid].jpg
317	$top write $tmpfile -format jpeg
318	set fid [open $tmpfile r]
319	fconfigure $fid -encoding binary -translation binary
320	set bytes [read $fid]
321	close $fid
322	file delete -force $tmpfile
323
324	return [list .jpg $bytes]
325	}
326	default {
327	error "bad option \"$option\": should be coming, controls, now"
328	}
329	}
330	}
331
332	# ----------------------------------------------------------------------
333	# USAGE: _rebuild ?<eventData>...?
334	#
335	# Called automatically whenever something changes that affects the
336	# data in the widget. Clears any existing data and rebuilds the
337	# widget to display new data.
338	# ----------------------------------------------------------------------
339	itcl::body Rappture::ImageResult::_rebuild {args} {
340	array set event $args
341	if {[info exists event(resize)] && $event(resize)} {
342	# window changed size -- recompute max scale below
343	set _scale(max) "?"
344	}
345
346	if {$_scale(max) == "?"} {
347	if {![_zoom rescale]} {
348	return
349	}
350	}
351	if {$_scale(current) == "?" \|\| $_scale(default)} {
352	set _scale(current) $_scale(max)
353	set _scale(x) 0
354	set _scale(y) 0
355	}
356
357	set w [winfo width $itk_component(image)]
358	set h [winfo height $itk_component(image)]
359	$_image(final) configure -width $w -height $h
360	set bg [$itk_component(image) cget -background]
361	set rgb [winfo rgb . $bg]
362	set bg [format "#%03x%03x%03x" [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]]
363	$_image(final) put $bg -to 0 0 $w $h
364
365	set imh [_top image]
366	if {$imh != ""} {
367	if {$_scale(current) <= 1.0} {
368	set wz [expr {round($_scale(current)*$w)}]
369	set hz [expr {round($_scale(current)*$h)}]
370	if {$wz > 1 && $hz > 1} {
371	$_image(zoom) configure -width $wz -height $hz
372	$_image(zoom) put $bg -to 0 0 $wz $hz
373	set sx [expr {round($_scale(x)*$_scale(current))}]
374	set sy [expr {round($_scale(y)*$_scale(current))}]
375	$_image(zoom) copy $imh -from $sx $sy
376	blt::winop resample $_image(zoom) $_image(final) sinc
377	}
378	} else {
379	set iw [image width $imh]
380	set ih [image height $imh]
381	set wz [expr {round(double($iw)/$_scale(current))}]
382	set hz [expr {round(double($ih)/$_scale(current))}]
383	if {$wz > 1 && $hz > 1} {
384	$_image(zoom) configure -width $wz -height $hz
385	$_image(zoom) put $bg -to 0 0 $wz $hz
386	blt::winop resample $imh $_image(zoom) sinc
387	$_image(final) copy $_image(zoom) -from $_scale(x) $_scale(y)
388	}
389	}
390	}
391
392	set note [_top note]
393	if {[string length $note] > 0} {
394	if {[regexp {^html://} $note]} {
395	set note [string range $note 7 end]
396	} else {
397	regexp {&} $note {\007} note
398	regexp {<} $note {\<} note
399	regexp {>} $note {\>} note
400	regexp {\007} $note {\&} note
401	regexp "\n\n" $note {<br/>} note
402	set note "<html><body>$note</body></html>"
403	}
404	set notes [$itk_interior.panes pane 1]
405	$itk_component(notes) load $note -in [file join [_top tooldir] docs]
406	$itk_interior.panes visibility 1 on
407	} else {
408	$itk_interior.panes visibility 1 off
409	}
410	}
411
412	# ----------------------------------------------------------------------
413	# USAGE: _top image\|note\|tooldir
414	#
415	# Used internally to get the topmost image currently being displayed.
416	# ----------------------------------------------------------------------
417	itcl::body Rappture::ImageResult::_top {option} {
418	set top $_topmost
419	if {"" == $top} {
420	set top [lindex $_dlist 0]
421	}
422	if {"" != $top} {
423	switch -- $option {
424	image { return [$top tkimage] }
425	note { return [$top hints note] }
426	tooldir { return [$top hints tooldir] }
427	default { error "bad option \"$option\": should be image, note, tooldir" }
428	}
429	}
430	return ""
431	}
432
433	# ----------------------------------------------------------------------
434	# USAGE: _zoom reset
435	# USAGE: _zoom in
436	# USAGE: _zoom out
437	#
438	# Called automatically when the user clicks on one of the zoom
439	# controls for this widget. Changes the zoom for the current view.
440	# ----------------------------------------------------------------------
441	itcl::body Rappture::ImageResult::_zoom {option args} {
442	switch -- $option {
443	rescale {
444	# empty list? then reset w/h max size
445	if {[llength $_dlist] == 0} {
446	set _max(w) 0
447	set _max(h) 0
448	set _scale(max) 1.0
449	} else {
450	set w [winfo width $itk_component(image)]
451	set h [winfo height $itk_component(image)]
452	if {$w == 1 && $h == 1} {
453	return 0
454	}
455
456	set wfac [expr {$_max(w)/double($w)}]
457	set hfac [expr {$_max(h)/double($h)}]
458	set _scale(max) [expr {($wfac > $hfac) ? $wfac : $hfac}]
459	}
460	return 1
461	}
462	reset {
463	set _scale(current) $_scale(max)
464	set _scale(default) 1
465	set _scale(x) 0
466	set _scale(y) 0
467	}
468	in {
469	set _scale(current) [expr {$_scale(current)*0.5}]
470	set _scale(default) 0
471	}
472	out {
473	set w [winfo width $itk_component(image)]
474	set h [winfo height $itk_component(image)]
475	if {$_max(w)/$_scale(current) > $w
476	\|\| $_max(h)/$_scale(current) > $h} {
477	# must be room left to zoom -- zoom out, but not beyond max
478	set _scale(current) [expr {$_scale(current)*2.0}]
479	if {$_scale(current) < $_scale(max)} {
480	set _scale(current) $_scale(max)
481	}
482	} else {
483	# no room left to zoom -- zoom out max
484	if {$_scale(max) < 1} {
485	set _scale(current) 1
486	} else {
487	set _scale(current) $_scale(max)
488	}
489	}
490	set _scale(default) 0
491	}
492	}
493	$_dispatcher event -idle !rebuild
494	}
495
496	# ----------------------------------------------------------------------
497	# USAGE: _move click <x> <y>
498	# USAGE: _move drag <x> <y>
499	# USAGE: _move release <x> <y>
500	#
501	# Called automatically when the user clicks and drags on the image
502	# to pan the view. Adjusts the (x,y) offset for the scaling info
503	# and redraws the widget.
504	# ----------------------------------------------------------------------
505	itcl::body Rappture::ImageResult::_move {option args} {
506	switch -- $option {
507	click {
508	foreach {x y} $args break
509	$itk_component(image) configure -cursor fleur
510	set _scale(x0) $_scale(x)
511	set _scale(y0) $_scale(y)
512	set _scale(xclick) $x
513	set _scale(yclick) $y
514	}
515	drag {
516	foreach {x y} $args break
517	if {[info exists _scale(xclick)] && [info exists _scale(yclick)]} {
518	set w [winfo width $itk_component(image)]
519	set h [winfo height $itk_component(image)]
520	set wx [expr {round($_max(w)/$_scale(current))}]
521	set hy [expr {round($_max(h)/$_scale(current))}]
522	if {$wx > $w \|\| $hy > $h} {
523	set x [expr {$_scale(x0)-$x+$_scale(xclick)}]
524	if {$x > $wx-$w} {set x [expr {$wx-$w}]}
525	if {$x < 0} {set x 0}
526
527	set y [expr {$_scale(y0)-$y+$_scale(yclick)}]
528	if {$y > $hy-$h} {set y [expr {$hy-$h}]}
529	if {$y < 0} {set y 0}
530
531	set _scale(x) $x
532	set _scale(y) $y
533	} else {
534	set _scale(x) 0
535	set _scale(y) 0
536	}
537	$_dispatcher event -idle !rebuild
538	}
539	}
540	release {
541	eval _move drag $args
542	$itk_component(image) configure -cursor ""
543	catch {unset _scale(xclick)}
544	catch {unset _scale(yclick)}
545	}
546	default {
547	error "bad option \"$option\": should be click, drag, release"
548	}
549	}
550	}

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

Download in other formats: