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

Revision 3853, 37.8 KB (checked in by ucacsva, 8 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.