root/vic/branches/mpeg4/tcl/ui-ctrlmenu.tcl @ 4064

Revision 4064, 42.0 KB (checked in by piers, 7 years ago)

Updates to fix grabbers on windows:
- Old vfw Win32 made more robust to failing grabbers
- Win32DS now attempts to select best resolution to fix the selected capture size. It is also now possible to select PAL or NTSC from Signal.. menu to adjust captured video size.
- Altered code so it chooses the capture size before calling RenderStream? on filterGraph - that way the filter graph manager can insert the appropriate colour space converter.
- Uses set_size_cif() in size() - which falls thru to ste_size_411() not handled. Fixed bug in Grabber.cpp: set_size_cif() where width=176 didn't have a break statement.
- tweaked ui-ctrlmenu.tcl so Signal..(type) is set before decimate on - so win32 grabber can use it.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1#
2# Copyright (c) 1993-1995 Regents of the University of California.
3# All rights reserved.
4#
5# Redistribution and use in source and binary forms, with or without
6# modification, are permitted provided that the following conditions
7# are met:
8# 1. Redistributions of source code must retain the above copyright
9#    notice, this list of conditions and the following disclaimer.
10# 2. Redistributions in binary form must reproduce the above copyright
11#    notice, this list of conditions and the following disclaimer in the
12#    documentation and/or other materials provided with the distribution.
13# 3. All advertising materials mentioning features or use of this software
14#    must display the following acknowledgement:
15#       This product includes software developed by the Computer Systems
16#       Engineering Group at Lawrence Berkeley Laboratory.
17# 4. Neither the name of the University nor of the Laboratory may be used
18#    to endorse or promote products derived from this software without
19#    specific prior written permission.
20#
21# THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
22# ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
23# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
24# ARE DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
25# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
26# DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
27# OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
28# HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
29# LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
30# OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
31# SUCH DAMAGE.
32#
33proc windowingsystem { } {
34    if { [ catch {set tkws [tk windowingsystem]}] } {
35            set tkws x11
36    }
37    return $tkws
38}
39
40proc fork_histtolut { } {
41        global V
42        if { $V(dither) == "gray" } {
43                open_dialog "cannot optimize grayscale rendering"
44                return
45        }
46        #
47        # create a histogram object and collect stats from decoders
48        #
49        set ch [$V(colorModel) create-hist]
50        set active 0
51        foreach src [session active] {
52                set d [$src handler]
53                if { ![$src mute] && $d != "" } {
54                        $d histogram $ch
55                        set active 1
56                }
57        }
58        if !$active {
59                open_dialog "no active, unmuted sources"
60                delete $ch
61                return
62        }
63        set pid [pid]
64        set outfile /tmp/vicLUT.$pid
65        set infile /tmp/vicHIST.$pid
66
67        if { [$ch dump $infile] < 0 } {
68                open_dialog "couldn't create $infile"
69                delete $ch
70                return
71        }
72        delete $ch
73        #
74        # fork off a histtolut and use tk fileevent to call back
75        # finish_histtolut when the child is done
76        #
77        #XXX -n
78        set eflag ""
79        if { $V(dither) == "ed" } {
80                set eflag "-e"
81        }
82        if [catch \
83          "open \"|histtolut $eflag -n 170 -o $outfile $infile\"" pipe] {
84                open_dialog "histtolut not installed in your path"
85                return
86        }
87        fileevent $pipe readable "finish_histtolut $pipe $infile $outfile"
88        # disable button while histtolut is running
89        $V(optionsMenu) entryconfigure "Optimize Colormap" \
90                -state disabled
91        .menu configure -cursor watch
92}
93
94proc finish_histtolut { pipe infile outfile } {
95        .menu configure -cursor ""
96        global V
97        $V(optionsMenu) entryconfigure "Optimize Colormap" \
98                -state normal
99        set cm $V(colorModel)
100        $cm free-colors
101        $cm lut $outfile
102        if ![$cm alloc-colors] {
103                #XXX unset lut
104                revert_to_gray
105        }
106        #XXX make this a proc
107        foreach src [session active] {
108                set d [$src handler]
109                if { $d != "" } {
110                        $d redraw
111                }
112        }
113        fileevent $pipe readable ""
114        close $pipe
115}
116
117proc have_transmit_permission {} {
118        global inputDeviceList
119        return [expr [info exists inputDeviceList] && ![yesno recvOnly]]
120}
121
122#
123# Build the menu panel.  Called from toggle_window,
124# the first time the Menu button is hit.
125#
126proc build.menu { } {
127        set w .menu
128        create_toplevel $w "vic menu"
129        wm withdraw $w
130        catch "wm resizable $w false false"
131
132        frame $w.session
133        frame $w.cb
134        build.xmit $w.cb
135        frame $w.encoder
136        build.encoder $w.encoder
137        frame $w.decoder
138        build.decoder $w.decoder
139        global V
140        set net $V(data-net)
141        build.session $w.session [$net addr] [$net port] \
142                [[srctab local] srcid] [$net ttl] [[srctab local] sdes name] \
143                [[srctab local] sdes note]
144
145        button $w.dismiss -text Dismiss -borderwidth 2 -width 8 \
146                -relief raised -anchor c \
147                -command "toggle_window $w" -font [mediumfont]
148
149        # added to catch window close action
150        wm protocol $w WM_DELETE_WINDOW "toggle_window $w"
151
152        pack $w.cb $w.encoder $w.decoder $w.session -padx 6 -fill x
153        pack $w.dismiss -anchor c -pady 4
154
155        if [have_transmit_permission] {
156                selectInitialDevice
157        }
158}
159
160proc defaultDevice {} {
161        set d [resource defaultDevice]
162        if { $d == "" } {
163                set d [resource device]
164        }
165        return $d
166}       
167
168proc selectInitialDevice {} {
169        global videoDevice inputDeviceList
170        set d [defaultDevice]
171        foreach v $inputDeviceList {
172                if { [$v nickname] == "$d" && \
173                        [$v attributes] != "disabled" } {
174                        set videoDevice $v
175                        select_device $v
176                        return
177                }
178        }
179        if { [string toupper [string range $d 0 4]] == "V4L2:" } {
180                set d [string range $d 5 end]
181                foreach v $inputDeviceList {
182                        set k [expr [string length [$v nickname]] - [string length $d]]
183                        if { [string range [$v nickname] 0 4] == "V4L2-" && \
184                                [string range [$v nickname] $k end] == "$d" && \
185                                [$v attributes] != "disabled" } {
186                                set videoDevice $v
187                                select_device $v
188                                return
189                        }
190                }
191        }
192        if { [string toupper [string range $d 0 3]] == "V4L:" } {
193                set d [string range $d 4 end]
194                foreach v $inputDeviceList {
195                        set k [expr [string length [$v nickname]] - [string length $d]]
196                        if { [string range [$v nickname] 0 3] == "V4L-" && \
197                                [string range [$v nickname] $k end] == "$d" && \
198                                [$v attributes] != "disabled" } {
199                                set videoDevice $v
200                                select_device $v
201                                return
202                        }
203                }
204        }
205        foreach v $inputDeviceList {
206                if { "[$v attributes]" != "disabled" &&
207                        "[$v nickname]" != "still" } {
208                        set videoDevice $v
209                        select_device $v
210                        return
211                }
212        }
213}
214
215proc build.session { w dst port srcid ttl name note } {
216        global V
217
218        set f [smallfont]
219
220        label $w.title -text Session
221        pack $w.title -fill x
222
223        frame $w.nb -relief sunken -borderwidth 2
224        pack $w.nb -fill x
225
226        frame $w.nb.frame
227        pack append $w.nb \
228                $w.nb.frame { top fillx }
229
230        label $w.nb.frame.info -font $f -anchor w \
231                -text "Address: $dst   Port: $port  ID: $srcid  TTL: $ttl Tool: $V(app)-[version]"
232
233        frame $w.nb.frame.name
234        label $w.nb.frame.name.label -text "Name: " -font $f -anchor e -width 6
235        mk.entry $w.nb.frame.name updateName $name
236        pack $w.nb.frame.name.label -side left
237        pack $w.nb.frame.name.entry -side left -expand 1 -fill x -pady 2
238
239        frame $w.nb.frame.msg
240        label $w.nb.frame.msg.label -text "Note: " -font $f -anchor e -width 6
241        mk.entry $w.nb.frame.msg update_note $note
242        pack $w.nb.frame.msg.label -side left
243        pack $w.nb.frame.msg.entry -side left -expand 1 -fill x -pady 2
244
245        mk.key $w.nb.frame
246
247        frame $w.nb.frame.b
248
249        if {[string match [ windowingsystem] "aqua"]} {
250                button $w.nb.frame.b.stats -text "Global Stats" -padx 10 \
251                         -anchor c -font $f -command create_global_window
252                button $w.nb.frame.b.members -text Members -padx 10 \
253                        -anchor c -font $f -command "toggle_window .srclist"
254        } else {
255                button $w.nb.frame.b.stats -text "Global Stats" -borderwidth 2 \
256                        -anchor c -font $f -command create_global_window
257                button $w.nb.frame.b.members -text Members -borderwidth 2 \
258                        -anchor c -font $f -command "toggle_window .srclist"
259        }
260
261        pack $w.nb.frame.b.stats $w.nb.frame.b.members \
262                -side left -padx 4 -pady 2 -anchor c
263
264        pack $w.nb.frame.info $w.nb.frame.name $w.nb.frame.msg \
265                $w.nb.frame.key \
266                -fill x -padx 2 -expand 1
267        pack $w.nb.frame.b -pady 2 -anchor c
268}
269
270proc setFillRate { } {
271        global sendingSlides transmitButtonState V
272        if { $transmitButtonState } {
273                if { $sendingSlides } {
274                        $V(grabber) fillrate 16
275                } else {
276                        $V(grabber) fillrate 2
277                }
278        }
279}
280
281proc updateName { w name } {
282        set name [string trim $name]
283        if { $name != ""} {
284                [srctab local] sdes name $name
285                return 0
286        }
287        return -1
288}
289
290proc update_note { w s } {
291        set s [string trim $s]
292        [srctab local] sdes note $s
293        return 0
294}
295
296proc encoder args {
297        global V
298        if ![info exists V(encoder)] {
299                puts "vic: encoder: no encoder"
300                return
301        }
302        eval $V(encoder) $args
303}
304
305proc grabber args {
306        global V
307        if ![info exists V(grabber)] {
308                # ignore
309                return
310        }
311        eval $V(grabber) $args
312}
313
314proc create_encoder fmt {
315        if { $fmt == "nvdct" } {
316                set encoder [new module nv]
317                $encoder use-dct 1
318        } else {
319                set encoder [new module $fmt]
320        }
321        return $encoder
322}
323
324set transmitButtonState 0
325set logoButtonState 0
326
327proc transmit { } {
328        global logoButton logoButtonState transmitButtonState videoFormat videoDevice V useJPEGforH261 useHardwareComp numEncoderLayers 
329        if ![have grabber] {
330                set DA [$videoDevice attributes]
331                set DF [attribute_class $DA format]
332                set DS [attribute_class $DA size]
333
334                # first, see if device can produce bitstream directly
335                # if not, try a transcoder
336                # if that doesn't work, try anything else
337
338                if { [inList $videoFormat $DF] } {
339                        if { $videoFormat == "h261" || $videoFormat == "cellb" || $videoFormat == "jpeg"} {
340                                # use special hardware tag...
341                                set encoder ""
342                                if  { $useHardwareComp } {
343                                        set encoder [create_encoder "$videoFormat/hw"]
344                                }
345                                if { $encoder == "" } {
346                                        set encoder [create_encoder "$videoFormat"]
347                                }
348                        } else {
349                                set encoder [create_encoder $videoFormat]
350                        }
351                        set grabtarget $encoder
352                        set grabq ""
353                } elseif { $videoFormat == "h261" && [inList jpeg $DF] && \
354                                $useJPEGforH261 } {
355                        # just jpeg->h261 at this time
356                        set transcoder [new transcoder jpeg/dct]
357                        set encoder [new module h261/dct]
358                        $transcoder target $encoder
359                        set grabtarget $transcoder
360                        set grabq "70"
361                } elseif { [inList $videoFormat [device_formats $videoDevice] ] } {
362                        set encoder [create_encoder $videoFormat]
363                        set grabtarget $encoder
364                        set grabq ""
365                }
366
367                $encoder transmitter $V(session)
368
369                $encoder loop_layer [expr {$numEncoderLayers + 1}]
370               
371                set V(encoder) $encoder
372                set ff [$grabtarget frame-format]
373                set V(grabber) [$videoDevice open $ff]
374                # special cases
375                if { $V(grabber) == "" && $ff == "411" } {
376                        # try cif instead of 411
377                        set V(grabber) [$videoDevice open cif]
378                }
379                if { $V(grabber) == "" } {
380                        #XXX
381                        puts "Error: grabber=\"\" puts XXX couldn't set up grabber/encoder for $ff->$videoFormat"
382                        exit 1
383                }
384                set error [$V(grabber) status]
385                if { $error < 0 } {
386                        close_device
387                        if { $error == -2 } {
388                                #XXX hack: this happens when we tried to open
389                                # a jvideo with a non-jpeg format
390                                set transmitButtonState 0
391                                set logoButtonState 0
392                                open_dialog \
393                                    "Can't use jvideo with $videoFormat format"
394                                select_device $videoDevice
395                                return
396                        }
397                        set transmitButtonState 0
398                        set logoButtonState 0
399                        open_dialog \
400                            "can't open [$videoDevice nickname] capture device"
401                        return
402                }
403               
404               
405                init_grabber $V(grabber)
406                if ![tm_init $V(grabber) $grabtarget] {
407                        $V(grabber) target $grabtarget
408                }
409
410                if { $grabq != "" } {
411                        $V(grabber) q $grabq
412                }
413        }
414        if [have capwin] {
415                set w [winfo toplevel $V(capwin)]
416                if $transmitButtonState {
417                        wm deiconify $w
418                } else {
419                        wm withdraw $w
420                }
421                update idletasks
422        }
423
424        update_encoder_param
425        $V(grabber) send $transmitButtonState
426}
427
428proc close_device {} {
429        global V
430        # XXX: bypassing the pure virtual funtion call problem under macosx
431        # need to figure out where is the bug
432        if { ![string match [ windowingsystem] "aqua"]} {
433            delete $V(encoder)
434            delete $V(grabber)
435            unset V(grabber)
436            unset V(encoder)
437        }
438        if [info exists V(capwin)] {
439                # delete the C++ object, then destrory the tk window
440                delete $V(capwin)
441                destroy [winfo toplevel $V(capwin)]
442                unset V(capwin)
443        }
444}
445
446proc release_device { } {
447        global transmitButtonState transmitButton
448        global logoButtonState logoButton
449
450        if [have grabber] {
451       
452                if $logoButtonState {
453                        $logoButton invoke
454                }
455                logo_quit
456       
457                if $transmitButtonState {
458                        $transmitButton invoke
459                }
460                close_device
461        }
462
463}
464
465proc configWinGrabber {} {
466        global configOnTransmit
467        grabber useconfig $configOnTransmit
468}
469
470proc build.buttons w {
471        set f [smallfont]
472        global transmitButton
473        set transmitButton $w.send
474        global logoButton
475        set logoButton $w.logo
476
477        checkbutton $w.send -text "Transmit" \
478                -relief raised -command transmit \
479                -anchor w -variable transmitButtonState -font $f \
480                -state disabled -highlightthickness 0
481#       checkbutton $w.freeze -text "Freeze" \
482#               -relief raised -command "grabber freeze \$freeze" \
483#               -anchor w -variable freeze -font $f \
484#               -highlightthickness 0
485        button $w.release -text "Release" \
486                -relief raised -command release_device \
487                -font $f -highlightthickness 0
488        checkbutton $w.logo -text "Overlay" \
489                -relief raised -command logo_transmit \
490                -anchor w -variable logoButtonState -font $f \
491                -state normal -highlightthickness 0
492               
493#       pack $w.send $w.release $w.freeze -fill both
494        pack $w.send $w.logo $w.release -fill both
495}
496
497proc doNothing { args } {
498}
499
500proc update_encoder_param {  } {
501        global videoFormat fps_slider bps_slider
502        if {$videoFormat == "mpeg4" || $videoFormat == "h264"} {
503            encoder kbps [$bps_slider get]
504            encoder fps [$fps_slider get]
505        }
506}
507
508proc set_bps { w value } {
509        global videoFormat
510
511        if [have grabber] {
512            grabber bps $value
513            if {$videoFormat == "mpeg4" || $videoFormat == "h264"} {
514                encoder kbps $value
515            }
516
517        #XXX
518            session data-bandwidth $value
519        }
520        $w configure -text "$value bps"
521}
522
523proc set_fps { w value } {
524        global videoFormat
525
526        if [have grabber] {     
527          grabber fps $value
528          if {$videoFormat == "mpeg4" || $videoFormat == "h264"} {
529                encoder fps $value
530          }
531        }
532        $w configure -text "$value fps"
533}
534
535proc build.sliders w {
536        set f [smallfont]
537
538        global V
539        set key $V(session)
540        global ftext btext
541        set ftext($key) "0.0 f/s"
542        set btext($key) "0.0 kb/s"
543
544        frame $w.info
545        label $w.info.label -text "Rate Control" -font $f
546        label $w.info.fps -textvariable ftext($key) -width 6 \
547                -font $f -pady 0 -borderwidth 0
548    label $w.info.bps -textvariable btext($key) -width 8 \
549                -font $f -pady 0 -borderwidth 0
550        pack $w.info.label -side left
551        pack $w.info.bps $w.info.fps -side right
552       
553        frame $w.bps
554        scale $w.bps.scale -orient horizontal -font $f \
555                -showvalue 0 -from 1 -to [option get . maxbw Vic] \
556                -command "set_bps $w.bps.value" -width 12 \
557                -sliderlength 20 \
558                -relief groove
559        label $w.bps.value -font $f -width 8 -anchor w
560
561        frame $w.fps
562        scale $w.fps.scale -font $f -orient horizontal \
563                -showvalue 0 -from 1 -to 30 \
564                -command "set_fps $w.fps.value" -width 12 \
565                -sliderlength 20 \
566                -relief groove
567        label $w.fps.value -font $f -width 8 -anchor w
568
569        pack $w.info -fill x
570        pack $w.bps $w.fps -fill x
571        pack $w.bps.scale -side left -fill x -expand 1
572        pack $w.bps.value -side left -anchor w
573        pack $w.fps.scale -fill x -side left -expand 1
574        pack $w.fps.value -side left -anchor w
575       
576        $w.bps.scale set [option get . bandwidth Vic]
577        $w.fps.scale set [option get . framerate Vic]
578
579        global fps_slider bps_slider
580        set fps_slider $w.fps.scale
581        set bps_slider $w.bps.scale
582}
583
584proc attribute_class { attr class } {
585        while { [llength $attr] >= 2 } {
586                if { [lindex $attr 0] == $class } {
587                        return [lindex $attr 1]
588                }
589                set attr [lrange $attr 2 end]
590        }
591        return ""
592}
593
594proc inList { item L } {
595        foreach v $L {
596                if { $v == $item } {
597                        return 1
598                }
599        }
600        return 0
601}
602
603#
604# Returns true iff device named by $device has an attribute named
605# $attr in the attribute class $class.  For example,
606# "device_supports vl size cif" would return true.
607# if $attr is "*", then returns true iff the indicated $class
608# exists in the attribute list (for example, "device_supports $d port *"
609# says whether a device supports port selection at all)
610#
611proc device_supports { device class attr } {
612        set L [$device attributes]
613        set L [attribute_class $L $class]
614        if { $attr == "*" } {
615                if { $L == "" } {
616                        return 0
617                } else {
618                        return 1
619                }
620        } else {
621                return [inList $attr $L]
622        }
623}
624
625# device_formats: any type of stream produce-able from this device
626# (not necessarily native)
627proc device_formats device {
628        set L [$device attributes]
629        set sizes [attribute_class $L size]
630        set formats [attribute_class $L format]
631        set fmtList ""
632        if [inList 422 $formats] {
633                set fmtList "$fmtList nv nvdct cellb jpeg raw"
634        }
635        if [inList 411 $formats] {
636                set fmtList "$fmtList bvc pvh"
637        }
638        if [inList cif $sizes] {
639                set fmtList "$fmtList h261 h261as h263+ h263 mpeg4 h264"
640        }
641        if [inList jpeg $formats] {
642                set fmtList "$fmtList jpeg"
643                global useJPEGforH261
644                if $useJPEGforH261 {
645                        set fmtList "$fmtList h261"
646                }
647        }
648        return $fmtList
649}
650
651#
652# called when selecting a new device: insert a grabber control panel
653# if it exists and remove the old one (if one was installed)
654#
655proc insert_grabber_panel devname {
656        set k [string first - $devname]
657        if { $k >= 0 } {
658                incr k -1
659                set devname [string tolower [string range $devname 0 $k]]
660        }
661        regsub -all " " $devname "_" devname
662        set w .menu.$devname
663        global grabberPanel
664        if [info exists grabberPanel] {
665                if { "$grabberPanel" == "$w" } {
666                        return
667                }
668                pack forget $grabberPanel
669                unset grabberPanel
670        }
671        if { [info procs build.$devname] != "" } {
672                if ![winfo exists $w] {
673                        frame $w
674                        build.$devname $w
675                }
676                pack $w -before .menu.encoder -padx 6 -fill x
677                set grabberPanel $w
678        }
679}
680
681#
682# Called when use selects a particular device (like videopix or xil)
683# (and at startup for default device)
684#
685proc select_device device {
686        global transmitButton logoButton sizeButtons portButton formatButtons \
687                videoFormat defaultFormat lastDevice defaultPort inputPort \
688                transmitButtonState logoButtonState typeButton
689
690        #
691        # Remember settings of various controls for previous device
692        # and close down the device if it's already open
693        #
694        set wasTransmitting $transmitButtonState
695        set wasOverlaying $logoButtonState
696        if [info exists lastDevice] {
697                set defaultFormat($lastDevice) $videoFormat
698                set defaultPort($lastDevice) $inputPort
699                release_device
700        }
701        set lastDevice $device
702
703        set fmtList [device_formats $device]
704        foreach b $formatButtons {
705                set fmt [lindex [$b configure -value] 4]
706                #XXX
707                if { $fmt == "bvc" && ![yesno enableBVC] } {
708                        $b configure -state disabled
709                } elseif { [inList $fmt $fmtList] } {
710                        $b configure -state normal
711                } else {
712                        $b configure -state disabled
713                }
714        }
715        $transmitButton configure -state normal
716        $logoButton configure -state normal
717        if [device_supports $device size small] {
718                $sizeButtons.b0 configure -state normal
719        } else {
720                $sizeButtons.b0 configure -state disabled
721        }
722        if [device_supports $device size large] {
723                $sizeButtons.b2 configure -state normal
724        } else {
725                $sizeButtons.b2 configure -state disabled
726        }
727        if [device_supports $device port *] {
728                $portButton configure -state normal
729                attach_ports $device
730        } else {
731                $portButton configure -state disabled
732        }
733        if [device_supports $device type *] {
734                $typeButton configure -state normal
735        } else {
736                $typeButton configure -state disabled
737        }
738        insert_grabber_panel [$device nickname]
739
740        #set videoFormat $defaultFormat($device)
741        select_format $videoFormat
742        if $wasOverlaying {
743                $logoButton invoke
744        }
745        if $wasTransmitting {
746                $transmitButton invoke
747        }
748}
749
750proc build.device w {
751        set f [smallfont]
752
753        set m $w.menu
754        if {[string match [ windowingsystem] "aqua"]} {
755            menubutton $w -menu $m -text Device -width 8 -pady 4
756        } else {
757            menubutton $w -menu $m -text Device... \
758                -relief raised -width 10 -font $f
759        }
760        menu $m
761
762        global defaultFormat inputDeviceList videoFormat
763        set videoFormat [option get . defaultFormat Vic]
764        if { $videoFormat == "h.261" } {
765                set videoFormat h261
766        } elseif { $videoFormat == "h.263plus"} {
767                set videoFormat h263+
768        } elseif { $videoFormat == "mpeg4"} {
769                set videoFormat mpeg4
770        } elseif { $videoFormat == "h264"} {
771                set videoFormat h264
772        }
773       
774
775        # Disabled the device button if we have no devices or
776        # if we don't have transmit persmission.
777        #
778        if { ![info exists inputDeviceList] || ![have_transmit_permission] } {
779                $w configure -state disabled
780                return
781        }
782        foreach d $inputDeviceList {
783                if { [$d nickname] == "still" && ![yesno stillGrabber] } {
784                        set defaultFormat($d) $videoFormat
785                        continue
786                }
787                # this is fragile
788                $m add radiobutton -label [$d nickname] \
789                        -command "select_device $d" \
790                        -value $d -variable videoDevice -font $f
791                if { "[$d attributes]" == "disabled" } {
792                        $m entryconfigure [$d nickname] -state disabled
793                }
794                set fmtList [device_formats $d]
795                if [inList $videoFormat $fmtList] {
796                        set defaultFormat($d) $videoFormat
797                } else {
798                        set defaultFormat($d) [lindex $fmtList 0]
799                }
800        }
801}
802
803proc format_col3 { w n0 n1 n2 } {
804        set f [smallfont]
805        frame $w
806        radiobutton $w.b0 -text $n0 -relief flat -font $f -anchor w \
807                -variable videoFormat -value $n0 -padx 0 -pady 0 \
808                -command "select_format $n0" -state disabled
809        radiobutton $w.b1 -text $n1 -relief flat -font $f -anchor w \
810                -variable videoFormat -value $n1 -padx 0 -pady 0 \
811                -command "select_format $n1" -state disabled
812        radiobutton $w.b2 -text $n2 -relief flat -font $f -anchor w \
813                -variable videoFormat -value $n2 -padx 0 -pady 0 \
814                -command "select_format $n2" -state disabled
815        pack $w.b0 $w.b1 $w.b2 -fill x
816
817        global formatButtons
818        lappend formatButtons $w.b0 $w.b1 $w.b2
819
820        #format_col $w.p0 nv nvdct cellb
821        #format_col $w.p1 jpeg h261 bvc
822        #format_col $w.p2 h263+ h263 raw
823}
824
825proc format_col { w n0 n1 } {
826        set f [smallfont]
827        frame $w
828        if { [string first : $n0] > 0 } {
829                set reliefn0 ridge
830                set n0 [ string range $n0 0 [expr {[string length $n0] -2 }] ]
831        } else {
832                set reliefn0 flat
833        }
834        if { [string first : $n1] > 0 } {
835                set reliefn1 ridge
836                set n1 [ string range $n1 0 [expr {[string length $n1] -2 }] ]
837        } else {
838                set reliefn1 flat
839        }
840        radiobutton $w.b0 -text $n0 -relief $reliefn0 -font $f -anchor w \
841                -variable videoFormat -value $n0 -padx 2 -pady 4 \
842                -command "select_format $n0" -state disabled
843        radiobutton $w.b1 -text $n1 -relief $reliefn1 -font $f -anchor w \
844                -variable videoFormat -value $n1 -padx 2 -pady 4 \
845                -command "select_format $n1" -state disabled
846        pack $w.b0 $w.b1 -fill x
847
848        global formatButtons
849        lappend formatButtons $w.b0 $w.b1
850
851        #format_col $w.p0 nv nvdct
852        #format_col $w.p1 jpeg h261
853        #format_col $w.p2 h263+ h263
854        #format_col $w.p3 raw cellb
855        #format_col $w.p4 pvh bvc
856}
857
858proc set_numEncoderLayers { value } {
859        global transmitButtonState numEncoderLayers V encoderLayerScale encoderLayerValue
860
861        $encoderLayerValue configure -text $value
862       
863        if $transmitButtonState {
864                $V(encoder) loop_layer [expr {$numEncoderLayers + 1}]
865                #$V(decoder) maxChannel $numEncoderLayers
866        }
867}
868
869proc build.encoderLayer_scale w {
870        global numLayers encoderLayerScale encoderLayerValue
871
872        set f [smallfont]
873
874        frame $w.tb
875        label $w.title -text "Layers" -font $f -anchor w
876        label $w.tb.value -text 0 -font $f -width 3
877        scale $w.tb.scale -font $f -orient horizontal \
878                -showvalue 0 -from 0 -to $numLayers \
879                -variable numEncoderLayers \
880                -width 12 -relief groove \
881        -command "set_numEncoderLayers"
882
883
884        set encoderLayerScale $w.tb.scale
885        set encoderLayerValue $w.tb.value
886
887        $encoderLayerValue configure -text $numLayers
888
889#$layerscale configure -state disabled
890
891        pack $w.tb.scale -side left -fill x -expand 1
892        pack $w.tb.value -side left
893        pack $w.title -padx 2 -side left
894        pack $w.tb -fill x -padx 6 -side left -expand 1
895}
896
897proc build.format w {
898        set encoder [new module h264]
899        if { $encoder == "" }  {
900          set gpl 1
901        } else {
902          delete $encoder
903          set gpl 0
904        }
905
906        format_col $w.p0 nv nvdct
907        format_col $w.p1 h261 h263
908        format_col $w.p2 h263+ h261as
909        if { $gpl == 0 } {
910          format_col $w.p3 mpeg4 h264
911        }
912        format_col $w.p4 raw cellb
913        format_col $w.p5 bvc pvh:
914        format_col $w.p6 jpeg null
915
916       
917        frame $w.glue0
918        frame $w.glue1
919        if { $gpl == 0 } {
920            pack $w.p0 $w.p1 $w.p2 $w.p3 $w.p4 $w.p5 $w.p6 -side left
921        } else {
922            pack $w.p0 $w.p1 $w.p2  $w.p4 $w.p5 $w.p6 -side left
923        }
924
925}
926
927proc build.size w {
928        set f [smallfont]
929
930        set b $w.b
931        frame $b
932        radiobutton $b.b0 -text "small" -command "restart" \
933                -padx 0 -pady 0 \
934                -anchor w -variable inputSize -font $f -relief flat -value 4
935        radiobutton $b.b1 -text "normal" -command "restart" \
936                -padx 0 -pady 0 \
937                -anchor w -variable inputSize -font $f -relief flat -value 2
938        radiobutton $b.b2 -text "large" -command "restart" \
939                -padx 0 -pady 0 \
940                -anchor w -variable inputSize -font $f -relief flat -value 1
941        pack $b.b0 $b.b1 $b.b2 -fill x
942        pack $b -anchor c -side left
943        global inputSize sizeButtons
944        set inputSize 2
945        set sizeButtons $b
946}
947
948proc build.port w {
949        set f [smallfont]
950        # create the menubutton but don't defer the menu creation until later
951        if {[string match [ windowingsystem] "aqua"]} {
952            menubutton $w -menu $w.menu -text Port -width 8 -pady 4 \
953                -state disabled
954        } else {
955            menubutton $w -menu $w.menu -text Port... \
956                -relief raised -width 10 -font $f -state disabled
957        }
958        global portButton inputPort
959        set portButton $w
960        set inputPort undefined
961}
962
963proc attach_ports device {
964        global portButton inputPort defaultPort
965        catch "destroy $portButton.menu"
966        set portnames [attribute_class [$device attributes] port]
967        set f [smallfont]
968        set m $portButton.menu
969        menu $m
970        foreach port $portnames {
971                $m add radiobutton -label $port \
972                        -command "grabber port \"$port\"" \
973                        -value $port -variable inputPort -font $f
974        }
975        if ![info exists defaultPort($device)] {
976                set nn [$device nickname]
977                if [info exists defaultPort($nn)] {
978                        set defaultPort($device) $defaultPort($nn)
979                } else {
980                        set s [resource defaultPort($nn)]
981                        if { $s != "" } {
982                                set defaultPort($device) $s
983                        } else {
984                                set defaultPort($device) [lindex $portnames 0]
985                        }
986                }
987        }
988        set inputPort $defaultPort($device)
989}
990
991proc build.type w {
992        set f [smallfont]
993
994        set m $w.menu
995        if {[string match [ windowingsystem] "aqua"]} {
996            menubutton $w -text Signal -menu $m -width 8 -pady 4 \
997                -state disabled
998        } else {
999            menubutton $w -text Signal... -menu $m -relief raised \
1000                -width 10 -font $f -state disabled
1001        }
1002        menu $m
1003        $m add radiobutton -label "auto" -command restart \
1004                -value auto -variable inputType -font $f
1005        $m add radiobutton -label "NTSC" -command restart \
1006                -value ntsc -variable inputType -font $f
1007        $m add radiobutton -label "PAL" -command restart \
1008                -value pal -variable inputType -font $f
1009        $m add radiobutton -label "SECAM" -command restart \
1010                -value secam -variable inputType -font $f
1011
1012        global inputType typeButton
1013        #set inputType auto
1014        set inputType [string tolower [option get . inputType Vic]]
1015        set typeButton $w
1016}
1017
1018proc build.encoder_buttons w {
1019        set f [smallfont]
1020        build.encoder_options $w.options
1021        build.device $w.device
1022        build.port $w.port
1023        build.type $w.type
1024        pack $w.device $w.port $w.type $w.options -fill x
1025}
1026
1027proc build.encoder_options w {
1028        global useJPEGforH261 tcl_platform useHardwareComp
1029        set useJPEGforH261 [yesno useJPEGforH261]
1030        set useHardwareComp [yesno useHardwareComp]
1031        set f [smallfont]
1032        set m $w.menu
1033        if {[string match [ windowingsystem] "aqua"]} {
1034            menubutton $w -text Options -menu $m -width 8 -pady 4
1035        } else {
1036            menubutton $w -text Options... -menu $m -relief raised -width 10 \
1037                -font $f
1038        }
1039        menu $m
1040        $m add checkbutton -label "Sending Slides" \
1041                -variable sendingSlides -font $f -command setFillRate
1042        $m add checkbutton -label "Use JPEG for H261" \
1043                -variable useJPEGforH261 -font $f -command restart
1044                $m add checkbutton -label "Use Hardware Encode" \
1045                -variable useHardwareComp -font $f -command restart
1046        if { $tcl_platform(platform) == "windows" || [string match [ windowingsystem] "aqua"] } {
1047                        $m add checkbutton -label "Configure on Transmit" \
1048                        -variable configOnTransmit -font $f \
1049                        -command  "grabber useconfig \$configOnTransmit"
1050                }
1051}
1052
1053proc build.tile w {
1054        set f [smallfont]
1055        set m $w.menu
1056        if {[string match [ windowingsystem] "aqua"]} {
1057            menubutton $w -text Tile -menu $m -width 8 -pady 4
1058        } else {
1059            menubutton $w -text Tile... -menu $m -relief raised -width 10 \
1060                        -font $f
1061        }
1062        menu $m
1063        $m add radiobutton -label Single -command "redecorate 1" \
1064                -value 1 -variable V(ncol) -font $f
1065        $m add radiobutton -label Double -command "redecorate 2" \
1066                -value 2 -variable V(ncol) -font $f
1067        $m add radiobutton -label Triple -command "redecorate 3" \
1068                -value 3 -variable V(ncol) -font $f
1069        $m add radiobutton -label Quad -command "redecorate 4" \
1070                -value 4 -variable V(ncol) -font $f
1071}
1072
1073proc build.decoder_options w {
1074        set f [smallfont]
1075        set m $w.menu
1076        if {[string match [ windowingsystem] "aqua"]} {
1077            menubutton $w -text Options -menu $m -width 8 -pady 4
1078        } else {
1079            menubutton $w -text Options... -menu $m -relief raised -width 10 \
1080                -font $f
1081        }
1082        menu $m
1083        $m add checkbutton -label "Mute New Sources" \
1084                -variable V(muteNewSources) -font $f
1085        $m add checkbutton -label "Use Hardware Decode" \
1086                -variable V(useHardwareDecode) -font $f
1087        $m add separator
1088        $m add command -label "Optimize Colormap" \
1089                -command fork_histtolut -font $f
1090
1091        global V
1092        set V(optionsMenu) $m
1093        if ![have dither] {
1094                $m entryconfigure "Optimize Colormap" -state disabled
1095        }
1096}
1097
1098proc build.external w {
1099        set f [smallfont]
1100        set m $w.menu
1101        global outputDeviceList
1102        if ![info exists outputDeviceList] {
1103                set outputDeviceList ""
1104        }
1105        if { [llength $outputDeviceList] <= 1 } {
1106                button $w -text External -relief raised \
1107                        -width 10 -font $f -highlightthickness 0 \
1108                        -command "extout_select $outputDeviceList"
1109        } else {
1110                menubutton $w -text External... -menu $m -relief raised \
1111                        -width 10 -font $f 
1112                menu $m
1113                foreach d $outputDeviceList {
1114                        $m add command -font $f -label [$d nickname] \
1115                                -command "extout_select $d"
1116                }
1117        }
1118        if { $outputDeviceList == "" } {
1119                $w configure -state disabled
1120        }
1121}
1122
1123proc build.dither w {
1124        set f [smallfont]
1125        if [have dither] {
1126                set var V(dither)
1127                set state normal
1128        } else {
1129                set var dummyDither
1130                set state disabled
1131        }
1132        set v $w.h0
1133        frame $v
1134        radiobutton $v.b0 -text "Ordered" -command set_dither \
1135                -padx 0 -pady 0 \
1136                -anchor w -variable $var -state $state \
1137                -font $f -relief flat -value od
1138        radiobutton $v.b1 -text "Error Diff" -command set_dither \
1139                -padx 0 -pady 0 \
1140                -anchor w -variable $var -state $state \
1141                -font $f -relief flat -value ed
1142        set v $w.h1
1143        frame $v
1144        radiobutton $v.b2 -text Quantize -command set_dither \
1145                -padx 0 -pady 0 \
1146                -anchor w -variable $var -state $state \
1147                -font $f -relief flat \
1148                -value quantize
1149        radiobutton $v.b3 -text Gray -command set_dither \
1150                -padx 0 -pady 0 \
1151                -anchor w -variable $var -state $state \
1152                -font $f -relief flat -value gray
1153
1154        pack $w.h0.b0 $w.h0.b1 -anchor w -fill x
1155        pack $w.h1.b2 $w.h1.b3 -anchor w -fill x
1156        pack $w.h0 $w.h1 -side left
1157}
1158
1159proc update_gamma { w s } {
1160        global V win_src
1161        set cm $V(colorModel)
1162        if ![$cm gamma $s] {
1163                return -1
1164        }
1165        set V(gamma) $s
1166        $cm free-colors
1167        if ![$cm alloc-colors] {
1168                revert_to_gray
1169        }
1170        #
1171        # Need to update all the windows.  Can't just do a redraw
1172        # on all the windows because that won't cause the renderer's
1173        # to update their copy of the image (which has the old colormap
1174        # installed).  Instead, go through all the active decoders and
1175        # force them to update all the windows.
1176        #
1177        foreach src [session active] {
1178                set d [$src handler]
1179                if { $d != "" } {
1180                        $d redraw
1181                }
1182        }
1183
1184        return 0
1185}
1186
1187proc build.gamma w {
1188        global V
1189        frame $w
1190        label $w.label -text "Gamma: " -font [smallfont] -anchor e
1191        mk.entry $w update_gamma $V(gamma)
1192        $w.entry configure -width 6
1193        if ![have dither] {
1194                $w.entry configure -state disabled -foreground gray60
1195                $w.label configure -foreground gray60
1196        }
1197        pack $w.label -side left
1198        pack $w.entry -side left -expand 1 -fill x -pady 2
1199}
1200
1201proc build.decoder w {
1202        set f [smallfont]
1203
1204        label $w.title -text Display
1205        frame $w.f -relief sunken -borderwidth 2
1206
1207        set v $w.f.h0
1208        frame $v
1209
1210        build.external $v.ext
1211        build.tile $v.tile
1212        build.decoder_options $v.options
1213
1214        pack $v.options $v.tile $v.ext -fill x -expand 1
1215
1216        set v $w.f.h2
1217        frame $v
1218        frame $v.dither -relief groove -borderwidth 2
1219        build.dither $v.dither
1220        frame $v.bot
1221        build.gamma $v.bot.gamma
1222        label $v.bot.mode -text "\[[winfo depth .top]-bit\]" -font $f
1223        pack $v.bot.gamma $v.bot.mode -side left -padx 4
1224        pack $v.dither -side left -anchor c -pady 2
1225        pack $v.bot -side left -anchor c -pady 2
1226
1227        pack $w.f.h0 -side left -padx 6 -pady 6
1228        pack $w.f.h2 -side left -padx 6 -pady 6 -fill x -expand 1
1229
1230        pack $w.title $w.f -fill x
1231}
1232
1233proc build.encoder w {
1234        label $w.title -text Encoder
1235        frame $w.f -relief sunken -borderwidth 2
1236
1237        frame $w.f.h0 -relief flat
1238        frame $w.f.quality -relief flat
1239        frame $w.f.h0.eb -relief flat
1240        frame $w.f.h0.format -relief groove -borderwidth 2
1241        frame $w.f.h0.size -relief groove -borderwidth 2
1242        frame $w.f.h0.gap -relief flat -width 4
1243
1244        build.encoder_buttons $w.f.h0.eb
1245        build.format $w.f.h0.format
1246        build.size $w.f.h0.size
1247
1248        build.q $w.f.quality
1249
1250        pack $w.f.h0.eb -side left -anchor n -fill y -padx 6 -pady 4
1251        pack $w.f.h0.format -side left -anchor n -fill both -expand 1
1252        pack $w.f.h0.size -side left -anchor c -fill both
1253        pack $w.f.h0.gap -side left -anchor c
1254
1255        pack $w.f.h0 -fill x -pady 4
1256        pack $w.f.quality -fill x -pady 6
1257        pack $w.title $w.f -fill x
1258}
1259
1260proc jpeg_setq value {
1261        global useHardwareComp videoDevice
1262        incr value
1263        if { $value > 95 } {
1264                set value 95
1265        } elseif { $value < 5 } {
1266                set value 5
1267        }
1268
1269        set DA [$videoDevice attributes]
1270        set DF [attribute_class $DA format]
1271        if { [inList "jpeg" $DF] && $useHardwareComp } {
1272                grabber q $value
1273        } elseif [have grabber] {
1274                encoder q $value
1275        }       
1276       
1277        global qvalue
1278        $qvalue configure -text $value
1279}
1280
1281proc h261_setq value {
1282        set value [expr int((1 - $value / 100.) * 29) + 1]
1283        if [have grabber] {
1284                encoder q $value
1285        }
1286        global qvalue
1287        $qvalue configure -text $value
1288}
1289
1290proc h261as_setq value {
1291        set value [expr int((1 - $value / 100.) * 29) + 1]
1292        if [have grabber] {
1293                encoder q $value
1294        }
1295        global qvalue
1296        $qvalue configure -text $value
1297}
1298
1299proc h263+_setq value {
1300        set value [expr int((1 - $value / 100.) * 29) + 1]
1301        if [have grabber] {
1302                encoder q $value
1303        }
1304        global qvalue
1305        $qvalue configure -text $value
1306}
1307
1308proc h263_setq value {
1309        set value [expr int((1 - $value / 100.) * 29) + 1]
1310        if [have grabber] {
1311                encoder q $value
1312        }
1313        global qvalue
1314        $qvalue configure -text $value
1315}
1316
1317proc nv_setq value {
1318        set value [expr (100 - $value) / 10]
1319        if [have grabber] {
1320                encoder q $value
1321        }
1322        global qvalue
1323        $qvalue configure -text $value
1324}
1325
1326proc nvdct_setq value {
1327        nv_setq $value
1328        global qvalue
1329        $qvalue configure -text $value
1330}
1331
1332proc raw_setq value {
1333        set value 1
1334        if [have grabber] {
1335                encoder q $value
1336        }
1337        global qvalue
1338        $qvalue configure -text $value
1339}
1340
1341set bvc_quantizer(0) { 0 0 0 0 1 1 1 1 2 2 }
1342set bvc_quantizer(1) { 0 0 0 1 1 1 1 1 2 3 }
1343set bvc_quantizer(2) { 0 0 0 1 1 1 1 2 3 3 }
1344set bvc_quantizer(3) { 0 0 0 1 1 1 2 2 4 4 }
1345set bvc_quantizer(4) { 0 0 0 2 2 2 3 3 4 4 }
1346set bvc_quantizer(5) { 0 0 0 2 2 2 3 4 4 4 }
1347set bvc_quantizer(6) { 0 0 0 2 2 2 4 4 5 5 }
1348set bvc_quantizer(7) { 0 0 0 2 3 3 4 5 5 5 }
1349set bvc_quantizer(8) { 0 0 0 2 3 4 6 6 6 6 }
1350set bvc_quantizer(9) { 2 2 2 3 6 5 7 7 7 7 }
1351
1352
1353proc bvc_setq value {
1354        set value [expr 9 - $value / 10]
1355        if [have grabber] {
1356                global bvc_quantizer
1357                set n 0
1358                foreach q $bvc_quantizer($value) {
1359                        encoder q $n [expr 7 - $q]
1360                        incr n
1361                }
1362        }
1363        global qvalue
1364        $qvalue configure -text $value
1365}
1366
1367set pvh_shmap { 0 1 2 1 }
1368set pvh_shs {
1369        { lum-dct 0 5-1--11- }
1370        { lum-dct 1 ---5111- }
1371        { lum-dct 2 --51-11- }
1372        { lum-sbc 0 ----4--2 }
1373        { lum-sbc 1 ----4--2 }
1374        { lum-sbc 2 ----4--2 }
1375        { chm     0 -5---1-- }
1376        { chm     1 ---5-1-- }
1377        { chm     2 --5--1-- }
1378}
1379
1380#
1381# Format specific routine to map generic quality <i>value</i>
1382# into actions that program the underlying PVH codec.
1383#
1384#VideoPipeline instproc
1385#
1386proc pvh_setq value {
1387#       $self instvar encoder_
1388#       if ![info exists encoder_] {
1389#               return -1
1390#       }
1391        if [have grabber] {
1392                #encoder q $value
1393
1394                #XXX ignore value and just set up the bit allocation
1395                #XXX should have variable strategies here
1396                global pvh_shmap pvh_shs
1397                set n [llength $pvh_shmap]
1398                set i 0
1399                while { $i < $n } {
1400                        encoder shmap $i [lindex $pvh_shmap $i]
1401                        incr i
1402                }
1403                set i 0
1404                foreach tuple $pvh_shs {
1405                        set compID [lindex $tuple 0]
1406                        set shID [lindex $tuple 1]
1407                        set pattern [lindex $tuple 2]
1408                        encoder comp $compID $shID $pattern
1409                }
1410                global qvalue
1411                $qvalue configure -text $value
1412               
1413                return 0
1414        }
1415        #XXX
1416        return -1
1417}
1418
1419#
1420# If the capture device is open, close it.  If transmission
1421# was active fire it up again.  Some state can only be set at
1422# device open time, so some controls must resort to this proc.
1423#
1424proc restart { } {
1425        if [have grabber] {
1426                global transmitButtonState logoButtonState videoDevice V
1427       
1428                # HANDLE TRANSMIT LOGO
1429                if $logoButtonState {
1430                        logo_quit
1431                        logo_transmit
1432                } else {
1433                        logo_quit
1434                }
1435
1436                # HANDLE TRANSMIT VIDEO
1437                if $transmitButtonState {
1438                        $V(grabber) send 0
1439                        close_device
1440                        transmit
1441                } else {
1442                        close_device
1443                }
1444               
1445        }
1446}
1447
1448proc disable_large_button { } {
1449        global sizeButtons inputSize
1450        if { $inputSize == 1 } {
1451                set inputSize 2
1452        }
1453        $sizeButtons.b2 configure -state disabled
1454}
1455
1456proc enable_large_button { } {
1457        global sizeButtons videoDevice
1458        if { [info exists videoDevice] && \
1459                [device_supports $videoDevice size large] } {
1460                $sizeButtons.b2 configure -state normal
1461        }
1462}
1463
1464set qscale_val(h261) 68
1465set qscale_val(h261as) 68
1466set qscale_val(h263) 68
1467set qscale_val(h263+) 68
1468set qscale_val(nv) 80
1469set qscale_val(nvdct) 80
1470set qscale_val(bvc) 60
1471set qscale_val(jpeg) 29
1472set qscale_val(raw) 1
1473set lastFmt ""
1474
1475proc select_format fmt {
1476        global qscale qlabel videoDevice videoFormat qscale_val lastFmt
1477
1478        if { $fmt == "h261" || $fmt == "pvh"} {
1479                # H.261 supports only QCIF/CIF
1480                disable_large_button
1481        } else {
1482                enable_large_button
1483        }
1484
1485        if { $fmt == "pvh"} {
1486                set w .menu.encoder.f.encoderLayer
1487                if ![winfo exists $w] {
1488                        frame $w
1489                        build.encoderLayer_scale $w
1490                }
1491                pack $w -before .menu.encoder.f.quality  -fill x
1492        } else {
1493                pack forget .menu.encoder.f.encoderLayer
1494        }
1495
1496        set qscale_val($lastFmt) [$qscale get]
1497        set lastFmt $videoFormat
1498
1499        set proc $fmt\_setq
1500        if [inList $proc [info commands *_setq]] {
1501                $qscale configure -state normal -command $proc
1502                $qlabel configure -foreground black
1503        } else {
1504                $qscale configure -state disabled
1505                $qlabel configure -foreground gray40
1506        }
1507        set qual [resource quality]
1508        if { $qual > 0 } {
1509                $qscale set [resource quality]
1510        } else { if [info exists qscale_val($fmt)] {
1511                $qscale set $qscale_val($fmt)
1512        }}
1513        if [have grabber] {
1514                global V
1515                set encoder [create_encoder $videoFormat]
1516
1517# MM
1518#               if { [info procs build.$devname\_$videoFormat] != "" } {
1519#                       if ![winfo exists $w] {
1520#                               frame $w
1521#                               build.$devname $w
1522#                       }
1523#                       pack $w -before .menu.encoder -padx 6 -fill x
1524#                       set grabberPanel $w
1525#               }
1526# MM
1527
1528                set ff [$encoder frame-format]
1529                if { "$ff" == "[$V(encoder) frame-format]" } {
1530                        #
1531                        # new framer has the same format as the
1532                        # old one.  just replace the old one without
1533                        # re-initializing the grabber.
1534                        # XXX doens't work if title-maker is installed
1535                        # SV, title-maker fix: see marked code below
1536                        delete $V(encoder)
1537                        set V(encoder) $encoder
1538
1539                        update_encoder_param
1540
1541                        $encoder transmitter $V(session)
1542                       
1543                        # SV ######################
1544                        global logoButtonState                 
1545                        if $logoButtonState {
1546                                logo_quit
1547                                logo_transmit
1548                        } else {
1549                                logo_quit
1550                        }                       
1551                        ###########################
1552                } else {
1553                        #
1554                        # Restart the grabber.
1555                        #
1556                        delete $encoder
1557                        restart
1558                }
1559        }
1560}
1561
1562proc init_grabber { grabber } {
1563        global V configOnTransmit tcl_platform
1564
1565        if { $tcl_platform(platform) == "windows" || [string match [ windowingsystem] "aqua"] } {
1566                $grabber useconfig $configOnTransmit
1567        }
1568
1569        if { [$grabber need-capwin] && ![have capwin] } {
1570                #
1571                # we need to create a window for input devices that
1572                # require capturing to the frame buffer.  create but
1573                # don't map it until after we call "$grabber decimate"
1574                # to specify it's size
1575                #
1576                set rgd [option get . localPlxDisplay $V(class)]
1577                if { $rgd != "" } {
1578                        open_dialog "Using Remote Grabbing Display $rgd"
1579                        toplevel .capture -class Vic -screen $rgd
1580                } else {
1581                        toplevel .capture -class Vic
1582                }
1583                wm title .capture "Video Capture Window"
1584                $grabber create-capwin .capture.video
1585                set V(capwin) .capture.video
1586                pack .capture.video
1587           
1588                # capture window shouldn't be covered
1589                bind .capture <Visibility> "raise .capture"
1590        }
1591
1592        $grabber transmitter $V(session)
1593        global qscale inputSize fps_slider bps_slider videoDevice
1594        global inputPort inputType portButton typeButton
1595        # MacOS-X requires port and input type to be set before decimate
1596        # is called otherwise the channel device's input may be busy
1597        if {[string match [ windowingsystem] "aqua"]} {
1598            if { [$portButton cget -state] == "normal" } {
1599                  $grabber port $inputPort
1600            }
1601        }
1602            if { [$typeButton cget -state] == "normal" } {
1603                  $grabber type $inputType
1604            }
1605       
1606        $grabber fps [$fps_slider get]
1607        $grabber bps [$bps_slider get]
1608        $grabber decimate $inputSize
1609        if { [lindex [$qscale configure -state] 4] == "normal" } {
1610                set cmd [lindex [$qscale configure -command] 4]
1611                $cmd [$qscale get]
1612        }
1613        if !{[string match [ windowingsystem] "aqua"]} {
1614            if { [$portButton cget -state] == "normal" } {
1615                $grabber port $inputPort
1616            }
1617            if { [$typeButton cget -state] == "normal" } {
1618                $grabber type $inputType
1619            }
1620        }
1621        setFillRate
1622        update
1623}
1624
1625proc build.q w {
1626        set f [smallfont]
1627        frame $w.tb
1628        label $w.title -text "Quality" -font $f -anchor w
1629        label $w.tb.value -text 0 -font $f -width 3
1630        scale $w.tb.scale -font $f -orient horizontal \
1631                -showvalue 0 -from 0 -to 99 \
1632                -width 12 -relief groove
1633        global qscale qvalue qlabel
1634        set qscale $w.tb.scale
1635        set qvalue $w.tb.value
1636        set qlabel $w.title
1637
1638        pack $w.tb.scale -side left -fill x -expand 1
1639        pack $w.tb.value -side left
1640        pack $w.title -padx 2 -side left
1641        pack $w.tb -fill x -padx 6 -side left -expand 1
1642}
1643
1644proc build.xmit w {
1645        set f [smallfont]
1646
1647        label $w.label -text Transmission
1648        frame $w.frame -relief sunken -borderwidth 2
1649        pack $w.label -fill x
1650        pack $w.frame -fill both -expand 1
1651        frame $w.frame.buttons
1652        build.buttons $w.frame.buttons
1653       
1654        frame $w.frame.combined
1655       
1656        frame $w.frame.combined.right
1657        build.sliders $w.frame.combined.right
1658        frame $w.frame.combined.tm
1659        build.titlemaker $w.frame.combined.tm
1660
1661        pack $w.frame.combined.right -side top -expand 1 -fill x -padx 10 -anchor w
1662        pack $w.frame.combined.tm -side bottom -expand 1 -fill y -pady 10 -anchor w
1663       
1664        pack $w.frame.buttons -side left -padx 6
1665        pack $w.frame.combined -side right -expand 1 -fill x -padx 10 -anchor c
1666
1667       
1668}
1669
1670proc set_dither {} {
1671        global win_src
1672        set wlist [array names win_src]
1673        foreach w $wlist {
1674                set ws($w) $win_src($w)
1675                detach_window $win_src($w) $w
1676        }
1677        if ![init_color] {
1678                revert_to_gray
1679        }
1680        foreach w $wlist {
1681                attach_window $ws($w) $w
1682        }
1683}       
1684
1685proc revert_to_gray {} {
1686        global V
1687        if { $V(dither) == "gray" } {
1688                #XXX
1689                puts stderr "vic: out of colors"
1690                exit 1
1691        }
1692        open_dialog "ran out of colors; reverting to gray"
1693        set V(dither) gray
1694        set_dither
1695}
Note: See TracBrowser for help on using the browser.