source: trunk/gui/scripts/videodistance.tcl @ 4381

Last change on this file since 4381 was 3330, checked in by gah, 11 years ago

merge (by hand) with Rappture1.2 branch
File size: 21.5 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2# ----------------------------------------------------------------------
3#  COMPONENT: videodistance - specify a distance in a video canvas
4#
5# ======================================================================
6#  AUTHOR:  Derrick Kearney, Purdue University
7#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
8#
9# See the file "license.terms" for information on usage and redistribution of
10# this file, and for a DISCLAIMER OF ALL WARRANTIES.
11# ======================================================================
12
13package require Itk
14package require BLT
15package require Img
16package require Rappture
17package require RapptureGUI
18
19itcl::class Rappture::VideoDistance {
20    inherit itk::Widget
21
22    itk_option define -color color Color "green"
23    itk_option define -fncallback fncallback Fncallback ""
24    itk_option define -bindentercb bindentercb Bindentercb ""
25    itk_option define -bindleavecb bindleavecb Bindleavecb ""
26    itk_option define -writetextcb writetextcb Writetextcb ""
27    itk_option define -px2dist px2dist Px2dist ""
28    itk_option define -units units Units "m"
29    itk_option define -bindings bindings Bindings "enable"
30    itk_option define -ondelete ondelete Ondelete ""
31    itk_option define -onframe onframe Onframe ""
32
33
34    constructor { name win args } {
35        # defined below
36    }
37    destructor {
38        # defined below
39    }
40
41    public method Show {args}
42    public method Hide {args}
43    public method Coords {args}
44    public method Frame {args}
45    public method Move {status x y}
46    public method Menu {args}
47
48
49    public variable  fncallback ""      ;# framenumber callback - tells what frame we are on
50    public variable  bindentercb ""     ;# enter binding callback - call this when entering the object
51    public variable  bindleavecb ""     ;# leave binding callback - call this when leaving the object
52    public variable  writetextcb ""     ;# write text callback - call this to write text to the canvas
53
54    protected method Enter {}
55    protected method Leave {}
56    protected method CatchEvent {event}
57
58    protected method _fixValue {args}
59    protected method _fixPx2Dist {px2dist}
60    protected method _fixBindings {status}
61
62    private variable _canvas        ""  ;# canvas which owns the object
63    private variable _name          ""  ;# id of the object
64    private variable _color         ""  ;# color of the object
65    private variable _frame         0   ;# frame number where the object lives
66    private variable _coords        ""  ;# coords of the object, x0 y0 x1 y1
67    private variable _x             0   ;# x coord when "pressed" for motion
68    private variable _y             0   ;# y coord when "pressed" for motion
69    private variable _px2dist       ""  ;# variable associated with -px2dist
70    private variable _units         ""  ;#
71    private variable _dist          0   ;# distance of the measured space
72}
73
74itk::usual VideoDistance {
75    keep -background -foreground -cursor -font
76    keep -plotbackground -plotforeground
77}
78
79# ----------------------------------------------------------------------
80# CONSTRUCTOR
81# ----------------------------------------------------------------------
82itcl::body Rappture::VideoDistance::constructor {name win args} {
83
84    set _name $name
85    set _canvas $win
86
87    # setup the control menu
88    set menu $itk_component(hull).distancecontrols
89    itk_component add menu {
90        Rappture::Balloon $itk_interior.menu -title "Controls"
91    }
92    set controls [$itk_component(menu) component inner]
93
94    set fg [option get $itk_component(hull) font Font]
95    label $controls.propertiesl -text "Properties" -font $fg \
96        -highlightthickness 0
97
98    # Measurement control
99    label $controls.measurementl -text "Value" -font $fg \
100        -highlightthickness 0
101    entry $controls.measuremente -width 5 -background white
102
103    # Frame number control
104    label $controls.framenuml -text "Frame" -font "Arial 9"\
105         -highlightthickness 0
106    Rappture::Spinint $controls.framenume \
107        -min 0 -width 5 -font "arial 9"
108
109    # x0
110    label $controls.x0l -text "x0" -font $fg -highlightthickness 0
111    #FIXME: if the canvas width increases after the distance widget is created,
112    #       this max is not updated.
113    Rappture::Spinint $controls.x0e \
114            -min 0 -max [winfo width ${_canvas}] -width 4 -font "arial 9"
115
116    # y0
117    label $controls.y0l -text "y0" -font $fg -highlightthickness 0
118    #FIXME: if the canvas height increases after the distance widget is created,
119    #       this max is not updated.
120    Rappture::Spinint $controls.y0e \
121            -min 0 -max [winfo height ${_canvas}] -width 4 -font "arial 9"
122
123    # x1
124    label $controls.x1l -text "x1" -font $fg -highlightthickness 0
125    #FIXME: if the canvas width increases after the distance widget is created,
126    #       this max is not updated.
127    Rappture::Spinint $controls.x1e \
128            -min 0 -max [winfo width ${_canvas}] -width 4 -font "arial 9"
129
130    # y1
131    label $controls.y1l -text "y1" -font $fg -highlightthickness 0
132    #FIXME: if the canvas height increases after the distance widget is created,
133    #       this max is not updated.
134    Rappture::Spinint $controls.y1e \
135            -min 0 -max [winfo height ${_canvas}] -width 4 -font "arial 9"
136
137    # Delete control
138    label $controls.deletel -text "Delete" -font $fg \
139        -highlightthickness 0
140    Rappture::Switch $controls.deleteb -showtext "false"
141    $controls.deleteb value false
142
143    button $controls.saveb -text Save \
144        -relief raised -pady 0 -padx 0  -font "Arial 9" \
145        -command [itcl::code $this Menu deactivate save] \
146        -activebackground grey90
147
148    button $controls.cancelb -text Cancel \
149        -relief raised -pady 0 -padx 0  -font "Arial 9" \
150        -command [itcl::code $this Menu deactivate cancel] \
151        -activebackground grey90
152
153    grid $controls.measurementl    -column 0 -row 0 -sticky e
154    grid $controls.measuremente    -column 1 -row 0 -sticky w
155    grid $controls.framenuml       -column 2 -row 0 -sticky e
156    grid $controls.framenume       -column 3 -row 0 -sticky w
157    grid $controls.x0l             -column 0 -row 1 -sticky e
158    grid $controls.x0e             -column 1 -row 1 -sticky w
159    grid $controls.y0l             -column 2 -row 1 -sticky e
160    grid $controls.y0e             -column 3 -row 1 -sticky w
161    grid $controls.x1l             -column 0 -row 2 -sticky e
162    grid $controls.x1e             -column 1 -row 2 -sticky w
163    grid $controls.y1l             -column 2 -row 2 -sticky e
164    grid $controls.y1e             -column 3 -row 2 -sticky w
165    grid $controls.deletel         -column 2 -row 3 -sticky e
166    grid $controls.deleteb         -column 3 -row 3 -sticky w
167    grid $controls.saveb           -column 0 -row 4 -sticky e -columnspan 2
168    grid $controls.cancelb         -column 2 -row 4 -sticky w -columnspan 2
169
170
171    # finish configuring the object
172    eval itk_initialize $args
173
174    # set the frame for the particle
175    Frame [uplevel \#0 $fncallback]
176    bind ${_name}-FrameEvent <<Frame>> [itcl::code $this CatchEvent Frame]
177}
178
179# ----------------------------------------------------------------------
180# DESTRUCTOR
181# ----------------------------------------------------------------------
182itcl::body Rappture::VideoDistance::destructor {} {
183    configure -px2dist ""  ;# remove variable trace
184
185    Hide object
186    _fixBindings disable
187
188    if {"" != $itk_option(-ondelete)} {
189        uplevel \#0 $itk_option(-ondelete)
190    }
191
192}
193
194# ----------------------------------------------------------------------
195#   Frame ?<frameNum>? - update the frame this object is in
196# ----------------------------------------------------------------------
197itcl::body Rappture::VideoDistance::Frame {args} {
198    if {[llength $args] == 1} {
199        set val [lindex $args 0]
200        if {([string is integer $val] != 1)} {
201            error "bad value: \"$val\": frame number should be an integer"
202        }
203
204        set _frame $val
205
206        if {"" != $itk_option(-onframe)} {
207            uplevel \#0 $itk_option(-onframe) ${_frame}
208        }
209    } elseif {[llength $args] != 0} {
210        error "wrong # args: should be \"Frame ?<frameNumber>?\""
211    }
212    return ${_frame}
213}
214
215# ----------------------------------------------------------------------
216#   Coords ?<x0> <y0> <x1> <y1>? - update the coordinates of this object
217# ----------------------------------------------------------------------
218itcl::body Rappture::VideoDistance::Coords {args} {
219    if {[llength $args] == 0} {
220        return ${_coords}
221    } elseif {[llength $args] == 1} {
222        foreach {x0 y0 x1 y1} [lindex $args 0] break
223    } elseif {[llength $args] == 4} {
224        foreach {x0 y0 x1 y1} $args break
225    } else {
226        error "wrong # args: should be \"Coords ?<x0> <y0> <x1> <y1>?\""
227    }
228
229    if {([string is double $x0] != 1)} {
230        error "bad value: \"$x0\": x coordinate should be a double"
231    }
232    if {([string is double $y0] != 1)} {
233        error "bad value: \"$y0\": y coordinate should be a double"
234    }
235    if {([string is double $x1] != 1)} {
236        error "bad value: \"$x1\": x coordinate should be a double"
237    }
238    if {([string is double $y1] != 1)} {
239        error "bad value: \"$y1\": y coordinate should be a double"
240    }
241
242    set _coords [list $x0 $y0 $x1 $y1]
243
244    if {[llength [${_canvas} find withtag ${_name}-line]] > 0} {
245        eval ${_canvas} coords ${_name}-line ${_coords}
246    }
247
248    _fixValue
249    return ${_coords}
250}
251
252# ----------------------------------------------------------------------
253#   Enter - bindings if the mouse enters the object's space
254# ----------------------------------------------------------------------
255itcl::body Rappture::VideoDistance::Enter {} {
256    uplevel \#0 $bindentercb
257}
258
259# ----------------------------------------------------------------------
260#   Leave - bindings if the mouse leaves the object's space
261# ----------------------------------------------------------------------
262itcl::body Rappture::VideoDistance::Leave {} {
263    uplevel \#0 $bindleavecb
264}
265
266
267# ----------------------------------------------------------------------
268#   CatchEvent - bindings for caught events
269# ----------------------------------------------------------------------
270itcl::body Rappture::VideoDistance::CatchEvent {event} {
271    switch -- $event {
272        "Frame" {
273            if {[uplevel \#0 $fncallback] == ${_frame}} {
274                ${_canvas} itemconfigure ${_name}-line -fill red
275            } else {
276                ${_canvas} itemconfigure ${_name}-line -fill ${_color}
277            }
278        }
279        default {
280            error "bad event \"$event\": should be one of Frame."
281        }
282
283    }
284}
285
286
287# ----------------------------------------------------------------------
288# Show - put properties of the object on the canvas
289#   object - draw the object on the canvas
290#   name - popup a ballon with the name of this object
291# ----------------------------------------------------------------------
292itcl::body Rappture::VideoDistance::Show {args} {
293    set option [lindex $args 0]
294    switch -- $option {
295        "object" {
296            if {[llength $args] != 1} {
297                error "wrong # args: should be \"object\""
298            }
299            ${_canvas} create line ${_coords} \
300                -fill ${_color}\
301                -width 2  \
302                -tags "measure ${_name} ${_name}-line" \
303                -dash {4 4} \
304                -arrow both
305        }
306        "name" {
307
308        }
309        default {
310            error "bad option \"$option\": should be one of object, name."
311        }
312    }
313}
314
315# ----------------------------------------------------------------------
316# Hide
317#   object - remove the particle from where it is drawn
318#   name - remove the popup with the name
319# ----------------------------------------------------------------------
320itcl::body Rappture::VideoDistance::Hide {args} {
321    set option [lindex $args 0]
322    switch -- $option {
323        "object" {
324            if {[llength $args] != 1} {
325                error "wrong # args: should be \"object\""
326            }
327            ${_canvas} delete "${_name}"
328        }
329        "name" {
330
331        }
332        default {
333            error "bad option \"$option\": should be one of object, name."
334        }
335    }
336}
337
338# ----------------------------------------------------------------------
339# Move - move the object to a new location
340# ----------------------------------------------------------------------
341itcl::body Rappture::VideoDistance::Move {status x y} {
342    switch -- $status {
343        "press" {
344            set _x $x
345            set _y $y
346        }
347        "motion" {
348            ${_canvas} move ${_name} [expr $x-${_x}] [expr $y-${_y}]
349            set _coords [${_canvas} coords ${_name}-line]
350            set _x $x
351            set _y $y
352        }
353        "release" {
354        }
355        default {
356            error "bad option \"$option\": should be one of press, motion, release."
357        }
358    }
359}
360
361# ----------------------------------------------------------------------
362# Menu - popup a menu with the particle controls
363#   create
364#   activate x y
365#   deactivate status
366# ----------------------------------------------------------------------
367itcl::body Rappture::VideoDistance::Menu {args} {
368    set option [lindex $args 0]
369    switch -- $option {
370        "activate" {
371            if {[llength $args] != 3} {
372                error "wrong # args: should be \"activate <x> <y>\""
373            }
374            foreach {x y} [lrange $args 1 end] break
375            set dir "left"
376            set x0 [winfo rootx ${_canvas}]
377            set y0 [winfo rooty ${_canvas}]
378            set w0 [winfo width ${_canvas}]
379            set h0 [winfo height ${_canvas}]
380            set x [expr $x0+$x]
381            set y [expr $y0+$y]
382            $itk_component(menu) activate @$x,$y $dir
383
384            # update the values in the menu
385            set controls [$itk_component(menu) component inner]
386            foreach {x0 y0 x1 y1} ${_coords} break
387            $controls.measuremente delete 0 end
388            $controls.measuremente insert 0 "${_dist} ${_units}"
389            $controls.framenume value ${_frame}
390            $controls.x0e value $x0
391            $controls.y0e value $y0
392            $controls.x1e value $x1
393            $controls.y1e value $y1
394            $controls.deleteb value false
395        }
396        "deactivate" {
397            $itk_component(menu) deactivate
398            if {[llength $args] != 2} {
399                error "wrong # args: should be \"deactivate <status>\""
400            }
401            set status [lindex $args 1]
402            switch -- $status {
403                "save" {
404                    set controls [$itk_component(menu) component inner]
405
406                    set newframenum [$controls.framenume value]
407                    if {${_frame} != $newframenum} {
408                        Frame $newframenum
409                    }
410
411                    foreach {oldx0 oldy0 oldx1 oldy1} ${_coords} break
412                    set newx0 [$controls.x0e value]
413                    set newy0 [$controls.y0e value]
414                    set newx1 [$controls.x1e value]
415                    set newy1 [$controls.y1e value]
416
417                    if {$oldx0 != $newx0 ||
418                        $oldy0 != $newy0 ||
419                        $oldx1 != $newx1 ||
420                        $oldy1 != $newy1} {
421
422                        Coords $newx0 $newy0 $newx1 $newy1
423                    }
424
425                    set newdist [Rappture::Units::convert \
426                        [$controls.measuremente get] \
427                        -context ${_units} -units off]
428
429                    if {$newdist != ${_dist}} {
430                        # update the distance displayed
431
432                        set px [expr sqrt(pow(($newx1-$newx0),2)+pow(($newy1-$newy0),2))]
433                        set px2dist [expr $newdist/$px]
434
435                        _fixPx2Dist $px2dist
436                    }
437
438                    if {[$controls.deleteb value]} {
439                        itcl::delete object $this
440                    }
441                }
442                "cancel" {
443                }
444                "default" {
445                    error "bad value \"$status\": should be one of save, cancel"
446                }
447            }
448        }
449        default {
450            error "bad option \"$option\": should be one of activate, deactivate."
451        }
452    }
453}
454
455# ----------------------------------------------------------------------
456# _fixBindings - enable/disable bindings
457#   enable
458#   disable
459# ----------------------------------------------------------------------
460itcl::body Rappture::VideoDistance::_fixBindings {status} {
461    switch -- $status {
462        "enable" {
463            ${_canvas} bind ${_name} <ButtonPress-1>   [itcl::code $this Move press %x %y]
464            ${_canvas} bind ${_name} <B1-Motion>       [itcl::code $this Move motion %x %y]
465            ${_canvas} bind ${_name} <ButtonRelease-1> [itcl::code $this Move release %x %y]
466
467            ${_canvas} bind ${_name} <ButtonPress-3>   [itcl::code $this Menu activate %x %y]
468
469            ${_canvas} bind ${_name} <Enter>           [itcl::code $this Enter]
470            ${_canvas} bind ${_name} <Leave>           [itcl::code $this Leave]
471
472            ${_canvas} bind ${_name} <B1-Enter>        { }
473            ${_canvas} bind ${_name} <B1-Leave>        { }
474            bindtags ${_canvas} [concat "${_name}-FrameEvent" [bindtags ${_canvas}]]
475        }
476        "disable" {
477            ${_canvas} bind ${_name} <ButtonPress-1>   { }
478            ${_canvas} bind ${_name} <B1-Motion>       { }
479            ${_canvas} bind ${_name} <ButtonRelease-1> { }
480
481            ${_canvas} bind ${_name} <ButtonPress-3>   { }
482
483            ${_canvas} bind ${_name} <Enter>           { }
484            ${_canvas} bind ${_name} <Leave>           { }
485
486            ${_canvas} bind ${_name} <B1-Enter>        { }
487            ${_canvas} bind ${_name} <B1-Leave>        { }
488            set tagnum [lsearch [bindtags ${_canvas}] "${_name}-FrameEvent"]
489            if {$tagnum >= 0} {
490                bindtags ${_canvas} [lreplace [bindtags ${_canvas}] $tagnum $tagnum]
491            }
492        }
493        default {
494            error "bad option \"$status\": should be one of enable, disable."
495        }
496    }
497}
498
499# ----------------------------------------------------------------------
500# USAGE: _fixPx2Dist
501# Invoked whenever the value for this object is changed by the user
502# via the popup menu.
503# ----------------------------------------------------------------------
504itcl::body Rappture::VideoDistance::_fixPx2Dist {px2dist} {
505    if {"" == $itk_option(-px2dist)} {
506        return
507    }
508    upvar #0 $itk_option(-px2dist) var
509    set var $px2dist
510}
511
512
513# ----------------------------------------------------------------------
514# USAGE: _fixValue
515# Invoked automatically whenever the -px2dist associated with this
516# widget is modified.  Copies the value to the current settings for
517# the widget.
518# ----------------------------------------------------------------------
519itcl::body Rappture::VideoDistance::_fixValue {args} {
520    if {"" == $itk_option(-px2dist)} {
521        return
522    }
523    upvar #0 $itk_option(-px2dist) var
524
525    if {"" == ${_coords}} {
526        # no coords, skip calculation
527        return
528    }
529
530    # calculate the length
531    foreach {x0 y0 x1 y1} ${_coords} break
532    set px [expr sqrt(pow(($x1-$x0),2)+pow(($y1-$y0),2))]
533    set _dist [expr $px*$var]
534
535    # run the new value through units conversion to round
536    # it off so when we show it in the menu and compare it
537    # to the value that comes back from the menu, we don't
538    # get differences in value due to rounding.
539    set _dist [Rappture::Units::convert ${_dist} -context ${_units} -units off]
540
541    set x [expr "$x0 + (($x1-$x0)/2)"]
542    set y [expr "$y0 + (($y1-$y0)/2)"]
543
544    set tt "${_dist} ${_units}"
545    set tags "meastext ${_name} ${_name}-val"
546    set width [expr sqrt(pow(abs($x1-$x0),2)+pow(abs($y1-$y0),2))]
547    set args [list $x $y "$tt" "${_color}" "$tags" $width]
548
549    # remove old text
550    ${_canvas} delete ${_name}-val
551
552    set controls [$itk_component(menu) component inner]
553    if {![$controls.deleteb value]} {
554        # if the object is not hidden, write _dist to the canvas
555        uplevel \#0 $writetextcb $args
556    }
557}
558
559
560# ----------------------------------------------------------------------
561# CONFIGURATION OPTION: -color
562# ----------------------------------------------------------------------
563itcl::configbody Rappture::VideoDistance::color {
564    if {[string compare "" $itk_option(-color)] != 0} {
565        # FIXME how to tell if the color is valid?
566        set _color $itk_option(-color)
567    } else {
568        error "bad value: \"$itk_option(-color)\": should be a valid color"
569    }
570}
571
572# ----------------------------------------------------------------------
573# CONFIGURE: -px2dist
574# ----------------------------------------------------------------------
575itcl::configbody Rappture::VideoDistance::px2dist {
576    if {"" != $_px2dist} {
577        upvar #0 $_px2dist var
578        trace remove variable var write [itcl::code $this _fixValue]
579    }
580
581    set _px2dist $itk_option(-px2dist)
582
583    if {"" != $_px2dist} {
584        upvar #0 $_px2dist var
585        trace add variable var write [itcl::code $this _fixValue]
586
587        # sync to the current value of this variable
588        if {[info exists var]} {
589            _fixValue
590        }
591    }
592}
593
594# ----------------------------------------------------------------------
595# CONFIGURE: -units
596# ----------------------------------------------------------------------
597itcl::configbody Rappture::VideoDistance::units {
598    set _units $itk_option(-units)
599    # _fixValue
600}
601
602
603# ----------------------------------------------------------------------
604# CONFIGURE: -bindings
605# ----------------------------------------------------------------------
606itcl::configbody Rappture::VideoDistance::bindings {
607    _fixBindings $itk_option(-bindings)
608}
609# ----------------------------------------------------------------------
Note: See TracBrowser for help on using the repository browser.