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

Last change on this file since 5091 was 3441, checked in by gah, 12 years ago

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