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

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

adding aspect ratio calculations.
disable analyze button when no movie has been choosen in piv
rename some functions
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    # get dimensions for the new image
601    # adjust the aspect ratio, if necessary
602
603    puts stderr "aspect ratio: [query aspectratio]"
604
605    foreach {w h} [query dimensions] break
606    foreach {num den} [query aspectratio] break
607
608    if {[expr 1.0*$w/$h] != [expr 1.0*$num/$den]} {
609        # we need to adjust the frame height and width
610        # to keep the correct aspect ratio
611        # hold the height constant,
612        # adjust the width as close as we can
613        # to the correct aspect ratio
614        set w [expr int(1.0*$num/$den*$h)]
615    }
616
617    if {-1 == ${_width}} {
618        set _width $w
619    }
620    if {-1 == ${_height}} {
621        set _height $h
622    }
623
624    # get an image with the new size
625    ${_imh} blank
626    ${_imh} configure -width 1 -height 1
627    ${_imh} configure -width 0 -height 0
628    ${_imh} put [${_movie} get image ${_width} ${_height}]
629
630    # place the image in the center of the canvas
631    set ccw [winfo width $itk_component(main)]
632    set cch [winfo height $itk_component(main)]
633    $itk_component(main) coords videoframe [expr $ccw/2.0] [expr $cch/2.0]
634
635    puts stderr "----------------------------"
636    puts stderr "adjusted = $w $h"
637    puts stderr "data     = ${_width} ${_height}"
638    puts stderr "image    = [image width ${_imh}] [image height ${_imh}]"
639    foreach {x0 y0 x1 y1} [$itk_component(main) bbox videoframe] break
640    puts stderr "bbox     = $x0 $y0 $x1 $y1"
641    puts stderr "ccw cch  = [expr $ccw/2.0] [expr $cch/2.0]"
642    puts stderr "main     = [winfo width $itk_component(main)] [winfo height $itk_component(main)]"
643    puts stderr "hull     = [winfo width $itk_component(hull)] [winfo height $itk_component(hull)]"
644}
645
646# ----------------------------------------------------------------------
647# video - play, stop, rewind, fastforward the video
648# ----------------------------------------------------------------------
649itcl::body Rappture::VideoScreen::video { args } {
650    set option [lindex $args 0]
651    switch -- $option {
652        "play" {
653            if {$_settings(play) == 1} {
654                eventually play
655            } else {
656                # pause/stop
657                after cancel $_id
658                set _pendings(play) 0
659                set _settings(play) 0
660            }
661        }
662        "seek" {
663            Seek [lreplace $args 0 0]
664        }
665        "stop" {
666            after cancel $_id
667            set _settings(play) 0
668        }
669        "speed" {
670            set speed [$itk_component(speed) value]
671            set _mspf [expr round(((1.0/${_framerate})*1000)/$speed)]
672            set _delay [expr {${_mspf} - ${_ofrd}}]
673            puts stderr "_mspf = ${_mspf} | $speed | ${_ofrd} | ${_delay}"
674        }
675        "update" {
676            eventually seek [expr round($_settings(framenum))]
677            # Seek [expr round($_settings(framenum))]
678        }
679        default {
680            error "bad option \"$option\": should be play, stop, toggle, position, or reset."
681        }
682    }
683}
684
685# ----------------------------------------------------------------------
686# query - query things about the video
687#
688#   dimensions  - returns width and height as a list
689#   frames      - number of frames in video (last frame + 1)
690#   framenum    - current position
691# ----------------------------------------------------------------------
692itcl::body Rappture::VideoScreen::query { type } {
693    set ret ""
694    switch -- $type {
695        "aspectratio" {
696            set ret [${_movie} aspect display]
697        }
698        "dimensions" {
699            set ret [${_movie} size]
700        }
701        "frames" {
702            set ret [expr [${_movie} get position end] + 1]
703        }
704        "framenum" {
705            set ret [${_movie} get position cur]
706        }
707        default {
708            error "bad type \"$type\": should be dimensions, frames, framenum."
709        }
710    }
711    return $ret
712}
713
714# ----------------------------------------------------------------------
715# Play - get the next video frame
716# ----------------------------------------------------------------------
717itcl::body Rappture::VideoScreen::Play {} {
718
719    set cur ${_nextframe}
720
721    # time how long it takes to retrieve the next frame
722    set _ofrd [time {
723        # use seek instead of next fxn incase the ${_nextframe} is
724        # not the current frame+1. this happens when we skip frames
725        # because the underlying c lib is too slow at reading.
726        ${_movie} seek $cur
727        ${_imh} put [${_movie} get image ${_width} ${_height}]
728    } 1]
729    regexp {(\d+\.?\d*) microseconds per iteration} ${_ofrd} match _ofrd
730    set _ofrd [expr {round(${_ofrd}/1000)}]
731
732    # calculate the delay we shoud see
733    # between frames being placed on screen
734    # taking into account the cost of retrieving the frame
735    set _delay [expr {${_mspf}-${_ofrd}}]
736    if {0 > ${_delay}} {
737        set _delay 0
738    }
739
740    set cur [${_movie} get position cur]
741
742    # update the dial and framenum widgets
743    set _settings(framenum) $cur
744
745
746    # no play cmds pending
747    set _pendings(play) 0
748
749    # if looping is turned on and markers setup,
750    # then loop back to loopstart when cur hits loopend
751    if {$_settings(loop)} {
752        if {$cur == [$itk_component(dialminor) mark position loopend]} {
753            Seek [$itk_component(dialminor) mark position loopstart]
754        }
755    }
756
757    # schedule the next frame to be displayed
758    if {$cur < ${_lastFrame}} {
759        set _id [after ${_delay} [itcl::code $this eventually play]]
760    } else {
761        video stop
762    }
763
764    event generate $itk_component(hull) <<Frame>>
765}
766
767
768# ----------------------------------------------------------------------
769# Seek - go to a frame in the video
770#   Seek +5
771#   Seek -5
772#   Seek 35
773# ----------------------------------------------------------------------
774itcl::body Rappture::VideoScreen::Seek {args} {
775    set val [lindex $args 0]
776    if {"" == $val} {
777        error "bad value: \"$val\": should be \"seek value\""
778    }
779    set cur [${_movie} get position cur]
780    if {[string compare $cur $val] == 0} {
781        # already at the frame to seek to
782        set _pendings(seek) 0
783        return
784    }
785    ${_movie} seek $val
786    ${_imh} put [${_movie} get image ${_width} ${_height}]
787
788    # update the dial and framenum widgets
789    set _settings(framenum) [${_movie} get position cur]
790    event generate $itk_component(main) <<Frame>>
791
792    # removing pending
793    set _pendings(seek) 0
794}
795
796
797# ----------------------------------------------------------------------
798# eventually -
799#   seek
800#   play
801# ----------------------------------------------------------------------
802itcl::body Rappture::VideoScreen::eventually {args} {
803    set option [lindex $args 0]
804    switch -- $option {
805        "seek" {
806            if {0 == $_pendings(seek)} {
807                # no seek pending, schedule one
808                set _pendings(seek) 1
809                after idle [itcl::code $this Seek [lindex $args 1]]
810            } else {
811                # there is a seek pending, update its seek value
812            }
813        }
814        "play" {
815            if {0 == $_pendings(play)} {
816                # no play pending schedule one
817                set _pendings(play) 1
818                set _nextframe [expr {[${_movie} get position cur] + 1}]
819                after idle [itcl::code $this Play]
820            } else {
821                # there is a play pending, update its frame value
822                incr _nextframe
823            }
824        }
825        default {
826        }
827    }
828}
829
830
831# ----------------------------------------------------------------------
832# togglePtrCtrl - choose pointer mode:
833#                 rectangle, measure, particlemark
834# ----------------------------------------------------------------------
835itcl::body Rappture::VideoScreen::togglePtrCtrl {tool} {
836
837    if {[info exists _pbvars($tool)] == 0} {
838        return
839    }
840
841    if {$_pbvars($tool) == 1} {
842        # unpush previously pushed buttons
843        foreach pbv [array names _pbvars] {
844            if {[string compare $tool $pbv] != 0} {
845                set _pbvars($pbv) 0
846            }
847        }
848    }
849    togglePtrBind $tool
850}
851
852
853# ----------------------------------------------------------------------
854# whatPtrCtrl - figure out the current pointer mode:
855#                 rectangle,  measure, particlemark
856# ----------------------------------------------------------------------
857itcl::body Rappture::VideoScreen::whatPtrCtrl {} {
858    foreach pbv [array names _pbvars] {
859        if {$_pbvars($pbv) != 0} {
860            return $pbv
861        }
862    }
863}
864
865
866# ----------------------------------------------------------------------
867# togglePtrBind - update the bindings based on pointer controls
868# ----------------------------------------------------------------------
869itcl::body Rappture::VideoScreen::togglePtrBind {pbvar} {
870
871    if {[string compare $pbvar current] == 0} {
872        set pbvar [whatPtrCtrl]
873    }
874
875    if {[string compare $pbvar rectangle] == 0} {
876
877        # Bindings for selecting rectangle
878        $itk_component(main) configure -cursor ""
879
880        bind $itk_component(main) <ButtonPress-1> \
881            [itcl::code $this Rubberband new %W %x %y]
882        bind $itk_component(main) <B1-Motion> \
883            [itcl::code $this Rubberband drag %W %x %y]
884        bind $itk_component(main) <ButtonRelease-1> \
885            [itcl::code $this Rubberband release %W %x %y]
886
887    } elseif {[string compare $pbvar measure] == 0} {
888
889        # Bindings for measuring distance
890        $itk_component(main) configure -cursor ""
891
892        bind $itk_component(main) <ButtonPress-1> \
893            [itcl::code $this Measure new %W %x %y]
894        bind $itk_component(main) <B1-Motion> \
895            [itcl::code $this Measure drag %W %x %y]
896        bind $itk_component(main) <ButtonRelease-1> \
897            [itcl::code $this Measure release %W %x %y]
898
899    } elseif {[string compare $pbvar particle] == 0} {
900
901        # Bindings for marking particle locations
902        $itk_component(main) configure -cursor ""
903
904        bind $itk_component(main) <ButtonPress-1> \
905            [itcl::code $this Particle new %W %x %y]
906        bind $itk_component(main) <B1-Motion> ""
907        bind $itk_component(main) <ButtonRelease-1> ""
908
909
910    } elseif {[string compare $pbvar object] == 0} {
911
912        # Bindings for interacting with objects
913        $itk_component(main) configure -cursor hand2
914
915        bind $itk_component(main) <ButtonPress-1> { }
916        bind $itk_component(main) <B1-Motion> { }
917        bind $itk_component(main) <ButtonRelease-1> { }
918
919    } else {
920
921        # invalid pointer mode
922
923    }
924}
925
926
927
928
929
930###### DRAWING TOOLS #####
931
932
933
934
935
936# ----------------------------------------------------------------------
937# Rubberband - draw a rubberband around something in the canvas
938# ----------------------------------------------------------------------
939itcl::body Rappture::VideoScreen::Rubberband {status win x y} {
940    switch -- $status {
941        "new" {
942            $win delete "rubbershape"
943            set _x0 $x
944            set _y0 $y
945            $win create rectangle \
946                $x $y $x $y -outline white -width 2  \
947                -tags "rubbershape" -dash {4 4}
948        }
949        "drag" {
950            foreach { x0 y0 x1 y1 } [$win coords "rubbershape"] break
951
952            if {$_x0 > $x} {
953                # backward direction
954                set x0 $x
955                set x1 $_x0
956            } else {
957                set x1 $x
958            }
959
960            if {$_y0 >= $y} {
961                # backward direction
962                set y0 $y
963                set y1 $_y0
964            } else {
965                set y1 $y
966            }
967
968            eval $win coords "rubbershape" [list $x0 $y0 $x1 $y1]
969        }
970        "release" {
971            Rubberband drag $win $x $y
972        }
973        default {
974            error "bad status \"$status\": should be new, drag, or release"
975        }
976    }
977}
978
979# ----------------------------------------------------------------------
980# Measure - draw a line to measure something on the canvas,
981#           when user releases the line, user is given the
982#           calculated measurement.
983# ----------------------------------------------------------------------
984itcl::body Rappture::VideoScreen::Measure {status win x y} {
985    switch -- $status {
986        "new" {
987            set name "measure[incr _counters(measure)]"
988
989            set _obj [Rappture::VideoDistance $itk_component(main).$name $name $win \
990                        -fncallback [itcl::code $this query framenum] \
991                        -bindentercb [itcl::code $this togglePtrBind object] \
992                        -bindleavecb [itcl::code $this togglePtrBind current] \
993                        -writetextcb [itcl::code $this writeText] \
994                        -ondelete [itcl::code $itk_component(dialminor) mark remove $name] \
995                        -onframe [itcl::code $itk_component(dialminor) mark add $name] \
996                        -px2dist [itcl::scope _px2dist] \
997                        -units "m" \
998                        -color green \
999                        -bindings disable]
1000            ${_obj} Coords $x $y $x $y
1001            ${_obj} Show object
1002            lappend _measurements ${_obj}
1003        }
1004        "drag" {
1005            # FIXME: something wrong with the bindings, if the objects menu is
1006            #        open, and you click on the canvas off the menu, a "drag"
1007            #        or "release" call is made. need to figure out how to
1008            #        disable bindings while obj's menu is open. for now
1009            #        we set _obj to "" when we are finished creating it and
1010            #        check to see if it's valid when we do a drag or release
1011
1012            if {"" == ${_obj}} {
1013                return
1014            }
1015
1016            ${_obj} Coords [lreplace [${_obj} Coords] 2 3 $x $y]
1017        }
1018        "release" {
1019            # if we enable ${_obj}'s bindings when we create it,
1020            # probably never entered because the object's <Enter>
1021            # bindings kick in before the window's release bindings do
1022
1023            if {"" == ${_obj}} {
1024                return
1025            }
1026
1027            Measure drag $win $x $y
1028
1029            if {${_px2dist} == 0} {
1030                ${_obj} Menu activate $x $y
1031            }
1032            ${_obj} configure -bindings enable
1033
1034            set _obj ""
1035        }
1036        default {
1037            error "bad status \"$status\": should be new, drag, or release"
1038        }
1039    }
1040}
1041
1042# ----------------------------------------------------------------------
1043# Particle - mark a particle in the video, a new particle object is
1044#            created from information like the name, which video
1045#            frames it lives in, it's coords in the canvas in each
1046#            frame, it's color...
1047# ----------------------------------------------------------------------
1048itcl::body Rappture::VideoScreen::Particle {status win x y} {
1049    switch -- $status {
1050        "new" {
1051            set name "particle[incr _counters(particle)]"
1052            set _obj [Rappture::VideoParticle $itk_component(main).$name $name $win \
1053                        -fncallback [itcl::code $this query framenum] \
1054                        -bindentercb [itcl::code $this togglePtrBind object] \
1055                        -bindleavecb [itcl::code $this togglePtrBind current] \
1056                        -trajcallback [itcl::code $this Trajectory] \
1057                        -ondelete [itcl::code $itk_component(dialminor) mark remove $name] \
1058                        -onframe [itcl::code $itk_component(dialminor) mark add $name] \
1059                        -framerange "0 ${_lastFrame}" \
1060                        -halo 5 \
1061                        -color green \
1062                        -px2dist [itcl::scope _px2dist] \
1063                        -units "m/s"]
1064            ${_obj} Coords $x $y
1065            ${_obj} Show object
1066            #$itk_component(dialminor) mark add $name current
1067            # bind $itk_component(hull) <<Frame>> [itcl::code $itk_component(main).$name UpdateFrame]
1068
1069            # link the new particle to the last particle added, if it exists
1070            set lastp [lindex ${_particles} end]
1071            while {"" == [info commands $lastp]} {
1072                set _particles [lreplace ${_particles} end end]
1073                if {[llength ${_particles}] == 0} {
1074                    break
1075                }
1076                set lastp [lindex ${_particles} end]
1077            }
1078            if {"" != [info commands $lastp]} {
1079                $lastp Link ${_obj}
1080            }
1081
1082            # add the particle to the list
1083            lappend _particles ${_obj}
1084        }
1085        default {
1086            error "bad status \"$status\": should be new"
1087        }
1088    }
1089}
1090
1091# ----------------------------------------------------------------------
1092# Trajectory - draw a trajectory between two particles
1093#
1094#   Trajectory $p0 $p1
1095# ----------------------------------------------------------------------
1096itcl::body Rappture::VideoScreen::Trajectory {args} {
1097
1098    set nargs [llength $args]
1099    if {($nargs != 1) && ($nargs != 2)} {
1100        error "wrong # args: should be \"Trajectory p0 p1\""
1101    }
1102
1103    set p0 ""
1104    set p1 ""
1105    foreach {p0 p1} $args break
1106
1107    if {[string compare "" $p0] == 0} {
1108        # p0 does not exist
1109        return
1110    }
1111
1112    # remove any old trajectory links from p0
1113    set p0name [$p0 name]
1114    set oldlink "vec-$p0name"
1115    $itk_component(main) delete $oldlink
1116
1117    # check to see if p1 exists anymore
1118    if {[string compare "" $p1] == 0} {
1119        # p1 does not exist
1120        return
1121    }
1122
1123    foreach {x0 y0} [$p0 Coords] break
1124    foreach {x1 y1} [$p1 Coords] break
1125    set p1name [$p1 name]
1126    set link "vec-$p0name-$p1name"
1127    $itk_component(main) create line $x0 $y0 $x1 $y1 \
1128        -fill green \
1129        -width 2 \
1130        -tags "vector $link vec-$p0name" \
1131        -dash {4 4} \
1132        -arrow last
1133    $itk_component(main) lower $link $p0name
1134
1135    # calculate trajectory, truncate it after 4 sigdigs
1136    set t [calculateTrajectory [$p0 Frame] $x0 $y0 [$p1 Frame] $x1 $y1]
1137    set tt [string range $t 0 [expr [string first . $t] + 4]]
1138
1139
1140    # calculate coords for text
1141    foreach { x0 y0 x1 y1 } [$itk_component(main) bbox $link] break
1142    set x [expr "$x0 + (abs($x1-$x0)/2)"]
1143    set y [expr "$y0 + (abs($y1-$y0)/2)"]
1144
1145    set tt "$tt m/s"
1146    set tags "vectext $link vec-$p0name"
1147    set width [expr sqrt(pow(abs($x1-$x0),2)+pow(abs($y1-$y0),2))]
1148
1149    writeText $x $y $tt green $tags $width
1150    return $link
1151}
1152
1153
1154# ----------------------------------------------------------------------
1155# writeText - write text to the canvas
1156#   writes text to the canvas in the color <color> at <x>,<y>
1157#   writes text twice more offset up-left and down right,
1158#   to add a shadowing effect so colors can be seen
1159#
1160#   FIXME: Not sure how the text wrapped due to -width collides with the
1161#          offset text.
1162# ----------------------------------------------------------------------
1163itcl::body Rappture::VideoScreen::writeText {x y text color tags width} {
1164    $itk_component(main) create text [expr $x-1] [expr $y] \
1165        -tags $tags \
1166        -justify center \
1167        -text $text \
1168        -fill black \
1169        -width $width
1170
1171    $itk_component(main) create text [expr $x+1] [expr $y] \
1172        -tags $tags \
1173        -justify center \
1174        -text $text \
1175        -fill black \
1176        -width $width
1177
1178    $itk_component(main) create text [expr $x] [expr $y-1] \
1179        -tags $tags \
1180        -justify center \
1181        -text $text \
1182        -fill black \
1183        -width $width
1184
1185    $itk_component(main) create text [expr $x] [expr $y+1] \
1186        -tags $tags \
1187        -justify center \
1188        -text $text \
1189        -fill black \
1190        -width $width
1191
1192#    # write text up-left
1193#    $itk_component(main) create text [expr $x-1] [expr $y-1] \
1194#        -tags $tags \
1195#        -justify center \
1196#        -text $text \
1197#        -fill black \
1198#        -width $width
1199#
1200#    # write text down-right
1201#    $itk_component(main) create text [expr $x+1] [expr $y+1] \
1202#        -tags $tags \
1203#        -justify center \
1204#        -text $text \
1205#        -fill black \
1206#        -width $width
1207
1208    # write text at x,y
1209    $itk_component(main) create text $x $y \
1210        -tags $tags \
1211        -justify center \
1212        -text $text \
1213        -fill $color \
1214        -width $width
1215
1216}
1217
1218# ----------------------------------------------------------------------
1219# calculateTrajectory - calculate the value of the trajectory
1220# ----------------------------------------------------------------------
1221itcl::body Rappture::VideoScreen::calculateTrajectory {args} {
1222    # set framerate 29.97         ;# frames per second
1223    # set px2dist    8.00         ;# px per meter
1224
1225    foreach {f0 x0 y0 f1 x1 y1} $args break
1226    set px [expr sqrt(pow(abs($x1-$x0),2)+pow(abs($y1-$y0),2))]
1227    set frames [expr $f1 - $f0]
1228
1229    if {($frames != 0) && (${_px2dist} != 0)} {
1230        set t [expr 1.0*$px/$frames*${_px2dist}*${_framerate}]
1231    } else {
1232        set t 0.0
1233    }
1234
1235    return $t
1236}
1237
1238# ----------------------------------------------------------------------
1239# toggleloop - add/remove a start/end loop mark to video dial.
1240# ----------------------------------------------------------------------
1241itcl::body Rappture::VideoScreen::toggleloop {} {
1242    if {$_settings(loop) == 0} {
1243        $itk_component(dialminor) loop disable
1244    } else {
1245        set cur [${_movie} get position cur]
1246        set end [${_movie} get position end]
1247
1248        set startframe [expr $cur-10]
1249        if {$startframe < 0} {
1250            set startframe 0
1251        }
1252
1253        set endframe [expr $cur+10]
1254        if {$endframe > $end} {
1255            set endframe $end
1256        }
1257
1258        $itk_component(dialminor) loop between $startframe $endframe
1259    }
1260
1261}
1262
1263# ----------------------------------------------------------------------
1264# OPTION: -width - width of the video
1265# ----------------------------------------------------------------------
1266itcl::configbody Rappture::VideoScreen::width {
1267    # $_dispatcher event -idle !fixsize
1268    if {[string is integer $itk_option(-width)] == 0} {
1269        error "bad value: \"$itk_option(-width)\": width should be an integer"
1270    }
1271    set _width $itk_option(-width)
1272    after idle [itcl::code $this fixSize]
1273}
1274
1275# ----------------------------------------------------------------------
1276# OPTION: -height - height of the video
1277# ----------------------------------------------------------------------
1278itcl::configbody Rappture::VideoScreen::height {
1279    # $_dispatcher event -idle !fixsize
1280    if {[string is integer $itk_option(-height)] == 0} {
1281        error "bad value: \"$itk_option(-height)\": height should be an integer"
1282    }
1283    set _height $itk_option(-height)
1284    after idle [itcl::code $this fixSize]
1285}
1286
1287# ----------------------------------------------------------------------
1288# OPTION: -fileopen
1289# ----------------------------------------------------------------------
1290itcl::configbody Rappture::VideoScreen::fileopen {
1291    $itk_component(fileopen) configure -command $itk_option(-fileopen)
1292}
Note: See TracBrowser for help on using the repository browser.