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

Revision 4706, 48.6 KB (checked in by douglask, 3 years ago)

Fix for VIC's Port and Signal button with MacOS X Tcl/Tk 8.5
  • 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
527        if {$videoFormat == "mpeg4" || $videoFormat == "h264"} {
528                encoder kbps [expr round([$bps_slider get])]
529                encoder fps [expr round([$fps_slider get])]
530        }
531}
532
533proc set_bps { w value } {
534        global videoFormat
535
536        set value [expr round($value)]
537        if [have grabber] {
538                grabber bps $value
539                if {$videoFormat == "mpeg4" || $videoFormat == "h264"} {
540                        encoder kbps $value
541                }
542
543                #XXX
544                session data-bandwidth $value
545        }
546        $w configure -text "$value bps"
547}
548
549proc set_fps { w value } {
550        global videoFormat
551
552        set value [expr round($value)]
553        if [have grabber] {
554                grabber fps $value
555                if {$videoFormat == "mpeg4" || $videoFormat == "h264"} {
556                        encoder fps $value
557                }
558        }
559        $w configure -text "$value fps"
560}
561
562proc build.sliders w {
563        set f [smallfont]
564
565        global V
566        set key $V(session)
567        global ftext btext
568        set ftext($key) "0.0 f/s"
569        set btext($key) "0.0 kb/s"
570
571        frame $w.info
572        label $w.info.label -text "Rate Control" -font $f
573        label $w.info.fps -textvariable ftext($key) -width 6 \
574                -font $f -pady 0 -borderwidth 0
575        label $w.info.bps -textvariable btext($key) -width 8 \
576                -font $f -pady 0 -borderwidth 0
577        pack $w.info.label -side left
578        pack $w.info.bps $w.info.fps -side right
579
580        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
581                frame $w.bps
582                ttk::scale $w.bps.scale -orient horizontal \
583                        -value 0 -from 1 -to [option get . maxbw Vic] \
584                        -command "set_bps $w.bps.value" \
585                        -length 20
586                label $w.bps.value -font $f -width 8 -anchor w
587
588                frame $w.fps
589                ttk::scale $w.fps.scale -orient horizontal \
590                        -value 0 -from 1 -to 30 \
591                        -command "set_fps $w.fps.value" \
592                        -length 20
593        } else {
594                frame $w.bps
595                scale $w.bps.scale -orient horizontal -font $f \
596                        -showvalue 0 -from 1 -to [option get . maxbw Vic] \
597                        -command "set_bps $w.bps.value" -width 12 \
598                        -sliderlength 20 \
599                        -relief groove
600                label $w.bps.value -font $f -width 8 -anchor w
601
602                frame $w.fps
603                scale $w.fps.scale -font $f -orient horizontal \
604                        -showvalue 0 -from 1 -to 30 \
605                        -command "set_fps $w.fps.value" -width 12 \
606                        -sliderlength 20 \
607                        -relief groove
608        }
609
610        label $w.fps.value -font $f -width 8 -anchor w
611
612        pack $w.info -fill x
613        pack $w.bps $w.fps -fill x
614        pack $w.bps.scale -side left -fill x -expand 1
615        pack $w.bps.value -side left -anchor w
616        pack $w.fps.scale -fill x -side left -expand 1
617        pack $w.fps.value -side left -anchor w
618
619        $w.bps.scale set [option get . bandwidth Vic]
620        $w.fps.scale set [option get . framerate Vic]
621
622        global fps_slider bps_slider
623        set fps_slider $w.fps.scale
624        set bps_slider $w.bps.scale
625}
626
627proc attribute_class { attr class } {
628        while { [llength $attr] >= 2 } {
629                if { [lindex $attr 0] == $class } {
630                        return [lindex $attr 1]
631                }
632                set attr [lrange $attr 2 end]
633        }
634        return ""
635}
636
637proc inList { item L } {
638        foreach v $L {
639                if { $v == $item } {
640                        return 1
641                }
642        }
643        return 0
644}
645
646#
647# Returns true iff device named by $device has an attribute named
648# $attr in the attribute class $class.  For example,
649# "device_supports vl size cif" would return true.
650# if $attr is "*", then returns true iff the indicated $class
651# exists in the attribute list (for example, "device_supports $d port *"
652# says whether a device supports port selection at all)
653#
654proc device_supports { device class attr } {
655        set L [$device attributes]
656        set L [attribute_class $L $class]
657        if { $attr == "*" } {
658                if { $L == "" } {
659                        return 0
660                } else {
661                        return 1
662                }
663        } else {
664                return [inList $attr $L]
665        }
666}
667
668# device_formats: any type of stream produce-able from this device
669# (not necessarily native)
670proc device_formats device {
671        set L [$device attributes]
672        set sizes [attribute_class $L size]
673        set formats [attribute_class $L format]
674        set fmtList ""
675        if [inList 422 $formats] {
676                set fmtList "$fmtList nv nvdct cellb jpeg raw"
677        }
678        if [inList 420 $formats] {
679                set fmtList "$fmtList bvc pvh h261as h264 mpeg4"
680        }
681        if [inList cif $sizes] {
682                set fmtList "$fmtList h261 h263 h263+"
683        }
684        if [inList jpeg $formats] {
685                set fmtList "$fmtList jpeg"
686                global useJPEGforH261
687                if $useJPEGforH261 {
688                        set fmtList "$fmtList h261"
689                }
690        }
691        return $fmtList
692}
693
694#
695# called when selecting a new device: insert a grabber control panel
696# if it exists and remove the old one (if one was installed)
697#
698proc insert_grabber_panel devname {
699        set k [string first - $devname]
700        if { $k >= 0 } {
701                incr k -1
702                set devname [string tolower [string range $devname 0 $k]]
703        }
704        regsub -all " " $devname "_" devname
705        set w .menu.$devname
706        global grabberPanel
707        if [info exists grabberPanel] {
708                if { "$grabberPanel" == "$w" } {
709                        return
710                }
711                pack forget $grabberPanel
712                unset grabberPanel
713        }
714        init_grabber_panel
715        if {[info procs build.$devname] != "" } {
716                if ![winfo exists $w] {
717                        frame $w
718                        build.$devname $w
719                }
720                pack $w -before .menu.encoder -padx 6 -fill x
721                set grabberPanel $w
722        }
723}
724
725#
726# Called when use selects a particular device (like videopix or xil)
727# (and at startup for default device)
728#
729proc select_device device {
730        global transmitButton logoButton sizeButtons portButton formatButtons \
731                videoFormat defaultFormat lastDevice defaultPort inputPort \
732                defaultType inputType transmitButtonState logoButtonState typeButton
733
734        #
735        # Remember settings of various controls for previous device
736        # and close down the device if it's already open
737        #
738        set wasTransmitting $transmitButtonState
739        set wasOverlaying $logoButtonState
740        if [info exists lastDevice] {
741                set defaultFormat($lastDevice) $videoFormat
742                set defaultPort($lastDevice) $inputPort
743                set defaultType($lastDevice) $inputType
744                release_device
745        }
746        set lastDevice $device
747
748        set fmtList [device_formats $device]
749        foreach b $formatButtons {
750                set fmt [lindex [$b configure -value] 4]
751                #XXX
752                if { $fmt == "bvc" && ![yesno enableBVC] } {
753                        $b configure -state disabled
754                } elseif { [inList $fmt $fmtList] } {
755                        $b configure -state normal
756                } else {
757                        $b configure -state disabled
758                }
759        }
760        $transmitButton configure -state normal
761        $logoButton configure -state normal
762        if [device_supports $device size small] {
763                $sizeButtons.b0 configure -state normal
764        } else {
765                $sizeButtons.b0 configure -state disabled
766        }
767        if { [device_supports $device size normal] || [device_supports $device size cif] } {
768                $sizeButtons.b1 configure -state normal
769        } else {
770                $sizeButtons.b1 configure -state disabled
771        }
772        if [device_supports $device size large] {
773                $sizeButtons.b2 configure -state normal
774        } else {
775                $sizeButtons.b2 configure -state disabled
776        }
777        if [device_supports $device port *] {
778                $portButton configure -state normal
779                attach_ports $device
780        } else {
781                $portButton configure -state disabled
782        }
783        if [device_supports $device type *] {
784                $typeButton configure -state normal
785                attach_types $device
786        } else {
787                $typeButton configure -state disabled
788        }
789        insert_grabber_panel [$device nickname]
790
791        #set videoFormat $defaultFormat($device)
792        select_format $videoFormat
793        if $wasOverlaying {
794                $logoButton invoke
795        }
796        if $wasTransmitting {
797                $transmitButton invoke
798        }
799}
800
801proc build.device w {
802        set f [smallfont]
803
804        set m $w.menu
805        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
806                ttk::menubutton $w -menu $m -text Device -width 8
807        } elseif {[windowingsystem] == "aqua"} {
808                menubutton $w -menu $m -text Device -width 8 -pady 4
809        } else {
810                menubutton $w -menu $m -text Device -indicatoron 1 \
811                        -relief raised -width 10 -font $f
812        }
813        menu $m
814
815        global defaultFormat inputDeviceList videoFormat
816        set videoFormat [option get . defaultFormat Vic]
817        if { $videoFormat == "h.261" } {
818                set videoFormat h261
819        } elseif { $videoFormat == "h.263plus"} {
820                set videoFormat h263+
821        } elseif { $videoFormat == "mpeg4"} {
822                set videoFormat mpeg4
823        } elseif { $videoFormat == "h264"} {
824                set videoFormat h264
825        }
826
827
828        # Disabled the device button if we have no devices or
829        # if we don't have transmit persmission.
830        #
831        if { ![info exists inputDeviceList] || ![have_transmit_permission] } {
832                $w configure -state disabled
833                return
834        }
835        foreach d $inputDeviceList {
836                if { [$d nickname] == "still" && ![yesno stillGrabber] } {
837                        set defaultFormat($d) $videoFormat
838                        continue
839                }
840                if { [$d nickname] == "filedev" && ![yesno fileGrabber] } {
841                        set defaultFormat($d) $videoFormat
842                        continue
843                }
844                # this is fragile
845                $m add radiobutton -label [$d nickname] \
846                        -command "select_device $d" \
847                        -value $d -variable videoDevice -font $f
848                if { "[$d attributes]" == "disabled" } {
849                        $m entryconfigure [$d nickname] -state disabled
850                }
851                set fmtList [device_formats $d]
852                if [inList $videoFormat $fmtList] {
853                        set defaultFormat($d) $videoFormat
854                } else {
855                        set defaultFormat($d) [lindex $fmtList 0]
856                }
857        }
858}
859
860proc format_col3 { w n0 n1 n2 } {
861        set f [smallfont]
862        frame $w
863
864        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
865                ttk::radiobutton $w.b0 -text $n0 \
866                        -variable videoFormat -value $n0 \
867                        -command "select_format $n0" -state disabled
868                ttk::radiobutton $w.b1 -text $n1 \
869                        -variable videoFormat -value $n1 \
870                        -command "select_format $n1" -state disabled
871                ttk::radiobutton $w.b2 -text $n2 \
872                        -variable videoFormat -value $n2 \
873                        -command "select_format $n2" -state disabled
874        } else {
875                radiobutton $w.b0 -text $n0 -relief flat -font $f -anchor w \
876                        -variable videoFormat -value $n0 -padx 0 -pady 0 \
877                        -command "select_format $n0" -state disabled
878                radiobutton $w.b1 -text $n1 -relief flat -font $f -anchor w \
879                        -variable videoFormat -value $n1 -padx 0 -pady 0 \
880                        -command "select_format $n1" -state disabled
881                radiobutton $w.b2 -text $n2 -relief flat -font $f -anchor w \
882                        -variable videoFormat -value $n2 -padx 0 -pady 0 \
883                        -command "select_format $n2" -state disabled
884        }
885        pack $w.b0 $w.b1 $w.b2 -fill x
886
887        global formatButtons
888        lappend formatButtons $w.b0 $w.b1 $w.b2
889
890        #format_col $w.p0 nv nvdct cellb
891        #format_col $w.p1 jpeg h261 bvc
892        #format_col $w.p2 h263+ h263 raw
893}
894
895proc format_col { w n0 n1 } {
896        set f [smallfont]
897        frame $w
898        if { [string first : $n0] > 0 } {
899                set reliefn0 ridge
900                set n0 [ string range $n0 0 [expr {[string length $n0] -2 }] ]
901        } else {
902                set reliefn0 flat
903        }
904        if { [string first : $n1] > 0 } {
905                set reliefn1 ridge
906                set n1 [ string range $n1 0 [expr {[string length $n1] -2 }] ]
907        } else {
908                set reliefn1 flat
909        }
910
911        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
912                ttk::radiobutton $w.b0 -text $n0 \
913                        -variable videoFormat -value $n0 \
914                        -command "select_format $n0" -state disabled
915                ttk::radiobutton $w.b1 -text $n1 \
916                        -variable videoFormat -value $n1 \
917                        -command "select_format $n1" -state disabled
918        } else {
919                radiobutton $w.b0 -text $n0 -relief $reliefn0 -font $f -anchor w \
920                        -variable videoFormat -value $n0 -padx 2 -pady 4 \
921                        -command "select_format $n0" -state disabled
922                radiobutton $w.b1 -text $n1 -relief $reliefn1 -font $f -anchor w \
923                        -variable videoFormat -value $n1 -padx 2 -pady 4 \
924                        -command "select_format $n1" -state disabled
925        }
926        pack $w.b0 $w.b1 -fill x
927
928        global formatButtons
929        lappend formatButtons $w.b0 $w.b1
930
931        #format_col $w.p0 nv nvdct
932        #format_col $w.p1 jpeg h261
933        #format_col $w.p2 h263+ h263
934        #format_col $w.p3 raw cellb
935        #format_col $w.p4 pvh bvc
936}
937
938proc set_numEncoderLayers { value } {
939        global transmitButtonState numEncoderLayers V encoderLayerScale encoderLayerValue
940
941        $encoderLayerValue configure -text $value
942
943        if $transmitButtonState {
944                $V(encoder) loop_layer [expr {$numEncoderLayers + 1}]
945                #$V(decoder) maxChannel $numEncoderLayers
946        }
947}
948
949proc build.encoderLayer_scale w {
950        global numLayers encoderLayerScale encoderLayerValue
951
952        set f [smallfont]
953
954        frame $w.tb
955        label $w.title -text "Layers" -font $f -anchor w
956        label $w.tb.value -text 0 -font $f -width 3
957        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
958                ttk::scale $w.tb.scale -orient horizontal \
959                        -value 0 -from 0 -to $numLayers \
960                        -variable numEncoderLayers \
961                        -command "set_numEncoderLayers"
962        } else {
963                scale $w.tb.scale -font $f -orient horizontal \
964                        -showvalue 0 -from 0 -to $numLayers \
965                        -variable numEncoderLayers \
966                        -width 12 -relief groove \
967                        -command "set_numEncoderLayers"
968        }
969
970        set encoderLayerScale $w.tb.scale
971        set encoderLayerValue $w.tb.value
972
973        $encoderLayerValue configure -text $numLayers
974
975#$layerscale configure -state disabled
976
977        pack $w.tb.scale -side left -fill x -expand 1
978        pack $w.tb.value -side left
979        pack $w.title -padx 2 -side left
980        pack $w.tb -fill x -padx 6 -side left -expand 1
981}
982
983proc codecexists c {
984        set encoder [new module $c]
985        if { $encoder == "" }  {
986                return 0
987        } else {
988                delete $encoder
989                return 1
990        }
991}
992proc build.format w {
993
994        format_col $w.p0 nv nvdct
995        format_col $w.p1 h261 h261as
996        if { [codecexists h263] } {
997                format_col $w.p2 h263 h263+
998        }
999        if { [codecexists h264] } {
1000                format_col $w.p3 mpeg4 h264
1001        }
1002        format_col $w.p4 raw cellb
1003        format_col $w.p5 bvc pvh:
1004        format_col $w.p6 jpeg null
1005
1006
1007        frame $w.glue0
1008        frame $w.glue1
1009        pack $w.p0 $w.p1 -side left
1010        if { [codecexists h263] } {
1011                pack $w.p2 -side left
1012        }
1013        if { [codecexists h264] } {
1014                pack $w.p3 -side left
1015        }
1016        pack $w.p4 $w.p5 $w.p6 -side left
1017
1018}
1019
1020proc build.size w {
1021        set f [smallfont]
1022
1023        set b $w.b
1024        frame $b
1025        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1026                ttk::radiobutton $b.b0 -text "small" -command "restart" \
1027                        -variable inputSize -value 4
1028                ttk::radiobutton $b.b1 -text "normal" -command "restart" \
1029                        -variable inputSize -value 2
1030                ttk::radiobutton $b.b2 -text "large" -command "restart" \
1031                        -variable inputSize -value 1
1032        } else {
1033                radiobutton $b.b0 -text "small" -command "restart" \
1034                        -padx 0 -pady 0 \
1035                        -anchor w -variable inputSize -font $f -relief flat -value 4
1036                radiobutton $b.b1 -text "normal" -command "restart" \
1037                        -padx 0 -pady 0 \
1038                        -anchor w -variable inputSize -font $f -relief flat -value 2
1039                radiobutton $b.b2 -text "large" -command "restart" \
1040                        -padx 0 -pady 0 \
1041                        -anchor w -variable inputSize -font $f -relief flat -value 1
1042        }
1043        pack $b.b0 $b.b1 $b.b2 -fill x
1044        pack $b -anchor c -side left
1045        global inputSize sizeButtons
1046        set inputSize 2
1047        set sizeButtons $b
1048}
1049
1050proc build.port w {
1051        set f [smallfont]
1052        # create the menubutton but don't defer the menu creation until later
1053        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1054                ttk::menubutton $w -menu $w.menu -text Port -width 8 \
1055                        -state disabled
1056        } elseif {[windowingsystem] == "aqua"} {
1057                menubutton $w -menu $w.menu -text Port -width 8 -pady 4 \
1058                        -state disabled
1059        } else {
1060                menubutton $w -menu $w.menu -text Port -indicatoron 1 \
1061                        -relief raised -width 10 -font $f -state disabled
1062        }
1063        global portButton inputPort
1064        set portButton $w
1065        set inputPort undefined
1066}
1067
1068proc attach_ports device {
1069        global portButton inputPort defaultPort
1070        catch "destroy $portButton.menu"
1071        set portnames [attribute_class [$device attributes] port]
1072        set f [smallfont]
1073        set m $portButton.menu
1074        menu $m
1075        foreach port $portnames {
1076                $m add radiobutton -label $port \
1077                        -command "grabber port \"$port\"" \
1078                        -value $port -variable inputPort -font $f
1079        }
1080        if ![info exists defaultPort($device)] {
1081                set nn [$device nickname]
1082                if [info exists defaultPort($nn)] {
1083                        set defaultPort($device) $defaultPort($nn)
1084                } else {
1085                        set s [resource defaultPort($nn)]
1086                        if { $s != "" } {
1087                                set defaultPort($device) $s
1088                        } else {
1089                                set defaultPort($device) [lindex $portnames 0]
1090                        }
1091                }
1092        }
1093        set inputPort $defaultPort($device)
1094}
1095
1096proc build.type w {
1097        set f [smallfont]
1098        # create the menubutton but don't defer the menu creation until later
1099        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1100                ttk::menubutton $w -menu $w.menu -text Signal -width 8 \
1101                        -state disabled
1102        } elseif {[windowingsystem] == "aqua"} {
1103                menubutton $w -menu $w.menu -text Signal -width 8 -pady 4 \
1104                        -state disabled
1105        } else {
1106                menubutton $w -menu $w.menu -text Signal -indicatoron 1 \
1107                        -relief raised -width 10 -font $f -state disabled
1108        }
1109        global typeButton inputType
1110        set typeButton $w
1111        set inputType undefined
1112}
1113
1114proc attach_types device {
1115        global typeButton inputType defaultType
1116        catch "destroy $typeButton.menu"
1117        set typenames [attribute_class [$device attributes] type]
1118        set f [smallfont]
1119        set m $typeButton.menu
1120        menu $m
1121        foreach typename $typenames {
1122                set type [string tolower $typename]
1123
1124                if { $type == "ntsc" } {
1125                        set typename "NTSC"
1126                } elseif { $type == "pal" } {
1127                        set typename "PAL"
1128                } elseif { $type == "secam" } {
1129                        set typename "SECAM"
1130                } elseif { $type == "auto" } {
1131                        set typename "auto"
1132                }
1133
1134                $m add radiobutton -label $typename -command restart \
1135                        -value $type -variable inputType -font $f
1136        }
1137        if ![info exists defaultType($device)] {
1138                set nn [$device nickname]
1139                if [info exists defaultType($nn)] {
1140                        set defaultType($device) $defaultType($nn)
1141                } else {
1142                        set s [string tolower [option get . inputType Vic]]
1143                        if { $s != "" } {
1144                                set defaultType($device) $s
1145                        } else {
1146                                set defaultType($device) [lindex $typenames 0]
1147                        }
1148                }
1149        }
1150        set inputType $defaultType($device)
1151}
1152
1153proc build.encoder_buttons w {
1154        set f [smallfont]
1155        build.encoder_options $w.options
1156        build.device $w.device
1157        build.port $w.port
1158        build.type $w.type
1159        pack $w.device $w.port $w.type $w.options -fill x
1160}
1161
1162proc build.encoder_options w {
1163        global useJPEGforH261 tcl_platform useHardwareComp
1164        set useJPEGforH261 [yesno useJPEGforH261]
1165        set useHardwareComp [yesno useHardwareComp]
1166        set f [smallfont]
1167        set m $w.menu
1168
1169        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1170                ttk::menubutton $w -text Options -menu $m -width 8
1171        } elseif {[windowingsystem] == "aqua"} {
1172                menubutton $w -text Options -menu $m -width 8 -pady 4
1173        } else {
1174                menubutton $w -text Options -menu $m -relief raised -width 10 \
1175                -font $f -indicatoron 1
1176        }
1177        menu $m
1178        $m add checkbutton -label "Sending Slides" \
1179                -variable sendingSlides -font $f -command setFillRate
1180        $m add checkbutton -label "Use JPEG for H261" \
1181                -variable useJPEGforH261 -font $f -command restart
1182        $m add checkbutton -label "Use Hardware Encode" \
1183                -variable useHardwareComp -font $f -command restart
1184        if { $tcl_platform(platform) == "windows" || [windowingsystem] == "aqua"} {
1185                $m add checkbutton -label "Configure on Transmit" \
1186                        -variable configOnTransmit -font $f \
1187                        -command  "grabber useconfig \$configOnTransmit"
1188        }
1189}
1190
1191proc build.tile w {
1192        set f [smallfont]
1193        set m $w.menu
1194        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1195                ttk::menubutton $w -text Tile -menu $m -width 8
1196        } elseif {[windowingsystem] == "aqua"} {
1197                menubutton $w -text Tile -menu $m -width 8 -pady 4
1198        } else {
1199                menubutton $w -text Tile -menu $m -relief raised -width 10 \
1200                        -font $f -indicatoron 1
1201        }
1202        menu $m
1203        $m add radiobutton -label Single -command "redecorate 1" \
1204                -value 1 -variable V(ncol) -font $f
1205        $m add radiobutton -label Double -command "redecorate 2" \
1206                -value 2 -variable V(ncol) -font $f
1207        $m add radiobutton -label Triple -command "redecorate 3" \
1208                -value 3 -variable V(ncol) -font $f
1209        $m add radiobutton -label Quad -command "redecorate 4" \
1210                -value 4 -variable V(ncol) -font $f
1211}
1212
1213proc build.decoder_options w {
1214        set f [smallfont]
1215        set m $w.menu
1216        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1217                ttk::menubutton $w -text Options -menu $m -width 8
1218        } elseif {[windowingsystem] == "aqua"} {
1219                menubutton $w -text Options -menu $m -width 8 -pady 4
1220        } else {
1221                menubutton $w -text Options -menu $m -relief raised -width 10 \
1222                        -font $f -indicatoron 1
1223        }
1224        menu $m
1225        $m add checkbutton -label "Mute New Sources" \
1226                -variable V(muteNewSources) -font $f
1227        $m add checkbutton -label "Use Hardware Decode" \
1228                -variable V(useHardwareDecode) -font $f
1229        $m add separator
1230        $m add command -label "Optimize Colormap" \
1231                -command fork_histtolut -font $f
1232
1233        global V
1234        set V(optionsMenu) $m
1235        if ![have dither] {
1236                $m entryconfigure "Optimize Colormap" -state disabled
1237        }
1238}
1239
1240proc build.external w {
1241        set m $w.menu
1242        global outputDeviceList
1243        if ![info exists outputDeviceList] {
1244                set outputDeviceList ""
1245        }
1246
1247        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1248                if { [llength $outputDeviceList] <= 1 } {
1249                        ttk::button $w -text External -width 10 \
1250                                -command "extout_select $outputDeviceList"
1251                } else {
1252                        ttk::menubutton $w -text External -menu $m -width 10
1253                        menu $m
1254                        foreach d $outputDeviceList {
1255                                $m add command -label [$d nickname] \
1256                                        -command "extout_select $d"
1257                        }
1258                }
1259        } else {
1260                set f [smallfont]
1261                if { [llength $outputDeviceList] <= 1 } {
1262                        button $w -text External -relief raised \
1263                                -width 10 -font $f -highlightthickness 0 \
1264                                -command "extout_select $outputDeviceList"
1265                } else {
1266                        menubutton $w -text External -menu $m -relief raised \
1267                                -width 10 -font $f -indicatoron 1
1268                        menu $m
1269                        foreach d $outputDeviceList {
1270                                $m add command -font $f -label [$d nickname] \
1271                                        -command "extout_select $d"
1272                        }
1273                }
1274        }
1275        if { $outputDeviceList == "" } {
1276                $w configure -state disabled
1277        }
1278}
1279
1280proc build.dither w {
1281        set f [smallfont]
1282        if [have dither] {
1283                set var V(dither)
1284                set state normal
1285        } else {
1286                set var dummyDither
1287                set state disabled
1288        }
1289        set v $w.h0
1290        frame $v
1291        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1292                ttk::radiobutton $v.b0 -text "Ordered" -command set_dither \
1293                        -variable $var -state $state \
1294                        -value od
1295                ttk::radiobutton $v.b1 -text "Error Diff" -command set_dither \
1296                        -variable $var -state $state \
1297                        -value ed
1298                set v $w.h1
1299                frame $v
1300                ttk::radiobutton $v.b2 -text Quantize -command set_dither \
1301                        -variable $var -state $state \
1302                        -value quantize
1303                ttk::radiobutton $v.b3 -text Gray -command set_dither \
1304                        -variable $var -state $state \
1305                        -value gray
1306        } else {
1307                radiobutton $v.b0 -text "Ordered" -command set_dither \
1308                        -padx 0 -pady 0 \
1309                        -anchor w -variable $var -state $state \
1310                        -font $f -relief flat -value od
1311                radiobutton $v.b1 -text "Error Diff" -command set_dither \
1312                        -padx 0 -pady 0 \
1313                        -anchor w -variable $var -state $state \
1314                        -font $f -relief flat -value ed
1315                set v $w.h1
1316                frame $v
1317                radiobutton $v.b2 -text Quantize -command set_dither \
1318                        -padx 0 -pady 0 \
1319                        -anchor w -variable $var -state $state \
1320                        -font $f -relief flat \
1321                        -value quantize
1322                radiobutton $v.b3 -text Gray -command set_dither \
1323                        -padx 0 -pady 0 \
1324                        -anchor w -variable $var -state $state \
1325                        -font $f -relief flat -value gray
1326        }
1327        pack $w.h0.b0 $w.h0.b1 -anchor w -fill x
1328        pack $w.h1.b2 $w.h1.b3 -anchor w -fill x
1329        pack $w.h0 $w.h1 -side left
1330}
1331
1332proc update_gamma { w s } {
1333        global V win_src
1334        set cm $V(colorModel)
1335        if ![$cm gamma $s] {
1336                return -1
1337        }
1338        set V(gamma) $s
1339        $cm free-colors
1340        if ![$cm alloc-colors] {
1341                revert_to_gray
1342        }
1343        #
1344        # Need to update all the windows.  Can't just do a redraw
1345        # on all the windows because that won't cause the renderer's
1346        # to update their copy of the image (which has the old colormap
1347        # installed).  Instead, go through all the active decoders and
1348        # force them to update all the windows.
1349        #
1350        foreach src [session active] {
1351                set d [$src handler]
1352                if { $d != "" } {
1353                        $d redraw
1354                }
1355        }
1356
1357        return 0
1358}
1359
1360proc build.gamma w {
1361        global V
1362        frame $w
1363        label $w.label -text "Gamma: " -font [smallfont] -anchor e
1364        mk.entry $w update_gamma $V(gamma)
1365        $w.entry configure -width 6
1366        if ![have dither] {
1367                $w.entry configure -state disabled -foreground gray60
1368                $w.label configure -foreground gray60
1369        }
1370        pack $w.label -side left
1371        pack $w.entry -side left -expand 1 -fill x -pady 2
1372}
1373
1374proc build.decoder w {
1375        set f [smallfont]
1376
1377        label $w.title -text Display
1378        frame $w.f -relief sunken -borderwidth 2
1379
1380        set v $w.f.h0
1381        frame $v
1382
1383        build.external $v.ext
1384        build.tile $v.tile
1385        build.decoder_options $v.options
1386
1387        pack $v.options $v.tile $v.ext -fill x -expand 1
1388
1389        set v $w.f.h2
1390        frame $v
1391        frame $v.dither -relief groove -borderwidth 2
1392        build.dither $v.dither
1393        frame $v.bot
1394        build.gamma $v.bot.gamma
1395        label $v.bot.mode -text "\[[winfo depth .top]-bit\]" -font $f
1396        pack $v.bot.gamma $v.bot.mode -side left -padx 4
1397        pack $v.dither -side left -anchor c -pady 2
1398        pack $v.bot -side left -anchor c -pady 2
1399
1400        pack $w.f.h0 -side left -padx 6 -pady 6
1401        pack $w.f.h2 -side left -padx 6 -pady 6 -fill x -expand 1
1402
1403        pack $w.title $w.f -fill x
1404}
1405
1406proc build.encoder w {
1407        label $w.title -text Encoder
1408        frame $w.f -relief sunken -borderwidth 2
1409
1410        frame $w.f.h0 -relief flat
1411        frame $w.f.quality -relief flat
1412        frame $w.f.h0.eb -relief flat
1413        frame $w.f.h0.format -relief groove -borderwidth 2
1414        frame $w.f.h0.size -relief groove -borderwidth 2
1415        frame $w.f.h0.gap -relief flat -width 4
1416
1417        build.encoder_buttons $w.f.h0.eb
1418        build.format $w.f.h0.format
1419        build.size $w.f.h0.size
1420
1421        build.q $w.f.quality
1422
1423        pack $w.f.h0.eb -side left -anchor n -fill y -padx 6 -pady 4
1424        pack $w.f.h0.format -side left -anchor n -fill both -expand 1
1425        pack $w.f.h0.size -side left -anchor c -fill both
1426        pack $w.f.h0.gap -side left -anchor c
1427
1428        pack $w.f.h0 -fill x -pady 4
1429        pack $w.f.quality -fill x -pady 6
1430        pack $w.title $w.f -fill x
1431}
1432
1433proc jpeg_setq value {
1434        global useHardwareComp videoDevice
1435        set value [expr round($value)]
1436        incr value
1437        if { $value > 95 } {
1438                set value 95
1439        } elseif { $value < 5 } {
1440                set value 5
1441        }
1442
1443        set DA [$videoDevice attributes]
1444        set DF [attribute_class $DA format]
1445        if { [inList "jpeg" $DF] && $useHardwareComp } {
1446                grabber q $value
1447        } elseif [have grabber] {
1448                encoder q $value
1449        }
1450
1451        global qvalue
1452        $qvalue configure -text $value
1453}
1454
1455proc h261_setq value {
1456        set value [expr int((1 - $value / 100.) * 29) + 1]
1457        if [have grabber] {
1458                encoder q $value
1459        }
1460        global qvalue
1461        $qvalue configure -text $value
1462}
1463
1464proc h261as_setq value {
1465        set value [expr int((1 - $value / 100.) * 29) + 1]
1466        if [have grabber] {
1467                encoder q $value
1468        }
1469        global qvalue
1470        $qvalue configure -text $value
1471}
1472
1473proc h263+_setq value {
1474        set value [expr int((1 - $value / 100.) * 29) + 1]
1475        if [have grabber] {
1476                encoder q $value
1477        }
1478        global qvalue
1479        $qvalue configure -text $value
1480}
1481
1482proc h263_setq value {
1483        set value [expr int((1 - $value / 100.) * 29) + 1]
1484        if [have grabber] {
1485                encoder q $value
1486        }
1487        global qvalue
1488        $qvalue configure -text $value
1489}
1490
1491proc nv_setq value {
1492        set value [expr (100 - $value) / 10]
1493        if [have grabber] {
1494                encoder q $value
1495        }
1496        global qvalue
1497        $qvalue configure -text [expr round($value * 10) / 10]
1498}
1499
1500proc nvdct_setq value {
1501        set value [expr round($value)]
1502        nv_setq $value
1503        global qvalue
1504        $qvalue configure -text $value
1505}
1506
1507proc raw_setq value {
1508        set value 1
1509        if [have grabber] {
1510                encoder q $value
1511        }
1512        global qvalue
1513        $qvalue configure -text $value
1514}
1515
1516set bvc_quantizer(0) { 0 0 0 0 1 1 1 1 2 2 }
1517set bvc_quantizer(1) { 0 0 0 1 1 1 1 1 2 3 }
1518set bvc_quantizer(2) { 0 0 0 1 1 1 1 2 3 3 }
1519set bvc_quantizer(3) { 0 0 0 1 1 1 2 2 4 4 }
1520set bvc_quantizer(4) { 0 0 0 2 2 2 3 3 4 4 }
1521set bvc_quantizer(5) { 0 0 0 2 2 2 3 4 4 4 }
1522set bvc_quantizer(6) { 0 0 0 2 2 2 4 4 5 5 }
1523set bvc_quantizer(7) { 0 0 0 2 3 3 4 5 5 5 }
1524set bvc_quantizer(8) { 0 0 0 2 3 4 6 6 6 6 }
1525set bvc_quantizer(9) { 2 2 2 3 6 5 7 7 7 7 }
1526
1527
1528proc bvc_setq value {
1529        set value [expr 9 - $value / 10]
1530        if [have grabber] {
1531                global bvc_quantizer
1532                set n 0
1533                foreach q $bvc_quantizer($value) {
1534                        encoder q $n [expr 7 - $q]
1535                        incr n
1536                }
1537        }
1538        global qvalue
1539        $qvalue configure -text $value
1540}
1541
1542set pvh_shmap { 0 1 2 1 }
1543set pvh_shs {
1544        { lum-dct 0 5-1--11- }
1545        { lum-dct 1 ---5111- }
1546        { lum-dct 2 --51-11- }
1547        { lum-sbc 0 ----4--2 }
1548        { lum-sbc 1 ----4--2 }
1549        { lum-sbc 2 ----4--2 }
1550        { chm     0 -5---1-- }
1551        { chm     1 ---5-1-- }
1552        { chm     2 --5--1-- }
1553}
1554
1555#
1556# Format specific routine to map generic quality <i>value</i>
1557# into actions that program the underlying PVH codec.
1558#
1559#VideoPipeline instproc
1560#
1561proc pvh_setq value {
1562#       $self instvar encoder_
1563#       if ![info exists encoder_] {
1564#               return -1
1565#       }
1566        if [have grabber] {
1567                #encoder q $value
1568
1569                #XXX ignore value and just set up the bit allocation
1570                #XXX should have variable strategies here
1571                global pvh_shmap pvh_shs
1572                set n [llength $pvh_shmap]
1573                set i 0
1574                while { $i < $n } {
1575                        encoder shmap $i [lindex $pvh_shmap $i]
1576                        incr i
1577                }
1578                set i 0
1579                foreach tuple $pvh_shs {
1580                        set compID [lindex $tuple 0]
1581                        set shID [lindex $tuple 1]
1582                        set pattern [lindex $tuple 2]
1583                        encoder comp $compID $shID $pattern
1584                }
1585                global qvalue
1586                $qvalue configure -text $value
1587
1588                return 0
1589        }
1590        #XXX
1591        return -1
1592}
1593
1594#
1595# If the capture device is open, close it.  If transmission
1596# was active fire it up again.  Some state can only be set at
1597# device open time, so some controls must resort to this proc.
1598#
1599proc restart { } {
1600        if [have grabber] {
1601                global transmitButtonState logoButtonState videoDevice V
1602
1603                # HANDLE TRANSMIT LOGO
1604                if $logoButtonState {
1605                        logo_quit
1606                        logo_transmit
1607                } else {
1608                        logo_quit
1609                }
1610
1611                # HANDLE TRANSMIT VIDEO
1612                if $transmitButtonState {
1613                        $V(grabber) send 0
1614                        close_device
1615                        transmit
1616                } else {
1617                        close_device
1618                }
1619        }
1620        set_software_scale_buttons_state
1621}
1622
1623proc disable_large_button { } {
1624        global sizeButtons inputSize
1625        if { $inputSize == 1 } {
1626                set inputSize 2
1627        }
1628        $sizeButtons.b2 configure -state disabled
1629}
1630
1631proc enable_large_button { } {
1632        global sizeButtons videoDevice
1633        if { [info exists videoDevice] && \
1634                [device_supports $videoDevice size large] } {
1635                $sizeButtons.b2 configure -state normal
1636        }
1637}
1638
1639proc set_software_scale_buttons_state { } {
1640        global inputSize softwareScaleButtons
1641        if { [info exists softwareScaleButtons] } {
1642                if { $inputSize == 1 } {
1643                        $softwareScaleButtons.b0 configure -state normal
1644                        $softwareScaleButtons.b1 configure -state normal
1645                        $softwareScaleButtons.b2 configure -state normal
1646                        $softwareScaleButtons.b3 configure -state normal
1647                        $softwareScaleButtons.b4 configure -state normal
1648                } else {
1649                        $softwareScaleButtons.b0 configure -state disabled
1650                        $softwareScaleButtons.b1 configure -state disabled
1651                        $softwareScaleButtons.b2 configure -state disabled
1652                        $softwareScaleButtons.b3 configure -state disabled
1653                        $softwareScaleButtons.b4 configure -state disabled
1654                }
1655        }
1656}
1657
1658set qscale_val(h261) 68
1659set qscale_val(h261as) 68
1660set qscale_val(h263) 68
1661set qscale_val(h263+) 68
1662set qscale_val(nv) 80
1663set qscale_val(nvdct) 80
1664set qscale_val(bvc) 60
1665set qscale_val(jpeg) 29
1666set qscale_val(raw) 1
1667set lastFmt ""
1668
1669proc select_format fmt {
1670        global qscale qlabel videoDevice videoFormat qscale_val lastFmt inputSize
1671
1672        if { $fmt == "h261" || $fmt == "pvh"} {
1673                # H.261 supports only QCIF/CIF
1674                disable_large_button
1675        } else {
1676                enable_large_button
1677        }
1678
1679        if { $fmt == "pvh"} {
1680                set w .menu.encoder.f.encoderLayer
1681                if ![winfo exists $w] {
1682                        frame $w
1683                        build.encoderLayer_scale $w
1684                }
1685                pack $w -before .menu.encoder.f.quality  -fill x
1686        } else {
1687                pack forget .menu.encoder.f.encoderLayer
1688        }
1689
1690        set qscale_val($lastFmt) [expr round([$qscale get])]
1691        set lastFmt $videoFormat
1692
1693        set proc $fmt\_setq
1694
1695        if [inList $proc [info commands *_setq]] {
1696                if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1697                        $qscale state !disabled
1698                        $qscale configure -command $proc
1699                } else {
1700                        $qscale configure -state normal -command $proc
1701                }
1702                $qlabel configure -foreground black
1703        } else {
1704                if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1705                        $qscale state !active
1706                        $qscale state disabled
1707                } else {
1708                        $qscale configure -state disabled
1709                }
1710                $qlabel configure -foreground gray40
1711        }
1712        set qual [resource quality]
1713        if { $qual > 0 } {
1714                $qscale set [resource quality]
1715        } else { if [info exists qscale_val($fmt)] {
1716                $qscale set $qscale_val($fmt)
1717        }}
1718        if [have grabber] {
1719                global V
1720                set encoder [create_encoder $videoFormat]
1721
1722# MM
1723#               if { [info procs build.$devname\_$videoFormat] != "" } {
1724#                       if ![winfo exists $w] {
1725#                               frame $w
1726#                               build.$devname $w
1727#                       }
1728#                       pack $w -before .menu.encoder -padx 6 -fill x
1729#                       set grabberPanel $w
1730#               }
1731# MM
1732
1733                set ff [$encoder frame-format]
1734                if { "$ff" == "[$V(encoder) frame-format]" && [windowingsystem] != "aqua"} {
1735                        #
1736                        # new framer has the same format as the
1737                        # old one.  just replace the old one without
1738                        # re-initializing the grabber.
1739                        # XXX doens't work if title-maker is installed
1740                        # SV, title-maker fix: see marked code below
1741                        delete $V(encoder)
1742                        $V(grabber) decimate $inputSize
1743                        set V(encoder) $encoder
1744
1745                        update_encoder_param
1746
1747                        $encoder transmitter $V(session)
1748
1749                        # SV ######################
1750                        global logoButtonState
1751                        if $logoButtonState {
1752                                logo_quit
1753                                logo_transmit
1754                        } else {
1755                                logo_quit
1756                        }
1757                        ###########################
1758                } else {
1759                        #
1760                        # Restart the grabber.
1761                        #
1762                        delete $encoder
1763                        restart
1764                }
1765        }
1766}
1767
1768proc init_grabber { grabber } {
1769        global V configOnTransmit tcl_platform
1770
1771        if { $tcl_platform(platform) == "windows" || [windowingsystem] == "aqua"} {
1772                $grabber useconfig $configOnTransmit
1773        }
1774
1775        if { [$grabber need-capwin] && ![have capwin] } {
1776                #
1777                # we need to create a window for input devices that
1778                # require capturing to the frame buffer.  create but
1779                # don't map it until after we call "$grabber decimate"
1780                # to specify it's size
1781                #
1782                set rgd [option get . localPlxDisplay $V(class)]
1783                if { $rgd != "" } {
1784                        open_dialog "Using Remote Grabbing Display $rgd"
1785                        toplevel .capture -class Vic -screen $rgd
1786                } else {
1787                        toplevel .capture -class Vic
1788                }
1789                wm title .capture "Video Capture Window"
1790                $grabber create-capwin .capture.video
1791                set V(capwin) .capture.video
1792                pack .capture.video
1793
1794                # capture window shouldn't be covered
1795                bind .capture <Visibility> "raise .capture"
1796        }
1797
1798        $grabber transmitter $V(session)
1799        global qscale inputSize fps_slider bps_slider videoDevice
1800        global inputPort inputType portButton typeButton
1801        # MacOS-X requires port and input type to be set before decimate
1802        # is called otherwise the channel device's input may be busy
1803        if {[windowingsystem] == "aqua"} {
1804                if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1805                        $portButton instate {!disabled} {
1806                                $grabber port $inputPort
1807                        }
1808                        $typeButton instate {!disabled} {
1809                                $grabber type $inputType
1810                        }
1811                } else {
1812                        if { [$portButton cget -state] == "normal" } {
1813                                $grabber port $inputPort
1814                        }
1815                        if { [$typeButton cget -state] == "normal" } {
1816                                $grabber type $inputType
1817                        }
1818                }
1819        }
1820
1821        $grabber fps [expr round([$fps_slider get])]
1822        $grabber bps [expr round([$bps_slider get])]
1823        $grabber decimate $inputSize
1824
1825        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1826                $qscale instate {!disabled} {
1827                        set cmd [$qscale cget -command]
1828                        $cmd [expr round([$qscale get])]
1829                }
1830                if {[windowingsystem] != "aqua"} {
1831                        $portButton instate {!disabled} {
1832                                $grabber port $inputPort
1833                        }
1834                        $typeButton instate {!disabled} {
1835                                $grabber type $inputType
1836                        }
1837                }
1838        } else {
1839                if { [lindex [$qscale configure -state] 4] == "normal" } {
1840                        set cmd [lindex [$qscale configure -command] 4]
1841                        $cmd [$qscale get]
1842                }
1843                if {[windowingsystem] != "aqua"} {
1844                        if { [$portButton cget -state] == "normal" } {
1845                                $grabber port $inputPort
1846                        }
1847                        if { [$typeButton cget -state] == "normal" } {
1848                                $grabber type $inputType
1849                        }
1850                }
1851        }
1852        setFillRate
1853        update
1854}
1855
1856proc build.q w {
1857        set f [smallfont]
1858        frame $w.tb
1859        label $w.title -text "Quality" -font $f -anchor w
1860        label $w.tb.value -text 0 -font $f -width 3
1861        if {$::tk_version > 8.4 && [windowingsystem] != "x11"} {
1862                ttk::scale $w.tb.scale -orient horizontal \
1863                        -value 0 -from 0 -to 99
1864        } else {
1865                scale $w.tb.scale -font $f -orient horizontal \
1866                        -showvalue 0 -from 0 -to 99 \
1867                        -width 12 -relief groove
1868        }
1869        global qscale qvalue qlabel
1870        set qscale $w.tb.scale
1871        set qvalue $w.tb.value
1872        set qlabel $w.title
1873
1874        pack $w.tb.scale -side left -fill x -expand 1
1875        pack $w.tb.value -side left
1876        pack $w.title -padx 2 -side left
1877        pack $w.tb -fill x -padx 6 -side left -expand 1
1878}
1879
1880proc build.xmit w {
1881        set f [smallfont]
1882
1883        label $w.label -text Transmission
1884        frame $w.frame -relief sunken -borderwidth 2
1885        pack $w.label -fill x
1886        pack $w.frame -fill both -expand 1
1887        frame $w.frame.buttons
1888        build.buttons $w.frame.buttons
1889
1890        frame $w.frame.combined
1891
1892        frame $w.frame.combined.right
1893        build.sliders $w.frame.combined.right
1894        frame $w.frame.combined.tm
1895        build.titlemaker $w.frame.combined.tm
1896
1897        pack $w.frame.combined.right -side top -expand 1 -fill x -padx 10 -anchor w
1898        pack $w.frame.combined.tm -side bottom -expand 1 -fill y -pady 10 -anchor w
1899
1900        pack $w.frame.buttons -side left -padx 6
1901        pack $w.frame.combined -side right -expand 1 -fill x -padx 10 -anchor c
1902}
1903
1904proc set_dither {} {
1905        global win_src
1906        set wlist [array names win_src]
1907        foreach w $wlist {
1908                set ws($w) $win_src($w)
1909                detach_window $win_src($w) $w
1910        }
1911        if ![init_color] {
1912                revert_to_gray
1913        }
1914        foreach w $wlist {
1915                attach_window $ws($w) $w
1916        }
1917}
1918
1919proc revert_to_gray {} {
1920        global V
1921        if { $V(dither) == "gray" } {
1922                #XXX
1923                puts stderr "vic: out of colors"
1924                exit 1
1925        }
1926        open_dialog "ran out of colors; reverting to gray"
1927        set V(dither) gray
1928        set_dither
1929}
1930
Note: See TracBrowser for help on using the browser.