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

Revision 4894, 50.9 KB (checked in by douglask, 4 years ago)

Ignore DirectShow? Decklink device

Fix for devices that don't have capture_resolution attribute

Revert to default of de-interlacing.

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