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

Revision 3807, 37.1 KB (checked in by ucacsva, 8 years ago)

Added Rhys's GUI controls for h261as.

  • 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                if ![tm_init $V(grabber) $grabtarget] {
362                        $V(grabber) target $grabtarget
363                }
364                init_grabber $V(grabber)
365                if { $grabq != "" } {
366                        $V(grabber) q $grabq
367                }
368        }
369        if [have capwin] {
370                set w [winfo toplevel $V(capwin)]
371                if $transmitButtonState {
372                        wm deiconify $w
373                } else {
374                        wm withdraw $w
375                }
376                update idletasks
377        }
378        $V(grabber) send $transmitButtonState
379}
380
381proc close_device {} {
382        global V
383        delete $V(encoder)
384        delete $V(grabber)
385        unset V(grabber) V(encoder)
386        if [info exists V(capwin)] {
387                # delete the C++ object, then destrory the tk window
388                delete $V(capwin)
389                destroy [winfo toplevel $V(capwin)]
390                unset V(capwin)
391        }
392}
393
394proc release_device { } {
395        global transmitButtonState transmitButton
396        global logoButtonState logoButton
397
398        if [have grabber] {
399       
400                if $logoButtonState {
401                        $logoButton invoke
402                }
403                logo_quit
404       
405                if $transmitButtonState {
406                        $transmitButton invoke
407                }
408                close_device
409        }
410
411}
412
413proc configWinGrabber {} {
414        global configOnTransmit
415        grabber useconfig $configOnTransmit
416}
417
418proc build.buttons w {
419        set f [smallfont]
420        global transmitButton
421        set transmitButton $w.send
422        global logoButton
423        set logoButton $w.logo
424
425        checkbutton $w.send -text "Transmit" \
426                -relief raised -command transmit \
427                -anchor w -variable transmitButtonState -font $f \
428                -state disabled -highlightthickness 0
429#       checkbutton $w.freeze -text "Freeze" \
430#               -relief raised -command "grabber freeze \$freeze" \
431#               -anchor w -variable freeze -font $f \
432#               -highlightthickness 0
433        button $w.release -text "Release" \
434                -relief raised -command release_device \
435                -font $f -highlightthickness 0
436        checkbutton $w.logo -text "Logo" \
437                -relief raised -command logo_transmit \
438                -anchor w -variable logoButtonState -font $f \
439                -state normal -highlightthickness 0
440               
441#       pack $w.send $w.release $w.freeze -fill both
442        pack $w.send $w.release -fill both
443        pack $w.send $w.logo -fill both
444}
445
446proc doNothing { args } {
447}
448
449proc set_bps { w value } {
450        if [have grabber] {
451                grabber bps $value
452        #XXX
453                session data-bandwidth $value
454        }
455        $w configure -text "$value kbps"
456}
457
458proc set_fps { w value } {
459        grabber fps $value
460        $w configure -text "$value fps"
461}
462
463proc build.sliders w {
464        set f [smallfont]
465
466        global V
467        set key $V(session)
468        global ftext btext
469        set ftext($key) "0.0 f/s"
470        set btext($key) "0.0 kb/s"
471
472        frame $w.info
473        label $w.info.label -text "Rate Control" -font $f
474        label $w.info.fps -textvariable ftext($key) -width 6 \
475                -font $f -pady 0 -borderwidth 0
476    label $w.info.bps -textvariable btext($key) -width 8 \
477                -font $f -pady 0 -borderwidth 0
478        pack $w.info.label -side left
479        pack $w.info.bps $w.info.fps -side right
480       
481        frame $w.bps
482        scale $w.bps.scale -orient horizontal -font $f \
483                -showvalue 0 -from 1 -to [option get . maxbw Vic] \
484                -command "set_bps $w.bps.value" -width 12 \
485                -sliderlength 20 \
486                -relief groove
487        label $w.bps.value -font $f -width 8 -anchor w
488
489        frame $w.fps
490        scale $w.fps.scale -font $f -orient horizontal \
491                -showvalue 0 -from 1 -to 30 \
492                -command "set_fps $w.fps.value" -width 12 \
493                -sliderlength 20 \
494                -relief groove
495        label $w.fps.value -font $f -width 8 -anchor w
496
497        pack $w.info -fill x
498        pack $w.bps $w.fps -fill x
499        pack $w.bps.scale -side left -fill x -expand 1
500        pack $w.bps.value -side left -anchor w
501        pack $w.fps.scale -fill x -side left -expand 1
502        pack $w.fps.value -side left -anchor w
503       
504        $w.bps.scale set [option get . bandwidth Vic]
505        $w.fps.scale set [option get . framerate Vic]
506
507        global fps_slider bps_slider
508        set fps_slider $w.fps.scale
509        set bps_slider $w.bps.scale
510}
511
512proc attribute_class { attr class } {
513        while { [llength $attr] >= 2 } {
514                if { [lindex $attr 0] == $class } {
515                        return [lindex $attr 1]
516                }
517                set attr [lrange $attr 2 end]
518        }
519        return ""
520}
521
522proc inList { item L } {
523        foreach v $L {
524                if { $v == $item } {
525                        return 1
526                }
527        }
528        return 0
529}
530
531#
532# Returns true iff device named by $device has an attribute named
533# $attr in the attribute class $class.  For example,
534# "device_supports vl size cif" would return true.
535# if $attr is "*", then returns true iff the indicated $class
536# exists in the attribute list (for example, "device_supports $d port *"
537# says whether a device supports port selection at all)
538#
539proc device_supports { device class attr } {
540        set L [$device attributes]
541        set L [attribute_class $L $class]
542        if { $attr == "*" } {
543                if { $L == "" } {
544                        return 0
545                } else {
546                        return 1
547                }
548        } else {
549                return [inList $attr $L]
550        }
551}
552
553# device_formats: any type of stream produce-able from this device
554# (not necessarily native)
555proc device_formats device {
556        set L [$device attributes]
557        set sizes [attribute_class $L size]
558        set formats [attribute_class $L format]
559        set fmtList ""
560        if [inList 422 $formats] {
561                set fmtList "$fmtList nv nvdct cellb jpeg raw"
562        }
563        if [inList 411 $formats] {
564                set fmtList "$fmtList bvc pvh"
565        }
566        if [inList cif $sizes] {
567                set fmtList "$fmtList h261 h261as h263+ h263"
568        }
569        if [inList jpeg $formats] {
570                set fmtList "$fmtList jpeg"
571                global useJPEGforH261
572                if $useJPEGforH261 {
573                        set fmtList "$fmtList h261"
574                }
575        }
576        return $fmtList
577}
578
579#
580# called when selecting a new device: insert a grabber control panel
581# if it exists and remove the old one (if one was installed)
582#
583proc insert_grabber_panel devname {
584        set k [string first - $devname]
585        if { $k >= 0 } {
586                incr k -1
587                set devname [string range $devname 0 $k]
588        }
589        regsub -all " " $devname "_" devname
590        set w .menu.$devname
591        global grabberPanel
592        if [info exists grabberPanel] {
593                if { "$grabberPanel" == "$w" } {
594                        return
595                }
596                pack forget $grabberPanel
597                unset grabberPanel
598        }
599        if { [info procs build.$devname] != "" } {
600                if ![winfo exists $w] {
601                        frame $w
602                        build.$devname $w
603                }
604                pack $w -before .menu.encoder -padx 6 -fill x
605                set grabberPanel $w
606        }
607}
608
609#
610# Called when use selects a particular device (like videopix or xil)
611# (and at startup for default device)
612#
613proc select_device device {
614        global transmitButton sizeButtons portButton formatButtons \
615                videoFormat defaultFormat lastDevice defaultPort inputPort \
616                transmitButtonState typeButton
617
618        #
619        # Remember settings of various controls for previous device
620        # and close down the device if it's already open
621        #
622        set wasTransmitting $transmitButtonState
623        if [info exists lastDevice] {
624                set defaultFormat($lastDevice) $videoFormat
625                set defaultPort($lastDevice) $inputPort
626                release_device
627        }
628        set lastDevice $device
629
630        set fmtList [device_formats $device]
631        foreach b $formatButtons {
632                set fmt [lindex [$b configure -value] 4]
633                #XXX
634                if { $fmt == "bvc" && ![yesno enableBVC] } {
635                        $b configure -state disabled
636                } elseif { [inList $fmt $fmtList] } {
637                        $b configure -state normal
638                } else {
639                        $b configure -state disabled
640                }
641        }
642        $transmitButton configure -state normal
643        if [device_supports $device size small] {
644                $sizeButtons.b0 configure -state normal
645        } else {
646                $sizeButtons.b0 configure -state disabled
647        }
648        if [device_supports $device size large] {
649                $sizeButtons.b2 configure -state normal
650        } else {
651                $sizeButtons.b2 configure -state disabled
652        }
653        if [device_supports $device port *] {
654                $portButton configure -state normal
655                attach_ports $device
656        } else {
657                $portButton configure -state disabled
658        }
659        if [device_supports $device type *] {
660                $typeButton configure -state normal
661        } else {
662                $typeButton configure -state disabled
663        }
664        insert_grabber_panel [$device nickname]
665
666        set videoFormat $defaultFormat($device)
667        select_format $videoFormat
668        if $wasTransmitting {
669                $transmitButton invoke
670        }
671}
672
673proc build.device w {
674        set f [smallfont]
675
676        set m $w.menu
677        menubutton $w -menu $m -text Device... \
678                -relief raised -width 10 -font $f
679        menu $m
680
681        global defaultFormat inputDeviceList videoFormat
682        set videoFormat [option get . defaultFormat Vic]
683        if { $videoFormat == "h.261" } {
684                set videoFormat h261
685        }
686        #
687        # Disabled the device button if we have no devices or
688        # if we don't have transmit persmission.
689        #
690        if { ![info exists inputDeviceList] || ![have_transmit_permission] } {
691                $w configure -state disabled
692                return
693        }
694        foreach d $inputDeviceList {
695                if { [$d nickname] == "still" && ![yesno stillGrabber] } {
696                        set defaultFormat($d) $videoFormat
697                        continue
698                }
699                # this is fragile
700                $m add radiobutton -label [$d nickname] \
701                        -command "select_device $d" \
702                        -value $d -variable videoDevice -font $f
703                if { "[$d attributes]" == "disabled" } {
704                        $m entryconfigure [$d nickname] -state disabled
705                }
706                set fmtList [device_formats $d]
707                if [inList $videoFormat $fmtList] {
708                        set defaultFormat($d) $videoFormat
709                } else {
710                        set defaultFormat($d) [lindex $fmtList 0]
711                }
712        }
713}
714
715proc format_col3 { w n0 n1 n2 } {
716        set f [smallfont]
717        frame $w
718        radiobutton $w.b0 -text $n0 -relief flat -font $f -anchor w \
719                -variable videoFormat -value $n0 -padx 0 -pady 0 \
720                -command "select_format $n0" -state disabled
721        radiobutton $w.b1 -text $n1 -relief flat -font $f -anchor w \
722                -variable videoFormat -value $n1 -padx 0 -pady 0 \
723                -command "select_format $n1" -state disabled
724        radiobutton $w.b2 -text $n2 -relief flat -font $f -anchor w \
725                -variable videoFormat -value $n2 -padx 0 -pady 0 \
726                -command "select_format $n2" -state disabled
727        pack $w.b0 $w.b1 $w.b2 -fill x
728
729        global formatButtons
730        lappend formatButtons $w.b0 $w.b1 $w.b2
731
732        #format_col $w.p0 nv nvdct cellb
733        #format_col $w.p1 jpeg h261 bvc
734        #format_col $w.p2 h263+ h263 raw
735}
736
737proc format_col { w n0 n1 } {
738        set f [smallfont]
739        frame $w
740        if { [string first : $n0] > 0 } {
741                set reliefn0 ridge
742                set n0 [ string range $n0 0 [expr {[string length $n0] -2 }] ]
743        } else {
744                set reliefn0 flat
745        }
746        if { [string first : $n1] > 0 } {
747                set reliefn1 ridge
748                set n1 [ string range $n1 0 [expr {[string length $n1] -2 }] ]
749        } else {
750                set reliefn1 flat
751        }
752        radiobutton $w.b0 -text $n0 -relief $reliefn0 -font $f -anchor w \
753                -variable videoFormat -value $n0 -padx 0 -pady 0 \
754                -command "select_format $n0" -state disabled
755        radiobutton $w.b1 -text $n1 -relief $reliefn1 -font $f -anchor w \
756                -variable videoFormat -value $n1 -padx 0 -pady 0 \
757                -command "select_format $n1" -state disabled
758        pack $w.b0 $w.b1 -fill x
759
760        global formatButtons
761        lappend formatButtons $w.b0 $w.b1
762
763        #format_col $w.p0 nv nvdct
764        #format_col $w.p1 jpeg h261
765        #format_col $w.p2 h263+ h263
766        #format_col $w.p3 raw cellb
767        #format_col $w.p4 pvh bvc
768}
769
770proc set_numEncoderLayers { value } {
771        global transmitButtonState numEncoderLayers V encoderLayerScale encoderLayerValue
772
773        $encoderLayerValue configure -text $value
774       
775        if $transmitButtonState {
776                $V(encoder) loop_layer [expr {$numEncoderLayers + 1}]
777                #$V(decoder) maxChannel $numEncoderLayers
778        }
779}
780
781proc build.encoderLayer_scale w {
782        global numLayers encoderLayerScale encoderLayerValue
783
784        set f [smallfont]
785
786        frame $w.tb
787        label $w.title -text "Layers" -font $f -anchor w
788        label $w.tb.value -text 0 -font $f -width 3
789        scale $w.tb.scale -font $f -orient horizontal \
790                -showvalue 0 -from 0 -to $numLayers \
791                -variable numEncoderLayers \
792                -width 12 -relief groove \
793        -command "set_numEncoderLayers"
794
795
796        set encoderLayerScale $w.tb.scale
797        set encoderLayerValue $w.tb.value
798
799        $encoderLayerValue configure -text $numLayers
800
801#$layerscale configure -state disabled
802
803        pack $w.tb.scale -side left -fill x -expand 1
804        pack $w.tb.value -side left
805        pack $w.title -padx 2 -side left
806        pack $w.tb -fill x -padx 6 -side left -expand 1
807}
808
809proc build.format w {
810        format_col $w.p0 nv nvdct
811        format_col $w.p1 jpeg h261
812        format_col $w.p2 h263+ h263
813        format_col $w.p3 raw cellb
814        format_col $w.p4 bvc pvh:
815        format_col $w.p5 h261as null
816       
817        frame $w.glue0
818        frame $w.glue1
819        pack $w.p0 $w.p1 $w.p2 $w.p3 $w.p4 $w.p5 -side left
820
821}
822
823proc build.size w {
824        set f [smallfont]
825
826        set b $w.b
827        frame $b
828        radiobutton $b.b0 -text "small" -command "grabber decimate 4" \
829                -padx 0 -pady 0 \
830                -anchor w -variable inputSize -font $f -relief flat -value 4
831        radiobutton $b.b1 -text "normal" -command "grabber decimate 2" \
832                -padx 0 -pady 0 \
833                -anchor w -variable inputSize -font $f -relief flat -value 2
834        radiobutton $b.b2 -text "large" -command "grabber decimate 1" \
835                -padx 0 -pady 0 \
836                -anchor w -variable inputSize -font $f -relief flat -value 1
837        pack $b.b0 $b.b1 $b.b2 -fill x
838        pack $b -anchor c -side left
839        global inputSize sizeButtons
840        set inputSize 2
841        set sizeButtons $b
842}
843
844proc build.port w {
845        set f [smallfont]
846        # create the menubutton but don't defer the menu creation until later
847        menubutton $w -menu $w.menu -text Port... \
848                -relief raised -width 10 -font $f -state disabled
849        global portButton inputPort
850        set portButton $w
851        set inputPort undefined
852}
853
854proc attach_ports device {
855        global portButton inputPort defaultPort
856        catch "destroy $portButton.menu"
857        set portnames [attribute_class [$device attributes] port]
858        set f [smallfont]
859        set m $portButton.menu
860        menu $m
861        foreach port $portnames {
862                $m add radiobutton -label $port \
863                        -command "grabber port $port" \
864                        -value $port -variable inputPort -font $f
865        }
866        if ![info exists defaultPort($device)] {
867                set nn [$device nickname]
868                if [info exists defaultPort($nn)] {
869                        set defaultPort($device) $defaultPort($nn)
870                } else {
871                        set s [resource defaultPort($nn)]
872                        if { $s != "" } {
873                                set defaultPort($device) $s
874                        } else {
875                                set defaultPort($device) [lindex $portnames 0]
876                        }
877                }
878        }
879        set inputPort $defaultPort($device)
880}
881
882proc build.type w {
883        set f [smallfont]
884
885        set m $w.menu
886        menubutton $w -text Signal... -menu $m -relief raised \
887                -width 10 -font $f -state disabled
888        menu $m
889        $m add radiobutton -label "auto" -command restart \
890                -value auto -variable inputType -font $f
891        $m add radiobutton -label "NTSC" -command restart \
892                -value ntsc -variable inputType -font $f
893        $m add radiobutton -label "PAL" -command restart \
894                -value pal -variable inputType -font $f
895        $m add radiobutton -label "SECAM" -command restart \
896                -value secam -variable inputType -font $f
897
898        global inputType typeButton
899        set inputType auto
900        set typeButton $w
901}
902
903proc build.encoder_buttons w {
904        set f [smallfont]
905        build.encoder_options $w.options
906        build.device $w.device
907        build.port $w.port
908        build.type $w.type
909        pack $w.device $w.port $w.type $w.options -fill x
910}
911
912proc build.encoder_options w {
913        global useJPEGforH261 tcl_platform useHardwareComp
914        set useJPEGforH261 [yesno useJPEGforH261]
915        set useHardwareComp [yesno useHardwareComp]
916        set f [smallfont]
917        set m $w.menu
918        menubutton $w -text Options... -menu $m -relief raised -width 10 \
919                -font $f
920        menu $m
921        $m add checkbutton -label "Sending Slides" \
922                -variable sendingSlides -font $f -command setFillRate
923        $m add checkbutton -label "Use JPEG for H261" \
924                -variable useJPEGforH261 -font $f -command restart
925                $m add checkbutton -label "Use Hardware Encode" \
926                -variable useHardwareComp -font $f -command restart
927                if {$tcl_platform(platform) == "windows"} {
928                        $m add checkbutton -label "Configure on Transmit" \
929                        -variable configOnTransmit -font $f
930                }
931}
932
933proc build.tile w {
934        set f [smallfont]
935        set m $w.menu
936        menubutton $w -text Tile... -menu $m -relief raised -width 10 \
937                -font $f
938        menu $m
939        $m add radiobutton -label Single -command "redecorate 1" \
940                -value 1 -variable V(ncol) -font $f
941        $m add radiobutton -label Double -command "redecorate 2" \
942                -value 2 -variable V(ncol) -font $f
943        $m add radiobutton -label Triple -command "redecorate 3" \
944                -value 3 -variable V(ncol) -font $f
945        $m add radiobutton -label Quad -command "redecorate 4" \
946                -value 4 -variable V(ncol) -font $f
947}
948
949proc build.decoder_options w {
950        set f [smallfont]
951        set m $w.menu
952        menubutton $w -text Options... -menu $m -relief raised -width 10 \
953                -font $f
954        menu $m
955        $m add checkbutton -label "Mute New Sources" \
956                -variable V(muteNewSources) -font $f
957        $m add checkbutton -label "Use Hardware Decode" \
958                -variable V(useHardwareDecode) -font $f
959        $m add separator
960        $m add command -label "Optimize Colormap" \
961                -command fork_histtolut -font $f
962
963        global V
964        set V(optionsMenu) $m
965        if ![have dither] {
966                $m entryconfigure "Optimize Colormap" -state disabled
967        }
968}
969
970proc build.external w {
971        set f [smallfont]
972        set m $w.menu
973        global outputDeviceList
974        if ![info exists outputDeviceList] {
975                set outputDeviceList ""
976        }
977        if { [llength $outputDeviceList] <= 1 } {
978                button $w -text External -relief raised \
979                        -width 10 -font $f -highlightthickness 0 \
980                        -command "extout_select $outputDeviceList"
981        } else {
982                menubutton $w -text External... -menu $m -relief raised \
983                        -width 10 -font $f 
984                menu $m
985                foreach d $outputDeviceList {
986                        $m add command -font $f -label [$d nickname] \
987                                -command "extout_select $d"
988                }
989        }
990        if { $outputDeviceList == "" } {
991                $w configure -state disabled
992        }
993}
994
995proc build.dither w {
996        set f [smallfont]
997        if [have dither] {
998                set var V(dither)
999                set state normal
1000        } else {
1001                set var dummyDither
1002                set state disabled
1003        }
1004        set v $w.h0
1005        frame $v
1006        radiobutton $v.b0 -text "Ordered" -command set_dither \
1007                -padx 0 -pady 0 \
1008                -anchor w -variable $var -state $state \
1009                -font $f -relief flat -value od
1010        radiobutton $v.b1 -text "Error Diff" -command set_dither \
1011                -padx 0 -pady 0 \
1012                -anchor w -variable $var -state $state \
1013                -font $f -relief flat -value ed
1014        set v $w.h1
1015        frame $v
1016        radiobutton $v.b2 -text Quantize -command set_dither \
1017                -padx 0 -pady 0 \
1018                -anchor w -variable $var -state $state \
1019                -font $f -relief flat \
1020                -value quantize
1021        radiobutton $v.b3 -text Gray -command set_dither \
1022                -padx 0 -pady 0 \
1023                -anchor w -variable $var -state $state \
1024                -font $f -relief flat -value gray
1025
1026        pack $w.h0.b0 $w.h0.b1 -anchor w -fill x
1027        pack $w.h1.b2 $w.h1.b3 -anchor w -fill x
1028        pack $w.h0 $w.h1 -side left
1029}
1030
1031proc update_gamma { w s } {
1032        global V win_src
1033        set cm $V(colorModel)
1034        if ![$cm gamma $s] {
1035                return -1
1036        }
1037        set V(gamma) $s
1038        $cm free-colors
1039        if ![$cm alloc-colors] {
1040                revert_to_gray
1041        }
1042        #
1043        # Need to update all the windows.  Can't just do a redraw
1044        # on all the windows because that won't cause the renderer's
1045        # to update their copy of the image (which has the old colormap
1046        # installed).  Instead, go through all the active decoders and
1047        # force them to update all the windows.
1048        #
1049        foreach src [session active] {
1050                set d [$src handler]
1051                if { $d != "" } {
1052                        $d redraw
1053                }
1054        }
1055
1056        return 0
1057}
1058
1059proc build.gamma w {
1060        global V
1061        frame $w
1062        label $w.label -text "Gamma: " -font [smallfont] -anchor e
1063        mk.entry $w update_gamma $V(gamma)
1064        $w.entry configure -width 6
1065        if ![have dither] {
1066                $w.entry configure -state disabled -foreground gray60
1067                $w.label configure -foreground gray60
1068        }
1069        pack $w.label -side left
1070        pack $w.entry -side left -expand 1 -fill x -pady 2
1071}
1072
1073proc build.decoder w {
1074        set f [smallfont]
1075
1076        label $w.title -text Display
1077        frame $w.f -relief sunken -borderwidth 2
1078
1079        set v $w.f.h0
1080        frame $v
1081
1082        build.external $v.ext
1083        build.tile $v.tile
1084        build.decoder_options $v.options
1085
1086        pack $v.options $v.tile $v.ext -fill x -expand 1
1087
1088        set v $w.f.h2
1089        frame $v
1090        frame $v.dither -relief groove -borderwidth 2
1091        build.dither $v.dither
1092        frame $v.bot
1093        build.gamma $v.bot.gamma
1094        label $v.bot.mode -text "\[[winfo depth .top]-bit\]" -font $f
1095        pack $v.bot.gamma $v.bot.mode -side left -padx 4
1096        pack $v.dither $v.bot -anchor c -pady 2
1097
1098        pack $w.f.h0 -side left -padx 6 -pady 6
1099        pack $w.f.h2 -side left -padx 6 -pady 6 -fill x -expand 1
1100
1101        pack $w.title $w.f -fill x
1102}
1103
1104proc build.encoder w {
1105        label $w.title -text Encoder
1106        frame $w.f -relief sunken -borderwidth 2
1107
1108        frame $w.f.h0 -relief flat
1109        frame $w.f.quality -relief flat
1110        frame $w.f.h0.eb -relief flat
1111        frame $w.f.h0.format -relief groove -borderwidth 2
1112        frame $w.f.h0.size -relief groove -borderwidth 2
1113        frame $w.f.h0.gap -relief flat -width 4
1114
1115        build.encoder_buttons $w.f.h0.eb
1116        build.format $w.f.h0.format
1117        build.size $w.f.h0.size
1118
1119        build.q $w.f.quality
1120
1121        pack $w.f.h0.eb -side left -anchor n -fill y -padx 6 -pady 4
1122        pack $w.f.h0.format -side left -anchor n -fill both -expand 1
1123        pack $w.f.h0.size -side left -anchor c -fill both
1124        pack $w.f.h0.gap -side left -anchor c
1125
1126        pack $w.f.h0 -fill x -pady 4
1127        pack $w.f.quality -fill x -pady 6
1128        pack $w.title $w.f -fill x
1129}
1130
1131proc jpeg_setq value {
1132        global useHardwareComp videoDevice
1133        incr value
1134        if { $value > 95 } {
1135                set value 95
1136        } elseif { $value < 5 } {
1137                set value 5
1138        }
1139
1140        set DA [$videoDevice attributes]
1141        set DF [attribute_class $DA format]
1142        if { [inList "jpeg" $DF] && $useHardwareComp } {
1143                grabber q $value
1144        } elseif [have grabber] {
1145                encoder q $value
1146        }       
1147       
1148        global qvalue
1149        $qvalue configure -text $value
1150}
1151
1152proc h261_setq value {
1153        set value [expr int((1 - $value / 100.) * 29) + 1]
1154        if [have grabber] {
1155                encoder q $value
1156        }
1157        global qvalue
1158        $qvalue configure -text $value
1159}
1160
1161proc h263+_setq value {
1162        set value [expr int((1 - $value / 100.) * 29) + 1]
1163        if [have grabber] {
1164                encoder q $value
1165        }
1166        global qvalue
1167        $qvalue configure -text $value
1168}
1169
1170proc h263_setq value {
1171        set value [expr int((1 - $value / 100.) * 29) + 1]
1172        if [have grabber] {
1173                encoder q $value
1174        }
1175        global qvalue
1176        $qvalue configure -text $value
1177}
1178
1179proc nv_setq value {
1180        set value [expr (100 - $value) / 10]
1181        if [have grabber] {
1182                encoder q $value
1183        }
1184        global qvalue
1185        $qvalue configure -text $value
1186}
1187
1188proc nvdct_setq value {
1189        nv_setq $value
1190        global qvalue
1191        $qvalue configure -text $value
1192}
1193
1194proc raw_setq value {
1195        set value 1
1196        if [have grabber] {
1197                encoder q $value
1198        }
1199        global qvalue
1200        $qvalue configure -text $value
1201}
1202
1203set bvc_quantizer(0) { 0 0 0 0 1 1 1 1 2 2 }
1204set bvc_quantizer(1) { 0 0 0 1 1 1 1 1 2 3 }
1205set bvc_quantizer(2) { 0 0 0 1 1 1 1 2 3 3 }
1206set bvc_quantizer(3) { 0 0 0 1 1 1 2 2 4 4 }
1207set bvc_quantizer(4) { 0 0 0 2 2 2 3 3 4 4 }
1208set bvc_quantizer(5) { 0 0 0 2 2 2 3 4 4 4 }
1209set bvc_quantizer(6) { 0 0 0 2 2 2 4 4 5 5 }
1210set bvc_quantizer(7) { 0 0 0 2 3 3 4 5 5 5 }
1211set bvc_quantizer(8) { 0 0 0 2 3 4 6 6 6 6 }
1212set bvc_quantizer(9) { 2 2 2 3 6 5 7 7 7 7 }
1213
1214
1215proc bvc_setq value {
1216        set value [expr 9 - $value / 10]
1217        if [have grabber] {
1218                global bvc_quantizer
1219                set n 0
1220                foreach q $bvc_quantizer($value) {
1221                        encoder q $n [expr 7 - $q]
1222                        incr n
1223                }
1224        }
1225        global qvalue
1226        $qvalue configure -text $value
1227}
1228
1229set pvh_shmap { 0 1 2 1 }
1230set pvh_shs {
1231        { lum-dct 0 5-1--11- }
1232        { lum-dct 1 ---5111- }
1233        { lum-dct 2 --51-11- }
1234        { lum-sbc 0 ----4--2 }
1235        { lum-sbc 1 ----4--2 }
1236        { lum-sbc 2 ----4--2 }
1237        { chm     0 -5---1-- }
1238        { chm     1 ---5-1-- }
1239        { chm     2 --5--1-- }
1240}
1241
1242#
1243# Format specific routine to map generic quality <i>value</i>
1244# into actions that program the underlying PVH codec.
1245#
1246#VideoPipeline instproc
1247#
1248proc pvh_setq value {
1249#       $self instvar encoder_
1250#       if ![info exists encoder_] {
1251#               return -1
1252#       }
1253        if [have grabber] {
1254                #encoder q $value
1255
1256                #XXX ignore value and just set up the bit allocation
1257                #XXX should have variable strategies here
1258                global pvh_shmap pvh_shs
1259                set n [llength $pvh_shmap]
1260                set i 0
1261                while { $i < $n } {
1262                        encoder shmap $i [lindex $pvh_shmap $i]
1263                        incr i
1264                }
1265                set i 0
1266                foreach tuple $pvh_shs {
1267                        set compID [lindex $tuple 0]
1268                        set shID [lindex $tuple 1]
1269                        set pattern [lindex $tuple 2]
1270                        encoder comp $compID $shID $pattern
1271                }
1272                global qvalue
1273                $qvalue configure -text $value
1274               
1275                return 0
1276        }
1277        #XXX
1278        return -1
1279}
1280
1281#
1282# If the capture device is open, close it.  If transmission
1283# was active fire it up again.  Some state can only be set at
1284# device open time, so some controls must resort to this proc.
1285#
1286proc restart { } {
1287        if [have grabber] {
1288                global transmitButtonState logoButtonState videoDevice V
1289       
1290                # HANDLE TRANSMIT LOGO
1291                if $logoButtonState {
1292                        logo_quit
1293                        logo_transmit
1294                } else {
1295                        logo_quit
1296                }
1297
1298                # HANDLE TRANSMIT VIDEO
1299                if $transmitButtonState {
1300                        $V(grabber) send 0
1301                        close_device
1302                        transmit
1303                } else {
1304                        close_device
1305                }
1306               
1307        }
1308}
1309
1310proc disable_large_button { } {
1311        global sizeButtons inputSize
1312        if { $inputSize == 1 } {
1313                set inputSize 2
1314        }
1315        $sizeButtons.b2 configure -state disabled
1316}
1317
1318proc enable_large_button { } {
1319        global sizeButtons videoDevice
1320        if { [info exists videoDevice] && \
1321                [device_supports $videoDevice size large] } {
1322                $sizeButtons.b2 configure -state normal
1323        }
1324}
1325
1326set qscale_val(h261) 68
1327set qscale_val(h263) 68
1328set qscale_val(h263+) 68
1329set qscale_val(nv) 80
1330set qscale_val(nvdct) 80
1331set qscale_val(bvc) 60
1332set qscale_val(jpeg) 29
1333set qscale_val(raw) 1
1334set lastFmt ""
1335
1336proc select_format fmt {
1337        global qscale qlabel videoDevice videoFormat qscale_val lastFmt
1338
1339        if { $fmt == "h261" || $fmt == "pvh"} {
1340                # H.261 supports only QCIF/CIF
1341                disable_large_button
1342        } else {
1343                enable_large_button
1344        }
1345
1346        if { $fmt == "pvh"} {
1347                set w .menu.encoder.f.encoderLayer
1348                if ![winfo exists $w] {
1349                        frame $w
1350                        build.encoderLayer_scale $w
1351                }
1352                pack $w -before .menu.encoder.f.quality  -fill x
1353        } else {
1354                pack forget .menu.encoder.f.encoderLayer
1355        }
1356
1357        set qscale_val($lastFmt) [$qscale get]
1358        set lastFmt $videoFormat
1359
1360        set proc $fmt\_setq
1361        if [inList $proc [info commands *_setq]] {
1362                $qscale configure -state normal -command $proc
1363                $qlabel configure -foreground black
1364        } else {
1365                $qscale configure -state disabled
1366                $qlabel configure -foreground gray40
1367        }
1368        set qual [resource quality]
1369        if { $qual > 0 } {
1370                $qscale set [resource quality]
1371        } else { if [info exists qscale_val($fmt)] {
1372                $qscale set $qscale_val($fmt)
1373        }}
1374        if [have grabber] {
1375                global V
1376                set encoder [create_encoder $videoFormat]
1377
1378# MM
1379#               if { [info procs build.$devname\_$videoFormat] != "" } {
1380#                       if ![winfo exists $w] {
1381#                               frame $w
1382#                               build.$devname $w
1383#                       }
1384#                       pack $w -before .menu.encoder -padx 6 -fill x
1385#                       set grabberPanel $w
1386#               }
1387# MM
1388
1389                set ff [$encoder frame-format]
1390                if { "$ff" == "[$V(encoder) frame-format]" } {
1391                        #
1392                        # new framer has the same format as the
1393                        # old one.  just replace the old one without
1394                        # re-initializing the grabber.
1395                        # XXX doens't work if title-maker is installed
1396                        #
1397                        delete $V(encoder)
1398                        set V(encoder) $encoder
1399                        $encoder transmitter $V(session)
1400                        $V(grabber) target $encoder
1401                } else {
1402                        #
1403                        # Restart the grabber.
1404                        #
1405                        delete $encoder
1406                        restart
1407                }
1408        }
1409}
1410
1411proc init_grabber { grabber } {
1412        global V configOnTransmit tcl_platform
1413
1414        if {$tcl_platform(platform) == "windows"} {
1415                $grabber useconfig $configOnTransmit
1416        }
1417
1418        if { [$grabber need-capwin] && ![have capwin] } {
1419                #
1420                # we need to create a window for input devices that
1421                # require capturing to the frame buffer.  create but
1422                # don't map it until after we call "$grabber decimate"
1423                # to specify it's size
1424                #
1425                set rgd [option get . localPlxDisplay $V(class)]
1426                if { $rgd != "" } {
1427                        open_dialog "Using Remote Grabbing Display $rgd"
1428                        toplevel .capture -class Vic -screen $rgd
1429                } else {
1430                        toplevel .capture -class Vic
1431                }
1432                wm title .capture "Video Capture Window"
1433                $grabber create-capwin .capture.video
1434                set V(capwin) .capture.video
1435                pack .capture.video
1436           
1437                # capture window shouldn't be covered
1438                bind .capture <Visibility> "raise .capture"
1439        }
1440
1441        $grabber transmitter $V(session)
1442        global qscale inputSize fps_slider bps_slider videoDevice
1443        $grabber fps [$fps_slider get]
1444        $grabber bps [$bps_slider get]
1445        $grabber decimate $inputSize
1446        if { [lindex [$qscale configure -state] 4] == "normal" } {
1447                set cmd [lindex [$qscale configure -command] 4]
1448                $cmd [$qscale get]
1449        }
1450        global inputPort inputType portButton typeButton
1451        if { [$portButton cget -state] == "normal" } {
1452                $grabber port $inputPort
1453        }
1454        if { [$typeButton cget -state] == "normal" } {
1455                $grabber type $inputType
1456        }
1457        setFillRate
1458        update
1459}
1460
1461proc build.q w {
1462        set f [smallfont]
1463        frame $w.tb
1464        label $w.title -text "Quality" -font $f -anchor w
1465        label $w.tb.value -text 0 -font $f -width 3
1466        scale $w.tb.scale -font $f -orient horizontal \
1467                -showvalue 0 -from 0 -to 99 \
1468                -width 12 -relief groove
1469        global qscale qvalue qlabel
1470        set qscale $w.tb.scale
1471        set qvalue $w.tb.value
1472        set qlabel $w.title
1473
1474        pack $w.tb.scale -side left -fill x -expand 1
1475        pack $w.tb.value -side left
1476        pack $w.title -padx 2 -side left
1477        pack $w.tb -fill x -padx 6 -side left -expand 1
1478}
1479
1480proc build.xmit w {
1481        set f [smallfont]
1482
1483        label $w.label -text Transmission
1484        frame $w.frame -relief sunken -borderwidth 2
1485        pack $w.label -fill x
1486        pack $w.frame -fill both -expand 1
1487        frame $w.frame.buttons
1488        build.buttons $w.frame.buttons
1489        frame $w.frame.right
1490        build.sliders $w.frame.right
1491        frame $w.frame.tm
1492        build.titlemaker $w.frame.tm
1493
1494        pack $w.frame.buttons -side left -padx 6
1495        pack $w.frame.right -side right -expand 1 -fill x -padx 10 -anchor c
1496        pack $w.frame.tm -side top -expand 1 -fill y -pady 10 -anchor c
1497       
1498}
1499
1500proc set_dither {} {
1501        global win_src
1502        set wlist [array names win_src]
1503        foreach w $wlist {
1504                set ws($w) $win_src($w)
1505                detach_window $win_src($w) $w
1506        }
1507        if ![init_color] {
1508                revert_to_gray
1509        }
1510        foreach w $wlist {
1511                attach_window $ws($w) $w
1512        }
1513}       
1514
1515proc revert_to_gray {} {
1516        global V
1517        if { $V(dither) == "gray" } {
1518                #XXX
1519                puts stderr "vic: out of colors"
1520                exit 1
1521        }
1522        open_dialog "ran out of colors; reverting to gray"
1523        set V(dither) gray
1524        set_dither
1525}
Note: See TracBrowser for help on using the browser.