source: trunk/gui/scripts/videoviewer.tcl @ 1930

Last change on this file since 1930 was 1925, checked in by dkearney, 14 years ago

updates for video widget code. adding uploadWord to filexfer to match the downloadWord. adding some images.
File size: 37.1 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: videoviewer - viewing movies
3#
4# ======================================================================
5#  AUTHOR:  Michael McLennan, Purdue University
6#  Copyright (c) 2004-2005  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
18#option add *VideoViewer.width 5i widgetDefault
19option add *VideoViewer*cursor crosshair widgetDefault
20#option add *VideoViewer.height 4i widgetDefault
21option add *VideoViewer.foreground black widgetDefault
22option add *VideoViewer.controlBackground gray widgetDefault
23option add *VideoViewer.controlDarkBackground #999999 widgetDefault
24option add *VideoViewer.plotBackground black widgetDefault
25option add *VideoViewer.plotForeground white widgetDefault
26option add *VideoViewer.plotOutline gray widgetDefault
27option add *VideoViewer.font \
28    -*-helvetica-medium-r-normal-*-12-* widgetDefault
29
30itcl::class Rappture::VideoViewer {
31    inherit itk::Widget
32
33    itk_option define -plotforeground plotForeground Foreground ""
34    itk_option define -plotbackground plotBackground Background ""
35    itk_option define -plotoutline plotOutline PlotOutline ""
36    itk_option define -width width Width -1
37    itk_option define -height height Height -1
38    itk_option define -controls controls Controls "show"
39
40    constructor { args } {
41        # defined below
42    }
43    destructor {
44        # defined below
45    }
46
47    public method load {filename}
48    public method video {args}
49    public method query {type}
50
51    protected method togglePtrBind {pbvar}
52    protected method togglePtrCtrl {pbvar}
53    protected method whatPtrCtrl {}
54
55    protected method Play {}
56    protected method Seek {n}
57    protected method Rubberband {status win x y}
58    protected method Distance {status win x y}
59    protected method Measure {status win x y}
60    protected method Particle {status win x y}
61    protected method Trajectory {args}
62    protected method updateMeasurements {}
63    protected method calculateTrajectory {args}
64    protected method fixSize {}
65
66
67
68    private common   _settings
69
70    private variable _width -1
71    private variable _height -1
72    private variable _controls ""
73    private variable _x0 0          ;# start x for rubberbanding
74    private variable _y0 0          ;# start y for rubberbanding
75    private variable _units "m"
76    private variable _movie ""      ;# movie we grab images from
77    private variable _lastFrame 0   ;# last frame in the movie
78    private variable _imh ""        ;# current image being displayed
79    private variable _id ""         ;# id of the next play command from after
80    private variable _pbvlist ""    ;# list of push button variables
81    private variable _px2dist 0     ;# conversion for screen px to distance
82    private variable _measCnt 0     ;# count of the number measure lines
83    private variable _measTags ""   ;# list of measure line tags on canvas
84    private variable _particles ""  ;# list of particles
85    private variable _pcnt -1       ;# particle count
86    private variable _framerate 30  ;# video frame rate
87    private variable _mspf 20       ;# milliseconds per frame wait time
88    private variable _waiting 0     ;# number of frames behind we are
89}
90
91itk::usual VideoViewer {
92    keep -background -foreground -cursor -font
93    keep -plotbackground -plotforeground
94}
95
96# ----------------------------------------------------------------------
97# CONSTRUCTOR
98# ----------------------------------------------------------------------
99itcl::body Rappture::VideoViewer::constructor {args} {
100
101    array set _settings [subst {
102        $this-arrows            0
103        $this-currenttime       0
104        $this-framenum          0
105        $this-duration          1:00
106        $this-loop              0
107        $this-play              0
108        $this-speed             500
109        $this-step              0
110    }]
111
112    # Create flow controls...
113
114    itk_component add main {
115        canvas $itk_interior.main \
116            -background black
117    } {
118        usual
119        rename -background -controlbackground controlBackground Background
120    }
121
122    itk_component add pointercontrols {
123        frame $itk_interior.pointercontrols
124    } {
125        usual
126        rename -background -controlbackground controlBackground Background
127    }
128
129
130    itk_component add moviecontrols {
131        frame $itk_interior.moviecontrols
132    } {
133        usual
134        rename -background -controlbackground controlBackground Background
135    }
136
137    pack forget $itk_component(main)
138    blt::table $itk_interior \
139        0,0 $itk_component(pointercontrols) -fill x \
140        1,0 $itk_component(main) -fill both \
141        2,0 $itk_component(moviecontrols) -fill x
142    # why do i have to explicitly say r0 and r2 instead of r*
143    blt::table configure $itk_interior r0 -resize none
144    blt::table configure $itk_interior r2 -resize none
145    blt::table configure $itk_interior c0 -padx 1
146
147
148    # setup pointer controls
149
150    set imagesDir [file join $RapptureGUI::library scripts images]
151
152    # ==== rectangle select tool ====
153    set rectImg [image create photo -file [file join $imagesDir "rect_dashed_black.png"]]
154    itk_component add rectangle {
155        Rappture::PushButton $itk_component(pointercontrols).rectanglepb \
156            -onimage $rectImg \
157            -offimage $rectImg \
158            -command [itcl::code $this togglePtrCtrl rectPbVar] \
159            -variable rectPbVar
160    } {
161        usual
162    }
163    Rappture::Tooltip::for $itk_component(rectangle) \
164        "rectangle select tool"
165
166    lappend _pbvlist rectPbVar
167
168    # ==== distance specify tool ====
169    set distImg [image create photo -file [file join $imagesDir "line_darrow_red.png"]]
170    itk_component add distance {
171        Rappture::PushButton $itk_component(pointercontrols).distancepb \
172            -onimage $distImg \
173            -offimage $distImg \
174            -command [itcl::code $this togglePtrCtrl distPbVar] \
175            -variable distPbVar
176    } {
177        usual
178    }
179    Rappture::Tooltip::for $itk_component(distance) \
180        "Specify the distance of a structure"
181
182    lappend _pbvlist distPbVar
183
184
185
186    # ==== measuring tool ====
187    set measImg [image create photo -file [file join $imagesDir "line_darrow_green.png"]]
188    itk_component add measure {
189        Rappture::PushButton $itk_component(pointercontrols).measurepb \
190            -onimage $measImg \
191            -offimage $measImg \
192            -command [itcl::code $this togglePtrCtrl measPbVar] \
193            -variable measPbVar
194    } {
195        usual
196    }
197    Rappture::Tooltip::for $itk_component(measure) \
198        "Measure the distance of a structure"
199
200    lappend _pbvlist measPbVar
201
202
203
204    # ==== particle mark tool ====
205    set particleImg [image create photo -file [file join $imagesDir "volume-on.gif"]]
206    itk_component add particle {
207        Rappture::PushButton $itk_component(pointercontrols).particlepb \
208            -onimage $particleImg \
209            -offimage $particleImg \
210            -command [itcl::code $this togglePtrCtrl partPbVar] \
211            -variable partPbVar
212    } {
213        usual
214    }
215    Rappture::Tooltip::for $itk_component(particle) \
216        "Mark the location of a particle to follow"
217
218    lappend _pbvlist partPbVar
219
220    blt::table $itk_component(pointercontrols) \
221        0,0 $itk_component(rectangle) -pady {3 0} \
222        0,1 $itk_component(distance) -pady {3 0} \
223        0,2 $itk_component(measure) -pady {3 0} \
224        0,3 $itk_component(particle) -pady {3 0}
225
226    blt::table configure $itk_component(pointercontrols) c* -resize none
227    blt::table configure $itk_component(pointercontrols) r* -resize none
228
229
230    # setup movie controls
231
232    # Rewind
233    itk_component add rewind {
234        button $itk_component(moviecontrols).reset \
235            -borderwidth 1 -padx 1 -pady 1 \
236            -image [Rappture::icon flow-rewind] \
237            -command [itcl::code $this video seek 0]
238    } {
239        usual
240        ignore -borderwidth
241        rename -highlightbackground -controlbackground controlBackground \
242            Background
243    }
244    Rappture::Tooltip::for $itk_component(rewind) \
245        "Rewind movie"
246
247    # Stop
248    itk_component add stop {
249        button $itk_component(moviecontrols).stop \
250            -borderwidth 1 -padx 1 -pady 1 \
251            -image [Rappture::icon flow-stop] \
252            -command [itcl::code $this video stop]
253    } {
254        usual
255        ignore -borderwidth
256        rename -highlightbackground -controlbackground controlBackground \
257            Background
258    }
259    Rappture::Tooltip::for $itk_component(stop) \
260        "Stop movie"
261
262    # Play
263    itk_component add play {
264        Rappture::PushButton $itk_component(moviecontrols).play \
265            -onimage [Rappture::icon flow-pause] \
266            -offimage [Rappture::icon flow-play] \
267            -variable [itcl::scope _settings($this-play)] \
268            -command [itcl::code $this video play]
269    }
270    set fg [option get $itk_component(hull) font Font]
271    Rappture::Tooltip::for $itk_component(play) \
272        "Play/Pause movie"
273
274    # Loop
275    itk_component add loop {
276        Rappture::PushButton $itk_component(moviecontrols).loop \
277            -onimage [Rappture::icon flow-loop] \
278            -offimage [Rappture::icon flow-loop] \
279            -variable [itcl::scope _settings($this-loop)]
280    }
281    Rappture::Tooltip::for $itk_component(loop) \
282        "Play continuously"
283
284    itk_component add dial {
285        Rappture::Flowdial $itk_component(moviecontrols).dial \
286            -length 10 -valuewidth 0 -valuepadding 0 -padding 6 \
287            -linecolor "" -activelinecolor "" \
288            -min 0.0 -max 1.0 \
289            -variable [itcl::scope _settings($this-currenttime)] \
290            -knobimage [Rappture::icon knob2] -knobposition center@middle
291    } {
292        usual
293        ignore -dialprogresscolor
294        rename -background -controlbackground controlBackground Background
295    }
296    $itk_component(dial) current 0.0
297    bind $itk_component(dial) <<Value>> [itcl::code $this video seek -currenttime]
298
299    # Current Frame Number
300    itk_component add framenum {
301        Rappture::Spinint $itk_component(moviecontrols).framenum \
302            -min 1 -max 1 -width 1 -font "arial 9"
303    } {
304        usual
305        ignore -highlightthickness
306        rename -background -controlbackground controlBackground Background
307    }
308    $itk_component(framenum) value 1
309    bind $itk_component(framenum) <<Value>> \
310        [itcl::code $this video seek -framenum]
311    Rappture::Tooltip::for $itk_component(framenum) \
312        "Set the current frame number"
313
314
315    # Duration
316    itk_component add duration {
317        entry $itk_component(moviecontrols).duration \
318            -textvariable [itcl::scope _settings($this-duration)] \
319            -bg white -width 6 -font "arial 9"
320    } {
321        usual
322        ignore -highlightthickness -background
323    }
324    bind $itk_component(duration) <Return> [itcl::code $this flow duration]
325    bind $itk_component(duration) <Tab> [itcl::code $this flow duration]
326    Rappture::Tooltip::for $itk_component(duration) \
327        "Set duration of movie (format is min:sec)"
328
329
330    itk_component add durationlabel {
331        label $itk_component(moviecontrols).durationl \
332            -text "Duration:" -font $fg \
333            -highlightthickness 0
334    } {
335        usual
336        ignore -highlightthickness
337        rename -background -controlbackground controlBackground Background
338    }
339
340    itk_component add speedlabel {
341        label $itk_component(moviecontrols).speedl -text "Speed:" -font $fg \
342            -highlightthickness 0
343    } {
344        usual
345        ignore -highlightthickness
346        rename -background -controlbackground controlBackground Background
347    }
348
349    # Speed
350    itk_component add speed {
351        Rappture::Flowspeed $itk_component(moviecontrols).speed \
352            -min 1 -max 10 -width 3 -font "arial 9"
353    } {
354        usual
355        ignore -highlightthickness
356        rename -background -controlbackground controlBackground Background
357    }
358    Rappture::Tooltip::for $itk_component(speed) \
359        "Change speed of movie"
360
361    $itk_component(speed) value 1
362    bind $itk_component(speed) <<Value>> [itcl::code $this video speed]
363
364
365    blt::table $itk_component(moviecontrols) \
366        0,0 $itk_component(rewind) -padx {3 0} \
367        0,1 $itk_component(stop) -padx {2 0} \
368        0,2 $itk_component(play) -padx {2 0} \
369        0,3 $itk_component(loop) -padx {2 0} \
370        0,4 $itk_component(dial) -fill x -padx {2 0 } \
371        0,5 $itk_component(framenum) -padx { 0 0} \
372        0,6 $itk_component(duration) -padx { 0 0} \
373        0,7 $itk_component(speed) -padx {2 3}
374
375    blt::table configure $itk_component(moviecontrols) c* -resize none
376    blt::table configure $itk_component(moviecontrols) c4 -resize both
377    blt::table configure $itk_component(moviecontrols) r0 -pady 1
378
379    itk_component add distGauge {
380        Rappture::Gauge $itk_interior.distGauge \
381            -units "m"
382    } {
383        usual
384        rename -background -controlbackground controlBackground Background
385    }
386    Rappture::Tooltip::for $itk_component(distGauge) \
387        "Length of structure"
388
389    bind $itk_component(distGauge) <<Value>> [itcl::code $this updateMeasurements]
390
391    eval itk_initialize $args
392}
393
394# ----------------------------------------------------------------------
395# DESTRUCTOR
396# ----------------------------------------------------------------------
397itcl::body Rappture::VideoViewer::destructor {} {
398    set _sendobjs ""  ;# stop any send in progress
399    $_dispatcher cancel !rebuild
400    $_dispatcher cancel !send_dataobjs
401    $_dispatcher cancel !send_transfunc
402    array unset _settings $this-*
403}
404
405# ----------------------------------------------------------------------
406# load - load a video file
407# ----------------------------------------------------------------------
408itcl::body Rappture::VideoViewer::load {filename} {
409
410    # open the file
411
412    set _movie [Rappture::Video "file" $filename]
413    set _framerate [${_movie} get framerate]
414    set _mspf [expr round(((1.0/${_framerate})*1000)/pow(2,[$itk_component(speed) value]-1))]
415    puts "framerate = ${_framerate}"
416    puts "mspf = ${_mspf}"
417
418    ${_movie} seek 0
419
420    # setup the image display
421
422    set _imh [image create photo]
423    foreach {w h} [query dimensions] break
424    if {${_width} == -1} {
425        set _width $w
426    }
427    if {${_height} == -1} {
428        set _height $h
429    }
430#    ${_imh} put [$_movie get image ${_width} ${_height}]
431    $itk_component(main) create image 0 0 -anchor nw -image $_imh
432
433    # setup timings for playing video
434
435    set _lastFrame [$_movie get position end]
436    set offset [expr 1.0/double(${_lastFrame})]
437    puts "end = ${_lastFrame}"
438    puts "offset = $offset"
439    $itk_component(dial) configure -offset $offset
440
441    set lcv ${_lastFrame}
442    set cnt 1
443    while {$lcv > 9} {
444        set lcv [expr $lcv/10]
445        incr cnt
446    }
447    $itk_component(framenum) configure -max ${_lastFrame} -width $cnt
448
449    fixSize
450}
451
452# ----------------------------------------------------------------------
453# fixSize
454# ----------------------------------------------------------------------
455itcl::body Rappture::VideoViewer::fixSize {} {
456
457    if {[string compare "" ${_movie}] == 0} {
458        return
459    }
460
461    # get an image with the new size
462    ${_imh} put [${_movie} get image ${_width} ${_height}]
463
464    # fix the dimesions of the canvas
465    $itk_component(main) configure -width ${_width} -height ${_height}
466
467    $itk_component(main) configure -scrollregion [$itk_component(main) bbox all]
468    #foreach { x0 y0 x1 y1 } [$itk_component(main) bbox all] break
469    #set w [expr abs($x1-$x0)]
470    #set h [expr abs($y1-$y0)]
471    #$itk_component(main) configure -width $w -height $h
472    # component hull configure -width $w -height $h
473}
474
475# ----------------------------------------------------------------------
476# video - play, stop, rewind, fastforward the video
477# ----------------------------------------------------------------------
478itcl::body Rappture::VideoViewer::video { args } {
479    set ret 0
480    set option [lindex $args 0]
481    switch -- $option {
482        "play" {
483            if {$_settings($this-play) == 1} {
484                # while in play move, you can't seek using the
485                # framenum spinint widget
486                bind $itk_component(framenum) <<Value>> ""
487                # start playing
488                Play
489            } else {
490                # pause
491                after cancel $_id
492                set _settings($this-play) 0
493                # setup seek bindings using the
494                # framenum spinint widget
495                bind $itk_component(framenum) <<Value>> \
496                    [itcl::code $this video seek -framenum]
497            }
498        }
499        "seek" {
500            Seek [lreplace $args 0 0]
501        }
502        "stop" {
503            after cancel $_id
504            set _settings($this-play) 0
505        }
506        "position" {
507            set ret [${_movie} get position cur]
508        }
509        "speed" {
510            set _mspf [expr round(((1.0/${_framerate})*1000)/pow(2,[$itk_component(speed) value]-1))]
511            puts "_mspf = ${_mspf}"
512        }
513        default {
514            error "bad option \"$option\": should be play, stop, toggle, position, or reset."
515        }
516    }
517    return $ret
518}
519
520# ----------------------------------------------------------------------
521# query - query things about the video
522# ----------------------------------------------------------------------
523itcl::body Rappture::VideoViewer::query { type } {
524    set ret ""
525    switch -- $type {
526        "dimensions" {
527            set ret [${_movie} size]
528        }
529        default {
530            error "bad type \"$type\": should be dimensions."
531        }
532    }
533    return $ret
534}
535
536# ----------------------------------------------------------------------
537# togglePtrCtrl - choose pointer mode:
538#                 rectangle, distance, measure, particlemark
539# ----------------------------------------------------------------------
540itcl::body Rappture::VideoViewer::togglePtrCtrl {pbvar} {
541
542    upvar 1 $pbvar inState
543    puts "togglePtrCtrl to $pbvar"
544    if {$inState == 1} {
545        # unpush previously pushed buttons
546        foreach pbv $_pbvlist {
547            if {[string compare $pbvar $pbv] != 0} {
548                upvar 1 $pbv var
549                set var 0
550            }
551        }
552    }
553    togglePtrBind $pbvar
554}
555
556
557# ----------------------------------------------------------------------
558# whatPtrCtrl - figure out the current pointer mode:
559#                 rectangle, distance, measure, particlemark
560# ----------------------------------------------------------------------
561itcl::body Rappture::VideoViewer::whatPtrCtrl {} {
562    foreach pbv $_pbvlist {
563        upvar #0 $pbv var
564        if {$var != "" && $var != 0} {
565            return $pbv
566        }
567    }
568}
569
570
571# ----------------------------------------------------------------------
572# togglePtrBind - update the bindings based on pointer controls
573# ----------------------------------------------------------------------
574itcl::body Rappture::VideoViewer::togglePtrBind {pbvar} {
575
576    if {[string compare $pbvar current] == 0} {
577        set pbvar [whatPtrCtrl]
578    }
579
580    if {[string compare $pbvar rectPbVar] == 0} {
581
582        # Bindings for selecting rectangle
583        $itk_component(main) configure -cursor ""
584
585        bind $itk_component(main) <ButtonPress-1> \
586            [itcl::code $this Rubberband new %W %x %y]
587        bind $itk_component(main) <B1-Motion> \
588            [itcl::code $this Rubberband drag %W %x %y]
589        bind $itk_component(main) <ButtonRelease-1> \
590            [itcl::code $this Rubberband release %W %x %y]
591
592    } elseif {[string compare $pbvar distPbVar] == 0} {
593
594        # Bindings for setting distance
595        $itk_component(main) configure -cursor ""
596
597        bind $itk_component(main) <ButtonPress-1> \
598            [itcl::code $this Distance new %W %x %y]
599        bind $itk_component(main) <B1-Motion> \
600            [itcl::code $this Distance drag %W %x %y]
601        bind $itk_component(main) <ButtonRelease-1> \
602            [itcl::code $this Distance release %W %x %y]
603
604    } elseif {[string compare $pbvar measPbVar] == 0} {
605
606        # Bindings for measuring distance
607        $itk_component(main) configure -cursor ""
608
609        bind $itk_component(main) <ButtonPress-1> \
610            [itcl::code $this Measure new %W %x %y]
611        bind $itk_component(main) <B1-Motion> \
612            [itcl::code $this Measure drag %W %x %y]
613        bind $itk_component(main) <ButtonRelease-1> \
614            [itcl::code $this Measure release %W %x %y]
615
616    } elseif {[string compare $pbvar partPbVar] == 0} {
617
618        # Bindings for marking particle locations
619        $itk_component(main) configure -cursor ""
620
621        bind $itk_component(main) <ButtonPress-1> \
622            [itcl::code $this Particle new %W %x %y]
623        bind $itk_component(main) <B1-Motion> ""
624        bind $itk_component(main) <ButtonRelease-1> ""
625
626    } elseif {[string compare $pbvar particle] == 0} {
627
628        # Bindings for interacting with particles
629        $itk_component(main) configure -cursor hand2
630
631        bind $itk_component(main) <ButtonPress-1> ""
632        bind $itk_component(main) <B1-Motion> ""
633        bind $itk_component(main) <ButtonRelease-1> ""
634
635    } else {
636
637        # invalid pointer mode
638
639    }
640}
641
642
643# ----------------------------------------------------------------------
644# play - get the next video frame
645# ----------------------------------------------------------------------
646itcl::body Rappture::VideoViewer::Play {} {
647
648    set cur [$_movie get position cur]
649
650#    # this probably is incorrect because other people
651#    # could schedule stuff in the after queue
652#    if {[llength [after info]] > 1} {
653#        # drop frames that get caught up in the "after queue"
654#        # in order to keep up with the frame rate
655#        #foreach i [after info] {
656#        #    after cancel $i
657#        #}
658#        incr _waiting
659#    } else {
660#        # display the next frame
661#        $_imh put [$_movie seek +[incr _waiting]]
662#        set _waiting 0
663#
664#        # update the dial and framenum widgets
665#        set _settings($this-currenttime) [expr 1.0*$cur/${_lastFrame}]
666#        $itk_component(framenum) value $cur
667#
668#    }
669
670    # display the next frame
671    $_movie next
672    $_imh put [$_movie get image ${_width} ${_height}]
673
674    # update the dial and framenum widgets
675    set _settings($this-currenttime) [expr 1.0*$cur/${_lastFrame}]
676    $itk_component(framenum) value $cur
677
678    if {[expr $cur%100] == 0} {
679        puts "after: [after info]"
680        puts "id = ${_id}"
681    }
682
683    # schedule the next frame to be displayed
684    if {$cur < ${_lastFrame}} {
685        set _id [after ${_mspf} [itcl::code $this Play]]
686    }
687}
688
689
690# ----------------------------------------------------------------------
691# Seek - go to a frame in the video video frame
692#   Seek -percent 43
693#   Seek -percent 0.5
694#   Seek +5
695#   Seek -5
696#   Seek 35
697#   Seek -currenttime
698#   Seek -framenum
699# ----------------------------------------------------------------------
700itcl::body Rappture::VideoViewer::Seek {args} {
701    set option [lindex $args 0]
702    switch -- $option {
703        "-percent" {
704            set val [lindex $args 1]
705            if {[string is integer -strict $val] == 1} {
706                set val [expr double($val) / 100.0]
707            }
708            # convert the percentage to a frame number (new cur)
709            set val [expr int($val * ${_lastFrame})]
710        }
711        "-currenttime" {
712            set val $_settings($this-currenttime)
713            set val [expr round($val * ${_lastFrame})]
714        }
715        "-framenum" {
716            set val [$itk_component(framenum) value]
717        }
718        default {
719            set val $option
720        }
721    }
722    if {"" == $val} {
723        error "bad value: \"$val\": should be \"seek \[-percent\] value\""
724    }
725    ${_movie} seek $val
726    ${_imh} put [${_movie} get image ${_width} ${_height}]
727    set cur [${_movie} get position cur]
728    set _settings($this-currenttime) [expr double($cur) / double(${_lastFrame})]
729}
730
731
732# ----------------------------------------------------------------------
733# Rubberband - draw a rubberband around something in the canvas
734# ----------------------------------------------------------------------
735itcl::body Rappture::VideoViewer::Rubberband {status win x y} {
736    switch -- $status {
737        "new" {
738            $win delete "rubbershape"
739            set _x0 $x
740            set _y0 $y
741            $win create rectangle \
742                $x $y $x $y -outline white -width 2  \
743                -tags "rubbershape" -dash {4 4}
744        }
745        "drag" {
746            foreach { x0 y0 x1 y1 } [$win coords "rubbershape"] break
747
748            if {$_x0 > $x} {
749                # backward direction
750                set x0 $x
751                set x1 $_x0
752            } else {
753                set x1 $x
754            }
755
756            if {$_y0 >= $y} {
757                # backward direction
758                set y0 $y
759                set y1 $_y0
760            } else {
761                set y1 $y
762            }
763
764            eval $win coords "rubbershape" [list $x0 $y0 $x1 $y1]
765        }
766        "release" {
767            Rubberband drag $win $x $y
768        }
769        default {
770            error "bad status \"$status\": should be new, drag, or release"
771        }
772    }
773}
774
775# ----------------------------------------------------------------------
776# updateMeasurements - update measurements based on provided distance
777# ----------------------------------------------------------------------
778itcl::body Rappture::VideoViewer::updateMeasurements {} {
779    foreach { x0 y0 x1 y1 } [$itk_component(main) bbox "distance"] break
780    set px [expr sqrt(pow(($x1-$x0),2)+pow(($y1-$y0),2))]
781    set dist [Rappture::Units::convert [$itk_component(distGauge) value] -units off]
782    set px2dist [expr $dist/$px]
783    if {$px2dist != ${_px2dist}} {
784        set _px2dist $px2dist
785    }
786
787    # if measure lines exist, update their values
788    foreach tag ${_measTags} {
789        foreach { x0 y0 x1 y1 } [$itk_component(main) bbox $tag] break
790        set px [expr sqrt(pow(($x1-$x0),2)+pow(($y1-$y0),2))]
791        set dist [expr $px*${_px2dist}]
792        regexp {measure(\d+)} $tag match cnt
793        $itk_component(measGauge$cnt) value $dist
794    }
795}
796
797# ----------------------------------------------------------------------
798# Distance - draw a line to measure something on the canvas,
799#            when user releases the line, user is prompted for
800#            a measurement which is stored and used as the bases
801#            for future distance calculations.
802# ----------------------------------------------------------------------
803itcl::body Rappture::VideoViewer::Distance {status win x y} {
804    switch -- $status {
805        "new" {
806            $win delete "distance"
807            $win delete "distance-val"
808            $win create line \
809                $x $y $x $y -fill red -width 2  \
810                -tags "distance" -dash {4 4} -arrow both
811        }
812        "drag" {
813            set coords [$win coords "distance"]
814            eval $win coords "distance" [lreplace $coords 2 3 $x $y]
815        }
816        "release" {
817            Distance drag $win $x $y
818            foreach { x0 y0 x1 y1 } [$itk_component(main) bbox "distance"] break
819            set rootx [winfo rootx $itk_component(main)]
820            set rooty [winfo rooty $itk_component(main)]
821            set x [expr "$x0 + (abs($x1-$x0)/2)"]
822            set y [expr "$y0 + (abs($y1-$y0)/2)"]
823            $itk_component(main) create window $x $y \
824                -window $itk_component(distGauge) \
825                -anchor center \
826                -tags "distance-val"
827        }
828        default {
829            error "bad status \"$status\": should be new, drag, or release"
830        }
831    }
832}
833# ----------------------------------------------------------------------
834# Measure - draw a line to measure something on the canvas,
835#           when user releases the line, user is given the
836#           calculated measurement.
837# ----------------------------------------------------------------------
838itcl::body Rappture::VideoViewer::Measure {status win x y} {
839    switch -- $status {
840        "new" {
841            $win delete "measure"
842            $win create line \
843                $x $y $x $y -fill green -width 2  \
844                -tags "measure" -dash {4 4} -arrow both
845        }
846        "drag" {
847            set coords [$win coords "measure"]
848            eval $win coords "measure" [lreplace $coords 2 3 $x $y]
849        }
850        "release" {
851            # finish drawing the measuring line
852            Measure drag $win $x $y
853
854            # calculate the location on the measuring line to place gauge
855            foreach { x0 y0 x1 y1 } [$itk_component(main) bbox "measure"] break
856            puts "bbox for $_measCnt is ($x0,$y0) ($x1,$y1)"
857            set rootx [winfo rootx $itk_component(main)]
858            set rooty [winfo rooty $itk_component(main)]
859            set x [expr "$x0 + (abs($x1-$x0)/2)"]
860            set y [expr "$y0 + (abs($y1-$y0)/2)"]
861
862#            set popup ".measure$_measCnt-popup"
863#            if { ![winfo exists $popup] } {
864#                # Create a popup for the measure line dialog
865#                Rappture::Balloon $popup -title "Configure measurement..."
866#                set inner [$popup component inner]
867#                # Create the print dialog widget and add it to the
868#                # the balloon popup.
869#                Rappture::XyPrint $inner.print-
870#                $popup configure \
871#                    -deactivatecommand [list $inner.print reset]-
872#                blt::table $inner 0,0 $inner.print -fill both
873#            }
874#
875#
876            # create a new gauge for this measuring line
877            itk_component add measGauge$_measCnt {
878                Rappture::Gauge $itk_interior.measGauge$_measCnt \
879                    -units "m"
880            } {
881                usual
882                rename -background -controlbackground controlBackground Background
883            }
884            Rappture::Tooltip::for $itk_component(measGauge$_measCnt) \
885                "Length of structure $_measCnt"
886
887            # place the gauge on the measuring line
888            $itk_component(main) create window $x $y \
889                -window $itk_component(measGauge$_measCnt) \
890                -anchor center \
891                -tags "measure$_measCnt-val"
892
893            # set the value of the gauge with the calculated distance
894            set px [expr sqrt(pow(($x1-$x0),2)+pow(($y1-$y0),2))]
895            set dist [expr $px*$_px2dist]
896            $itk_component(measGauge$_measCnt) value $dist
897
898            # rename the tag for the line
899            # so we can have multiple measure lines
900            # store tag name for future value updates
901            $itk_component(main) addtag "measure$_measCnt" withtag "measure"
902            $itk_component(main) dtag "measure" "measure"
903            lappend _measTags "measure$_measCnt"
904            incr _measCnt
905        }
906        default {
907            error "bad status \"$status\": should be new, drag, or release"
908        }
909    }
910}
911
912# ----------------------------------------------------------------------
913# Particle - mark a particle in the video, a new particle object is
914#            created from information like the name, which video
915#            frames it lives in, it's coords in the canvas in each
916#            frame, it's color...
917# ----------------------------------------------------------------------
918itcl::body Rappture::VideoViewer::Particle {status win x y} {
919    switch -- $status {
920        "new" {
921            incr _pcnt
922            puts "pcnt = ${_pcnt}"
923            set name "particle${_pcnt}"
924            set p [Rappture::VideoParticle $itk_component(main).#auto $win \
925                    -fncallback [itcl::code $this video position cur] \
926                    -trajcallback [itcl::code $this Trajectory] \
927                    -halo 5 \
928                    -name $name \
929                    -color green]
930            set frameNum [$_movie get position cur]
931            $p Add frame $frameNum $x $y
932            $p Show particle
933
934            # link the new particle to the last particle added
935            set lastp ""
936            while {[llength ${_particles}] > 0} {
937                set lastp [lindex ${_particles} end]
938                if {[llength [$lastp Coords]] != 0} {
939                    break
940                } else {
941                    set _particles [lreplace ${_particles} end end]
942                    set lastp ""
943                }
944            }
945
946            if {[string compare "" $lastp] != 0} {
947                $lastp Link $p
948                bind $lastp <<Motion>> [itcl::code $lastp drawVectors]]
949            }
950
951
952            # add the particle to the list
953            lappend _particles $p
954
955            $win bind $name <ButtonPress-1> [itcl::code $p Move press %x %y]
956            $win bind $name <B1-Motion> [itcl::code $p Move motion %x %y]
957            $win bind $name <ButtonRelease-1> [itcl::code $p Move release %x %y]
958
959            $win bind $name <ButtonPress-3> [itcl::code $p Menu activate %x %y]
960
961            $win bind $name <Enter> [itcl::code $this togglePtrBind particle]
962            $win bind $name <Leave> [itcl::code $this togglePtrBind current]
963
964#            set pm [Rappture::VideoParticleManager]
965#            $pm add $p0
966#            set plist [$pm list]
967        }
968        default {
969            error "bad status \"$status\": should be new, drag, or release"
970        }
971    }
972}
973
974# ----------------------------------------------------------------------
975# Trajectory - draw a trajectory between two particles
976# ----------------------------------------------------------------------
977itcl::body Rappture::VideoViewer::Trajectory {args} {
978
979    set nargs [llength $args]
980    if {($nargs != 1) && ($nargs != 2)} {
981        error "wrong # args: should be \"Trajectory p0 p1\""
982    }
983
984    set p0 ""
985    set p1 ""
986    foreach {p0 p1} $args break
987
988    if {[string compare "" $p0] == 0} {
989        # p0 does not exist
990        return
991    }
992
993    # remove any old trajectory links from p0
994    set p0name [$p0 cget -name]
995    set oldlink "vec-$p0name"
996    puts "removing $oldlink"
997    $itk_component(main) delete $oldlink
998
999    # check to see if p1 exists anymore
1000    if {[string compare "" $p1] == 0} {
1001        # p1 does not exist
1002        return
1003    }
1004
1005    foreach {x0 y0} [$p0 Coords] break
1006    foreach {x1 y1} [$p1 Coords] break
1007    set p1name [$p1 cget -name]
1008    set link "vec-$p0name-$p1name"
1009    puts "adding $link"
1010    $itk_component(main) create line $x0 $y0 $x1 $y1 \
1011        -fill green \
1012        -width 2 \
1013        -tags "vector $link vec-$p0name" \
1014        -dash {4 4} \
1015        -arrow last
1016
1017    # calculate trajectory, truncate it after 4 sigdigs
1018    puts "---------$link---------"
1019    set t [calculateTrajectory [$p0 Frame] $x0 $y0 [$p1 Frame] $x1 $y1]
1020    set tt [string range $t 0 [expr [string first . $t] + 4]]
1021
1022
1023    # calculate coords for text
1024    foreach { x0 y0 x1 y1 } [$itk_component(main) bbox $link] break
1025    set x [expr "$x0 + (abs($x1-$x0)/2)"]
1026    set y [expr "$y0 + (abs($y1-$y0)/2)"]
1027
1028    $itk_component(main) create text $x $y \
1029        -tags "vectext $link vec-$p0name" \
1030        -justify center \
1031        -text "$tt [$itk_component(distGauge) cget -units]/s" \
1032        -fill green \
1033        -width [expr sqrt(pow(abs($x1-$x0),2)+pow(abs($y1-$y0),2))]
1034}
1035
1036# ----------------------------------------------------------------------
1037# calculateTrajectory - calculate the value of the trajectory
1038# ----------------------------------------------------------------------
1039itcl::body Rappture::VideoViewer::calculateTrajectory {args} {
1040    # set framerate 29.97         ;# frames per second
1041    # set px2dist    8.00         ;# px per meter
1042
1043    foreach {f0 x0 y0 f1 x1 y1} $args break
1044    set px [expr sqrt(pow(abs($x1-$x0),2)+pow(abs($y1-$y0),2))]
1045    set frames [expr $f1 - $f0]
1046
1047    if {($frames != 0) && (${_px2dist} != 0)} {
1048        set t [expr 1.0*$px/$frames/${_px2dist}*${_framerate}]
1049    } else {
1050        set t 0.0
1051    }
1052
1053    puts "px = $px"
1054    puts "frames = $frames"
1055    puts "px2dist = ${_px2dist}"
1056    puts "framerate = ${_framerate}"
1057    puts "trajectory = $t"
1058
1059    return $t
1060}
1061
1062# ----------------------------------------------------------------------
1063# OPTION: -width
1064# ----------------------------------------------------------------------
1065itcl::configbody Rappture::VideoViewer::width {
1066    # $_dispatcher event -idle !fixsize
1067    if {[string is integer $itk_option(-width)] == 0} {
1068        error "bad value: \"$itk_option(-width)\": width should be an integer"
1069    }
1070    set _width $itk_option(-width)
1071    after idle [itcl::code $this fixSize]
1072}
1073
1074# ----------------------------------------------------------------------
1075# OPTION: -height
1076# ----------------------------------------------------------------------
1077itcl::configbody Rappture::VideoViewer::height {
1078    # $_dispatcher event -idle !fixsize
1079    if {[string is integer $itk_option(-height)] == 0} {
1080        error "bad value: \"$itk_option(-height)\": height should be an integer"
1081    }
1082    set _height $itk_option(-height)
1083    after idle [itcl::code $this fixSize]
1084}
1085
1086# ----------------------------------------------------------------------
1087# OPTION: -controls
1088# ----------------------------------------------------------------------
1089itcl::configbody Rappture::VideoViewer::controls {
1090    switch $itk_option(-controls) {
1091        show {
1092        }
1093        hide {
1094        }
1095        default {
1096            error "bad value: \"$itk_option(-height)\": height should be an integer"
1097        }
1098    }
1099    set _height $itk_option(-height)
1100    after idle [itcl::code $this fixSize]
1101}
1102
Note: See TracBrowser for help on using the repository browser.