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

Last change on this file since 3177 was 3177, checked in by mmc, 12 years ago

Updated all of the copyright notices to reference the transfer to
the new HUBzero Foundation, LLC.
File size: 41.5 KB
Line 
1# ----------------------------------------------------------------------
2#  COMPONENT: video - viewing movies
3#
4# ======================================================================
5#  AUTHOR:  Michael McLennan, Purdue University
6#  Copyright (c) 2004-2012  HUBzero Foundation, LLC
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.