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

Last change on this file since 1979 was 1979, checked in by dkearney, 13 years ago

video widget updates

RpVideo?.c - adding support for seeking backwards one frame.
previously, seeking backwards left us at the closest previous
key frame. we now seek forward again to get to the frame we
really wanted.

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