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

Revision 4761, 49.1 KB (checked in by turam, 3 years ago)

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