root/vic/trunk/tcl/ui-ctrlmenu.tcl @ 3853

Revision 3853, 37.8 KB (checked in by ucacsva, 10 years ago)

Tidied up vic gui for overlays. Got rid of transparency slider (not ready yet, maybe not too useful either).

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