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

Last change on this file since 4735 was 3813, checked in by ldelgass, 11 years ago

Fix bug in 'add' method of viewer widgets: list search for existing dataobj
entry was wrong (list and pattern transposed), causing potential duplicate
entries in dataobj list.

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