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 _topimage {}
|
---|
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 | x 0
|
---|
66 | y 0
|
---|
67 | }
|
---|
68 |
|
---|
69 | option add hull.width hull.height
|
---|
70 | pack propagate $itk_component(hull) no
|
---|
71 |
|
---|
72 | itk_component add controls {
|
---|
73 | frame $itk_interior.cntls
|
---|
74 | } {
|
---|
75 | usual
|
---|
76 | rename -background -controlbackground controlBackground Background
|
---|
77 | }
|
---|
78 | pack $itk_component(controls) -side right -fill y
|
---|
79 |
|
---|
80 | itk_component add reset {
|
---|
81 | button $itk_component(controls).reset \
|
---|
82 | -borderwidth 1 -padx 1 -pady 1 \
|
---|
83 | -bitmap [Rappture::icon reset] \
|
---|
84 | -command [itcl::code $this _zoom reset]
|
---|
85 | } {
|
---|
86 | usual
|
---|
87 | ignore -borderwidth
|
---|
88 | rename -highlightbackground -controlbackground controlBackground Background
|
---|
89 | }
|
---|
90 | pack $itk_component(reset) -padx 4 -pady 4
|
---|
91 | Rappture::Tooltip::for $itk_component(reset) "Reset the view to the default zoom level"
|
---|
92 |
|
---|
93 | itk_component add zoomin {
|
---|
94 | button $itk_component(controls).zin \
|
---|
95 | -borderwidth 1 -padx 1 -pady 1 \
|
---|
96 | -bitmap [Rappture::icon zoomin] \
|
---|
97 | -command [itcl::code $this _zoom in]
|
---|
98 | } {
|
---|
99 | usual
|
---|
100 | ignore -borderwidth
|
---|
101 | rename -highlightbackground -controlbackground controlBackground Background
|
---|
102 | }
|
---|
103 | pack $itk_component(zoomin) -padx 4 -pady 4
|
---|
104 | Rappture::Tooltip::for $itk_component(zoomin) "Zoom in"
|
---|
105 |
|
---|
106 | itk_component add zoomout {
|
---|
107 | button $itk_component(controls).zout \
|
---|
108 | -borderwidth 1 -padx 1 -pady 1 \
|
---|
109 | -bitmap [Rappture::icon zoomout] \
|
---|
110 | -command [itcl::code $this _zoom out]
|
---|
111 | } {
|
---|
112 | usual
|
---|
113 | ignore -borderwidth
|
---|
114 | rename -highlightbackground -controlbackground controlBackground Background
|
---|
115 | }
|
---|
116 | pack $itk_component(zoomout) -padx 4 -pady 4
|
---|
117 | Rappture::Tooltip::for $itk_component(zoomout) "Zoom out"
|
---|
118 |
|
---|
119 |
|
---|
120 | set _image(zoom) [image create photo]
|
---|
121 | set _image(final) [image create photo]
|
---|
122 |
|
---|
123 | itk_component add image {
|
---|
124 | label $itk_interior.image -image $_image(final)
|
---|
125 | } {
|
---|
126 | keep -background -foreground -cursor -font
|
---|
127 | }
|
---|
128 | pack $itk_component(image) -expand yes -fill both
|
---|
129 |
|
---|
130 | #
|
---|
131 | # Add bindings for resize/move
|
---|
132 | #
|
---|
133 | bind $itk_component(image) <Configure> \
|
---|
134 | [list $_dispatcher event -idle !rebuild resize 1]
|
---|
135 |
|
---|
136 | bind $itk_component(image) <ButtonPress-1> \
|
---|
137 | [itcl::code $this _move click %x %y]
|
---|
138 | bind $itk_component(image) <B1-Motion> \
|
---|
139 | [itcl::code $this _move drag %x %y]
|
---|
140 | bind $itk_component(image) <ButtonRelease-1> \
|
---|
141 | [itcl::code $this _move release %x %y]
|
---|
142 |
|
---|
143 | eval itk_initialize $args
|
---|
144 | }
|
---|
145 |
|
---|
146 | # ----------------------------------------------------------------------
|
---|
147 | # DESTRUCTOR
|
---|
148 | # ----------------------------------------------------------------------
|
---|
149 | itcl::body Rappture::ImageResult::destructor {} {
|
---|
150 | foreach name [array names _image] {
|
---|
151 | image delete $_image($name)
|
---|
152 | }
|
---|
153 | }
|
---|
154 |
|
---|
155 | # ----------------------------------------------------------------------
|
---|
156 | # USAGE: add <image> ?<settings>?
|
---|
157 | #
|
---|
158 | # Clients use this to add an image to the plot. The optional <settings>
|
---|
159 | # are used to configure the image. Allowed settings are -color,
|
---|
160 | # -brightness, -width, -linestyle and -raise.
|
---|
161 | # ----------------------------------------------------------------------
|
---|
162 | itcl::body Rappture::ImageResult::add {image {settings ""}} {
|
---|
163 | array set params {
|
---|
164 | -color auto
|
---|
165 | -brightness 0
|
---|
166 | -width 1
|
---|
167 | -raise 0
|
---|
168 | -linestyle solid
|
---|
169 | -description ""
|
---|
170 | -param ""
|
---|
171 | }
|
---|
172 | foreach {opt val} $settings {
|
---|
173 | if {![info exists params($opt)]} {
|
---|
174 | error "bad setting \"$opt\": should be [join [lsort [array names params]] {, }]"
|
---|
175 | }
|
---|
176 | set params($opt) $val
|
---|
177 | }
|
---|
178 |
|
---|
179 | if {$params(-raise)} {
|
---|
180 | set _topmost $image
|
---|
181 | $_dispatcher event -idle !rebuild
|
---|
182 | }
|
---|
183 |
|
---|
184 | set pos [lsearch -exact $image $_dlist]
|
---|
185 | if {$pos < 0} {
|
---|
186 | lappend _dlist $image
|
---|
187 | $_dispatcher event -idle !rebuild
|
---|
188 | }
|
---|
189 | }
|
---|
190 |
|
---|
191 | # ----------------------------------------------------------------------
|
---|
192 | # USAGE: get
|
---|
193 | #
|
---|
194 | # Clients use this to query the list of images being displayed, in
|
---|
195 | # order from bottom to top of this result.
|
---|
196 | # ----------------------------------------------------------------------
|
---|
197 | itcl::body Rappture::ImageResult::get {} {
|
---|
198 | # put the dataobj list in order according to -raise options
|
---|
199 | set dlist $_dlist
|
---|
200 |
|
---|
201 | set i [lsearch $_dlist $_topmost]
|
---|
202 | if {$i >= 0} {
|
---|
203 | set dlist [lreplace $dlist $i $i]
|
---|
204 | set dlist [linsert $dlist 0 $_topmost]
|
---|
205 | }
|
---|
206 | return $dlist
|
---|
207 | }
|
---|
208 |
|
---|
209 | # ----------------------------------------------------------------------
|
---|
210 | # USAGE: delete ?<image1> <image2> ...?
|
---|
211 | #
|
---|
212 | # Clients use this to delete an image from the plot. If no images
|
---|
213 | # are specified, then all images are deleted.
|
---|
214 | # ----------------------------------------------------------------------
|
---|
215 | itcl::body Rappture::ImageResult::delete {args} {
|
---|
216 | if {[llength $args] == 0} {
|
---|
217 | set args $_dlist
|
---|
218 | }
|
---|
219 |
|
---|
220 | # delete all specified curves
|
---|
221 | set changed 0
|
---|
222 | foreach image $args {
|
---|
223 | set pos [lsearch -exact $_dlist $image]
|
---|
224 | if {$pos >= 0} {
|
---|
225 | set _dlist [lreplace $_dlist $pos $pos]
|
---|
226 | set changed 1
|
---|
227 |
|
---|
228 | if {$image == $_topmost} {
|
---|
229 | set _topmost ""
|
---|
230 | }
|
---|
231 | }
|
---|
232 | }
|
---|
233 |
|
---|
234 | # if anything changed, then rebuild the plot
|
---|
235 | if {$changed} {
|
---|
236 | $_dispatcher event -idle !rebuild
|
---|
237 | }
|
---|
238 | }
|
---|
239 |
|
---|
240 | # ----------------------------------------------------------------------
|
---|
241 | # USAGE: scale ?<image1> <image2> ...?
|
---|
242 | #
|
---|
243 | # Sets the default limits for the overall plot according to the
|
---|
244 | # limits of the data for all of the given <image> objects. This
|
---|
245 | # accounts for all images--even those not showing on the screen.
|
---|
246 | # Because of this, the limits are appropriate for all images as
|
---|
247 | # the user scans through data in the ResultSet viewer.
|
---|
248 | # ----------------------------------------------------------------------
|
---|
249 | itcl::body Rappture::ImageResult::scale {args} {
|
---|
250 | set _max(w) 0
|
---|
251 | set _max(h) 0
|
---|
252 | foreach image $args {
|
---|
253 | set imh [$image tkimage]
|
---|
254 |
|
---|
255 | set w [image width $imh]
|
---|
256 | if {$w > $_max(w)} { set _max(w) $w }
|
---|
257 |
|
---|
258 | set h [image height $imh]
|
---|
259 | if {$h > $_max(h)} { set _max(h) $h }
|
---|
260 | }
|
---|
261 |
|
---|
262 | # scale is unknown for now... scale later at next _rebuild
|
---|
263 | set _scale(max) "?"
|
---|
264 | set _scale(current) "?"
|
---|
265 |
|
---|
266 | $_dispatcher event -idle !rebuild
|
---|
267 | }
|
---|
268 |
|
---|
269 | # ----------------------------------------------------------------------
|
---|
270 | # USAGE: download coming
|
---|
271 | # USAGE: download controls <downloadCommand>
|
---|
272 | # USAGE: download now
|
---|
273 | #
|
---|
274 | # Clients use this method to create a downloadable representation
|
---|
275 | # of the plot. Returns a list of the form {ext string}, where
|
---|
276 | # "ext" is the file extension (indicating the type of data) and
|
---|
277 | # "string" is the data itself.
|
---|
278 | # ----------------------------------------------------------------------
|
---|
279 | itcl::body Rappture::ImageResult::download {option args} {
|
---|
280 | switch $option {
|
---|
281 | coming {
|
---|
282 | # nothing to do
|
---|
283 | }
|
---|
284 | controls {
|
---|
285 | # no controls for this download yet
|
---|
286 | return ""
|
---|
287 | }
|
---|
288 | now {
|
---|
289 | set top [_topimage]
|
---|
290 | if {$top == ""} {
|
---|
291 | return ""
|
---|
292 | }
|
---|
293 |
|
---|
294 | #
|
---|
295 | # Hack alert! Need data in binary format,
|
---|
296 | # so we'll save to a file and read it back.
|
---|
297 | #
|
---|
298 | set tmpfile /tmp/image[pid].jpg
|
---|
299 | $top write $tmpfile -format jpeg
|
---|
300 | set fid [open $tmpfile r]
|
---|
301 | fconfigure $fid -encoding binary -translation binary
|
---|
302 | set bytes [read $fid]
|
---|
303 | close $fid
|
---|
304 | file delete -force $tmpfile
|
---|
305 |
|
---|
306 | return [list .jpg $bytes]
|
---|
307 | }
|
---|
308 | default {
|
---|
309 | error "bad option \"$option\": should be coming, controls, now"
|
---|
310 | }
|
---|
311 | }
|
---|
312 | }
|
---|
313 |
|
---|
314 | # ----------------------------------------------------------------------
|
---|
315 | # USAGE: _rebuild ?<eventData>...?
|
---|
316 | #
|
---|
317 | # Called automatically whenever something changes that affects the
|
---|
318 | # data in the widget. Clears any existing data and rebuilds the
|
---|
319 | # widget to display new data.
|
---|
320 | # ----------------------------------------------------------------------
|
---|
321 | itcl::body Rappture::ImageResult::_rebuild {args} {
|
---|
322 | array set event $args
|
---|
323 | if {[info exists event(resize)] && $event(resize)} {
|
---|
324 | # window changed size -- recompute max scale below
|
---|
325 | set _scale(max) "?"
|
---|
326 | }
|
---|
327 |
|
---|
328 | if {$_scale(max) == "?"} {
|
---|
329 | if {![_zoom rescale]} {
|
---|
330 | return
|
---|
331 | }
|
---|
332 | }
|
---|
333 | if {$_scale(current) == "?"} {
|
---|
334 | _zoom reset
|
---|
335 | }
|
---|
336 |
|
---|
337 | set w [winfo width $itk_component(image)]
|
---|
338 | set h [winfo height $itk_component(image)]
|
---|
339 | $_image(final) configure -width $w -height $h
|
---|
340 | set bg [$itk_component(image) cget -background]
|
---|
341 | set rgb [winfo rgb . $bg]
|
---|
342 | set bg [format "#%03x%03x%03x" [lindex $rgb 0] [lindex $rgb 1] [lindex $rgb 2]]
|
---|
343 | $_image(final) put $bg -to 0 0 $w $h
|
---|
344 |
|
---|
345 | set imh [_topimage]
|
---|
346 | if {$imh != ""} {
|
---|
347 | if {$_scale(current) <= 1.0} {
|
---|
348 | set wz [expr {round($_scale(current)*$w)}]
|
---|
349 | set hz [expr {round($_scale(current)*$h)}]
|
---|
350 | if {$wz > 1 && $hz > 1} {
|
---|
351 | $_image(zoom) configure -width $wz -height $hz
|
---|
352 | $_image(zoom) put $bg -to 0 0 $wz $hz
|
---|
353 | set sx [expr {round($_scale(x)*$_scale(current))}]
|
---|
354 | set sy [expr {round($_scale(y)*$_scale(current))}]
|
---|
355 | $_image(zoom) copy $imh -from $sx $sy
|
---|
356 | blt::winop resample $_image(zoom) $_image(final) sinc
|
---|
357 | }
|
---|
358 | } else {
|
---|
359 | set iw [image width $imh]
|
---|
360 | set ih [image height $imh]
|
---|
361 | set wz [expr {round(double($iw)/$_scale(current))}]
|
---|
362 | set hz [expr {round(double($ih)/$_scale(current))}]
|
---|
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 | blt::winop resample $imh $_image(zoom) sinc
|
---|
367 | $_image(final) copy $_image(zoom) -from $_scale(x) $_scale(y)
|
---|
368 | }
|
---|
369 | }
|
---|
370 | }
|
---|
371 | }
|
---|
372 |
|
---|
373 | # ----------------------------------------------------------------------
|
---|
374 | # USAGE: _topimage
|
---|
375 | #
|
---|
376 | # Used internally to get the topmost image currently being displayed.
|
---|
377 | # ----------------------------------------------------------------------
|
---|
378 | itcl::body Rappture::ImageResult::_topimage {} {
|
---|
379 | set top $_topmost
|
---|
380 | if {"" == $top} {
|
---|
381 | set top [lindex $_dlist 0]
|
---|
382 | }
|
---|
383 | if {"" != $top} {
|
---|
384 | return [$top tkimage]
|
---|
385 | }
|
---|
386 | return ""
|
---|
387 | }
|
---|
388 |
|
---|
389 | # ----------------------------------------------------------------------
|
---|
390 | # USAGE: _zoom reset
|
---|
391 | # USAGE: _zoom in
|
---|
392 | # USAGE: _zoom out
|
---|
393 | #
|
---|
394 | # Called automatically when the user clicks on one of the zoom
|
---|
395 | # controls for this widget. Changes the zoom for the current view.
|
---|
396 | # ----------------------------------------------------------------------
|
---|
397 | itcl::body Rappture::ImageResult::_zoom {option args} {
|
---|
398 | switch -- $option {
|
---|
399 | rescale {
|
---|
400 | # empty list? then reset w/h max size
|
---|
401 | if {[llength $_dlist] == 0} {
|
---|
402 | set _max(w) 0
|
---|
403 | set _max(h) 0
|
---|
404 | set _scale(max) 1.0
|
---|
405 | } else {
|
---|
406 | set w [winfo width $itk_component(image)]
|
---|
407 | set h [winfo height $itk_component(image)]
|
---|
408 | if {$w == 1 && $h == 1} {
|
---|
409 | return 0
|
---|
410 | }
|
---|
411 |
|
---|
412 | set wfac [expr {$_max(w)/double($w)}]
|
---|
413 | set hfac [expr {$_max(h)/double($h)}]
|
---|
414 | set _scale(max) [expr {($wfac > $hfac) ? $wfac : $hfac}]
|
---|
415 | }
|
---|
416 | return 1
|
---|
417 | }
|
---|
418 | reset {
|
---|
419 | set _scale(current) $_scale(max)
|
---|
420 | set _scale(x) 0
|
---|
421 | set _scale(y) 0
|
---|
422 | }
|
---|
423 | in {
|
---|
424 | set _scale(current) [expr {$_scale(current)*0.5}]
|
---|
425 | }
|
---|
426 | out {
|
---|
427 | set w [winfo width $itk_component(image)]
|
---|
428 | set h [winfo height $itk_component(image)]
|
---|
429 | if {$_max(w)/$_scale(current) > $w
|
---|
430 | || $_max(h)/$_scale(current) > $h} {
|
---|
431 | # must be room left to zoom -- zoom out, but not beyond max
|
---|
432 | set _scale(current) [expr {$_scale(current)*2.0}]
|
---|
433 | if {$_scale(current) < $_scale(max)} {
|
---|
434 | set _scale(current) $_scale(max)
|
---|
435 | }
|
---|
436 | } else {
|
---|
437 | # no room left to zoom -- zoom out max
|
---|
438 | if {$_scale(max) < 1} {
|
---|
439 | set _scale(current) 1
|
---|
440 | } else {
|
---|
441 | set _scale(current) $_scale(max)
|
---|
442 | }
|
---|
443 | }
|
---|
444 | }
|
---|
445 | }
|
---|
446 | $_dispatcher event -idle !rebuild
|
---|
447 | }
|
---|
448 |
|
---|
449 | # ----------------------------------------------------------------------
|
---|
450 | # USAGE: _move click <x> <y>
|
---|
451 | # USAGE: _move drag <x> <y>
|
---|
452 | # USAGE: _move release <x> <y>
|
---|
453 | #
|
---|
454 | # Called automatically when the user clicks and drags on the image
|
---|
455 | # to pan the view. Adjusts the (x,y) offset for the scaling info
|
---|
456 | # and redraws the widget.
|
---|
457 | # ----------------------------------------------------------------------
|
---|
458 | itcl::body Rappture::ImageResult::_move {option args} {
|
---|
459 | switch -- $option {
|
---|
460 | click {
|
---|
461 | foreach {x y} $args break
|
---|
462 | $itk_component(image) configure -cursor fleur
|
---|
463 | set _scale(x0) $_scale(x)
|
---|
464 | set _scale(y0) $_scale(y)
|
---|
465 | set _scale(xclick) $x
|
---|
466 | set _scale(yclick) $y
|
---|
467 | }
|
---|
468 | drag {
|
---|
469 | foreach {x y} $args break
|
---|
470 | if {[info exists _scale(xclick)] && [info exists _scale(yclick)]} {
|
---|
471 | set w [winfo width $itk_component(image)]
|
---|
472 | set h [winfo height $itk_component(image)]
|
---|
473 | set wx [expr {round($_max(w)/$_scale(current))}]
|
---|
474 | set hy [expr {round($_max(h)/$_scale(current))}]
|
---|
475 | if {$wx > $w || $hy > $h} {
|
---|
476 | set x [expr {$_scale(x0)-$x+$_scale(xclick)}]
|
---|
477 | if {$x > $wx-$w} {set x [expr {$wx-$w}]}
|
---|
478 | if {$x < 0} {set x 0}
|
---|
479 |
|
---|
480 | set y [expr {$_scale(y0)-$y+$_scale(yclick)}]
|
---|
481 | if {$y > $hy-$h} {set y [expr {$hy-$h}]}
|
---|
482 | if {$y < 0} {set y 0}
|
---|
483 |
|
---|
484 | set _scale(x) $x
|
---|
485 | set _scale(y) $y
|
---|
486 | } else {
|
---|
487 | set _scale(x) 0
|
---|
488 | set _scale(y) 0
|
---|
489 | }
|
---|
490 | $_dispatcher event -idle !rebuild
|
---|
491 | }
|
---|
492 | }
|
---|
493 | release {
|
---|
494 | eval _move drag $args
|
---|
495 | $itk_component(image) configure -cursor ""
|
---|
496 | catch {unset _scale(xclick)}
|
---|
497 | catch {unset _scale(yclick)}
|
---|
498 | }
|
---|
499 | default {
|
---|
500 | error "bad option \"$option\": should be click, drag, release"
|
---|
501 | }
|
---|
502 | }
|
---|
503 | }
|
---|