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

Revision 904, 33.0 KB (checked in by piers, 15 years ago)

Net dir: tcl - contains all tcl files, and tcl2cpp (former known as tcl2c++)

  • 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        pack $w.cb $w.encoder $w.decoder $w.session -padx 6 -fill x
143        pack $w.dismiss -anchor c -pady 4
144
145        if [have_transmit_permission] {
146                selectInitialDevice
147        }
148}
149
150proc defaultDevice {} {
151        set d [resource defaultDevice]
152        if { $d == "" } {
153                set d [resource device]
154        }
155        return $d
156}       
157
158proc selectInitialDevice {} {
159        global videoDevice inputDeviceList
160        set d [defaultDevice]
161        foreach v $inputDeviceList {
162                if { [$v nickname] == "$d" && \
163                        [$v attributes] != "disabled" } {
164                        set videoDevice $v
165                        select_device $v
166                        return
167                }
168        }
169        foreach v $inputDeviceList {
170                if { "[$v attributes]" != "disabled" &&
171                        "[$v nickname]" != "still" } {
172                        set videoDevice $v
173                        select_device $v
174                        return
175                }
176        }
177}
178
179proc build.session { w dst port srcid ttl name } {
180        set f [smallfont]       
181
182        label $w.title -text Session
183        pack $w.title -fill x
184
185        frame $w.nb -relief sunken -borderwidth 2
186        pack $w.nb -fill x
187
188        frame $w.nb.frame
189        pack append $w.nb \
190                $w.nb.frame { top fillx }
191
192        label $w.nb.frame.info -font $f -anchor w \
193                -text "Dest: $dst   Port: $port  ID: $srcid  TTL: $ttl"
194
195        frame $w.nb.frame.name
196        label $w.nb.frame.name.label -text "Name: " -font $f -anchor e -width 6
197        mk.entry $w.nb.frame.name updateName $name
198        pack $w.nb.frame.name.label -side left
199        pack $w.nb.frame.name.entry -side left -expand 1 -fill x -pady 2
200
201        frame $w.nb.frame.msg
202        label $w.nb.frame.msg.label -text "Note: " -font $f -anchor e -width 6
203        mk.entry $w.nb.frame.msg update_note ""
204        pack $w.nb.frame.msg.label -side left
205        pack $w.nb.frame.msg.entry -side left -expand 1 -fill x -pady 2
206
207        mk.key $w.nb.frame
208
209        frame $w.nb.frame.b
210
211        button $w.nb.frame.b.stats -text "Global Stats" -borderwidth 2 \
212                -anchor c -font $f -command create_global_window
213        button $w.nb.frame.b.members -text Members -borderwidth 2 \
214                -anchor c -font $f -command "toggle_window .srclist"
215
216        pack $w.nb.frame.b.stats $w.nb.frame.b.members \
217                -side left -padx 4 -pady 2 -anchor c
218
219        pack $w.nb.frame.info $w.nb.frame.name $w.nb.frame.msg \
220                $w.nb.frame.key \
221                -fill x -padx 2 -expand 1
222        pack $w.nb.frame.b -pady 2 -anchor c
223}
224
225proc setFillRate { } {
226        global sendingSlides transmitButtonState V
227        if { $transmitButtonState } {
228                if { $sendingSlides } {
229                        $V(grabber) fillrate 16
230                } else {
231                        $V(grabber) fillrate 2
232                }
233        }
234}
235
236proc updateName { w name } {
237        set name [string trim $name]
238        if { $name != ""} {
239                [srctab local] sdes name $name
240                return 0
241        }
242        return -1
243}
244
245proc update_note { w s } {
246        set s [string trim $s]
247        [srctab local] sdes note $s
248        return 0
249}
250
251proc encoder args {
252        global V
253        if ![info exists V(encoder)] {
254                puts "vic: encoder: no encoder"
255                return
256        }
257        eval $V(encoder) $args
258}
259
260proc grabber args {
261        global V
262        if ![info exists V(grabber)] {
263                # ignore
264                return
265        }
266        eval $V(grabber) $args
267}
268
269proc create_encoder fmt {
270        if { $fmt == "nvdct" } {
271                set encoder [new module nv]
272                $encoder use-dct 1
273        } else {
274                set encoder [new module $fmt]
275        }
276        return $encoder
277}
278
279set transmitButtonState 0
280proc transmit { } {
281        global transmitButtonState videoFormat videoDevice V useJPEGforH261 useHardwareComp
282        if ![have grabber] {
283                set DA [$videoDevice attributes]
284                set DF [attribute_class $DA format]
285                set DS [attribute_class $DA size]
286
287                # first, see if device can produce bitstream directly
288                # if not, try a transcoder
289                # if that doesn't work, try anything else
290
291                if { [inList $videoFormat $DF] } {
292                        if { $videoFormat == "h261" || $videoFormat == "cellb" || $videoFormat == "jpeg"} {
293                                # use special hardware tag...
294                                set encoder ""
295                                if  { $useHardwareComp } {
296                                        set encoder [create_encoder "$videoFormat/hw"]
297                                }
298                                if { $encoder == "" } {
299                                        set encoder [create_encoder "$videoFormat"]
300                                }
301                        } else {
302                                set encoder [create_encoder $videoFormat]
303                        }
304                        set grabtarget $encoder
305                        set grabq ""
306                } elseif { $videoFormat == "h261" && [inList jpeg $DF] && \
307                                $useJPEGforH261 } {
308                        # just jpeg->h261 at this time
309                        set transcoder [new transcoder jpeg/dct]
310                        set encoder [new module h261/dct]
311                        $transcoder target $encoder
312                        set grabtarget $transcoder
313                        set grabq "70"
314                } elseif { [inList $videoFormat [device_formats $videoDevice] ] } {
315                        set encoder [create_encoder $videoFormat]
316                        set grabtarget $encoder
317                        set grabq ""
318                }
319
320                $encoder transmitter $V(session)
321                set V(encoder) $encoder
322                set ff [$grabtarget frame-format]
323                set V(grabber) [$videoDevice open $ff]
324                # special cases
325                if { $V(grabber) == "" && $ff == "411" } {
326                        # try cif instead of 411
327                        set V(grabber) [$videoDevice open cif]
328                }
329                if { $V(grabber) == "" } {
330                        #XXX
331                        puts "Error: grabber=\"\" puts XXX couldn't set up grabber/encoder for $ff->$videoFormat"
332                        exit 1
333                }
334                set error [$V(grabber) status]
335                if { $error < 0 } {
336                        close_device
337                        if { $error == -2 } {
338                                #XXX hack: this happens when we tried to open
339                                # a jvideo with a non-jpeg format
340                                set transmitButtonState 0
341                                open_dialog \
342                                    "Can't use jvideo with $videoFormat format"
343                                select_device $videoDevice
344                                return
345                        }
346                        set transmitButtonState 0
347                        open_dialog \
348                            "can't open [$videoDevice nickname] capture device"
349                        return
350                }
351                if ![tm_init $V(grabber) $grabtarget] {
352                        $V(grabber) target $grabtarget
353                }
354                init_grabber $V(grabber)
355                if { $grabq != "" } {
356                        $V(grabber) q $grabq
357                }
358        }
359        if [have capwin] {
360                set w [winfo toplevel $V(capwin)]
361                if $transmitButtonState {
362                        wm deiconify $w
363                } else {
364                        wm withdraw $w
365                }
366                update idletasks
367        }
368        $V(grabber) send $transmitButtonState
369}
370
371proc close_device {} {
372        global V
373        delete $V(encoder)
374        delete $V(grabber)
375        unset V(grabber) V(encoder)
376        if [info exists V(capwin)] {
377                # delete the C++ object, then destrory the tk window
378                delete $V(capwin)
379                destroy [winfo toplevel $V(capwin)]
380                unset V(capwin)
381        }
382}
383
384proc release_device { } {
385        global transmitButtonState transmitButton
386        if [have grabber] {
387                if $transmitButtonState {
388                        $transmitButton invoke
389                }
390                close_device
391        }
392}
393
394proc configWinGrabber {} {
395        global configOnTransmit
396        grabber useconfig $configOnTransmit
397}
398
399proc build.buttons w {
400        set f [smallfont]
401        global transmitButton
402        set transmitButton $w.send
403        checkbutton $w.send -text "Transmit" \
404                -relief raised -command transmit \
405                -anchor w -variable transmitButtonState -font $f \
406                -state disabled -highlightthickness 0
407#       checkbutton $w.freeze -text "Freeze" \
408#               -relief raised -command "grabber freeze \$freeze" \
409#               -anchor w -variable freeze -font $f \
410#               -highlightthickness 0
411        button $w.release -text "Release" \
412                -relief raised -command release_device \
413                -font $f -highlightthickness 0
414
415#       pack $w.send $w.release $w.freeze -fill both
416        pack $w.send $w.release -fill both
417}
418
419proc doNothing { args } {
420}
421
422proc set_bps { w value } {
423        if [have grabber] {
424                grabber bps $value
425        #XXX
426                session data-bandwidth $value
427        }
428        $w configure -text "$value kbps"
429}
430
431proc set_fps { w value } {
432        grabber fps $value
433        $w configure -text "$value fps"
434}
435
436proc build.sliders w {
437        set f [smallfont]
438
439        global V
440        set key $V(session)
441        global ftext btext
442        set ftext($key) "0.0 f/s"
443        set btext($key) "0.0 kb/s"
444
445        frame $w.info
446        label $w.info.label -text "Rate Control" -font $f
447        label $w.info.fps -textvariable ftext($key) -width 6 \
448                -font $f -pady 0 -borderwidth 0
449        label $w.info.bps -textvariable btext($key) -width 8 \
450                -font $f -pady 0 -borderwidth 0
451        pack $w.info.label -side left
452        pack $w.info.bps $w.info.fps -side right
453       
454        frame $w.bps
455        scale $w.bps.scale -orient horizontal -font $f \
456                -showvalue 0 -from 1 -to [option get . maxbw Vic] \
457                -command "set_bps $w.bps.value" -width 12 \
458                -sliderlength 20 \
459                -relief groove
460        label $w.bps.value -font $f -width 8 -anchor w
461
462        frame $w.fps
463        scale $w.fps.scale -font $f -orient horizontal \
464                -showvalue 0 -from 1 -to 30 \
465                -command "set_fps $w.fps.value" -width 12 \
466                -sliderlength 20 \
467                -relief groove
468        label $w.fps.value -font $f -width 8 -anchor w
469
470        pack $w.info -fill x
471        pack $w.bps $w.fps -fill x
472        pack $w.bps.scale -side left -fill x -expand 1
473        pack $w.bps.value -side left -anchor w
474        pack $w.fps.scale -fill x -side left -expand 1
475        pack $w.fps.value -side left -anchor w
476       
477        $w.bps.scale set [option get . bandwidth Vic]
478        $w.fps.scale set [option get . framerate Vic]
479
480        global fps_slider bps_slider
481        set fps_slider $w.fps.scale
482        set bps_slider $w.bps.scale
483}
484
485proc attribute_class { attr class } {
486        while { [llength $attr] >= 2 } {
487                if { [lindex $attr 0] == $class } {
488                        return [lindex $attr 1]
489                }
490                set attr [lrange $attr 2 end]
491        }
492        return ""
493}
494
495proc inList { item L } {
496        foreach v $L {
497                if { $v == $item } {
498                        return 1
499                }
500        }
501        return 0
502}
503
504#
505# Returns true iff device named by $device has an attribute named
506# $attr in the attribute class $class.  For example,
507# "device_supports vl size cif" would return true.
508# if $attr is "*", then returns true iff the indicated $class
509# exists in the attribute list (for example, "device_supports $d port *"
510# says whether a device supports port selection at all)
511#
512proc device_supports { device class attr } {
513        set L [$device attributes]
514        set L [attribute_class $L $class]
515        if { $attr == "*" } {
516                if { $L == "" } {
517                        return 0
518                } else {
519                        return 1
520                }
521        } else {
522                return [inList $attr $L]
523        }
524}
525
526# device_formats: any type of stream produce-able from this device
527# (not necessarily native)
528proc device_formats device {
529        set L [$device attributes]
530        set sizes [attribute_class $L size]
531        set formats [attribute_class $L format]
532        set fmtList ""
533        if [inList 422 $formats] {
534                set fmtList "$fmtList nv nvdct cellb jpeg raw"
535        }
536        if [inList 411 $formats] {
537                set fmtList "$fmtList bvc"
538        }
539        if [inList cif $sizes] {
540                set fmtList "$fmtList h261 h263+ h263"
541        }
542        if [inList jpeg $formats] {
543                set fmtList "$fmtList jpeg"
544                global useJPEGforH261
545                if $useJPEGforH261 {
546                        set fmtList "$fmtList h261"
547                }
548        }
549        return $fmtList
550}
551
552#
553# called when selecting a new device: insert a grabber control panel
554# if it exists and remove the old one (if one was installed)
555#
556proc insert_grabber_panel devname {
557        set k [string first - $devname]
558        if { $k >= 0 } {
559                incr k -1
560                set devname [string range $devname 0 $k]
561        }
562        regsub -all " " $devname "_" devname
563        set w .menu.$devname
564        global grabberPanel
565        if [info exists grabberPanel] {
566                if { "$grabberPanel" == "$w" } {
567                        return
568                }
569                pack forget $grabberPanel
570                unset grabberPanel
571        }
572        if { [info procs build.$devname] != "" } {
573                if ![winfo exists $w] {
574                        frame $w
575                        build.$devname $w
576                }
577                pack $w -before .menu.encoder -padx 6 -fill x
578                set grabberPanel $w
579        }
580}
581
582#
583# Called when use selects a particular device (like videopix or xil)
584# (and at startup for default device)
585#
586proc select_device device {
587        global transmitButton sizeButtons portButton formatButtons \
588                videoFormat defaultFormat lastDevice defaultPort inputPort \
589                transmitButtonState typeButton
590
591        #
592        # Remember settings of various controls for previous device
593        # and close down the device if it's already open
594        #
595        set wasTransmitting $transmitButtonState
596        if [info exists lastDevice] {
597                set defaultFormat($lastDevice) $videoFormat
598                set defaultPort($lastDevice) $inputPort
599                release_device
600        }
601        set lastDevice $device
602
603        set fmtList [device_formats $device]
604        foreach b $formatButtons {
605                set fmt [lindex [$b configure -value] 4]
606                #XXX
607                if { $fmt == "bvc" && ![yesno enableBVC] } {
608                        $b configure -state disabled
609                } elseif { [inList $fmt $fmtList] } {
610                        $b configure -state normal
611                } else {
612                        $b configure -state disabled
613                }
614        }
615        $transmitButton configure -state normal
616        if [device_supports $device size small] {
617                $sizeButtons.b0 configure -state normal
618        } else {
619                $sizeButtons.b0 configure -state disabled
620        }
621        if [device_supports $device size large] {
622                $sizeButtons.b2 configure -state normal
623        } else {
624                $sizeButtons.b2 configure -state disabled
625        }
626        if [device_supports $device port *] {
627                $portButton configure -state normal
628                attach_ports $device
629        } else {
630                $portButton configure -state disabled
631        }
632        if [device_supports $device type *] {
633                $typeButton configure -state normal
634        } else {
635                $typeButton configure -state disabled
636        }
637        insert_grabber_panel [$device nickname]
638
639        set videoFormat $defaultFormat($device)
640        select_format $videoFormat
641        if $wasTransmitting {
642                $transmitButton invoke
643        }
644}
645
646proc build.device w {
647        set f [smallfont]
648
649        set m $w.menu
650        menubutton $w -menu $m -text Device... \
651                -relief raised -width 10 -font $f
652        menu $m
653
654        global defaultFormat inputDeviceList videoFormat
655        set videoFormat [option get . defaultFormat Vic]
656        if { $videoFormat == "h.261" } {
657                set videoFormat h261
658        }
659        #
660        # Disabled the device button if we have no devices or
661        # if we don't have transmit persmission.
662        #
663        if { ![info exists inputDeviceList] || ![have_transmit_permission] } {
664                $w configure -state disabled
665                return
666        }
667        foreach d $inputDeviceList {
668                if { [$d nickname] == "still" && ![yesno stillGrabber] } {
669                        set defaultFormat($d) $videoFormat
670                        continue
671                }
672                # this is fragile
673                $m add radiobutton -label [$d nickname] \
674                        -command "select_device $d" \
675                        -value $d -variable videoDevice -font $f
676                if { "[$d attributes]" == "disabled" } {
677                        $m entryconfigure [$d nickname] -state disabled
678                }
679                set fmtList [device_formats $d]
680                if [inList $videoFormat $fmtList] {
681                        set defaultFormat($d) $videoFormat
682                } else {
683                        set defaultFormat($d) [lindex $fmtList 0]
684                }
685        }
686}
687
688proc format_col { w n0 n1 n2 } {
689        set f [smallfont]
690        frame $w
691        radiobutton $w.b0 -text $n0 -relief flat -font $f -anchor w \
692                -variable videoFormat -value $n0 -padx 0 -pady 0 \
693                -command "select_format $n0" -state disabled
694        radiobutton $w.b1 -text $n1 -relief flat -font $f -anchor w \
695                -variable videoFormat -value $n1 -padx 0 -pady 0 \
696                -command "select_format $n1" -state disabled
697        radiobutton $w.b2 -text $n2 -relief flat -font $f -anchor w \
698                -variable videoFormat -value $n2 -padx 0 -pady 0 \
699                -command "select_format $n2" -state disabled
700        pack $w.b0 $w.b1 $w.b2 -fill x
701
702        global formatButtons
703        lappend formatButtons $w.b0 $w.b1 $w.b2
704}
705
706proc build.format w {
707        format_col $w.p0 nv nvdct cellb
708        format_col $w.p1 jpeg h261 bvc
709        format_col $w.p2 h263+ h263 raw
710
711        set f [smallfont]
712
713        frame $w.glue0
714        frame $w.glue1
715
716        pack $w.glue0 -side left -fill x -expand 1
717        pack $w.p0 $w.p1 $w.p2 -side left
718        pack $w.glue1 -side left -fill x -expand 1
719
720}
721
722proc build.size w {
723        set f [smallfont]
724
725        set b $w.b
726        frame $b
727        radiobutton $b.b0 -text "small" -command "grabber decimate 4" \
728                -padx 0 -pady 0 \
729                -anchor w -variable inputSize -font $f -relief flat -value 4
730        radiobutton $b.b1 -text "normal" -command "grabber decimate 2" \
731                -padx 0 -pady 0 \
732                -anchor w -variable inputSize -font $f -relief flat -value 2
733        radiobutton $b.b2 -text "large" -command "grabber decimate 1" \
734                -padx 0 -pady 0 \
735                -anchor w -variable inputSize -font $f -relief flat -value 1
736        pack $b.b0 $b.b1 $b.b2 -fill x
737        pack $b -anchor c -side left
738        global inputSize sizeButtons
739        set inputSize 2
740        set sizeButtons $b
741}
742
743proc build.port w {
744        set f [smallfont]
745        # create the menubutton but don't defer the menu creation until later
746        menubutton $w -menu $w.menu -text Port... \
747                -relief raised -width 10 -font $f -state disabled
748        global portButton inputPort
749        set portButton $w
750        set inputPort undefined
751}
752
753proc attach_ports device {
754        global portButton inputPort defaultPort
755        catch "destroy $portButton.menu"
756        set portnames [attribute_class [$device attributes] port]
757        set f [smallfont]
758        set m $portButton.menu
759        menu $m
760        foreach port $portnames {
761                $m add radiobutton -label $port \
762                        -command "grabber port $port" \
763                        -value $port -variable inputPort -font $f
764        }
765        if ![info exists defaultPort($device)] {
766                set nn [$device nickname]
767                if [info exists defaultPort($nn)] {
768                        set defaultPort($device) $defaultPort($nn)
769                } else {
770                        set s [resource defaultPort($nn)]
771                        if { $s != "" } {
772                                set defaultPort($device) $s
773                        } else {
774                                set defaultPort($device) [lindex $portnames 0]
775                        }
776                }
777        }
778        set inputPort $defaultPort($device)
779}
780
781proc build.type w {
782        set f [smallfont]
783
784        set m $w.menu
785        menubutton $w -text Signal... -menu $m -relief raised \
786                -width 10 -font $f -state disabled
787        menu $m
788        $m add radiobutton -label "auto" -command restart \
789                -value auto -variable inputType -font $f
790        $m add radiobutton -label "NTSC" -command restart \
791                -value ntsc -variable inputType -font $f
792        $m add radiobutton -label "PAL" -command restart \
793                -value pal -variable inputType -font $f
794        $m add radiobutton -label "SECAM" -command restart \
795                -value secam -variable inputType -font $f
796
797        global inputType typeButton
798        set inputType auto
799        set typeButton $w
800}
801
802proc build.encoder_buttons w {
803        set f [smallfont]
804        build.encoder_options $w.options
805        build.device $w.device
806        build.port $w.port
807        build.type $w.type
808        pack $w.device $w.port $w.type $w.options -fill x
809}
810
811proc build.encoder_options w {
812        global useJPEGforH261 tcl_platform useHardwareComp
813        set useJPEGforH261 [yesno useJPEGforH261]
814        set useHardwareComp [yesno useHardwareComp]
815        set f [smallfont]
816        set m $w.menu
817        menubutton $w -text Options... -menu $m -relief raised -width 10 \
818                -font $f
819        menu $m
820        $m add checkbutton -label "Sending Slides" \
821                -variable sendingSlides -font $f -command setFillRate
822        $m add checkbutton -label "Use JPEG for H261" \
823                -variable useJPEGforH261 -font $f -command restart
824                $m add checkbutton -label "Use Hardware Encode" \
825                -variable useHardwareComp -font $f -command restart
826                if {$tcl_platform(platform) == "windows"} {
827                        $m add checkbutton -label "Configure on Transmit" \
828                        -variable configOnTransmit -font $f
829                }
830}
831
832proc build.tile w {
833        set f [smallfont]
834        set m $w.menu
835        menubutton $w -text Tile... -menu $m -relief raised -width 10 \
836                -font $f
837        menu $m
838        $m add radiobutton -label Single -command "redecorate 1" \
839                -value 1 -variable V(ncol) -font $f
840        $m add radiobutton -label Double -command "redecorate 2" \
841                -value 2 -variable V(ncol) -font $f
842        $m add radiobutton -label Triple -command "redecorate 3" \
843                -value 3 -variable V(ncol) -font $f
844        $m add radiobutton -label Quad -command "redecorate 4" \
845                -value 4 -variable V(ncol) -font $f
846}
847
848proc build.decoder_options w {
849        set f [smallfont]
850        set m $w.menu
851        menubutton $w -text Options... -menu $m -relief raised -width 10 \
852                -font $f
853        menu $m
854        $m add checkbutton -label "Mute New Sources" \
855                -variable V(muteNewSources) -font $f
856        $m add checkbutton -label "Use Hardware Decode" \
857                -variable V(useHardwareDecode) -font $f
858        $m add separator
859        $m add command -label "Optimize Colormap" \
860                -command fork_histtolut -font $f
861
862        global V
863        set V(optionsMenu) $m
864        if ![have dither] {
865                $m entryconfigure "Optimize Colormap" -state disabled
866        }
867}
868
869proc build.external w {
870        set f [smallfont]
871        set m $w.menu
872        global outputDeviceList
873        if ![info exists outputDeviceList] {
874                set outputDeviceList ""
875        }
876        if { [llength $outputDeviceList] <= 1 } {
877                button $w -text External -relief raised \
878                        -width 10 -font $f -highlightthickness 0 \
879                        -command "extout_select $outputDeviceList"
880        } else {
881                menubutton $w -text External... -menu $m -relief raised \
882                        -width 10 -font $f 
883                menu $m
884                foreach d $outputDeviceList {
885                        $m add command -font $f -label [$d nickname] \
886                                -command "extout_select $d"
887                }
888        }
889        if { $outputDeviceList == "" } {
890                $w configure -state disabled
891        }
892}
893
894proc build.dither w {
895        set f [smallfont]
896        if [have dither] {
897                set var V(dither)
898                set state normal
899        } else {
900                set var dummyDither
901                set state disabled
902        }
903        set v $w.h0
904        frame $v
905        radiobutton $v.b0 -text "Ordered" -command set_dither \
906                -padx 0 -pady 0 \
907                -anchor w -variable $var -state $state \
908                -font $f -relief flat -value od
909        radiobutton $v.b1 -text "Error Diff" -command set_dither \
910                -padx 0 -pady 0 \
911                -anchor w -variable $var -state $state \
912                -font $f -relief flat -value ed
913        set v $w.h1
914        frame $v
915        radiobutton $v.b2 -text Quantize -command set_dither \
916                -padx 0 -pady 0 \
917                -anchor w -variable $var -state $state \
918                -font $f -relief flat \
919                -value quantize
920        radiobutton $v.b3 -text Gray -command set_dither \
921                -padx 0 -pady 0 \
922                -anchor w -variable $var -state $state \
923                -font $f -relief flat -value gray
924
925        pack $w.h0.b0 $w.h0.b1 -anchor w -fill x
926        pack $w.h1.b2 $w.h1.b3 -anchor w -fill x
927        pack $w.h0 $w.h1 -side left
928}
929
930proc update_gamma { w s } {
931        global V win_src
932        set cm $V(colorModel)
933        if ![$cm gamma $s] {
934                return -1
935        }
936        set V(gamma) $s
937        $cm free-colors
938        if ![$cm alloc-colors] {
939                revert_to_gray
940        }
941        #
942        # Need to update all the windows.  Can't just do a redraw
943        # on all the windows because that won't cause the renderer's
944        # to update their copy of the image (which has the old colormap
945        # installed).  Instead, go through all the active decoders and
946        # force them to update all the windows.
947        #
948        foreach src [session active] {
949                set d [$src handler]
950                if { $d != "" } {
951                        $d redraw
952                }
953        }
954
955        return 0
956}
957
958proc build.gamma w {
959        global V
960        frame $w
961        label $w.label -text "Gamma: " -font [smallfont] -anchor e
962        mk.entry $w update_gamma $V(gamma)
963        $w.entry configure -width 6
964        if ![have dither] {
965                $w.entry configure -state disabled -foreground gray60
966                $w.label configure -foreground gray60
967        }
968        pack $w.label -side left
969        pack $w.entry -side left -expand 1 -fill x -pady 2
970}
971
972proc build.decoder w {
973        set f [smallfont]
974
975        label $w.title -text Display
976        frame $w.f -relief sunken -borderwidth 2
977
978        set v $w.f.h0
979        frame $v
980
981        build.external $v.ext
982        build.tile $v.tile
983        build.decoder_options $v.options
984
985        pack $v.options $v.tile $v.ext -fill x -expand 1
986
987        set v $w.f.h2
988        frame $v
989        frame $v.dither -relief groove -borderwidth 2
990        build.dither $v.dither
991        frame $v.bot
992        build.gamma $v.bot.gamma
993        label $v.bot.mode -text "\[[winfo depth .top]-bit\]" -font $f
994        pack $v.bot.gamma $v.bot.mode -side left -padx 4
995        pack $v.dither $v.bot -anchor c -pady 2
996
997        pack $w.f.h0 -side left -padx 6 -pady 6
998        pack $w.f.h2 -side left -padx 6 -pady 6 -fill x -expand 1
999
1000        pack $w.title $w.f -fill x
1001}
1002
1003proc build.encoder w {
1004        label $w.title -text Encoder
1005        frame $w.f -relief sunken -borderwidth 2
1006
1007        frame $w.f.h0 -relief flat
1008        frame $w.f.h1 -relief flat
1009        frame $w.f.h0.eb -relief flat
1010        frame $w.f.h0.format -relief groove -borderwidth 2
1011        frame $w.f.h0.size -relief groove -borderwidth 2
1012        frame $w.f.h0.gap -relief flat -width 4
1013
1014        build.encoder_buttons $w.f.h0.eb
1015        build.format $w.f.h0.format
1016        build.size $w.f.h0.size
1017
1018        build.q $w.f.h1
1019
1020        pack $w.f.h0.eb -side left -anchor n -fill y -padx 6 -pady 4
1021        pack $w.f.h0.format -side left -anchor n -fill both -expand 1
1022        pack $w.f.h0.size -side left -anchor c -fill both
1023        pack $w.f.h0.gap -side left -anchor c
1024
1025        pack $w.f.h0 -fill x -pady 4
1026        pack $w.f.h1 -fill x -pady 6
1027        pack $w.title $w.f -fill x
1028}
1029
1030proc jpeg_setq value {
1031        global useHardwareComp videoDevice
1032        incr value
1033        if { $value > 95 } {
1034                set value 95
1035        } elseif { $value < 5 } {
1036                set value 5
1037        }
1038
1039        set DA [$videoDevice attributes]
1040        set DF [attribute_class $DA format]
1041        if { [inList "jpeg" $DF] && $useHardwareComp } {
1042                grabber q $value
1043        } elseif [have grabber] {
1044                encoder q $value
1045        }       
1046       
1047        global qvalue
1048        $qvalue configure -text $value
1049}
1050
1051proc h261_setq value {
1052        set value [expr int((1 - $value / 100.) * 29) + 1]
1053        if [have grabber] {
1054                encoder q $value
1055        }
1056        global qvalue
1057        $qvalue configure -text $value
1058}
1059
1060proc h263+_setq value {
1061        set value [expr int((1 - $value / 100.) * 29) + 1]
1062        if [have grabber] {
1063                encoder q $value
1064        }
1065        global qvalue
1066        $qvalue configure -text $value
1067}
1068
1069proc h263_setq value {
1070        set value [expr int((1 - $value / 100.) * 29) + 1]
1071        if [have grabber] {
1072                encoder q $value
1073        }
1074        global qvalue
1075        $qvalue configure -text $value
1076}
1077
1078proc nv_setq value {
1079        set value [expr (100 - $value) / 10]
1080        if [have grabber] {
1081                encoder q $value
1082        }
1083        global qvalue
1084        $qvalue configure -text $value
1085}
1086
1087proc nvdct_setq value {
1088        nv_setq $value
1089}
1090
1091proc raw_setq value {
1092        set value 1
1093        if [have grabber] {
1094                encoder q $value
1095        }
1096        global qvalue
1097        $qvalue configure -text $value
1098}
1099
1100set bvc_quantizer(0) { 0 0 0 0 1 1 1 1 2 2 }
1101set bvc_quantizer(1) { 0 0 0 1 1 1 1 1 2 3 }
1102set bvc_quantizer(2) { 0 0 0 1 1 1 1 2 3 3 }
1103set bvc_quantizer(3) { 0 0 0 1 1 1 2 2 4 4 }
1104set bvc_quantizer(4) { 0 0 0 2 2 2 3 3 4 4 }
1105set bvc_quantizer(5) { 0 0 0 2 2 2 3 4 4 4 }
1106set bvc_quantizer(6) { 0 0 0 2 2 2 4 4 5 5 }
1107set bvc_quantizer(7) { 0 0 0 2 3 3 4 5 5 5 }
1108set bvc_quantizer(8) { 0 0 0 2 3 4 6 6 6 6 }
1109set bvc_quantizer(9) { 2 2 2 3 6 5 7 7 7 7 }
1110
1111
1112proc bvc_setq value {
1113        set value [expr 9 - $value / 10]
1114        if [have grabber] {
1115                global bvc_quantizer
1116                set n 0
1117                foreach q $bvc_quantizer($value) {
1118                        encoder q $n [expr 7 - $q]
1119                        incr n
1120                }
1121        }
1122        global qvalue
1123        $qvalue configure -text $value
1124}
1125
1126#
1127# If the capture device is open, close it.  If transmission
1128# was active fire it up again.  Some state can only be set at
1129# device open time, so some controls must resort to this proc.
1130#
1131proc restart { } {
1132        if [have grabber] {
1133                global transmitButtonState videoDevice V
1134                if $transmitButtonState {
1135                        $V(grabber) send 0
1136                        close_device
1137                        transmit
1138                } else {
1139                        close_device
1140                }
1141        }
1142}
1143
1144proc disable_large_button { } {
1145        global sizeButtons inputSize
1146        if { $inputSize == 1 } {
1147                set inputSize 2
1148        }
1149        $sizeButtons.b2 configure -state disabled
1150}
1151
1152proc enable_large_button { } {
1153        global sizeButtons videoDevice
1154        if { [info exists videoDevice] && \
1155                [device_supports $videoDevice size large] } {
1156                $sizeButtons.b2 configure -state normal
1157        }
1158}
1159
1160set qscale_val(h261) 68
1161set qscale_val(h263) 68
1162set qscale_val(h263+) 68
1163set qscale_val(nv) 80
1164set qscale_val(nvdct) 80
1165set qscale_val(bvc) 60
1166set qscale_val(jpeg) 29
1167set qscale_val(raw) 1
1168set lastFmt ""
1169
1170proc select_format fmt {
1171        global qscale qlabel videoDevice videoFormat qscale_val lastFmt
1172
1173        if { $fmt == "h261" } {
1174                # H.261 supports only QCIF/CIF
1175                disable_large_button
1176        } else {
1177                enable_large_button
1178        }
1179
1180        set qscale_val($lastFmt) [$qscale get]
1181        set lastFmt $videoFormat
1182
1183        set proc $fmt\_setq
1184        if [inList $proc [info commands *_setq]] {
1185                $qscale configure -state normal -command $proc
1186                $qlabel configure -foreground black
1187        } else {
1188                $qscale configure -state disabled
1189                $qlabel configure -foreground gray40
1190        }
1191        set qual [resource quality]
1192        if { $qual > 0 } {
1193                puts "vic: quality found "
1194                $qscale set [resource quality]
1195        } else { if [info exists qscale_val($fmt)] {
1196                $qscale set $qscale_val($fmt)
1197        }}
1198        if [have grabber] {
1199                global V
1200                set encoder [create_encoder $videoFormat]
1201
1202# MM
1203#               if { [info procs build.$devname\_$videoFormat] != "" } {
1204#                       if ![winfo exists $w] {
1205#                               frame $w
1206#                               build.$devname $w
1207#                       }
1208#                       pack $w -before .menu.encoder -padx 6 -fill x
1209#                       set grabberPanel $w
1210#               }
1211# MM
1212
1213                set ff [$encoder frame-format]
1214                if { "$ff" == "[$V(encoder) frame-format]" } {
1215                        #
1216                        # new framer has the same format as the
1217                        # old one.  just replace the old one without
1218                        # re-initializing the grabber.
1219                        # XXX doens't work if title-maker is installed
1220                        #
1221                        delete $V(encoder)
1222                        set V(encoder) $encoder
1223                        $encoder transmitter $V(session)
1224                        $V(grabber) target $encoder
1225                } else {
1226                        #
1227                        # Restart the grabber.
1228                        #
1229                        delete $encoder
1230                        restart
1231                }
1232        }
1233}
1234
1235proc init_grabber { grabber } {
1236        global V configOnTransmit tcl_platform
1237
1238        if {$tcl_platform(platform) == "windows"} {
1239                $grabber useconfig $configOnTransmit
1240        }
1241
1242        if { [$grabber need-capwin] && ![have capwin] } {
1243                #
1244                # we need to create a window for input devices that
1245                # require capturing to the frame buffer.  create but
1246                # don't map it until after we call "$grabber decimate"
1247                # to specify it's size
1248                #
1249                set rgd [option get . localPlxDisplay $V(class)]
1250                if { $rgd != "" } {
1251                        open_dialog "Using Remote Grabbing Display $rgd"
1252                        toplevel .capture -class Vic -screen $rgd
1253                } else {
1254                        toplevel .capture -class Vic
1255                }
1256                wm title .capture "Video Capture Window"
1257                $grabber create-capwin .capture.video
1258                set V(capwin) .capture.video
1259                pack .capture.video
1260           
1261                # capture window shouldn't be covered
1262                bind .capture <Visibility> "raise .capture"
1263        }
1264
1265        $grabber transmitter $V(session)
1266        global qscale inputSize fps_slider bps_slider videoDevice
1267        $grabber fps [$fps_slider get]
1268        $grabber bps [$bps_slider get]
1269        $grabber decimate $inputSize
1270        if { [lindex [$qscale configure -state] 4] == "normal" } {
1271                set cmd [lindex [$qscale configure -command] 4]
1272                $cmd [$qscale get]
1273        }
1274        global inputPort inputType portButton typeButton
1275        if { [$portButton cget -state] == "normal" } {
1276                $grabber port $inputPort
1277        }
1278        if { [$typeButton cget -state] == "normal" } {
1279                $grabber type $inputType
1280        }
1281        setFillRate
1282        update
1283}
1284
1285proc build.q w {
1286        set f [smallfont]
1287        frame $w.tb
1288        label $w.title -text "Quality" -font $f -anchor w
1289        label $w.tb.value -text 0 -font $f -width 3
1290        scale $w.tb.scale -font $f -orient horizontal \
1291                -showvalue 0 -from 0 -to 99 \
1292                -width 12 -relief groove
1293        global qscale qvalue qlabel
1294        set qscale $w.tb.scale
1295        set qvalue $w.tb.value
1296        set qlabel $w.title
1297
1298        pack $w.tb.scale -side left -fill x -expand 1
1299        pack $w.tb.value -side left
1300        pack $w.title -padx 2 -side left
1301        pack $w.tb -fill x -padx 6 -side left -expand 1
1302}
1303
1304proc build.xmit w {
1305        set f [smallfont]
1306        label $w.label -text Transmission
1307        frame $w.frame -relief sunken -borderwidth 2
1308        pack $w.label -fill x
1309        pack $w.frame -fill both -expand 1
1310
1311        frame $w.frame.buttons
1312        build.buttons $w.frame.buttons
1313        frame $w.frame.right
1314        build.sliders $w.frame.right
1315
1316        pack $w.frame.buttons -side left -padx 6
1317        pack $w.frame.right -side right -expand 1 -fill x -padx 10 -anchor c
1318}
1319
1320proc set_dither {} {
1321        global win_src
1322        set wlist [array names win_src]
1323        foreach w $wlist {
1324                set ws($w) $win_src($w)
1325                detach_window $win_src($w) $w
1326        }
1327        if ![init_color] {
1328                revert_to_gray
1329        }
1330        foreach w $wlist {
1331                attach_window $ws($w) $w
1332        }
1333}       
1334
1335proc revert_to_gray {} {
1336        global V
1337        if { $V(dither) == "gray" } {
1338                #XXX
1339                puts stderr "vic: out of colors"
1340                exit 1
1341        }
1342        open_dialog "ran out of colors; reverting to gray"
1343        set V(dither) gray
1344        set_dither
1345}
Note: See TracBrowser for help on using the browser.