source: branches/1.3/gui/scripts/imageresult.tcl @ 5045

Last change on this file since 5045 was 5045, checked in by mmc, 5 years ago

Ported changes to Panes widget over from trunk:
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# ======================================================================
15package require Itk
16package require BLT
17package require Img
18
19option add *ImageResult.width 3i widgetDefault
20option add *ImageResult.height 3i widgetDefault
21option add *ImageResult.controlBackground gray widgetDefault
22option add *ImageResult.font \
23    -*-helvetica-medium-r-normal-*-12-* widgetDefault
24
25itcl::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                                                                               
51itk::usual ImageResult {
52    keep -background -foreground -cursor -font
53}
54
55# ----------------------------------------------------------------------
56# CONSTRUCTOR
57# ----------------------------------------------------------------------
58itcl::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# ----------------------------------------------------------------------
170itcl::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# ----------------------------------------------------------------------
183itcl::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# ----------------------------------------------------------------------
213itcl::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# ----------------------------------------------------------------------
231itcl::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# ----------------------------------------------------------------------
265itcl::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# ----------------------------------------------------------------------
295itcl::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# ----------------------------------------------------------------------
330itcl::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 {\&lt;} note
424            regexp {>} $note {\&gt;} note
425            regexp {\007} $note {\&amp;} 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# ----------------------------------------------------------------------
442itcl::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# ----------------------------------------------------------------------
466itcl::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# ----------------------------------------------------------------------
548itcl::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.