source: branches/1.3/gui/scripts/videopreview.tcl @ 5115

Last change on this file since 5115 was 3330, checked in by gah, 11 years ago

merge (by hand) with Rappture1.2 branch
File size: 17.6 KB
Line 
1# -*- mode: tcl; indent-tabs-mode: nil -*-
2# ----------------------------------------------------------------------
3#  COMPONENT: videopreview - previewing movies
4#
5# ======================================================================
6#  AUTHOR:  Derrick Kearney, 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 300 widgetDefault
20option add *Video.height 300 widgetDefault
21option add *Video.font \
22    -*-helvetica-medium-r-normal-*-12-* widgetDefault
23
24itcl::class Rappture::VideoPreview {
25    inherit itk::Widget
26
27    itk_option define -width width Width -1
28    itk_option define -height height Height -1
29    itk_option define -variable variable Variable ""
30
31    constructor { args } {
32        # defined below
33    }
34    destructor {
35        # defined below
36    }
37
38    public method load {type data}
39    public method loadcb {args}
40    public method video {args}
41    public method query {type}
42
43    protected method Play {}
44    protected method Seek {n}
45    protected method fixSize {}
46    protected method _fixValue {args}
47    protected method Upload {args}
48    protected method eventually {args}
49
50
51    private common   _settings
52    private common   _pendings
53
54    private variable _variable ""   ;# quick way to change movie
55    private variable _path  ""      ;# path of movie
56    private variable _width -1      ;# start x for rubberbanding
57    private variable _height -1     ;# start x for rubberbanding
58    private variable _movie ""      ;# movie we grab images from
59    private variable _lastFrame 0   ;# last frame in the movie
60    private variable _imh ""        ;# current image being displayed
61    private variable _id ""         ;# id of the next play command from after
62    private variable _framerate 30  ;# video frame rate
63    private variable _mspf  7       ;# milliseconds per frame wait time
64    private variable _ofrd  19      ;# observed frame retrieval delay of
65                                    ;# underlying c lib in milliseconds
66    private variable _delay  0      ;# milliseconds between play calls
67    private variable _nextframe 0   ;#
68}
69
70
71itk::usual VideoPreview {
72}
73
74# ----------------------------------------------------------------------
75# CONSTRUCTOR
76# ----------------------------------------------------------------------
77itcl::body Rappture::VideoPreview::constructor {args} {
78
79    array set _settings [subst {
80        $this-framenum          0
81        $this-play              0
82    }]
83
84    array set _pendings [subst {
85        play 0
86    }]
87
88    itk_component add main {
89        canvas $itk_interior.main \
90            -background black
91    } {
92        usual
93        rename -background -controlbackground controlBackground Background
94    }
95    bind $itk_component(main) <Configure> [itcl::code $this fixSize]
96
97    # hold the video frames in an image on the canvas
98    set _imh [image create photo]
99    $itk_component(main) create image 0 0 -anchor nw -image $_imh
100
101    # setup movie controls
102    itk_component add moviecontrols {
103        frame $itk_interior.moviecontrols
104    } {
105        usual
106        rename -background -controlbackground controlBackground Background
107    }
108
109    # setup frame number frame
110    itk_component add frnumfr {
111        frame $itk_component(moviecontrols).frnumfr
112    } {
113        usual
114        rename -background -controlbackground controlBackground Background
115    }
116
117    set imagesDir [file join $RapptureGUI::library scripts images]
118
119
120    # Play
121    itk_component add play {
122        Rappture::PushButton $itk_component(moviecontrols).play \
123            -onimage [Rappture::icon flow-pause] \
124            -offimage [Rappture::icon flow-play] \
125            -disabledimage [Rappture::icon flow-play] \
126            -variable [itcl::scope _settings($this-play)] \
127            -command [itcl::code $this video play]
128    }
129    set fg [option get $itk_component(hull) font Font]
130    Rappture::Tooltip::for $itk_component(play) \
131        "Play/Pause movie"
132    $itk_component(play) disable
133
134    # Video Dial Major
135    itk_component add dialmajor {
136        Rappture::Videodial1 $itk_component(moviecontrols).dialmajor \
137            -length 10 -valuewidth 0 -valuepadding 0 -padding 6 \
138            -linecolor "" -activelinecolor "" \
139            -min 0 -max 1 \
140            -variable [itcl::scope _settings($this-framenum)] \
141            -dialoutlinecolor black \
142            -knobimage [Rappture::icon knob2] -knobposition center@middle
143    } {
144        usual
145        ignore -dialprogresscolor
146        rename -background -controlbackground controlBackground Background
147    }
148    $itk_component(dialmajor) current 0
149    bind $itk_component(dialmajor) <<Value>> [itcl::code $this video update]
150
151    itk_component add framenumlabel {
152        label $itk_component(frnumfr).framenuml -text "Frame:" -font $fg \
153            -highlightthickness 0
154    } {
155        usual
156        ignore -highlightthickness
157        rename -background -controlbackground controlBackground Background
158    }
159
160    # Current Frame Number
161    itk_component add framenum {
162        label $itk_component(frnumfr).framenum \
163            -width 5 -font "arial 9" \
164            -textvariable [itcl::scope _settings($this-framenum)]
165    } {
166        usual
167        ignore -highlightthickness
168        rename -background -controlbackground controlBackground Background
169    }
170    Rappture::Tooltip::for $itk_component(framenum) \
171        "Current frame number"
172
173
174    pack $itk_component(framenumlabel) -side left
175    pack $itk_component(framenum) -side right
176
177
178    blt::table $itk_component(moviecontrols) \
179        0,0 $itk_component(play) -padx {2 0} \
180        0,1 $itk_component(dialmajor) -fill x -padx {2 2} \
181        0,2 $itk_component(frnumfr) -padx {2 4}
182
183    blt::table configure $itk_component(moviecontrols) c* -resize none
184    blt::table configure $itk_component(moviecontrols) c1 -resize both
185    blt::table configure $itk_component(moviecontrols) r0 -pady 1
186
187
188    blt::table $itk_interior \
189        0,0 $itk_component(main) -fill both \
190        1,0 $itk_component(moviecontrols) -fill x
191    blt::table configure $itk_interior c* -resize both
192    blt::table configure $itk_interior r0 -resize both
193    blt::table configure $itk_interior r1 -resize both
194
195    eval itk_initialize $args
196
197    $itk_component(main) configure -background black
198}
199
200# ----------------------------------------------------------------------
201# DESTRUCTOR
202# ----------------------------------------------------------------------
203itcl::body Rappture::VideoPreview::destructor {} {
204    array unset _settings $this-*
205    if {[info exists _imh]} {
206        image delete $_imh
207    }
208}
209
210# ----------------------------------------------------------------------
211# load - load a video file
212#   type - type of data, "data" or "file"
213#   data - what to load.
214#       if type == "data", data is treated like binary data
215#       if type == "file", data is treated like the name of a file
216#           and is opened and then loaded.
217# ----------------------------------------------------------------------
218itcl::body Rappture::VideoPreview::load {type data} {
219
220    # open the file
221
222    set fname ""
223    switch $type {
224        "data" {
225            set fname "/tmp/tmpVV[pid].video"
226            set fid [open $fname "w"]
227            fconfigure $fid -translation binary -encoding binary
228            puts $fid $data
229            close $fid
230            set type "file"
231            set data $fname
232        }
233        "file" {
234            # do nothing
235        }
236        default {
237            error "bad value: \"$type\": should be \"load \[data|file\] <data>\""
238        }
239    }
240
241    video stop
242
243    if {([info exists _movie]) && ("" != ${_movie})} {
244        ${_movie} release
245    }
246
247    set _movie [Rappture::Video $type $data]
248    file delete $fname
249    set _framerate [${_movie} framerate]
250    set _mspf [expr round(((1.0/${_framerate})*1000))]
251    set _delay [expr {${_mspf} - ${_ofrd}}]
252
253    video seek 0
254
255    # update the dial and framenum widgets
256    set _settings($this-framenum) 0
257
258    # setup the image display
259
260    foreach {w h} [query dimensions] break
261    if {${_width} == -1} {
262        set _width $w
263    }
264    if {${_height} == -1} {
265        set _height $h
266    }
267
268    set _lastFrame [${_movie} get position end]
269
270    # update the dial with video information
271    $itk_component(dialmajor) configure -min 0 -max ${_lastFrame}
272    $itk_component(play) enable
273
274    fixSize
275}
276
277# ----------------------------------------------------------------------
278# loadcb - load callback
279# ----------------------------------------------------------------------
280itcl::body Rappture::VideoPreview::loadcb {args} {
281    video stop
282    Rappture::filexfer::upload {piv tool} {id label desc} [itcl::code $this Upload]
283}
284
285# ----------------------------------------------------------------------
286# Upload -
287# ----------------------------------------------------------------------
288itcl::body Rappture::VideoPreview::Upload {args} {
289    array set data $args
290    video stop
291
292    if {[info exists data(error)]} {
293        Rappture::Tooltip::cue $itk::component(main) $data(error)
294        puts stderr $data(error)
295    }
296
297    if {[info exists data(path)] && [info exists data(data)]} {
298        Rappture::Tooltip::cue hide  ;# take down note about the popup window
299
300        # load data
301        load "data" $data(data)
302    }
303
304}
305
306# ----------------------------------------------------------------------
307# USAGE: _fixValue ?<name1> <name2> <op>?
308#
309# Invoked automatically whenever the -variable associated with this
310# widget is modified.  Copies the value to the current settings for
311# the widget.
312# ----------------------------------------------------------------------
313itcl::body Rappture::VideoPreview::_fixValue {args} {
314    if {"" == $itk_option(-variable)} {
315        return
316    }
317    upvar #0 $itk_option(-variable) var
318    if {[file readable $var]} {
319        # load and start playing the video
320        set _path $var
321        load file ${_path}
322        set _settings($this-play) 1
323        video play
324    }
325}
326
327# ----------------------------------------------------------------------
328# fixSize
329# ----------------------------------------------------------------------
330itcl::body Rappture::VideoPreview::fixSize {} {
331
332    if {[string compare "" ${_movie}] == 0} {
333        return
334    }
335
336    if {![winfo ismapped $itk_component(hull)]} {
337        return
338    }
339
340    set cw [winfo width $itk_component(main)]
341    set ch [winfo height $itk_component(main)]
342
343    # FIXME: right now we only deal with 16:9 ratio videos
344    # always keep the aspect ratio correct
345    set _width [expr int(int($cw/16.0)*16.0)]
346    set _height [expr int(${_width}/(16.0/9.0))]
347    if {${_height} > $ch} {
348        # if height is limiting us, shrink some more
349        set _height [expr int(int($ch/9.0)*9.0)]
350        set _width [expr int(${_height}*(16.0/9.0))]
351    }
352
353    # get an image with the new size
354    ${_imh} blank
355    ${_imh} put [${_movie} get image ${_width} ${_height}]
356
357    # make the canvas fit the image
358    $itk_component(main) configure -width ${_width} -height ${_height}
359}
360
361# ----------------------------------------------------------------------
362# video - play, stop, rewind, fastforward the video
363# ----------------------------------------------------------------------
364itcl::body Rappture::VideoPreview::video { args } {
365    set option [lindex $args 0]
366    switch -- $option {
367        "play" {
368            if {$_settings($this-play) == 1} {
369                eventually play
370            } else {
371                # pause/stop
372                after cancel $_id
373                set _pendings(play) 0
374                set _settings($this-play) 0
375            }
376        }
377        "seek" {
378            Seek [lreplace $args 0 0]
379        }
380        "stop" {
381            after cancel $_id
382            set _settings($this-play) 0
383        }
384        "update" {
385            # eventually seek [expr round($_settings($this-framenum))]
386            Seek [expr round($_settings($this-framenum))]
387        }
388        default {
389            error "bad option \"$option\": should be play, stop, toggle, position, or reset."
390        }
391    }
392}
393
394# ----------------------------------------------------------------------
395# query - query things about the video
396#
397#   dimensions  - returns width and height as a list
398#   frames      - number of frames in video (last frame + 1)
399#   framenum    - current position
400# ----------------------------------------------------------------------
401itcl::body Rappture::VideoPreview::query { type } {
402    set ret ""
403    switch -- $type {
404        "dimensions" {
405            set ret [${_movie} size]
406        }
407        "frames" {
408            set ret [expr [${_movie} get position end] + 1]
409        }
410        "framenum" {
411            set ret [${_movie} get position cur]
412        }
413        default {
414            error "bad type \"$type\": should be dimensions, frames, framenum."
415        }
416    }
417    return $ret
418}
419
420# ----------------------------------------------------------------------
421# Play - get the next video frame
422# ----------------------------------------------------------------------
423itcl::body Rappture::VideoPreview::Play {} {
424
425    set cur ${_nextframe}
426
427    # time how long it takes to retrieve the next frame
428    set _ofrd [time {
429        # use seek instead of next fxn incase the ${_nextframe} is
430        # not the current frame+1. this happens when we skip frames
431        # because the underlying c lib is too slow at reading.
432        $_movie seek $cur
433        $_imh put [${_movie} get image ${_width} ${_height}]
434    } 1]
435    regexp {(\d+\.?\d*) microseconds per iteration} ${_ofrd} match _ofrd
436    set _ofrd [expr {round(${_ofrd}/1000)}]
437
438    # calculate the delay we shoud see
439    # between frames being placed on screen
440    # taking into account the cost of retrieving the frame
441    set _delay [expr {${_mspf}-${_ofrd}}]
442    if {0 > ${_delay}} {
443        set _delay 0
444    }
445
446    set cur [${_movie} get position cur]
447
448    # update the dial and framenum widgets
449    set _settings($this-framenum) $cur
450
451    # no play cmds pending
452    set _pendings(play) 0
453
454    # schedule the next frame to be displayed
455    if {$cur < ${_lastFrame}} {
456        set _id [after ${_delay} [itcl::code $this eventually play]]
457    } else {
458        video stop
459    }
460
461    event generate $itk_component(hull) <<Frame>>
462}
463
464
465# ----------------------------------------------------------------------
466# Seek - go to a frame in the video
467#   Seek +5
468#   Seek -5
469#   Seek 35
470# ----------------------------------------------------------------------
471itcl::body Rappture::VideoPreview::Seek {args} {
472    set val [lindex $args 0]
473    if {"" == $val} {
474        error "bad value: \"$val\": should be \"seek value\""
475    }
476    set cur [${_movie} get position cur]
477    if {[string compare $cur $val] == 0} {
478        # already at the frame to seek to
479        return
480    }
481    ${_movie} seek $val
482    ${_imh} put [${_movie} get image ${_width} ${_height}]
483
484    # update the dial and framenum widgets
485    set _settings($this-framenum) [${_movie} get position cur]
486    event generate $itk_component(main) <<Frame>>
487
488}
489
490
491# ----------------------------------------------------------------------
492# eventually -
493#   seek
494#   play
495# ----------------------------------------------------------------------
496itcl::body Rappture::VideoPreview::eventually {args} {
497    set option [lindex $args 0]
498    switch -- $option {
499        "seek" {
500            if {$_pendings(seek) == 0} {
501                # no seek pending, schedule one
502                set $_pendings(seek) 1
503                after idle [itcl::code $this Seek [lindex $args 1]]
504            } else {
505                # there is a seek pending, update its seek value
506            }
507        }
508        "play" {
509            if {0 == $_pendings(play)} {
510                # no play pending schedule one
511                set _pendings(play) 1
512                set _nextframe [expr {[${_movie} get position cur] + 1}]
513                after idle [itcl::code $this Play]
514            } else {
515                # there is a play pending, update its frame value
516                incr _nextframe
517            }
518        }
519        default {
520        }
521    }
522}
523
524# ----------------------------------------------------------------------
525# CONFIGURE: -variable
526# ----------------------------------------------------------------------
527itcl::configbody Rappture::VideoPreview::variable {
528    if {"" != $_variable} {
529        upvar #0 $_variable var
530        trace remove variable var write [itcl::code $this _fixValue]
531    }
532
533    set _variable $itk_option(-variable)
534
535    if {"" != $_variable} {
536        upvar #0 $_variable var
537        trace add variable var write [itcl::code $this _fixValue]
538
539        # sync to the current value of this variable
540        if {[info exists var]} {
541            _fixValue
542        }
543    }
544}
545
546# ----------------------------------------------------------------------
547# OPTION: -width
548# ----------------------------------------------------------------------
549itcl::configbody Rappture::VideoPreview::width {
550    # $_dispatcher event -idle !fixsize
551    if {[string is integer $itk_option(-width)] == 0} {
552        error "bad value: \"$itk_option(-width)\": width should be an integer"
553    }
554    set _width $itk_option(-width)
555    after idle [itcl::code $this fixSize]
556}
557
558# ----------------------------------------------------------------------
559# OPTION: -height
560# ----------------------------------------------------------------------
561itcl::configbody Rappture::VideoPreview::height {
562    # $_dispatcher event -idle !fixsize
563    if {[string is integer $itk_option(-height)] == 0} {
564        error "bad value: \"$itk_option(-height)\": height should be an integer"
565    }
566    set _height $itk_option(-height)
567    after idle [itcl::code $this fixSize]
568}
Note: See TracBrowser for help on using the repository browser.