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

Last change on this file since 3582 was 3330, checked in by gah, 12 years ago

merge (by hand) with Rappture1.2 branch

File size: 20.5 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    foreach {opt val} $settings {
192        if {![info exists params($opt)]} {
193            error "bad setting \"$opt\": should be [join [lsort [array names params]] {, }]"
194        }
195        set params($opt) $val
196    }
197
198    if {$params(-raise)} {
199        set _topmost $image
200        $_dispatcher event -idle !rebuild
201    }
202
203    set pos [lsearch -exact $image $_dlist]
204    if {$pos < 0} {
205        lappend _dlist $image
206        $_dispatcher event -idle !rebuild
207    }
208}
209
210# ----------------------------------------------------------------------
211# USAGE: get
212#
213# Clients use this to query the list of images being displayed, in
214# order from bottom to top of this result.
215# ----------------------------------------------------------------------
216itcl::body Rappture::ImageResult::get {} {
217    # put the dataobj list in order according to -raise options
218    set dlist $_dlist
219
220    set i [lsearch $_dlist $_topmost]
221    if {$i >= 0} {
222        set dlist [lreplace $dlist $i $i]
223        set dlist [linsert $dlist 0 $_topmost]
224    }
225    return $dlist
226}
227
228# ----------------------------------------------------------------------
229# USAGE: delete ?<image1> <image2> ...?
230#
231# Clients use this to delete an image from the plot.  If no images
232# are specified, then all images are deleted.
233# ----------------------------------------------------------------------
234itcl::body Rappture::ImageResult::delete {args} {
235    if {[llength $args] == 0} {
236        set args $_dlist
237    }
238
239    # delete all specified curves
240    set changed 0
241    foreach image $args {
242        set pos [lsearch -exact $_dlist $image]
243        if {$pos >= 0} {
244            set _dlist [lreplace $_dlist $pos $pos]
245            set changed 1
246
247            if {$image == $_topmost} {
248                set _topmost ""
249            }
250        }
251    }
252
253    # if anything changed, then rebuild the plot
254    if {$changed} {
255        $_dispatcher event -idle !rebuild
256    }
257}
258
259# ----------------------------------------------------------------------
260# USAGE: scale ?<image1> <image2> ...?
261#
262# Sets the default limits for the overall plot according to the
263# limits of the data for all of the given <image> objects.  This
264# accounts for all images--even those not showing on the screen.
265# Because of this, the limits are appropriate for all images as
266# the user scans through data in the ResultSet viewer.
267# ----------------------------------------------------------------------
268itcl::body Rappture::ImageResult::scale {args} {
269    set _max(w) 0
270    set _max(h) 0
271    foreach image $args {
272        set imh [$image tkimage]
273
274        set w [image width $imh]
275        if {$w > $_max(w)} { set _max(w) $w }
276
277        set h [image height $imh]
278        if {$h > $_max(h)} { set _max(h) $h }
279    }
280
281    # scale is unknown for now... scale later at next _rebuild
282    set _scale(max) "?"
283    set _scale(current) "?"
284
285    $_dispatcher event -idle !rebuild
286}
287
288# ----------------------------------------------------------------------
289# USAGE: download coming
290# USAGE: download controls <downloadCommand>
291# USAGE: download now
292#
293# Clients use this method to create a downloadable representation
294# of the plot.  Returns a list of the form {ext string}, where
295# "ext" is the file extension (indicating the type of data) and
296# "string" is the data itself.
297# ----------------------------------------------------------------------
298itcl::body Rappture::ImageResult::download {option args} {
299    switch $option {
300        coming {
301            # nothing to do
302        }
303        controls {
304            # no controls for this download yet
305            return ""
306        }
307        now {
308            set top [_top image]
309            if {$top == ""} {
310                return ""
311            }
312            # Get the image data (as base64) and decode it back to binary.
313            # This is better than writing to temporary files.  When we switch
314            # to the BLT picture image it won't be necessary to decode the
315            # image data.
316            set bytes [$top data -format "jpeg -quality 100"]
317            set bytes [Rappture::encoding::decode -as b64 $bytes]
318            return [list .jpg $bytes]
319        }
320        default {
321            error "bad option \"$option\": should be coming, controls, now"
322        }
323    }
324}
325
326# ----------------------------------------------------------------------
327# USAGE: _rebuild ?<eventData>...?
328#
329# Called automatically whenever something changes that affects the
330# data in the widget.  Clears any existing data and rebuilds the
331# widget to display new data.
332# ----------------------------------------------------------------------
333itcl::body Rappture::ImageResult::_rebuild {args} {
334    array set event $args
335    if {[info exists event(resize)] && $event(resize)} {
336        # window changed size -- recompute max scale below
337        set _scale(max) "?"
338    }
339
340    if {$_scale(max) == "?"} {
341        if {![_zoom rescale]} {
342            return
343        }
344    }
345    if {$_scale(current) == "?" || $_scale(default)} {
346        set _scale(current) $_scale(max)
347        set _scale(x) 0.5
348        set _scale(y) 0.5
349    }
350
351    set w [winfo width $itk_component(image)]
352    set h [winfo height $itk_component(image)]
353    set bg [$itk_component(image) cget -background]
354
355    set imh [_top image]
356    if {$imh != ""} {
357        set iw [image width $imh]
358        set ih [image height $imh]
359        set wz [expr {round($w*$_scale(current))}]
360        set hz [expr {round($h*$_scale(current))}]
361
362        if {$wz < $iw || $hz < $ih} {
363            #
364            # Scale the image up by creating a "zoom" image which
365            # is smaller than the current image.  Sample a small
366            # part of the original image by copying into the "zoom"
367            # image, then scale that part up to the full "view" area.
368            #
369            if {$wz > $iw} {
370                set wz $iw
371            }
372            if {$hz > $ih} {
373                set hz $ih
374            }
375
376            set sx [expr {round($_scale(x)*$_max(w)-0.5*$wz)}]
377            if {$sx+$wz > $iw} {
378                set sx [expr {$iw-$wz}]
379            }
380            if {$sx < 0} {
381                set sx 0
382            }
383
384            set sy [expr {round($_scale(y)*$_max(h)-0.5*$hz)}]
385            if {$sy+$hz > $ih} {
386                set sy [expr {$ih-$hz}]
387            }
388            if {$sy < 0} {
389                set sy 0
390            }
391
392            if {$wz > 1 && $hz > 1} {
393                $_image(zoom) configure -width $wz -height $hz
394                set wf [expr {round(double($wz)/$_scale(current))}]
395                set hf [expr {round(double($hz)/$_scale(current))}]
396                $_image(final) configure -width $wf -height $hf
397                $_image(zoom) copy $imh -from $sx $sy
398                blt::winop resample $_image(zoom) $_image(final) sinc
399            }
400        } else {
401            #
402            # Scale the image down by creating a "zoom" image which
403            # is smaller than the current image.  Resize the original
404            # image to the smaller size, then copy into the current
405            # view.
406            #
407            set wz [expr {round(double($iw)/$_scale(current))}]
408            set hz [expr {round(double($ih)/$_scale(current))}]
409            if {$wz > 1 && $hz > 1} {
410                $_image(zoom) configure -width $wz -height $hz
411                $_image(zoom) put $bg -to 0 0 $wz $hz
412                blt::winop resample $imh $_image(zoom) sinc
413
414                $_image(final) configure -width $wz -height $hz
415                $_image(final) copy $_image(zoom) -from 0 0
416            }
417        }
418    }
419
420    set note [_top note]
421    if {[string length $note] > 0} {
422        if {[regexp {^html://} $note]} {
423            set note [string range $note 7 end]
424        } else {
425            regexp {&} $note {\007} note
426            regexp {<} $note {\&lt;} note
427            regexp {>} $note {\&gt;} note
428            regexp {\007} $note {\&amp;} note
429            regexp "\n\n" $note {<br/>} note
430            set note "<html><body>$note</body></html>"
431        }
432        set notes [$itk_interior.panes pane 1]
433        $itk_component(notes) load $note -in [file join [_top tooldir] docs]
434        $itk_interior.panes visibility 1 on
435    } else {
436        $itk_interior.panes visibility 1 off
437    }
438}
439
440# ----------------------------------------------------------------------
441# USAGE: _top image|note|tooldir
442#
443# Used internally to get the topmost image currently being displayed.
444# ----------------------------------------------------------------------
445itcl::body Rappture::ImageResult::_top {option} {
446    set top $_topmost
447    if {"" == $top} {
448        set top [lindex $_dlist 0]
449    }
450    if {"" != $top} {
451        switch -- $option {
452            image   { return [$top tkimage] }
453            note    { return [$top hints note] }
454            tooldir { return [$top hints tooldir] }
455            default { error "bad option \"$option\": should be image, note, tooldir" }
456        }
457    }
458    return ""
459}
460
461# ----------------------------------------------------------------------
462# USAGE: _zoom reset
463# USAGE: _zoom in
464# USAGE: _zoom out
465#
466# Called automatically when the user clicks on one of the zoom
467# controls for this widget.  Changes the zoom for the current view.
468# ----------------------------------------------------------------------
469itcl::body Rappture::ImageResult::_zoom {option args} {
470    switch -- $option {
471        rescale {
472            # empty list? then reset w/h max size
473            if {[llength $_dlist] == 0} {
474                set _max(w) 0
475                set _max(h) 0
476                set _scale(max) 1.0
477            } else {
478                set w [winfo width $itk_component(image)]
479                set h [winfo height $itk_component(image)]
480                if {$w == 1 && $h == 1} {
481                    return 0
482                }
483
484                if {$w < $h} {
485                    if {$_max(w)/double($_max(h)) > $w/double($h)} {
486                        set _scale(max) [expr {$_max(w)/double($w)}]
487                    } else {
488                        set _scale(max) [expr {$_max(h)/double($h)}]
489                    }
490                } else {
491                    if {$_max(w)/double($_max(h)) < $w/double($h)} {
492                        set _scale(max) [expr {$_max(h)/double($h)}]
493                    } else {
494                        set _scale(max) [expr {$_max(w)/double($w)}]
495                    }
496                }
497            }
498            return 1
499        }
500        reset {
501            set _scale(current) $_scale(max)
502            set _scale(default) 1
503            set _scale(x) 0.5
504            set _scale(y) 0.5
505            Rappture::Logger::log image zoom -reset
506        }
507        in {
508            set _scale(current) [expr {$_scale(current)*0.8}]
509            set _scale(default) 0
510            Rappture::Logger::log image zoom -in
511        }
512        out {
513            set w [winfo width $itk_component(image)]
514            set h [winfo height $itk_component(image)]
515            if {$_max(w)/$_scale(current) > $w
516                  || $_max(h)/$_scale(current) > $h} {
517                # must be room left to zoom -- zoom out, but not beyond max
518                set _scale(current) [expr {$_scale(current)*1.25}]
519                if {$_scale(current) > $_scale(max)} {
520                    set _scale(current) $_scale(max)
521                }
522            } else {
523                # no room left to zoom -- zoom out max
524                set _scale(current) $_scale(max)
525            }
526
527            # fix the center of view, in case it is now out of bounds
528            if {$_scale(current) > 1.0} {
529                set _scale(x) 0.5
530                set _scale(y) 0.5
531            }
532
533            # keep this zoom setting now that we've zoomed out
534            set _scale(default) 0
535
536            Rappture::Logger::log image zoom -out
537        }
538    }
539    $_dispatcher event -idle !rebuild
540}
541
542# ----------------------------------------------------------------------
543# USAGE: _move click <x> <y>
544# USAGE: _move drag <x> <y>
545# USAGE: _move release <x> <y>
546#
547# Called automatically when the user clicks and drags on the image
548# to pan the view.  Adjusts the (x,y) offset for the scaling info
549# and redraws the widget.
550# ----------------------------------------------------------------------
551itcl::body Rappture::ImageResult::_move {option args} {
552    switch -- $option {
553        click {
554            foreach {x y} $args break
555            $itk_component(image) configure -cursor fleur
556            set _scale(x0) $_scale(x)
557            set _scale(y0) $_scale(y)
558            set _scale(xclick) $x
559            set _scale(yclick) $y
560        }
561        drag {
562            foreach {x y} $args break
563            if {[info exists _scale(xclick)] && [info exists _scale(yclick)]} {
564                set w [winfo width $itk_component(image)]
565                set h [winfo height $itk_component(image)]
566                set wx [expr {round($_max(w)/$_scale(current))}]
567                set hy [expr {round($_max(h)/$_scale(current))}]
568                if {$wx > $w || $hy > $h} {
569                    set x [expr {$_scale(x0)-($x-$_scale(xclick))/double($wx)}]
570                    set y [expr {$_scale(y0)-($y-$_scale(yclick))/double($hy)}]
571                    if {$x*$_max(w) < 0.5*$w*$_scale(current)} {
572                        set x [expr {0.5*$w*$_scale(current)/$_max(w)}]
573                    }
574                    if {$x*$_max(w) > $_max(w) - 0.5*$w*$_scale(current)} {
575                        set x [expr {1 - 0.5*$w*$_scale(current)/$_max(w)}]
576                    }
577                    if {$y*$_max(h) < 0.5*$h*$_scale(current)} {
578                        set y [expr {0.5*$h*$_scale(current)/$_max(h)}]
579                    }
580                    if {$y*$_max(h) > $_max(h) - 0.5*$h*$_scale(current)} {
581                        set y [expr {1 - 0.5*$h*$_scale(current)/$_max(h)}]
582                    }
583                    set _scale(x) $x
584                    set _scale(y) $y
585                } else {
586                    set _scale(x) 0.5
587                    set _scale(y) 0.5
588                }
589                $_dispatcher event -idle !rebuild
590            }
591        }
592        release {
593            eval _move drag $args
594            $itk_component(image) configure -cursor ""
595            catch {unset _scale(xclick)}
596            catch {unset _scale(yclick)}
597
598            Rappture::Logger::log image moveto $_scale(x),$_scale(y)
599        }
600        default {
601            error "bad option \"$option\": should be click, drag, release"
602        }
603    }
604}
Note: See TracBrowser for help on using the repository browser.