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

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

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