source: trunk/gui/scripts/videoscreen.tcl @ 2029

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

fixing keypress in videodial2 by adding focus when user clicks on the currentmark
in videodial2, disable markers from being drawn if they are less than or greater than the displayed min and max on the dial
File size: 40.3 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: video - 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 *Video.width 300 widgetDefault
19option add *Video.height 300 widgetDefault
20option add *Video.foreground black widgetDefault
21option add *Video.controlBackground gray widgetDefault
22option add *Video.font \
23    -*-helvetica-medium-r-normal-*-12-* widgetDefault
24
25itcl::class Rappture::VideoScreen {
26    inherit itk::Widget
27
28    itk_option define -width width Width -1
29    itk_option define -height height Height -1
30    itk_option define -fileopen fileopen Fileopen ""
31
32    constructor { args } {
33        # defined below
34    }
35    destructor {
36        # defined below
37    }
38
39    public method load {type data}
40    public method loadcb {args}
41    public method video {args}
42    public method query {type}
43
44    protected method Play {}
45    protected method Seek {n}
46    protected method fixSize {}
47    protected method Upload {args}
48    protected method eventually {args}
49
50    private method togglePtrCtrl {pbvar}
51    private method whatPtrCtrl {}
52    private method togglePtrBind {pbvar}
53
54    # drawing tools
55    private method Rubberband {status win x y}
56    private method updateMeasurements {}
57    private method Measure {status win x y}
58    private method Particle {status win x y}
59    private method Trajectory {args}
60    private method calculateTrajectory {args}
61    private method writeText {x y text color tags width}
62    private method clearDrawings {}
63
64    # video dial tools
65    private method toggleloop {}
66
67    private common   _settings
68    private common   _pendings
69    private common   _pbvars
70    private common   _counters
71
72    private variable _width -1      ;# start x for rubberbanding
73    private variable _height -1     ;# start x for rubberbanding
74    private variable _movie ""      ;# movie we grab images from
75    private variable _lastFrame 0   ;# last frame in the movie
76    private variable _imh ""        ;# current image being displayed
77    private variable _id ""         ;# id of the next play command from after
78    private variable _framerate 30  ;# video frame rate
79    private variable _mspf  7       ;# milliseconds per frame wait time
80    private variable _ofrd  19      ;# observed frame retrieval delay of
81                                    ;# underlying c lib in milliseconds
82    private variable _delay  0      ;# milliseconds between play calls
83    private variable _nextframe 0   ;#
84
85    private variable _px2dist 0     ;# conversion for pixels to user specified distance
86    private variable _particles ""  ;# list of particles
87    private variable _measurements "" ;# list of all measurement lines
88    private variable _obj ""        ;# temp var holding the last created object
89}
90
91
92itk::usual VideoScreen {
93    keep -background -foreground -cursor -font
94    keep -plotbackground -plotforeground
95}
96
97# ----------------------------------------------------------------------
98# CONSTRUCTOR
99# ----------------------------------------------------------------------
100itcl::body Rappture::VideoScreen::constructor {args} {
101
102    array set _settings [subst {
103        framenum          0
104        loop              0
105        play              0
106        speed             1
107    }]
108
109    array set _pendings {
110        seek 0
111        play 0
112    }
113
114    array set _counters {
115        particle 0
116        measure 0
117    }
118
119    # Create flow controls...
120
121    itk_component add main {
122        canvas $itk_interior.main \
123            -background black
124    } {
125        usual
126        rename -background -controlbackground controlBackground Background
127    }
128    bind $itk_component(main) <Configure> [itcl::code $this fixSize]
129
130    # hold the video frames in an image on the canvas
131    set _imh [image create photo]
132    $itk_component(main) create image 0 0 -anchor nw -image $_imh
133
134    # setup movie controls
135    itk_component add moviecontrols {
136        frame $itk_interior.moviecontrols
137    } {
138        usual
139        rename -background -controlbackground controlBackground Background
140    }
141
142    # setup frame number frame
143    itk_component add frnumfr {
144        frame $itk_component(moviecontrols).frnumfr
145    } {
146        usual
147        rename -background -controlbackground controlBackground Background
148    }
149
150    set imagesDir [file join $RapptureGUI::library scripts images]
151
152    # ==== fileopen ====
153    itk_component add fileopen {
154        button $itk_component(moviecontrols).fileopen \
155            -borderwidth 1 -padx 1 -pady 1 \
156            -image [Rappture::icon upload] \
157            -command [itcl::code $this loadcb]
158    } {
159        usual
160    }
161    Rappture::Tooltip::for $itk_component(fileopen) \
162        "Open file"
163
164    # ==== measuring tool ====
165    set measImg [image create photo -file [file join $imagesDir "line_darrow_green.png"]]
166    itk_component add measure {
167        Rappture::PushButton $itk_component(moviecontrols).measurepb \
168            -onimage $measImg \
169            -offimage $measImg \
170            -disabledimage $measImg \
171            -command [itcl::code $this togglePtrCtrl "measure"] \
172            -variable [itcl::scope _pbvars(measure)]
173    } {
174        usual
175    }
176    $itk_component(measure) disable
177    Rappture::Tooltip::for $itk_component(measure) \
178        "Measure the distance of a structure"
179
180    # ==== particle mark tool ====
181    set particleImg [image create photo -file [file join $imagesDir "volume-on.gif"]]
182    itk_component add particle {
183        Rappture::PushButton $itk_component(moviecontrols).particlepb \
184            -onimage $particleImg \
185            -offimage $particleImg \
186            -disabledimage $particleImg \
187            -command [itcl::code $this togglePtrCtrl "particle"] \
188            -variable [itcl::scope _pbvars(particle)]
189    } {
190        usual
191    }
192    $itk_component(particle) disable
193    Rappture::Tooltip::for $itk_component(particle) \
194        "Mark the location of a particle to follow"
195
196
197    # Rewind
198    itk_component add rewind {
199        button $itk_component(moviecontrols).rewind \
200            -borderwidth 1 -padx 1 -pady 1 \
201            -image [Rappture::icon video-rewind] \
202            -command [itcl::code $this video seek 0]
203    } {
204        usual
205        ignore -borderwidth
206        rename -highlightbackground -controlbackground controlBackground \
207            Background
208    }
209    $itk_component(rewind) configure -state disabled
210    Rappture::Tooltip::for $itk_component(rewind) \
211        "Rewind movie"
212
213    # Seek back
214    itk_component add seekback {
215        button $itk_component(moviecontrols).seekback \
216            -borderwidth 1 -padx 1 -pady 1 \
217            -image [Rappture::icon flow-rewind] \
218            -command [itcl::code $this video seek -1]
219    } {
220        usual
221        ignore -borderwidth
222        rename -highlightbackground -controlbackground controlBackground \
223            Background
224    }
225    $itk_component(seekback) configure -state disabled
226    Rappture::Tooltip::for $itk_component(rewind) \
227        "Seek backwards 1 frame"
228
229    # Play
230    itk_component add play {
231        Rappture::PushButton $itk_component(moviecontrols).play \
232            -onimage [Rappture::icon flow-pause] \
233            -offimage [Rappture::icon flow-play] \
234            -disabledimage [Rappture::icon flow-play] \
235            -variable [itcl::scope _settings(play)] \
236            -command [itcl::code $this video play]
237    }
238    $itk_component(play) disable
239    Rappture::Tooltip::for $itk_component(play) \
240        "Play/Pause movie"
241
242    # Seek forward
243    itk_component add seekforward {
244        button $itk_component(moviecontrols).seekforward \
245            -borderwidth 1 -padx 1 -pady 1 \
246            -image [Rappture::icon flow-forward] \
247            -command [itcl::code $this video seek +1]
248    } {
249        usual
250        ignore -borderwidth
251        rename -highlightbackground -controlbackground controlBackground \
252            Background
253    }
254    $itk_component(seekforward) configure -state disabled
255    Rappture::Tooltip::for $itk_component(seekforward) \
256        "Seek forward 1 frame"
257
258    # Loop
259    itk_component add loop {
260        Rappture::PushButton $itk_component(moviecontrols).loop \
261            -onimage [Rappture::icon flow-loop] \
262            -offimage [Rappture::icon flow-loop] \
263            -disabledimage [Rappture::icon flow-loop] \
264            -variable [itcl::scope _settings(loop)] \
265            -command [itcl::code $this toggleloop]
266    }
267    $itk_component(loop) disable
268    Rappture::Tooltip::for $itk_component(loop) \
269        "Play continuously between marked sections"
270
271    itk_component add dial {
272        frame $itk_interior.dial
273    } {
274        usual
275        rename -background -controlbackground controlBackground Background
276    }
277
278    # Video Dial Major
279    itk_component add dialmajor {
280        Rappture::Videodial1 $itk_component(dial).dialmajor \
281            -length 10 -valuewidth 0 -valuepadding 0 -padding 6 \
282            -linecolor "" -activelinecolor "" \
283            -min 0 -max 1 \
284            -variable [itcl::scope _settings(framenum)] \
285            -dialoutlinecolor black \
286            -knobimage [Rappture::icon knob2] -knobposition center@middle
287    } {
288        usual
289        ignore -dialprogresscolor
290        rename -background -controlbackground controlBackground Background
291    }
292    $itk_component(dialmajor) current 0
293    bind $itk_component(dialmajor) <<Value>> [itcl::code $this video update]
294
295    # Video Dial Minor
296    itk_component add dialminor {
297        Rappture::Videodial2 $itk_component(dial).dialminor \
298            -padding 0 \
299            -min 0 -max 1 \
300            -minortick 1 -majortick 5 \
301            -variable [itcl::scope _settings(framenum)] \
302            -dialoutlinecolor black
303    } {
304        usual
305        rename -background -controlbackground controlBackground Background
306    }
307    $itk_component(dialminor) current 0
308    bind $itk_component(dialminor) <<Value>> [itcl::code $this video update]
309
310    set fg [option get $itk_component(hull) font Font]
311
312    itk_component add framenumlabel {
313        label $itk_component(frnumfr).framenuml -text "Frame:" -font $fg \
314            -highlightthickness 0
315    } {
316        usual
317        ignore -highlightthickness
318        rename -background -controlbackground controlBackground Background
319    }
320
321    # Current Frame Number
322    itk_component add framenum {
323        label $itk_component(frnumfr).framenum \
324            -background white -font "arial 9" \
325            -textvariable [itcl::scope _settings(framenum)]
326    } {
327        usual
328        ignore -highlightthickness
329        rename -background -controlbackground controlBackground Background
330    }
331    Rappture::Tooltip::for $itk_component(framenum) \
332        "Current frame number"
333
334
335    pack $itk_component(framenumlabel) -side left
336    pack $itk_component(framenum) -side right
337
338
339    itk_component add speedlabel {
340        label $itk_component(moviecontrols).speedl -text "Speed:" -font $fg \
341            -highlightthickness 0
342    } {
343        usual
344        ignore -highlightthickness
345        rename -background -controlbackground controlBackground Background
346    }
347
348    # Speed
349    itk_component add speed {
350        Rappture::Videospeed $itk_component(moviecontrols).speed \
351            -min 0 -max 1 -width 4 -font "arial 9" -factor 2
352    } {
353        usual
354        ignore -highlightthickness
355        rename -background -controlbackground controlBackground Background
356    }
357    Rappture::Tooltip::for $itk_component(speed) \
358        "Change speed of movie"
359
360    $itk_component(speed) value 0.25
361    bind $itk_component(speed) <<Value>> [itcl::code $this video speed]
362
363
364    blt::table $itk_component(dial) \
365        0,0 $itk_component(dialmajor) -fill x \
366        1,0 $itk_component(dialminor) -fill x
367
368    blt::table $itk_component(moviecontrols) \
369        0,0 $itk_component(fileopen) -padx {2 0}  \
370        0,1 $itk_component(measure) -padx {4 0}  \
371        0,2 $itk_component(particle) -padx {4 0} \
372        0,5 $itk_component(dial) -fill x -padx {2 4} -rowspan 3 \
373        1,0 $itk_component(rewind) -padx {2 0} \
374        1,1 $itk_component(seekback) -padx {4 0} \
375        1,2 $itk_component(play) -padx {4 0} \
376        1,3 $itk_component(seekforward) -padx {4 0} \
377        1,4 $itk_component(loop) -padx {4 0} \
378        2,0 $itk_component(frnumfr) -padx {2 0} -columnspan 3 \
379        2,3 $itk_component(speed) -padx {2 0} -columnspan 2
380
381    blt::table configure $itk_component(moviecontrols) c* -resize none
382    blt::table configure $itk_component(moviecontrols) c5 -resize both
383    blt::table configure $itk_component(moviecontrols) r0 -pady 1
384
385
386    blt::table $itk_interior \
387        0,0 $itk_component(main) -fill both \
388        1,0 $itk_component(moviecontrols) -fill x
389    blt::table configure $itk_interior c* -resize both
390    blt::table configure $itk_interior r0 -resize both
391    blt::table configure $itk_interior r1 -resize none
392
393    eval itk_initialize $args
394}
395
396# ----------------------------------------------------------------------
397# DESTRUCTOR
398# ----------------------------------------------------------------------
399itcl::body Rappture::VideoScreen::destructor {} {
400    array unset _settings *
401    array unset _pendings *
402    array unset _pbvars *
403    array unset _counters *
404
405
406    if {[info exists _imh]} {
407        image delete ${_imh}
408        set _imh ""
409    }
410
411    if {[info exists measImg]} {
412        image delete $measImg
413        set measImg ""
414    }
415
416    if {[info exists particleImg]} {
417        image delete $particleImg
418        set particleImg ""
419    }
420
421    if {("" != [info commands ${_movie}])} {
422        # clear the movie if it is still open
423        ${_movie} release
424        set _movie ""
425    }
426
427    clearDrawings
428}
429
430# ----------------------------------------------------------------------
431# clearDrawings - delete all particle and measurement objects
432# ----------------------------------------------------------------------
433itcl::body Rappture::VideoScreen::clearDrawings {} {
434
435    # delete all previously placed particles
436    set obj [lindex ${_particles} end]
437    while {"" != [info commands $obj]} {
438        itcl::delete object $obj
439        set _particles [lreplace ${_particles} end end]
440        if {[llength ${_particles}] == 0} {
441            break
442        }
443        set obj [lindex ${_particles} end]
444    }
445
446    # delete all previously placed measurements
447    set obj [lindex ${_measurements} end]
448    while {"" != [info commands $obj]} {
449        itcl::delete object $obj
450        set _measurements [lreplace ${_measurements} end end]
451        if {[llength ${_measurements}] == 0} {
452            break
453        }
454        set obj [lindex ${_measurements} end]
455    }
456}
457
458# ----------------------------------------------------------------------
459# load - load a video file
460#   type - type of data, "data" or "file"
461#   data - what to load.
462#       if type == "data", data is treated like binary data
463#       if type == "file", data is treated like the name of a file
464#           and is opened and then loaded.
465# ----------------------------------------------------------------------
466itcl::body Rappture::VideoScreen::load {type data} {
467
468    # open the file
469    set fname ""
470    switch $type {
471        "data" {
472            if {"" == $data} {
473                error "bad value \"$data\": data should be a movie"
474            }
475
476            set fname "/tmp/tmpVV[pid].video"
477            set fid [open $fname "w"]
478            fconfigure $fid -translation binary -encoding binary
479            puts $fid $data
480            close $fid
481            set type "file"
482            set data $fname
483        }
484        "file" {
485            if {"" == $data} {
486                error "bad value \"$data\": data should be a movie file path"
487            }
488            # do nothing
489        }
490        default {
491            error "bad value: \"$type\": should be \"load \[data|file\] <data>\""
492        }
493    }
494
495    video stop
496
497    if {"file" == $type} {
498        if {("" != [info commands ${_movie}])} {
499            # compare the new file name to the name of the file
500            # we already have open in our _movie object.
501            # if they are the same, do not reopen the video.
502            # if they are different, close the old movie
503            # and clear out all old drawings from the canvas.
504            set err [catch {${_movie} get filename} filename]
505            if {($err == 0)&& ($data == $filename)} {
506                # video file already open, don't reopen it.
507                return
508            } else {
509                # clear the old movie
510                ${_movie} release
511
512                # delete drawings objects from canvas
513                clearDrawings
514            }
515        }
516    }
517
518    set _movie [Rappture::Video $type $data]
519    if {"" != $fname} {
520        file delete $fname
521    }
522    set _framerate [${_movie} get framerate]
523    video speed
524
525    video seek 0
526
527    # update the dial and framenum widgets
528    set _settings(framenum) 0
529
530
531    # setup the image display
532
533    foreach {w h} [query dimensions] break
534    if {${_width} == -1} {
535        set _width $w
536    }
537    if {${_height} == -1} {
538        set _height $h
539    }
540
541    set _lastFrame [$_movie get position end]
542
543    # update the dial with video information
544    $itk_component(dialmajor) configure -min 0 -max ${_lastFrame}
545    $itk_component(dialminor) configure -min 0 -max ${_lastFrame}
546
547    # turn on the buttons and dials
548    $itk_component(measure) enable
549    $itk_component(particle) enable
550    $itk_component(rewind) configure -state normal
551    $itk_component(seekback) configure -state normal
552    $itk_component(play) enable
553    $itk_component(seekforward) configure -state normal
554    $itk_component(loop) enable
555
556    # make sure looping is off
557    set _settings(loop) 0
558    $itk_component(dialminor) loop disable
559
560    fixSize
561}
562
563# ----------------------------------------------------------------------
564# loadcb - load callback
565# ----------------------------------------------------------------------
566itcl::body Rappture::VideoScreen::loadcb {args} {
567    video stop
568    Rappture::filexfer::upload {piv tool} {id label desc} [itcl::code $this Upload]
569}
570
571# ----------------------------------------------------------------------
572# Upload -
573# ----------------------------------------------------------------------
574itcl::body Rappture::VideoScreen::Upload {args} {
575    array set data $args
576    video stop
577
578    if {[info exists data(error)]} {
579        Rappture::Tooltip::cue $itk::component(main) $data(error)
580        puts stderr $data(error)
581    }
582
583    if {[info exists data(path)] && [info exists data(data)]} {
584        Rappture::Tooltip::cue hide  ;# take down note about the popup window
585
586        # load data
587        load "data" $data(data)
588    }
589
590}
591
592
593# ----------------------------------------------------------------------
594# fixSize
595# ----------------------------------------------------------------------
596itcl::body Rappture::VideoScreen::fixSize {} {
597
598    if {[string compare "" ${_movie}] == 0} {
599        return
600    }
601
602#    set _width [winfo width $itk_component(main)]
603#    set _height [winfo height $itk_component(main)]
604#
605#    # get an image with the new size
606#    ${_imh} put [${_movie} get image ${_width} ${_height}]
607#
608#    # fix the dimesions of the canvas
609#    #$itk_component(main) configure -width ${_width} -height ${_height}
610#
611#    $itk_component(main) configure -scrollregion [$itk_component(main) bbox all]
612
613######################
614
615    # get an image with the new size
616    ${_imh} put [${_movie} get image ${_width} ${_height}]
617    puts stderr "${_width} ${_height}"
618
619    # fix the dimesions of the video canvas
620    $itk_component(main) configure -width ${_width} -height ${_height}
621}
622
623# ----------------------------------------------------------------------
624# video - play, stop, rewind, fastforward the video
625# ----------------------------------------------------------------------
626itcl::body Rappture::VideoScreen::video { args } {
627    set option [lindex $args 0]
628    switch -- $option {
629        "play" {
630            if {$_settings(play) == 1} {
631                eventually play
632            } else {
633                # pause/stop
634                after cancel $_id
635                set _pendings(play) 0
636                set _settings(play) 0
637            }
638        }
639        "seek" {
640            Seek [lreplace $args 0 0]
641        }
642        "stop" {
643            after cancel $_id
644            set _settings(play) 0
645        }
646        "speed" {
647            set speed [$itk_component(speed) value]
648            set _mspf [expr round(((1.0/${_framerate})*1000)/$speed)]
649            set _delay [expr {${_mspf} - ${_ofrd}}]
650            puts stderr "_mspf = ${_mspf} | $speed | ${_ofrd} | ${_delay}"
651        }
652        "update" {
653            eventually seek [expr round($_settings(framenum))]
654            # Seek [expr round($_settings(framenum))]
655        }
656        default {
657            error "bad option \"$option\": should be play, stop, toggle, position, or reset."
658        }
659    }
660}
661
662# ----------------------------------------------------------------------
663# query - query things about the video
664#
665#   dimensions  - returns width and height as a list
666#   frames      - number of frames in video (last frame + 1)
667#   framenum    - current position
668# ----------------------------------------------------------------------
669itcl::body Rappture::VideoScreen::query { type } {
670    set ret ""
671    switch -- $type {
672        "dimensions" {
673            set ret [${_movie} size]
674        }
675        "frames" {
676            set ret [expr [${_movie} get position end] + 1]
677        }
678        "framenum" {
679            set ret [${_movie} get position cur]
680        }
681        default {
682            error "bad type \"$type\": should be dimensions, frames, framenum."
683        }
684    }
685    return $ret
686}
687
688# ----------------------------------------------------------------------
689# Play - get the next video frame
690# ----------------------------------------------------------------------
691itcl::body Rappture::VideoScreen::Play {} {
692
693    set cur ${_nextframe}
694
695    # time how long it takes to retrieve the next frame
696    set _ofrd [time {
697        # use seek instead of next fxn incase the ${_nextframe} is
698        # not the current frame+1. this happens when we skip frames
699        # because the underlying c lib is too slow at reading.
700        $_movie seek $cur
701        $_imh put [$_movie get image ${_width} ${_height}]
702    } 1]
703    regexp {(\d+\.?\d*) microseconds per iteration} ${_ofrd} match _ofrd
704    set _ofrd [expr {round(${_ofrd}/1000)}]
705
706    # calculate the delay we shoud see
707    # between frames being placed on screen
708    # taking into account the cost of retrieving the frame
709    set _delay [expr {${_mspf}-${_ofrd}}]
710    if {0 > ${_delay}} {
711        set _delay 0
712    }
713
714    set cur [$_movie get position cur]
715
716    # update the dial and framenum widgets
717    set _settings(framenum) $cur
718
719
720    # no play cmds pending
721    set _pendings(play) 0
722
723    # if looping is turned on and markers setup,
724    # then loop back to loopstart when cur hits loopend
725    if {$_settings(loop)} {
726        if {$cur == [$itk_component(dialminor) mark position loopend]} {
727            Seek [$itk_component(dialminor) mark position loopstart]
728        }
729    }
730
731    # schedule the next frame to be displayed
732    if {$cur < ${_lastFrame}} {
733        set _id [after ${_delay} [itcl::code $this eventually play]]
734    } else {
735        video stop
736    }
737
738    event generate $itk_component(hull) <<Frame>>
739}
740
741
742# ----------------------------------------------------------------------
743# Seek - go to a frame in the video
744#   Seek +5
745#   Seek -5
746#   Seek 35
747# ----------------------------------------------------------------------
748itcl::body Rappture::VideoScreen::Seek {args} {
749    set val [lindex $args 0]
750    if {"" == $val} {
751        error "bad value: \"$val\": should be \"seek value\""
752    }
753    set cur [$_movie get position cur]
754    if {[string compare $cur $val] == 0} {
755        # already at the frame to seek to
756        set _pendings(seek) 0
757        return
758    }
759    ${_movie} seek $val
760    ${_imh} put [${_movie} get image ${_width} ${_height}]
761
762    # update the dial and framenum widgets
763    set _settings(framenum) [$_movie get position cur]
764    event generate $itk_component(main) <<Frame>>
765
766    # removing pending
767    set _pendings(seek) 0
768}
769
770
771# ----------------------------------------------------------------------
772# eventually -
773#   seek
774#   play
775# ----------------------------------------------------------------------
776itcl::body Rappture::VideoScreen::eventually {args} {
777    set option [lindex $args 0]
778    switch -- $option {
779        "seek" {
780            if {0 == $_pendings(seek)} {
781                # no seek pending, schedule one
782                set _pendings(seek) 1
783                after idle [itcl::code $this Seek [lindex $args 1]]
784            } else {
785                # there is a seek pending, update its seek value
786            }
787        }
788        "play" {
789            if {0 == $_pendings(play)} {
790                # no play pending schedule one
791                set _pendings(play) 1
792                set _nextframe [expr {[$_movie get position cur] + 1}]
793                after idle [itcl::code $this Play]
794            } else {
795                # there is a play pending, update its frame value
796                incr _nextframe
797            }
798        }
799        default {
800        }
801    }
802}
803
804
805# ----------------------------------------------------------------------
806# togglePtrCtrl - choose pointer mode:
807#                 rectangle, measure, particlemark
808# ----------------------------------------------------------------------
809itcl::body Rappture::VideoScreen::togglePtrCtrl {tool} {
810
811    if {[info exists _pbvars($tool)] == 0} {
812        return
813    }
814
815    if {$_pbvars($tool) == 1} {
816        # unpush previously pushed buttons
817        foreach pbv [array names _pbvars] {
818            if {[string compare $tool $pbv] != 0} {
819                set _pbvars($pbv) 0
820            }
821        }
822    }
823    togglePtrBind $tool
824}
825
826
827# ----------------------------------------------------------------------
828# whatPtrCtrl - figure out the current pointer mode:
829#                 rectangle,  measure, particlemark
830# ----------------------------------------------------------------------
831itcl::body Rappture::VideoScreen::whatPtrCtrl {} {
832    foreach pbv [array names _pbvars] {
833        if {$_pbvars($pbv) != 0} {
834            return $pbv
835        }
836    }
837}
838
839
840# ----------------------------------------------------------------------
841# togglePtrBind - update the bindings based on pointer controls
842# ----------------------------------------------------------------------
843itcl::body Rappture::VideoScreen::togglePtrBind {pbvar} {
844
845    if {[string compare $pbvar current] == 0} {
846        set pbvar [whatPtrCtrl]
847    }
848
849    if {[string compare $pbvar rectangle] == 0} {
850
851        # Bindings for selecting rectangle
852        $itk_component(main) configure -cursor ""
853
854        bind $itk_component(main) <ButtonPress-1> \
855            [itcl::code $this Rubberband new %W %x %y]
856        bind $itk_component(main) <B1-Motion> \
857            [itcl::code $this Rubberband drag %W %x %y]
858        bind $itk_component(main) <ButtonRelease-1> \
859            [itcl::code $this Rubberband release %W %x %y]
860
861    } elseif {[string compare $pbvar measure] == 0} {
862
863        # Bindings for measuring distance
864        $itk_component(main) configure -cursor ""
865
866        bind $itk_component(main) <ButtonPress-1> \
867            [itcl::code $this Measure new %W %x %y]
868        bind $itk_component(main) <B1-Motion> \
869            [itcl::code $this Measure drag %W %x %y]
870        bind $itk_component(main) <ButtonRelease-1> \
871            [itcl::code $this Measure release %W %x %y]
872
873    } elseif {[string compare $pbvar particle] == 0} {
874
875        # Bindings for marking particle locations
876        $itk_component(main) configure -cursor ""
877
878        bind $itk_component(main) <ButtonPress-1> \
879            [itcl::code $this Particle new %W %x %y]
880        bind $itk_component(main) <B1-Motion> ""
881        bind $itk_component(main) <ButtonRelease-1> ""
882
883
884    } elseif {[string compare $pbvar object] == 0} {
885
886        # Bindings for interacting with objects
887        $itk_component(main) configure -cursor hand2
888
889        bind $itk_component(main) <ButtonPress-1> { }
890        bind $itk_component(main) <B1-Motion> { }
891        bind $itk_component(main) <ButtonRelease-1> { }
892
893    } else {
894
895        # invalid pointer mode
896
897    }
898}
899
900
901
902
903
904###### DRAWING TOOLS #####
905
906
907
908
909
910# ----------------------------------------------------------------------
911# Rubberband - draw a rubberband around something in the canvas
912# ----------------------------------------------------------------------
913itcl::body Rappture::VideoScreen::Rubberband {status win x y} {
914    switch -- $status {
915        "new" {
916            $win delete "rubbershape"
917            set _x0 $x
918            set _y0 $y
919            $win create rectangle \
920                $x $y $x $y -outline white -width 2  \
921                -tags "rubbershape" -dash {4 4}
922        }
923        "drag" {
924            foreach { x0 y0 x1 y1 } [$win coords "rubbershape"] break
925
926            if {$_x0 > $x} {
927                # backward direction
928                set x0 $x
929                set x1 $_x0
930            } else {
931                set x1 $x
932            }
933
934            if {$_y0 >= $y} {
935                # backward direction
936                set y0 $y
937                set y1 $_y0
938            } else {
939                set y1 $y
940            }
941
942            eval $win coords "rubbershape" [list $x0 $y0 $x1 $y1]
943        }
944        "release" {
945            Rubberband drag $win $x $y
946        }
947        default {
948            error "bad status \"$status\": should be new, drag, or release"
949        }
950    }
951}
952
953# ----------------------------------------------------------------------
954# Measure - draw a line to measure something on the canvas,
955#           when user releases the line, user is given the
956#           calculated measurement.
957# ----------------------------------------------------------------------
958itcl::body Rappture::VideoScreen::Measure {status win x y} {
959    switch -- $status {
960        "new" {
961            set name "measure[incr _counters(measure)]"
962
963            set _obj [Rappture::VideoDistance $itk_component(main).$name $name $win \
964                        -fncallback [itcl::code $this query framenum] \
965                        -bindentercb [itcl::code $this togglePtrBind object] \
966                        -bindleavecb [itcl::code $this togglePtrBind current] \
967                        -writetextcb [itcl::code $this writeText] \
968                        -ondelete [itcl::code $itk_component(dialminor) mark remove $name] \
969                        -onframe [itcl::code $itk_component(dialminor) mark add $name] \
970                        -px2dist [itcl::scope _px2dist] \
971                        -units "m" \
972                        -color green \
973                        -bindings disable]
974            ${_obj} Coords $x $y $x $y
975            ${_obj} Show object
976            lappend _measurements ${_obj}
977        }
978        "drag" {
979            # FIXME: something wrong with the bindings, if the objects menu is
980            #        open, and you click on the canvas off the menu, a "drag"
981            #        or "release" call is made. need to figure out how to
982            #        disable bindings while obj's menu is open. for now
983            #        we set _obj to "" when we are finished creating it and
984            #        check to see if it's valid when we do a drag or release
985
986            if {"" == ${_obj}} {
987                return
988            }
989
990            ${_obj} Coords [lreplace [${_obj} Coords] 2 3 $x $y]
991        }
992        "release" {
993            # if we enable ${_obj}'s bindings when we create it,
994            # probably never entered because the object's <Enter>
995            # bindings kick in before the window's release bindings do
996
997            if {"" == ${_obj}} {
998                return
999            }
1000
1001            Measure drag $win $x $y
1002
1003            if {${_px2dist} == 0} {
1004                ${_obj} Menu activate $x $y
1005            }
1006            ${_obj} configure -bindings enable
1007
1008            set _obj ""
1009        }
1010        default {
1011            error "bad status \"$status\": should be new, drag, or release"
1012        }
1013    }
1014}
1015
1016# ----------------------------------------------------------------------
1017# Particle - mark a particle in the video, a new particle object is
1018#            created from information like the name, which video
1019#            frames it lives in, it's coords in the canvas in each
1020#            frame, it's color...
1021# ----------------------------------------------------------------------
1022itcl::body Rappture::VideoScreen::Particle {status win x y} {
1023    switch -- $status {
1024        "new" {
1025            set name "particle[incr _counters(particle)]"
1026            set _obj [Rappture::VideoParticle $itk_component(main).$name $name $win \
1027                        -fncallback [itcl::code $this query framenum] \
1028                        -bindentercb [itcl::code $this togglePtrBind object] \
1029                        -bindleavecb [itcl::code $this togglePtrBind current] \
1030                        -trajcallback [itcl::code $this Trajectory] \
1031                        -ondelete [itcl::code $itk_component(dialminor) mark remove $name] \
1032                        -onframe [itcl::code $itk_component(dialminor) mark add $name] \
1033                        -framerange "0 ${_lastFrame}" \
1034                        -halo 5 \
1035                        -color green \
1036                        -px2dist [itcl::scope _px2dist] \
1037                        -units "m/s"]
1038            ${_obj} Coords $x $y
1039            ${_obj} Show object
1040            #$itk_component(dialminor) mark add $name current
1041            # bind $itk_component(hull) <<Frame>> [itcl::code $itk_component(main).$name UpdateFrame]
1042
1043            # link the new particle to the last particle added, if it exists
1044            set lastp [lindex ${_particles} end]
1045            while {"" == [info commands $lastp]} {
1046                set _particles [lreplace ${_particles} end end]
1047                if {[llength ${_particles}] == 0} {
1048                    break
1049                }
1050                set lastp [lindex ${_particles} end]
1051            }
1052            if {"" != [info commands $lastp]} {
1053                $lastp Link ${_obj}
1054            }
1055
1056            # add the particle to the list
1057            lappend _particles ${_obj}
1058        }
1059        default {
1060            error "bad status \"$status\": should be new"
1061        }
1062    }
1063}
1064
1065# ----------------------------------------------------------------------
1066# Trajectory - draw a trajectory between two particles
1067#
1068#   Trajectory $p0 $p1
1069# ----------------------------------------------------------------------
1070itcl::body Rappture::VideoScreen::Trajectory {args} {
1071
1072    set nargs [llength $args]
1073    if {($nargs != 1) && ($nargs != 2)} {
1074        error "wrong # args: should be \"Trajectory p0 p1\""
1075    }
1076
1077    set p0 ""
1078    set p1 ""
1079    foreach {p0 p1} $args break
1080
1081    if {[string compare "" $p0] == 0} {
1082        # p0 does not exist
1083        return
1084    }
1085
1086    # remove any old trajectory links from p0
1087    set p0name [$p0 name]
1088    set oldlink "vec-$p0name"
1089    $itk_component(main) delete $oldlink
1090
1091    # check to see if p1 exists anymore
1092    if {[string compare "" $p1] == 0} {
1093        # p1 does not exist
1094        return
1095    }
1096
1097    foreach {x0 y0} [$p0 Coords] break
1098    foreach {x1 y1} [$p1 Coords] break
1099    set p1name [$p1 name]
1100    set link "vec-$p0name-$p1name"
1101    $itk_component(main) create line $x0 $y0 $x1 $y1 \
1102        -fill green \
1103        -width 2 \
1104        -tags "vector $link vec-$p0name" \
1105        -dash {4 4} \
1106        -arrow last
1107    $itk_component(main) lower $link $p0name
1108
1109    # calculate trajectory, truncate it after 4 sigdigs
1110    set t [calculateTrajectory [$p0 Frame] $x0 $y0 [$p1 Frame] $x1 $y1]
1111    set tt [string range $t 0 [expr [string first . $t] + 4]]
1112
1113
1114    # calculate coords for text
1115    foreach { x0 y0 x1 y1 } [$itk_component(main) bbox $link] break
1116    set x [expr "$x0 + (abs($x1-$x0)/2)"]
1117    set y [expr "$y0 + (abs($y1-$y0)/2)"]
1118
1119    set tt "$tt m/s"
1120    set tags "vectext $link vec-$p0name"
1121    set width [expr sqrt(pow(abs($x1-$x0),2)+pow(abs($y1-$y0),2))]
1122
1123    writeText $x $y $tt green $tags $width
1124    return $link
1125}
1126
1127
1128# ----------------------------------------------------------------------
1129# writeText - write text to the canvas
1130#   writes text to the canvas in the color <color> at <x>,<y>
1131#   writes text twice more offset up-left and down right,
1132#   to add a shadowing effect so colors can be seen
1133#
1134#   FIXME: Not sure how the text wrapped due to -width collides with the
1135#          offset text.
1136# ----------------------------------------------------------------------
1137itcl::body Rappture::VideoScreen::writeText {x y text color tags width} {
1138    $itk_component(main) create text [expr $x-1] [expr $y] \
1139        -tags $tags \
1140        -justify center \
1141        -text $text \
1142        -fill black \
1143        -width $width
1144
1145    $itk_component(main) create text [expr $x+1] [expr $y] \
1146        -tags $tags \
1147        -justify center \
1148        -text $text \
1149        -fill black \
1150        -width $width
1151
1152    $itk_component(main) create text [expr $x] [expr $y-1] \
1153        -tags $tags \
1154        -justify center \
1155        -text $text \
1156        -fill black \
1157        -width $width
1158
1159    $itk_component(main) create text [expr $x] [expr $y+1] \
1160        -tags $tags \
1161        -justify center \
1162        -text $text \
1163        -fill black \
1164        -width $width
1165
1166#    # write text up-left
1167#    $itk_component(main) create text [expr $x-1] [expr $y-1] \
1168#        -tags $tags \
1169#        -justify center \
1170#        -text $text \
1171#        -fill black \
1172#        -width $width
1173#
1174#    # write text down-right
1175#    $itk_component(main) create text [expr $x+1] [expr $y+1] \
1176#        -tags $tags \
1177#        -justify center \
1178#        -text $text \
1179#        -fill black \
1180#        -width $width
1181
1182    # write text at x,y
1183    $itk_component(main) create text $x $y \
1184        -tags $tags \
1185        -justify center \
1186        -text $text \
1187        -fill $color \
1188        -width $width
1189
1190}
1191
1192# ----------------------------------------------------------------------
1193# calculateTrajectory - calculate the value of the trajectory
1194# ----------------------------------------------------------------------
1195itcl::body Rappture::VideoScreen::calculateTrajectory {args} {
1196    # set framerate 29.97         ;# frames per second
1197    # set px2dist    8.00         ;# px per meter
1198
1199    foreach {f0 x0 y0 f1 x1 y1} $args break
1200    set px [expr sqrt(pow(abs($x1-$x0),2)+pow(abs($y1-$y0),2))]
1201    set frames [expr $f1 - $f0]
1202
1203    if {($frames != 0) && (${_px2dist} != 0)} {
1204        set t [expr 1.0*$px/$frames*${_px2dist}*${_framerate}]
1205    } else {
1206        set t 0.0
1207    }
1208
1209    return $t
1210}
1211
1212# ----------------------------------------------------------------------
1213# toggleloop - add/remove a start/end loop mark to video dial.
1214# ----------------------------------------------------------------------
1215itcl::body Rappture::VideoScreen::toggleloop {} {
1216    if {$_settings(loop) == 0} {
1217        $itk_component(dialminor) loop disable
1218    } else {
1219        set cur [$_movie get position cur]
1220        set end [$_movie get position end]
1221
1222        set startframe [expr $cur-10]
1223        if {$startframe < 0} {
1224            set startframe 0
1225        }
1226
1227        set endframe [expr $cur+10]
1228        if {$endframe > $end} {
1229            set endframe $end
1230        }
1231
1232        $itk_component(dialminor) loop between $startframe $endframe
1233    }
1234
1235}
1236
1237# ----------------------------------------------------------------------
1238# OPTION: -width
1239# ----------------------------------------------------------------------
1240itcl::configbody Rappture::VideoScreen::width {
1241    # $_dispatcher event -idle !fixsize
1242    if {[string is integer $itk_option(-width)] == 0} {
1243        error "bad value: \"$itk_option(-width)\": width should be an integer"
1244    }
1245    set _width $itk_option(-width)
1246    after idle [itcl::code $this fixSize]
1247}
1248
1249# ----------------------------------------------------------------------
1250# OPTION: -height
1251# ----------------------------------------------------------------------
1252itcl::configbody Rappture::VideoScreen::height {
1253    # $_dispatcher event -idle !fixsize
1254    if {[string is integer $itk_option(-height)] == 0} {
1255        error "bad value: \"$itk_option(-height)\": height should be an integer"
1256    }
1257    set _height $itk_option(-height)
1258    after idle [itcl::code $this fixSize]
1259}
1260
1261# ----------------------------------------------------------------------
1262# OPTION: -fileopen
1263# ----------------------------------------------------------------------
1264itcl::configbody Rappture::VideoScreen::fileopen {
1265    $itk_component(fileopen) configure -command $itk_option(-fileopen)
1266}
Note: See TracBrowser for help on using the repository browser.