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

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

Added dynamic check for h263 & h264 codecs - to control display of the codecs in the control panel.

  • 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] && $useJPEGforH261 } {
354                        # just jpeg->h261 at this time
355                        set transcoder [new transcoder jpeg/dct]
356                        set encoder [new module h261/dct]
357                        $transcoder target $encoder
358                        set grabtarget $transcoder
359                        set grabq "70"
360                } elseif { [inList $videoFormat [device_formats $videoDevice] ] } {
361                        set encoder [create_encoder $videoFormat]
362                        set grabtarget $encoder
363                        set grabq ""
364                }
365
366                $encoder transmitter $V(session)
367
368                $encoder loop_layer [expr {$numEncoderLayers + 1}]
369               
370                set V(encoder) $encoder
371                set ff [$grabtarget frame-format]
372                set V(grabber) [$videoDevice open $ff]
373                # special cases
374                if { $V(grabber) == "" && $ff == "411" } {
375                        # try cif instead of 411
376                        set V(grabber) [$videoDevice open cif]
377                }
378                if { $V(grabber) == "" } {
379                        #XXX
380                        puts "Error: grabber=\"\" puts XXX couldn't set up grabber/encoder for $ff->$videoFormat"
381                        exit 1
382                }
383                set error [$V(grabber) status]
384                if { $error < 0 } {
385                        close_device
386                        if { $error == -2 } {
387                                #XXX hack: this happens when we tried to open
388                                # a jvideo with a non-jpeg format
389                                set transmitButtonState 0
390                                set logoButtonState 0
391                                open_dialog \
392                                    "Can't use jvideo with $videoFormat format"
393                                select_device $videoDevice
394                                return
395                        }
396                        set transmitButtonState 0
397                        set logoButtonState 0
398                        open_dialog \
399                            "can't open [$videoDevice nickname] capture device"
400                        return
401                }
402               
403               
404                init_grabber $V(grabber)
405                if ![tm_init $V(grabber) $grabtarget] {
406                        $V(grabber) target $grabtarget
407                }
408
409                if { $grabq != "" } {
410                        $V(grabber) q $grabq
411                }
412        }
413        if [have capwin] {
414                set w [winfo toplevel $V(capwin)]
415                if $transmitButtonState {
416                        wm deiconify $w
417                } else {
418                        wm withdraw $w
419                }
420                update idletasks
421        }
422
423        update_encoder_param
424        $V(grabber) send $transmitButtonState
425}
426
427proc close_device {} {
428        global V
429        # XXX: bypassing the pure virtual funtion call problem under macosx
430        # need to figure out where is the bug
431        if { ![string match [ windowingsystem] "aqua"]} {
432            delete $V(encoder)
433            delete $V(grabber)
434            unset V(grabber)
435            unset V(encoder)
436        }
437        if [info exists V(capwin)] {
438                # delete the C++ object, then destrory the tk window
439                delete $V(capwin)
440                destroy [winfo toplevel $V(capwin)]
441                unset V(capwin)
442        }
443}
444
445proc release_device { } {
446        global transmitButtonState transmitButton
447        global logoButtonState logoButton
448
449        if [have grabber] {
450       
451                if $logoButtonState {
452                        $logoButton invoke
453                }
454                logo_quit
455       
456                if $transmitButtonState {
457                        $transmitButton invoke
458                }
459                close_device
460        }
461
462}
463
464proc configWinGrabber {} {
465        global configOnTransmit
466        grabber useconfig $configOnTransmit
467}
468
469proc build.buttons w {
470        set f [smallfont]
471        global transmitButton
472        set transmitButton $w.send
473        global logoButton
474        set logoButton $w.logo
475
476        checkbutton $w.send -text "Transmit" \
477                -relief raised -command transmit \
478                -anchor w -variable transmitButtonState -font $f \
479                -state disabled -highlightthickness 0
480#       checkbutton $w.freeze -text "Freeze" \
481#               -relief raised -command "grabber freeze \$freeze" \
482#               -anchor w -variable freeze -font $f \
483#               -highlightthickness 0
484        button $w.release -text "Release" \
485                -relief raised -command release_device \
486                -font $f -highlightthickness 0
487        checkbutton $w.logo -text "Overlay" \
488                -relief raised -command logo_transmit \
489                -anchor w -variable logoButtonState -font $f \
490                -state normal -highlightthickness 0
491               
492#       pack $w.send $w.release $w.freeze -fill both
493        pack $w.send $w.logo $w.release -fill both
494}
495
496proc doNothing { args } {
497}
498
499proc update_encoder_param {  } {
500        global videoFormat fps_slider bps_slider
501        if {$videoFormat == "mpeg4" || $videoFormat == "h264"} {
502            encoder kbps [$bps_slider get]
503            encoder fps [$fps_slider get]
504        }
505}
506
507proc set_bps { w value } {
508        global videoFormat
509
510        if [have grabber] {
511            grabber bps $value
512            if {$videoFormat == "mpeg4" || $videoFormat == "h264"} {
513                encoder kbps $value
514            }
515
516        #XXX
517            session data-bandwidth $value
518        }
519        $w configure -text "$value bps"
520}
521
522proc set_fps { w value } {
523        global videoFormat
524
525        if [have grabber] {     
526          grabber fps $value
527          if {$videoFormat == "mpeg4" || $videoFormat == "h264"} {
528                encoder fps $value
529          }
530        }
531        $w configure -text "$value fps"
532}
533
534proc build.sliders w {
535        set f [smallfont]
536
537        global V
538        set key $V(session)
539        global ftext btext
540        set ftext($key) "0.0 f/s"
541        set btext($key) "0.0 kb/s"
542
543        frame $w.info
544        label $w.info.label -text "Rate Control" -font $f
545        label $w.info.fps -textvariable ftext($key) -width 6 \
546                -font $f -pady 0 -borderwidth 0
547    label $w.info.bps -textvariable btext($key) -width 8 \
548                -font $f -pady 0 -borderwidth 0
549        pack $w.info.label -side left
550        pack $w.info.bps $w.info.fps -side right
551       
552        frame $w.bps
553        scale $w.bps.scale -orient horizontal -font $f \
554                -showvalue 0 -from 1 -to [option get . maxbw Vic] \
555                -command "set_bps $w.bps.value" -width 12 \
556                -sliderlength 20 \
557                -relief groove
558        label $w.bps.value -font $f -width 8 -anchor w
559
560        frame $w.fps
561        scale $w.fps.scale -font $f -orient horizontal \
562                -showvalue 0 -from 1 -to 30 \
563                -command "set_fps $w.fps.value" -width 12 \
564                -sliderlength 20 \
565                -relief groove
566        label $w.fps.value -font $f -width 8 -anchor w
567
568        pack $w.info -fill x
569        pack $w.bps $w.fps -fill x
570        pack $w.bps.scale -side left -fill x -expand 1
571        pack $w.bps.value -side left -anchor w
572        pack $w.fps.scale -fill x -side left -expand 1
573        pack $w.fps.value -side left -anchor w
574       
575        $w.bps.scale set [option get . bandwidth Vic]
576        $w.fps.scale set [option get . framerate Vic]
577
578        global fps_slider bps_slider
579        set fps_slider $w.fps.scale
580        set bps_slider $w.bps.scale
581}
582
583proc attribute_class { attr class } {
584        while { [llength $attr] >= 2 } {
585                if { [lindex $attr 0] == $class } {
586                        return [lindex $attr 1]
587                }
588                set attr [lrange $attr 2 end]
589        }
590        return ""
591}
592
593proc inList { item L } {
594        foreach v $L {
595                if { $v == $item } {
596                        return 1
597                }
598        }
599        return 0
600}
601
602#
603# Returns true iff device named by $device has an attribute named
604# $attr in the attribute class $class.  For example,
605# "device_supports vl size cif" would return true.
606# if $attr is "*", then returns true iff the indicated $class
607# exists in the attribute list (for example, "device_supports $d port *"
608# says whether a device supports port selection at all)
609#
610proc device_supports { device class attr } {
611        set L [$device attributes]
612        set L [attribute_class $L $class]
613        if { $attr == "*" } {
614                if { $L == "" } {
615                        return 0
616                } else {
617                        return 1
618                }
619        } else {
620                return [inList $attr $L]
621        }
622}
623
624# device_formats: any type of stream produce-able from this device
625# (not necessarily native)
626proc device_formats device {
627        set L [$device attributes]
628        set sizes [attribute_class $L size]
629        set formats [attribute_class $L format]
630        set fmtList ""
631        if [inList 422 $formats] {
632                set fmtList "$fmtList nv nvdct cellb jpeg raw"
633        }
634        if [inList 411 $formats] {
635                set fmtList "$fmtList bvc pvh"
636        }
637        if [inList cif $sizes] {
638                set fmtList "$fmtList h261 h261as h263+ h263 mpeg4 h264"
639        }
640        if [inList jpeg $formats] {
641                set fmtList "$fmtList jpeg"
642                global useJPEGforH261
643                if $useJPEGforH261 {
644                        set fmtList "$fmtList h261"
645                }
646        }
647        return $fmtList
648}
649
650#
651# called when selecting a new device: insert a grabber control panel
652# if it exists and remove the old one (if one was installed)
653#
654proc insert_grabber_panel devname {
655        set k [string first - $devname]
656        if { $k >= 0 } {
657                incr k -1
658                set devname [string tolower [string range $devname 0 $k]]
659        }
660        regsub -all " " $devname "_" devname
661        set w .menu.$devname
662        global grabberPanel
663        if [info exists grabberPanel] {
664                if { "$grabberPanel" == "$w" } {
665                        return
666                }
667                pack forget $grabberPanel
668                unset grabberPanel
669        }
670        if { [info procs build.$devname] != "" } {
671                if ![winfo exists $w] {
672                        frame $w
673                        build.$devname $w
674                }
675                pack $w -before .menu.encoder -padx 6 -fill x
676                set grabberPanel $w
677        }
678}
679
680#
681# Called when use selects a particular device (like videopix or xil)
682# (and at startup for default device)
683#
684proc select_device device {
685        global transmitButton logoButton sizeButtons portButton formatButtons \
686                videoFormat defaultFormat lastDevice defaultPort inputPort \
687                transmitButtonState logoButtonState typeButton
688
689        #
690        # Remember settings of various controls for previous device
691        # and close down the device if it's already open
692        #
693        set wasTransmitting $transmitButtonState
694        set wasOverlaying $logoButtonState
695        if [info exists lastDevice] {
696                set defaultFormat($lastDevice) $videoFormat
697                set defaultPort($lastDevice) $inputPort
698                release_device
699        }
700        set lastDevice $device
701
702        set fmtList [device_formats $device]
703        foreach b $formatButtons {
704                set fmt [lindex [$b configure -value] 4]
705                #XXX
706                if { $fmt == "bvc" && ![yesno enableBVC] } {
707                        $b configure -state disabled
708                } elseif { [inList $fmt $fmtList] } {
709                        $b configure -state normal
710                } else {
711                        $b configure -state disabled
712                }
713        }
714        $transmitButton configure -state normal
715        $logoButton configure -state normal
716        if [device_supports $device size small] {
717                $sizeButtons.b0 configure -state normal
718        } else {
719                $sizeButtons.b0 configure -state disabled
720        }
721        if [device_supports $device size large] {
722                $sizeButtons.b2 configure -state normal
723        } else {
724                $sizeButtons.b2 configure -state disabled
725        }
726        if [device_supports $device port *] {
727                $portButton configure -state normal
728                attach_ports $device
729        } else {
730                $portButton configure -state disabled
731        }
732        if [device_supports $device type *] {
733                $typeButton configure -state normal
734        } else {
735                $typeButton configure -state disabled
736        }
737        insert_grabber_panel [$device nickname]
738
739        #set videoFormat $defaultFormat($device)
740        select_format $videoFormat
741        if $wasOverlaying {
742                $logoButton invoke
743        }
744        if $wasTransmitting {
745                $transmitButton invoke
746        }
747}
748
749proc build.device w {
750        set f [smallfont]
751
752        set m $w.menu
753        if {[string match [ windowingsystem] "aqua"]} {
754            menubutton $w -menu $m -text Device -width 8 -pady 4
755        } else {
756            menubutton $w -menu $m -text Device... \
757                -relief raised -width 10 -font $f
758        }
759        menu $m
760
761        global defaultFormat inputDeviceList videoFormat
762        set videoFormat [option get . defaultFormat Vic]
763        if { $videoFormat == "h.261" } {
764                set videoFormat h261
765        } elseif { $videoFormat == "h.263plus"} {
766                set videoFormat h263+
767        } elseif { $videoFormat == "mpeg4"} {
768                set videoFormat mpeg4
769        } elseif { $videoFormat == "h264"} {
770                set videoFormat h264
771        }
772       
773
774        # Disabled the device button if we have no devices or
775        # if we don't have transmit persmission.
776        #
777        if { ![info exists inputDeviceList] || ![have_transmit_permission] } {
778                $w configure -state disabled
779                return
780        }
781        foreach d $inputDeviceList {
782                if { [$d nickname] == "still" && ![yesno stillGrabber] } {
783                        set defaultFormat($d) $videoFormat
784                        continue
785                }
786                # this is fragile
787                $m add radiobutton -label [$d nickname] \
788                        -command "select_device $d" \
789                        -value $d -variable videoDevice -font $f
790                if { "[$d attributes]" == "disabled" } {
791                        $m entryconfigure [$d nickname] -state disabled
792                }
793                set fmtList [device_formats $d]
794                if [inList $videoFormat $fmtList] {
795                        set defaultFormat($d) $videoFormat
796                } else {
797                        set defaultFormat($d) [lindex $fmtList 0]
798                }
799        }
800}
801
802proc format_col3 { w n0 n1 n2 } {
803        set f [smallfont]
804        frame $w
805        radiobutton $w.b0 -text $n0 -relief flat -font $f -anchor w \
806                -variable videoFormat -value $n0 -padx 0 -pady 0 \
807                -command "select_format $n0" -state disabled
808        radiobutton $w.b1 -text $n1 -relief flat -font $f -anchor w \
809                -variable videoFormat -value $n1 -padx 0 -pady 0 \
810                -command "select_format $n1" -state disabled
811        radiobutton $w.b2 -text $n2 -relief flat -font $f -anchor w \
812                -variable videoFormat -value $n2 -padx 0 -pady 0 \
813                -command "select_format $n2" -state disabled
814        pack $w.b0 $w.b1 $w.b2 -fill x
815
816        global formatButtons
817        lappend formatButtons $w.b0 $w.b1 $w.b2
818
819        #format_col $w.p0 nv nvdct cellb
820        #format_col $w.p1 jpeg h261 bvc
821        #format_col $w.p2 h263+ h263 raw
822}
823
824proc format_col { w n0 n1 } {
825        set f [smallfont]
826        frame $w
827        if { [string first : $n0] > 0 } {
828                set reliefn0 ridge
829                set n0 [ string range $n0 0 [expr {[string length $n0] -2 }] ]
830        } else {
831                set reliefn0 flat
832        }
833        if { [string first : $n1] > 0 } {
834                set reliefn1 ridge
835                set n1 [ string range $n1 0 [expr {[string length $n1] -2 }] ]
836        } else {
837                set reliefn1 flat
838        }
839        radiobutton $w.b0 -text $n0 -relief $reliefn0 -font $f -anchor w \
840                -variable videoFormat -value $n0 -padx 2 -pady 4 \
841                -command "select_format $n0" -state disabled
842        radiobutton $w.b1 -text $n1 -relief $reliefn1 -font $f -anchor w \
843                -variable videoFormat -value $n1 -padx 2 -pady 4 \
844                -command "select_format $n1" -state disabled
845        pack $w.b0 $w.b1 -fill x
846
847        global formatButtons
848        lappend formatButtons $w.b0 $w.b1
849
850        #format_col $w.p0 nv nvdct
851        #format_col $w.p1 jpeg h261
852        #format_col $w.p2 h263+ h263
853        #format_col $w.p3 raw cellb
854        #format_col $w.p4 pvh bvc
855}
856
857proc set_numEncoderLayers { value } {
858        global transmitButtonState numEncoderLayers V encoderLayerScale encoderLayerValue
859
860        $encoderLayerValue configure -text $value
861       
862        if $transmitButtonState {
863                $V(encoder) loop_layer [expr {$numEncoderLayers + 1}]
864                #$V(decoder) maxChannel $numEncoderLayers
865        }
866}
867
868proc build.encoderLayer_scale w {
869        global numLayers encoderLayerScale encoderLayerValue
870
871        set f [smallfont]
872
873        frame $w.tb
874        label $w.title -text "Layers" -font $f -anchor w
875        label $w.tb.value -text 0 -font $f -width 3
876        scale $w.tb.scale -font $f -orient horizontal \
877                -showvalue 0 -from 0 -to $numLayers \
878                -variable numEncoderLayers \
879                -width 12 -relief groove \
880        -command "set_numEncoderLayers"
881
882
883        set encoderLayerScale $w.tb.scale
884        set encoderLayerValue $w.tb.value
885
886        $encoderLayerValue configure -text $numLayers
887
888#$layerscale configure -state disabled
889
890        pack $w.tb.scale -side left -fill x -expand 1
891        pack $w.tb.value -side left
892        pack $w.title -padx 2 -side left
893        pack $w.tb -fill x -padx 6 -side left -expand 1
894}
895
896proc codecexists c {
897        set encoder [new module $c]
898        if { $encoder == "" }  {
899          return 0
900    } else {
901          delete $encoder
902          return 1
903    }
904}
905proc build.format w {
906
907        format_col $w.p0 nv nvdct
908        format_col $w.p1 h261 h261as
909        if { [codecexists h263] } {
910                format_col $w.p2 h263 h263+
911        }
912        if { [codecexists h264] } {
913          format_col $w.p3 mpeg4 h264
914    }
915        format_col $w.p4 raw cellb
916        format_col $w.p5 bvc pvh:
917        format_col $w.p6 jpeg null
918
919       
920        frame $w.glue0
921        frame $w.glue1
922        pack $w.p0 $w.p1 -side left
923        if { [codecexists h263] } {
924            pack $w.p2 -side left
925        }
926        if { [codecexists h264] } {
927            pack $w.p3 -side left
928        }
929        pack $w.p4 $w.p5 $w.p6 -side left
930
931}
932
933proc build.size w {
934        set f [smallfont]
935
936        set b $w.b
937        frame $b
938        radiobutton $b.b0 -text "small" -command "restart" \
939                -padx 0 -pady 0 \
940                -anchor w -variable inputSize -font $f -relief flat -value 4
941        radiobutton $b.b1 -text "normal" -command "restart" \
942                -padx 0 -pady 0 \
943                -anchor w -variable inputSize -font $f -relief flat -value 2
944        radiobutton $b.b2 -text "large" -command "restart" \
945                -padx 0 -pady 0 \
946                -anchor w -variable inputSize -font $f -relief flat -value 1
947        pack $b.b0 $b.b1 $b.b2 -fill x
948        pack $b -anchor c -side left
949        global inputSize sizeButtons
950        set inputSize 2
951        set sizeButtons $b
952}
953
954proc build.port w {
955        set f [smallfont]
956        # create the menubutton but don't defer the menu creation until later
957        if {[string match [ windowingsystem] "aqua"]} {
958            menubutton $w -menu $w.menu -text Port -width 8 -pady 4 \
959                -state disabled
960        } else {
961            menubutton $w -menu $w.menu -text Port... \
962                -relief raised -width 10 -font $f -state disabled
963        }
964        global portButton inputPort
965        set portButton $w
966        set inputPort undefined
967}
968
969proc attach_ports device {
970        global portButton inputPort defaultPort
971        catch "destroy $portButton.menu"
972        set portnames [attribute_class [$device attributes] port]
973        set f [smallfont]
974        set m $portButton.menu
975        menu $m
976        foreach port $portnames {
977                $m add radiobutton -label $port \
978                        -command "grabber port \"$port\"" \
979                        -value $port -variable inputPort -font $f
980        }
981        if ![info exists defaultPort($device)] {
982                set nn [$device nickname]
983                if [info exists defaultPort($nn)] {
984                        set defaultPort($device) $defaultPort($nn)
985                } else {
986                        set s [resource defaultPort($nn)]
987                        if { $s != "" } {
988                                set defaultPort($device) $s
989                        } else {
990                                set defaultPort($device) [lindex $portnames 0]
991                        }
992                }
993        }
994        set inputPort $defaultPort($device)
995}
996
997proc build.type w {
998        set f [smallfont]
999
1000        set m $w.menu
1001        if {[string match [ windowingsystem] "aqua"]} {
1002            menubutton $w -text Signal -menu $m -width 8 -pady 4 \
1003                -state disabled
1004        } else {
1005            menubutton $w -text Signal... -menu $m -relief raised \
1006                -width 10 -font $f -state disabled
1007        }
1008        menu $m
1009        $m add radiobutton -label "auto" -command restart \
1010                -value auto -variable inputType -font $f
1011        $m add radiobutton -label "NTSC" -command restart \
1012                -value ntsc -variable inputType -font $f
1013        $m add radiobutton -label "PAL" -command restart \
1014                -value pal -variable inputType -font $f
1015        $m add radiobutton -label "SECAM" -command restart \
1016                -value secam -variable inputType -font $f
1017
1018        global inputType typeButton
1019        #set inputType auto
1020        set inputType [string tolower [option get . inputType Vic]]
1021        set typeButton $w
1022}
1023
1024proc build.encoder_buttons w {
1025        set f [smallfont]
1026        build.encoder_options $w.options
1027        build.device $w.device
1028        build.port $w.port
1029        build.type $w.type
1030        pack $w.device $w.port $w.type $w.options -fill x
1031}
1032
1033proc build.encoder_options w {
1034        global useJPEGforH261 tcl_platform useHardwareComp
1035        set useJPEGforH261 [yesno useJPEGforH261]
1036        set useHardwareComp [yesno useHardwareComp]
1037        set f [smallfont]
1038        set m $w.menu
1039        if {[string match [ windowingsystem] "aqua"]} {
1040            menubutton $w -text Options -menu $m -width 8 -pady 4
1041        } else {
1042            menubutton $w -text Options... -menu $m -relief raised -width 10 \
1043                -font $f
1044        }
1045        menu $m
1046        $m add checkbutton -label "Sending Slides" \
1047                -variable sendingSlides -font $f -command setFillRate
1048        $m add checkbutton -label "Use JPEG for H261" \
1049                -variable useJPEGforH261 -font $f -command restart
1050                $m add checkbutton -label "Use Hardware Encode" \
1051                -variable useHardwareComp -font $f -command restart
1052        if { $tcl_platform(platform) == "windows" || [string match [ windowingsystem] "aqua"] } {
1053                        $m add checkbutton -label "Configure on Transmit" \
1054                        -variable configOnTransmit -font $f \
1055                        -command  "grabber useconfig \$configOnTransmit"
1056                }
1057}
1058
1059proc build.tile w {
1060        set f [smallfont]
1061        set m $w.menu
1062        if {[string match [ windowingsystem] "aqua"]} {
1063            menubutton $w -text Tile -menu $m -width 8 -pady 4
1064        } else {
1065            menubutton $w -text Tile... -menu $m -relief raised -width 10 \
1066                        -font $f
1067        }
1068        menu $m
1069        $m add radiobutton -label Single -command "redecorate 1" \
1070                -value 1 -variable V(ncol) -font $f
1071        $m add radiobutton -label Double -command "redecorate 2" \
1072                -value 2 -variable V(ncol) -font $f
1073        $m add radiobutton -label Triple -command "redecorate 3" \
1074                -value 3 -variable V(ncol) -font $f
1075        $m add radiobutton -label Quad -command "redecorate 4" \
1076                -value 4 -variable V(ncol) -font $f
1077}
1078
1079proc build.decoder_options w {
1080        set f [smallfont]
1081        set m $w.menu
1082        if {[string match [ windowingsystem] "aqua"]} {
1083            menubutton $w -text Options -menu $m -width 8 -pady 4
1084        } else {
1085            menubutton $w -text Options... -menu $m -relief raised -width 10 \
1086                -font $f
1087        }
1088        menu $m
1089        $m add checkbutton -label "Mute New Sources" \
1090                -variable V(muteNewSources) -font $f
1091        $m add checkbutton -label "Use Hardware Decode" \
1092                -variable V(useHardwareDecode) -font $f
1093        $m add separator
1094        $m add command -label "Optimize Colormap" \
1095                -command fork_histtolut -font $f
1096
1097        global V
1098        set V(optionsMenu) $m
1099        if ![have dither] {
1100                $m entryconfigure "Optimize Colormap" -state disabled
1101        }
1102}
1103
1104proc build.external w {
1105        set f [smallfont]
1106        set m $w.menu
1107        global outputDeviceList
1108        if ![info exists outputDeviceList] {
1109                set outputDeviceList ""
1110        }
1111        if { [llength $outputDeviceList] <= 1 } {
1112                button $w -text External -relief raised \
1113                        -width 10 -font $f -highlightthickness 0 \
1114                        -command "extout_select $outputDeviceList"
1115        } else {
1116                menubutton $w -text External... -menu $m -relief raised \
1117                        -width 10 -font $f 
1118                menu $m
1119                foreach d $outputDeviceList {
1120                        $m add command -font $f -label [$d nickname] \
1121                                -command "extout_select $d"
1122                }
1123        }
1124        if { $outputDeviceList == "" } {
1125                $w configure -state disabled
1126        }
1127}
1128
1129proc build.dither w {
1130        set f [smallfont]
1131        if [have dither] {
1132                set var V(dither)
1133                set state normal
1134        } else {
1135                set var dummyDither
1136                set state disabled
1137        }
1138        set v $w.h0
1139        frame $v
1140        radiobutton $v.b0 -text "Ordered" -command set_dither \
1141                -padx 0 -pady 0 \
1142                -anchor w -variable $var -state $state \
1143                -font $f -relief flat -value od
1144        radiobutton $v.b1 -text "Error Diff" -command set_dither \
1145                -padx 0 -pady 0 \
1146                -anchor w -variable $var -state $state \
1147                -font $f -relief flat -value ed
1148        set v $w.h1
1149        frame $v
1150        radiobutton $v.b2 -text Quantize -command set_dither \
1151                -padx 0 -pady 0 \
1152                -anchor w -variable $var -state $state \
1153                -font $f -relief flat \
1154                -value quantize
1155        radiobutton $v.b3 -text Gray -command set_dither \
1156                -padx 0 -pady 0 \
1157                -anchor w -variable $var -state $state \
1158                -font $f -relief flat -value gray
1159
1160        pack $w.h0.b0 $w.h0.b1 -anchor w -fill x
1161        pack $w.h1.b2 $w.h1.b3 -anchor w -fill x
1162        pack $w.h0 $w.h1 -side left
1163}
1164
1165proc update_gamma { w s } {
1166        global V win_src
1167        set cm $V(colorModel)
1168        if ![$cm gamma $s] {
1169                return -1
1170        }
1171        set V(gamma) $s
1172        $cm free-colors
1173        if ![$cm alloc-colors] {
1174                revert_to_gray
1175        }
1176        #
1177        # Need to update all the windows.  Can't just do a redraw
1178        # on all the windows because that won't cause the renderer's
1179        # to update their copy of the image (which has the old colormap
1180        # installed).  Instead, go through all the active decoders and
1181        # force them to update all the windows.
1182        #
1183        foreach src [session active] {
1184                set d [$src handler]
1185                if { $d != "" } {
1186                        $d redraw
1187                }
1188        }
1189
1190        return 0
1191}
1192
1193proc build.gamma w {
1194        global V
1195        frame $w
1196        label $w.label -text "Gamma: " -font [smallfont] -anchor e
1197        mk.entry $w update_gamma $V(gamma)
1198        $w.entry configure -width 6
1199        if ![have dither] {
1200                $w.entry configure -state disabled -foreground gray60
1201                $w.label configure -foreground gray60
1202        }
1203        pack $w.label -side left
1204        pack $w.entry -side left -expand 1 -fill x -pady 2
1205}
1206
1207proc build.decoder w {
1208        set f [smallfont]
1209
1210        label $w.title -text Display
1211        frame $w.f -relief sunken -borderwidth 2
1212
1213        set v $w.f.h0
1214        frame $v
1215
1216        build.external $v.ext
1217        build.tile $v.tile
1218        build.decoder_options $v.options
1219
1220        pack $v.options $v.tile $v.ext -fill x -expand 1
1221
1222        set v $w.f.h2
1223        frame $v
1224        frame $v.dither -relief groove -borderwidth 2
1225        build.dither $v.dither
1226        frame $v.bot
1227        build.gamma $v.bot.gamma
1228        label $v.bot.mode -text "\[[winfo depth .top]-bit\]" -font $f
1229        pack $v.bot.gamma $v.bot.mode -side left -padx 4
1230        pack $v.dither -side left -anchor c -pady 2
1231        pack $v.bot -side left -anchor c -pady 2
1232
1233        pack $w.f.h0 -side left -padx 6 -pady 6
1234        pack $w.f.h2 -side left -padx 6 -pady 6 -fill x -expand 1
1235
1236        pack $w.title $w.f -fill x
1237}
1238
1239proc build.encoder w {
1240        label $w.title -text Encoder
1241        frame $w.f -relief sunken -borderwidth 2
1242
1243        frame $w.f.h0 -relief flat
1244        frame $w.f.quality -relief flat
1245        frame $w.f.h0.eb -relief flat
1246        frame $w.f.h0.format -relief groove -borderwidth 2
1247        frame $w.f.h0.size -relief groove -borderwidth 2
1248        frame $w.f.h0.gap -relief flat -width 4
1249
1250        build.encoder_buttons $w.f.h0.eb
1251        build.format $w.f.h0.format
1252        build.size $w.f.h0.size
1253
1254        build.q $w.f.quality
1255
1256        pack $w.f.h0.eb -side left -anchor n -fill y -padx 6 -pady 4
1257        pack $w.f.h0.format -side left -anchor n -fill both -expand 1
1258        pack $w.f.h0.size -side left -anchor c -fill both
1259        pack $w.f.h0.gap -side left -anchor c
1260
1261        pack $w.f.h0 -fill x -pady 4
1262        pack $w.f.quality -fill x -pady 6
1263        pack $w.title $w.f -fill x
1264}
1265
1266proc jpeg_setq value {
1267        global useHardwareComp videoDevice
1268        incr value
1269        if { $value > 95 } {
1270                set value 95
1271        } elseif { $value < 5 } {
1272                set value 5
1273        }
1274
1275        set DA [$videoDevice attributes]
1276        set DF [attribute_class $DA format]
1277        if { [inList "jpeg" $DF] && $useHardwareComp } {
1278                grabber q $value
1279        } elseif [have grabber] {
1280                encoder q $value
1281        }       
1282       
1283        global qvalue
1284        $qvalue configure -text $value
1285}
1286
1287proc h261_setq value {
1288        set value [expr int((1 - $value / 100.) * 29) + 1]
1289        if [have grabber] {
1290                encoder q $value
1291        }
1292        global qvalue
1293        $qvalue configure -text $value
1294}
1295
1296proc h261as_setq value {
1297        set value [expr int((1 - $value / 100.) * 29) + 1]
1298        if [have grabber] {
1299                encoder q $value
1300        }
1301        global qvalue
1302        $qvalue configure -text $value
1303}
1304
1305proc h263+_setq value {
1306        set value [expr int((1 - $value / 100.) * 29) + 1]
1307        if [have grabber] {
1308                encoder q $value
1309        }
1310        global qvalue
1311        $qvalue configure -text $value
1312}
1313
1314proc h263_setq value {
1315        set value [expr int((1 - $value / 100.) * 29) + 1]
1316        if [have grabber] {
1317                encoder q $value
1318        }
1319        global qvalue
1320        $qvalue configure -text $value
1321}
1322
1323proc nv_setq value {
1324        set value [expr (100 - $value) / 10]
1325        if [have grabber] {
1326                encoder q $value
1327        }
1328        global qvalue
1329        $qvalue configure -text $value
1330}
1331
1332proc nvdct_setq value {
1333        nv_setq $value
1334        global qvalue
1335        $qvalue configure -text $value
1336}
1337
1338proc raw_setq value {
1339        set value 1
1340        if [have grabber] {
1341                encoder q $value
1342        }
1343        global qvalue
1344        $qvalue configure -text $value
1345}
1346
1347set bvc_quantizer(0) { 0 0 0 0 1 1 1 1 2 2 }
1348set bvc_quantizer(1) { 0 0 0 1 1 1 1 1 2 3 }
1349set bvc_quantizer(2) { 0 0 0 1 1 1 1 2 3 3 }
1350set bvc_quantizer(3) { 0 0 0 1 1 1 2 2 4 4 }
1351set bvc_quantizer(4) { 0 0 0 2 2 2 3 3 4 4 }
1352set bvc_quantizer(5) { 0 0 0 2 2 2 3 4 4 4 }
1353set bvc_quantizer(6) { 0 0 0 2 2 2 4 4 5 5 }
1354set bvc_quantizer(7) { 0 0 0 2 3 3 4 5 5 5 }
1355set bvc_quantizer(8) { 0 0 0 2 3 4 6 6 6 6 }
1356set bvc_quantizer(9) { 2 2 2 3 6 5 7 7 7 7 }
1357
1358
1359proc bvc_setq value {
1360        set value [expr 9 - $value / 10]
1361        if [have grabber] {
1362                global bvc_quantizer
1363                set n 0
1364                foreach q $bvc_quantizer($value) {
1365                        encoder q $n [expr 7 - $q]
1366                        incr n
1367                }
1368        }
1369        global qvalue
1370        $qvalue configure -text $value
1371}
1372
1373set pvh_shmap { 0 1 2 1 }
1374set pvh_shs {
1375        { lum-dct 0 5-1--11- }
1376        { lum-dct 1 ---5111- }
1377        { lum-dct 2 --51-11- }
1378        { lum-sbc 0 ----4--2 }
1379        { lum-sbc 1 ----4--2 }
1380        { lum-sbc 2 ----4--2 }
1381        { chm     0 -5---1-- }
1382        { chm     1 ---5-1-- }
1383        { chm     2 --5--1-- }
1384}
1385
1386#
1387# Format specific routine to map generic quality <i>value</i>
1388# into actions that program the underlying PVH codec.
1389#
1390#VideoPipeline instproc
1391#
1392proc pvh_setq value {
1393#       $self instvar encoder_
1394#       if ![info exists encoder_] {
1395#               return -1
1396#       }
1397        if [have grabber] {
1398                #encoder q $value
1399
1400                #XXX ignore value and just set up the bit allocation
1401                #XXX should have variable strategies here
1402                global pvh_shmap pvh_shs
1403                set n [llength $pvh_shmap]
1404                set i 0
1405                while { $i < $n } {
1406                        encoder shmap $i [lindex $pvh_shmap $i]
1407                        incr i
1408                }
1409                set i 0
1410                foreach tuple $pvh_shs {
1411                        set compID [lindex $tuple 0]
1412                        set shID [lindex $tuple 1]
1413                        set pattern [lindex $tuple 2]
1414                        encoder comp $compID $shID $pattern
1415                }
1416                global qvalue
1417                $qvalue configure -text $value
1418               
1419                return 0
1420        }
1421        #XXX
1422        return -1
1423}
1424
1425#
1426# If the capture device is open, close it.  If transmission
1427# was active fire it up again.  Some state can only be set at
1428# device open time, so some controls must resort to this proc.
1429#
1430proc restart { } {
1431        if [have grabber] {
1432                global transmitButtonState logoButtonState videoDevice V
1433       
1434                # HANDLE TRANSMIT LOGO
1435                if $logoButtonState {
1436                        logo_quit
1437                        logo_transmit
1438                } else {
1439                        logo_quit
1440                }
1441
1442                # HANDLE TRANSMIT VIDEO
1443                if $transmitButtonState {
1444                        $V(grabber) send 0
1445                        close_device
1446                        transmit
1447                } else {
1448                        close_device
1449                }
1450               
1451        }
1452}
1453
1454proc disable_large_button { } {
1455        global sizeButtons inputSize
1456        if { $inputSize == 1 } {
1457                set inputSize 2
1458        }
1459        $sizeButtons.b2 configure -state disabled
1460}
1461
1462proc enable_large_button { } {
1463        global sizeButtons videoDevice
1464        if { [info exists videoDevice] && \
1465                [device_supports $videoDevice size large] } {
1466                $sizeButtons.b2 configure -state normal
1467        }
1468}
1469
1470set qscale_val(h261) 68
1471set qscale_val(h261as) 68
1472set qscale_val(h263) 68
1473set qscale_val(h263+) 68
1474set qscale_val(nv) 80
1475set qscale_val(nvdct) 80
1476set qscale_val(bvc) 60
1477set qscale_val(jpeg) 29
1478set qscale_val(raw) 1
1479set lastFmt ""
1480
1481proc select_format fmt {
1482        global qscale qlabel videoDevice videoFormat qscale_val lastFmt
1483
1484        if { $fmt == "h261" || $fmt == "pvh"} {
1485                # H.261 supports only QCIF/CIF
1486                disable_large_button
1487        } else {
1488                enable_large_button
1489        }
1490
1491        if { $fmt == "pvh"} {
1492                set w .menu.encoder.f.encoderLayer
1493                if ![winfo exists $w] {
1494                        frame $w
1495                        build.encoderLayer_scale $w
1496                }
1497                pack $w -before .menu.encoder.f.quality  -fill x
1498        } else {
1499                pack forget .menu.encoder.f.encoderLayer
1500        }
1501
1502        set qscale_val($lastFmt) [$qscale get]
1503        set lastFmt $videoFormat
1504
1505        set proc $fmt\_setq
1506        if [inList $proc [info commands *_setq]] {
1507                $qscale configure -state normal -command $proc
1508                $qlabel configure -foreground black
1509        } else {
1510                $qscale configure -state disabled
1511                $qlabel configure -foreground gray40
1512        }
1513        set qual [resource quality]
1514        if { $qual > 0 } {
1515                $qscale set [resource quality]
1516        } else { if [info exists qscale_val($fmt)] {
1517                $qscale set $qscale_val($fmt)
1518        }}
1519        if [have grabber] {
1520                global V
1521                set encoder [create_encoder $videoFormat]
1522
1523# MM
1524#               if { [info procs build.$devname\_$videoFormat] != "" } {
1525#                       if ![winfo exists $w] {
1526#                               frame $w
1527#                               build.$devname $w
1528#                       }
1529#                       pack $w -before .menu.encoder -padx 6 -fill x
1530#                       set grabberPanel $w
1531#               }
1532# MM
1533
1534                set ff [$encoder frame-format]
1535                if { "$ff" == "[$V(encoder) frame-format]" } {
1536                        #
1537                        # new framer has the same format as the
1538                        # old one.  just replace the old one without
1539                        # re-initializing the grabber.
1540                        # XXX doens't work if title-maker is installed
1541                        # SV, title-maker fix: see marked code below
1542                        delete $V(encoder)
1543                        set V(encoder) $encoder
1544
1545                        update_encoder_param
1546
1547                        $encoder transmitter $V(session)
1548                       
1549                        # SV ######################
1550                        global logoButtonState                 
1551                        if $logoButtonState {
1552                                logo_quit
1553                                logo_transmit
1554                        } else {
1555                                logo_quit
1556                        }                       
1557                        ###########################
1558                } else {
1559                        #
1560                        # Restart the grabber.
1561                        #
1562                        delete $encoder
1563                        restart
1564                }
1565        }
1566}
1567
1568proc init_grabber { grabber } {
1569        global V configOnTransmit tcl_platform
1570
1571        if { $tcl_platform(platform) == "windows" || [string match [ windowingsystem] "aqua"] } {
1572                $grabber useconfig $configOnTransmit
1573        }
1574
1575        if { [$grabber need-capwin] && ![have capwin] } {
1576                #
1577                # we need to create a window for input devices that
1578                # require capturing to the frame buffer.  create but
1579                # don't map it until after we call "$grabber decimate"
1580                # to specify it's size
1581                #
1582                set rgd [option get . localPlxDisplay $V(class)]
1583                if { $rgd != "" } {
1584                        open_dialog "Using Remote Grabbing Display $rgd"
1585                        toplevel .capture -class Vic -screen $rgd
1586                } else {
1587                        toplevel .capture -class Vic
1588                }
1589                wm title .capture "Video Capture Window"
1590                $grabber create-capwin .capture.video
1591                set V(capwin) .capture.video
1592                pack .capture.video
1593           
1594                # capture window shouldn't be covered
1595                bind .capture <Visibility> "raise .capture"
1596        }
1597
1598        $grabber transmitter $V(session)
1599        global qscale inputSize fps_slider bps_slider videoDevice
1600        global inputPort inputType portButton typeButton
1601        # MacOS-X requires port and input type to be set before decimate
1602        # is called otherwise the channel device's input may be busy
1603        if {[string match [ windowingsystem] "aqua"]} {
1604            if { [$portButton cget -state] == "normal" } {
1605                  $grabber port $inputPort
1606            }
1607        }
1608            if { [$typeButton cget -state] == "normal" } {
1609                  $grabber type $inputType
1610            }
1611       
1612        $grabber fps [$fps_slider get]
1613        $grabber bps [$bps_slider get]
1614        $grabber decimate $inputSize
1615        if { [lindex [$qscale configure -state] 4] == "normal" } {
1616                set cmd [lindex [$qscale configure -command] 4]
1617                $cmd [$qscale get]
1618        }
1619    if !{[string match [ windowingsystem] "aqua"]} {
1620            if { [$portButton cget -state] == "normal" } {
1621                $grabber port $inputPort
1622            }
1623            if { [$typeButton cget -state] == "normal" } {
1624                $grabber type $inputType
1625            }
1626        }
1627        setFillRate
1628        update
1629}
1630
1631proc build.q w {
1632        set f [smallfont]
1633        frame $w.tb
1634        label $w.title -text "Quality" -font $f -anchor w
1635        label $w.tb.value -text 0 -font $f -width 3
1636        scale $w.tb.scale -font $f -orient horizontal \
1637                -showvalue 0 -from 0 -to 99 \
1638                -width 12 -relief groove
1639        global qscale qvalue qlabel
1640        set qscale $w.tb.scale
1641        set qvalue $w.tb.value
1642        set qlabel $w.title
1643
1644        pack $w.tb.scale -side left -fill x -expand 1
1645        pack $w.tb.value -side left
1646        pack $w.title -padx 2 -side left
1647        pack $w.tb -fill x -padx 6 -side left -expand 1
1648}
1649
1650proc build.xmit w {
1651        set f [smallfont]
1652
1653        label $w.label -text Transmission
1654        frame $w.frame -relief sunken -borderwidth 2
1655        pack $w.label -fill x
1656        pack $w.frame -fill both -expand 1
1657        frame $w.frame.buttons
1658        build.buttons $w.frame.buttons
1659       
1660        frame $w.frame.combined
1661       
1662        frame $w.frame.combined.right
1663        build.sliders $w.frame.combined.right
1664        frame $w.frame.combined.tm
1665        build.titlemaker $w.frame.combined.tm
1666
1667        pack $w.frame.combined.right -side top -expand 1 -fill x -padx 10 -anchor w
1668        pack $w.frame.combined.tm -side bottom -expand 1 -fill y -pady 10 -anchor w
1669       
1670        pack $w.frame.buttons -side left -padx 6
1671        pack $w.frame.combined -side right -expand 1 -fill x -padx 10 -anchor c
1672
1673       
1674}
1675
1676proc set_dither {} {
1677        global win_src
1678        set wlist [array names win_src]
1679        foreach w $wlist {
1680                set ws($w) $win_src($w)
1681                detach_window $win_src($w) $w
1682        }
1683        if ![init_color] {
1684                revert_to_gray
1685        }
1686        foreach w $wlist {
1687                attach_window $ws($w) $w
1688        }
1689}       
1690
1691proc revert_to_gray {} {
1692        global V
1693        if { $V(dither) == "gray" } {
1694                #XXX
1695                puts stderr "vic: out of colors"
1696                exit 1
1697        }
1698        open_dialog "ran out of colors; reverting to gray"
1699        set V(dither) gray
1700        set_dither
1701}
Note: See TracBrowser for help on using the browser.