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

Last change on this file since 1916 was 1916, checked in by dkearney, 11 years ago

switching from RpMediaPlayer? to RpVideo? code for the video viewer widget. changed flowdial widget so the dial moved as needed for the video widget.

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