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

Revision 4060, 41.9 KB (checked in by piers, 7 years ago)

Patches for tcl/tk-80 compatibility
- One bug report/patch from Christoph Willing <willing@…> but I modified it to use a catch statement as it's nice to have the zero padding for video windows. It seems that there's xero padding on tcl/tck-80 anyway.
- Patch from Doug Kosovic (6june07) for his updates to V4L controls

  • 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            if { [$typeButton cget -state] == "normal" } {
1602                  $grabber type $inputType
1603            }
1604        }
1605        $grabber fps [$fps_slider get]
1606        $grabber bps [$bps_slider get]
1607        $grabber decimate $inputSize
1608        if { [lindex [$qscale configure -state] 4] == "normal" } {
1609                set cmd [lindex [$qscale configure -command] 4]
1610                $cmd [$qscale get]
1611        }
1612        if !{[string match [ windowingsystem] "aqua"]} {
1613            if { [$portButton cget -state] == "normal" } {
1614                $grabber port $inputPort
1615            }
1616            if { [$typeButton cget -state] == "normal" } {
1617                $grabber type $inputType
1618            }
1619        }
1620        setFillRate
1621        update
1622}
1623
1624proc build.q w {
1625        set f [smallfont]
1626        frame $w.tb
1627        label $w.title -text "Quality" -font $f -anchor w
1628        label $w.tb.value -text 0 -font $f -width 3
1629        scale $w.tb.scale -font $f -orient horizontal \
1630                -showvalue 0 -from 0 -to 99 \
1631                -width 12 -relief groove
1632        global qscale qvalue qlabel
1633        set qscale $w.tb.scale
1634        set qvalue $w.tb.value
1635        set qlabel $w.title
1636
1637        pack $w.tb.scale -side left -fill x -expand 1
1638        pack $w.tb.value -side left
1639        pack $w.title -padx 2 -side left
1640        pack $w.tb -fill x -padx 6 -side left -expand 1
1641}
1642
1643proc build.xmit w {
1644        set f [smallfont]
1645
1646        label $w.label -text Transmission
1647        frame $w.frame -relief sunken -borderwidth 2
1648        pack $w.label -fill x
1649        pack $w.frame -fill both -expand 1
1650        frame $w.frame.buttons
1651        build.buttons $w.frame.buttons
1652       
1653        frame $w.frame.combined
1654       
1655        frame $w.frame.combined.right
1656        build.sliders $w.frame.combined.right
1657        frame $w.frame.combined.tm
1658        build.titlemaker $w.frame.combined.tm
1659
1660        pack $w.frame.combined.right -side top -expand 1 -fill x -padx 10 -anchor w
1661        pack $w.frame.combined.tm -side bottom -expand 1 -fill y -pady 10 -anchor w
1662       
1663        pack $w.frame.buttons -side left -padx 6
1664        pack $w.frame.combined -side right -expand 1 -fill x -padx 10 -anchor c
1665
1666       
1667}
1668
1669proc set_dither {} {
1670        global win_src
1671        set wlist [array names win_src]
1672        foreach w $wlist {
1673                set ws($w) $win_src($w)
1674                detach_window $win_src($w) $w
1675        }
1676        if ![init_color] {
1677                revert_to_gray
1678        }
1679        foreach w $wlist {
1680                attach_window $ws($w) $w
1681        }
1682}       
1683
1684proc revert_to_gray {} {
1685        global V
1686        if { $V(dither) == "gray" } {
1687                #XXX
1688                puts stderr "vic: out of colors"
1689                exit 1
1690        }
1691        open_dialog "ran out of colors; reverting to gray"
1692        set V(dither) gray
1693        set_dither
1694}
Note: See TracBrowser for help on using the browser.