[Sumover-dev] [svn commit] r3996 - vic/branches/mpeg4/tcl
sumover-dev at cs.ucl.ac.uk
sumover-dev at cs.ucl.ac.uk
Wed May 2 22:54:08 BST 2007
Author: piers
Date: Wed May 2 22:53:29 2007
New Revision: 3996
Modified:
vic/branches/mpeg4/tcl/ui-grabber.tcl
vic/branches/mpeg4/tcl/ui-main.tcl
vic/branches/mpeg4/tcl/ui-resource.tcl
vic/branches/mpeg4/tcl/ui-srclist.tcl
vic/branches/mpeg4/tcl/ui-stats.tcl
vic/branches/mpeg4/tcl/ui-windows.tcl
Log:
Updates for AG-vic - mostly for autoplace and also for resource changes - so that contrast etc comes form resources files.
Modified: vic/branches/mpeg4/tcl/ui-grabber.tcl
==============================================================================
--- vic/branches/mpeg4/tcl/ui-grabber.tcl (original)
+++ vic/branches/mpeg4/tcl/ui-grabber.tcl Wed May 2 22:53:29 2007
@@ -24,14 +24,18 @@
# ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
# FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+proc build.dc10 w {
+ build.v4l $w
+}
+
proc build.v4l w {
set f [smallfont]
global contrast brightness hue saturation norm
- set contrast 128
- set brightness 128
- set hue 128
- set saturation 128
- set norm 0
+ set contrast [resource contrast]
+ set brightness [resource brightness]
+ set hue [resource hue]
+ set saturation [resource saturation]
+ set norm 0
label $w.title -text "Video4Linux grabber controls"
pack $w.title -fill x -expand 1
Modified: vic/branches/mpeg4/tcl/ui-main.tcl
==============================================================================
--- vic/branches/mpeg4/tcl/ui-main.tcl (original)
+++ vic/branches/mpeg4/tcl/ui-main.tcl Wed May 2 22:53:29 2007
@@ -61,8 +61,7 @@
if {[string equal [tk windowingsystem] "aqua"]} {
global V
set net $V(data-net)
- label $w.bar.title -text "TTL: [$net ttl]" -font [smallfont] \
- -justify left
+ label $w.bar.title -text "Address: [$net addr] Port: [$net port] TTL: [$net ttl]" -font [smallfont] -justify left
button $w.bar.quit -text Quit \
-font [smallfont] \
-command adios
@@ -72,11 +71,13 @@
button $w.bar.help -text Help \
-font [smallfont] \
-command "toggle_window .help"
+ button $w.bar.autoplace -text Autoplace \
+ -font [smallfont] \
+ -command "ag_autoplace::show_ui"
} else {
global V
set net $V(data-net)
- label $w.bar.title -text "TTL: [$net ttl]" -font [smallfont] \
- -relief flat -justify left
+ label $w.bar.title -text "Address: [$net addr] Port: [$net port] TTL: [$net ttl]" -font [smallfont] -relief flat -justify left
button $w.bar.quit -text Quit -relief raised \
-font [smallfont] -command adios \
-highlightthickness 1
@@ -86,9 +87,27 @@
button $w.bar.help -text Help -relief raised \
-font [smallfont] -highlightthickness 1 \
-command "toggle_window .help"
+ button $w.bar.autoplace -text Autoplace -relief raised \
+ -font [smallfont] -highlightthickness 1 \
+ -command "ag_autoplace::show_ui"
}
pack $w.bar.title -side left -fill both -expand 1
- pack $w.bar.menu $w.bar.help $w.bar.quit -side left -padx 1 -pady 1
+ pack $w.bar.menu $w.bar.autoplace $w.bar.help $w.bar.quit -side left -padx 1 -pady 1
+}
+
+proc build.bar2 w {
+
+ frame $w.bar2 -relief ridge -borderwidth 0
+
+ button $w.bar2.autoplace -text Autoplace -relief raised \
+ -font [smallfont] -highlightthickness 1 \
+ -command "ag_autoplace::show_ui"
+ button $w.bar2.pixrate -text Pixrate -relief raised \
+ -font [smallfont] -highlightthickness 1 \
+ -command "create_pixrate_stats_window"
+
+
+ pack $w.bar2.autoplace $w.bar2.pixrate -side right -padx 1 -pady 1
}
#
@@ -207,7 +226,7 @@
}
puts stderr \
"vic: warning: ran out of colors; using private colormap"
- destroy .top
+ destroy .top
frame .top -visual $V(visual) -colormap new
if ![init_color] {
puts stderr "vic: internal error: no colors"
@@ -228,16 +247,22 @@
bind . <Control-c> { adios }
bind . <Control-d> { adios }
- foreach i { 1 2 3 4 } {
+ foreach i { 1 2 3 4 5 6 7 8} {
bind . <Key-$i> "redecorate $i"
}
- build.bar .top
- pack .top.bar -fill x -side bottom
+ frame .top.barholder -relief ridge -borderwidth 2
+
+ build.bar .top.barholder
+# build.bar2 .top.barholder
+
+ pack .top.barholder.bar -fill x -side bottom
+# pack .top.barholder.bar2 -fill x -side bottom
+ pack .top.barholder -side bottom -fill x
pack .top -expand 1 -fill both
label .top.label -text "Waiting for video..."
- pack .top.label -before .top.bar -anchor c -expand 1
+ pack .top.label -before .top.barholder -anchor c -expand 1
#
# Withdraw window so that user-placement is deferred
@@ -282,11 +307,13 @@
frame $w
pack $w -fill both -anchor n
}
+ invoke_source_callback activate $src
}
proc rm_active src {
global active V
unset active($src)
+ invoke_source_callback deactivate $src
if { ![yesno relateInterface] && [array size active] == 0 } {
pack forget $V(grid)
destroy $V(grid)
@@ -371,6 +398,8 @@
} else {
set src_nickname($src) $cname
set info "$addr/$fmt"
+
+ invoke_source_callback sdes_update $src
}
} elseif [cname_redundant $name $cname] {
set src_nickname($src) $name
@@ -963,7 +992,7 @@
}
proc update_src src {
- global ftext updated
+
if ![info exists ftext($src)] {
return
}
@@ -984,7 +1013,8 @@
video to the conference address you're running on. Otherwise, you'll \
see a thumbnail sized image and accompanying information for each source. \
Click on the thumbnail to open a larger viewing window. You can tile the \
-thumbnails in multiple columns using the ``Tile'' menu in the ``Menu'' window."
+thumbnails in multiple columns using the ``Tile'' menu in the ``Menu'' window, \
+or by pressing a number key (e.g., press 3 to view three columns)."
"Clicking on the ``mute'' button for a given source will \
turn off decoding. It is usually a good idea to do \
this for your own, looped-back transmission."
@@ -1006,7 +1036,7 @@
have X resources that conflict with tk. A common problem is \
defining ``*background'' and/or ``*foreground''."
-"Bugs and suggestions to vic at ee.lbl.gov. Thanks."
+"Bugs and suggestions to vic at cs.ucl.ac.uk Thanks."
}
}
Modified: vic/branches/mpeg4/tcl/ui-resource.tcl
==============================================================================
--- vic/branches/mpeg4/tcl/ui-resource.tcl (original)
+++ vic/branches/mpeg4/tcl/ui-resource.tcl Wed May 2 22:53:29 2007
@@ -89,10 +89,13 @@
if {$tcl_platform(platform) == "windows"} {
set helv10 [search_font $foundry helvetica medium 12]
+ set helv4b [search_font $foundry helvetica bold 10]
set helv10b [search_font $foundry helvetica bold 12]
set helv12b [search_font $foundry helvetica bold 12]
set times14 [search_font $foundry times medium 14]
} else {
+ #ag_puts "in lnonwindows section"
+ set helv4b [search_font $foundry helvetica bold 10]
set helv10 [search_font $foundry helvetica medium 10]
set helv10b [search_font $foundry helvetica bold 10]
set helv12b [search_font $foundry helvetica bold 12]
@@ -102,9 +105,11 @@
option add *Font $helv12b startupFile
option add Vic.medfont $helv12b startupFile
option add Vic.smallfont $helv10b startupFile
+ option add Vic.minifont $helv4b startupFile
option add Vic.helpfont $times14 startupFile
option add Vic.entryfont $helv10 startupFile
-}
+
+ }
proc init_resources {} {
@@ -113,8 +118,10 @@
# use 2 pixels of padding by default, except with MacOSX Aqua
#
if {![string equal [tk windowingsystem] "aqua"]} {
- option add *padX 2
- option add *padY 2
+ option add *video*padX 0
+ option add *video*padY 0
+ option add *padX 1
+ option add *padY 1
}
#
# don't put tearoffs in pull-down menus
@@ -139,18 +146,18 @@
#
# These can be overridden.
#
- option add Vic.geometry 300x225 startupFile
+ option add Vic.geometry 400x300 startupFile
option add Vic.mtu 1024 startupFile
option add Vic.network ip startupFile
- option add Vic.framerate 15 startupFile
+ option add Vic.framerate 8 startupFile
option add Vic.defaultTTL 16 startupFile
option add Vic.maxbw -1 startupFile
- option add Vic.bandwidth 512 startupFile
+ option add Vic.bandwidth 128 startupFile
option add Vic.iconPrefix vic: startupFile
option add Vic.priority 10 startupFile
option add Vic.confBusChannel 0 startupFile
- option add Vic.defaultFormat mpeg4 startupFile
+ option add Vic.defaultFormat h.261 startupFile
option add Vic.sessionType rtpv2 startupFile
option add Vic.grabber none startupFile
option add Vic.stampInterval 1000 startupFile
@@ -168,12 +175,12 @@
option add Vic.quality "0" startupFile
option add Vic.inputType "ntsc" startupFile
- option add Vic.brightness "0" startupFile
- option add Vic.contrast "0" startupFile
+ option add Vic.brightness "128" startupFile
+ option add Vic.contrast "128" startupFile
option add Vic.chromau "0" startupFile
option add Vic.chromav "0" startupFile
- option add Vic.saturation "0" startupFile
- option add Vic.hue "0" startupFile
+ option add Vic.saturation "230" startupFile
+ option add Vic.hue "128" startupFile
option add Vic.chroma_saturation "0" startupFile
option add Vic.chroma_gain "0" startupFile
@@ -246,5 +253,5 @@
# list of sdes items to display in info window
option add Vic.sdesList "cname tool email note"
- option readfile ~/.RTPdefaults startupFile
+ catch "option readfile ~/.RTPdefaults startupFile"
}
Modified: vic/branches/mpeg4/tcl/ui-srclist.tcl
==============================================================================
--- vic/branches/mpeg4/tcl/ui-srclist.tcl (original)
+++ vic/branches/mpeg4/tcl/ui-srclist.tcl Wed May 2 22:53:29 2007
@@ -97,6 +97,7 @@
incr srclist_bottom 2
$srclist config -scrollregion "0 0 2.5i $srclist_bottom"
}
+ invoke_source_callback register $src
}
proc adjustNames { thresh h } {
@@ -118,6 +119,7 @@
#
proc unregister src {
global name_line info_line nametag srclist
+ invoke_source_callback unregister $src
destroy_rtp_stats $src
Modified: vic/branches/mpeg4/tcl/ui-stats.tcl
==============================================================================
--- vic/branches/mpeg4/tcl/ui-stats.tcl (original)
+++ vic/branches/mpeg4/tcl/ui-stats.tcl Wed May 2 22:53:29 2007
@@ -121,7 +121,7 @@
#
# Special-case playout estimator since it's not a counter
#
- if { $src != "session" } {
+ if { $src != "session" && $src != "pixrate" } {
set r $p.playout
frame $r
set cmd "create_plot_window $src Playout \{get-playout $src\}"
Modified: vic/branches/mpeg4/tcl/ui-windows.tcl
==============================================================================
--- vic/branches/mpeg4/tcl/ui-windows.tcl (original)
+++ vic/branches/mpeg4/tcl/ui-windows.tcl Wed May 2 22:53:29 2007
@@ -37,6 +37,9 @@
# destroy a viewing window but remember where it was
# and what size it was
#
+set server_socket ""
+set button_active 0
+
proc destroy_userwin {w {bypass false} } {
global win_src
@@ -187,7 +190,6 @@
set w .vw$uid
toplevel $w -class Vic \
-visual "[winfo visual .top] [winfo depth .top]"
-# -colormap .top
catch "wm resizable $w false false"
#
# make windows become x-y resizeable
@@ -325,27 +327,119 @@
label $w.bar.label -text "" -anchor w -relief raised
pack $w.bar.label -expand 1 -side left -fill both
- pack $w.bar.decoder $w.bar.size $w.bar.mode $w.bar.dismiss -side left -fill y
+# comment next line to remove buttons
+# pack $w.bar.decoder $w.bar.size $w.bar.mode $w.bar.dismiss -side left -fill y
pack $w.frame.video -anchor c
pack $w.frame -expand 1 -fill both
- pack $w.bar -fill x
+# comment next line to remove buttons
+# pack $w.bar -fill x
bind $w <Enter> { focus %W }
#wm focusmodel $w active
+ bind $w <s> "resize $v 176 144"
+ bind $w <m> "resize $v 352 288"
+ bind $w <l> "resize $v 704 576"
+ bind $w <S> "resize $v 160 120"
+ bind $w <M> "resize $v 320 240"
+ bind $w <L> "resize $v 640 480"
+ bind $w <e> "resize $v 1000 750"
+ bind $w <E> "resize $v 1024 768"
+ bind $w <x> "resize $v 640 240"
+
bind $w <d> "destroy_userwin $v"
bind $w <q> "destroy_userwin $v"
$w.bar.dismiss configure -command "destroy_userwin $v"
# added to catch window close action
wm protocol $w WM_DELETE_WINDOW "destroy_userwin $v"
+ $w.bar.dismiss configure -command "destroy_userwin $v"
bind $w <Return> "switcher_next $v"
bind $w <space> "switcher_next $v"
bind $w <greater> "switcher_next $v"
bind $w <less> "switcher_prev $v"
bind $w <comma> "switcher_prev $v"
+
+ bind $w <g> "set_window_glue $v 1"
+ bind $w <G> "set_window_glue $v 0"
+ bind $w <h> "set_hardware_render $v 1"
+ bind $w <H> "set_hardware_render $v 0"
+
+ switcher_register $v $src window_switch
+
+ global window_glue
+ set window_glue($v) 0
+ global button_active vtk_client
+
+ bind $v <Button-3> {
+ tk_popup $m %x %y
+ }
+
+# puts "w is $v"
+
+ bind $v <Control-KeyPress> {
+# puts "got ctl keypress %K %x %y"
+ if { [string length %K] == 1 } {
+ binary scan %K c keyval
+ send_to_vtk K 0 $keyval %x %y %W
+ break
+ }
+ }
+ bind $v <Button> {
+ global notifier_id ag_last_x ag_last_y
+
+ send_to_vtk D 0 %b %x %y %W
+
+ set button_active %b
+ set modifier 0
+
+ set ag_last_x %x
+ set ag_last_y %y
+
+ set notifier_id [after 100 ag_update_motion]
+ }
+ bind $v <Control-Button> {
+ global notifier_id
+ send_to_vtk D 0 [expr %b | 8] %x %y %W
+
+ set button_active %b
+ set notifier_id [after 100 ag_update_motion]
+ }
+ bind $v <Shift-Button> {
+ global notifier_id
+ send_to_vtk D 0 [expr %b | 16] %x %y %W
+
+ set button_active %b
+ set notifier_id [after 100 ag_update_motion]
+ }
+ bind $v <Shift-Control-Button> {
+ global notifier_id
+ send_to_vtk D 0 [expr %b | 8 | 16] %x %y %W
+
+ set button_active %b
+ set notifier_id [after 100 ag_update_motion]
+ }
+
+ bind $v <ButtonRelease> {
+ if $button_active {
+ global notifier_id
+ set button_active 0
+ after cancel $notifier_id
+ send_to_vtk U 0 %b %x %y %W
+ }
+ }
+ bind $v <Motion> {
+ if $button_active {
+ global ag_motion_x ag_motion_y ag_motion_W
+# send_to_vtk M 0 $button_active %x %y %W
+ set ag_motion_x %x
+ set ag_motion_y %y
+ set ag_motion_W %W
+ }
+ }
+
# double clicking to toggle fullscreen mode
bind $w <Double-1> {
set src $win_src(%W)
@@ -354,38 +448,38 @@
}
# Resize
- bind $w <ButtonPress> {
+ bind $w <Meta-ButtonPress> {
global click_x click_y
set click_x %x
set click_y %y
}
- bind $w <ButtonRelease> {
- global win_src win_target click_x click_y
+ bind $w <Meta-ButtonRelease> {
+ global win_src win_target click_x click_y
- if { [info exists win_src(%W)] & [info exists win_target(%W)]} {
- # %W is vw.frame.video
- set src $win_src(%W)
-
- # iw/ih mean viewing video size rightnow
- set iw [%W width]
- set ih [%W height]
-
- set aspect_r [expr 1.0*$ih / $iw]
- set diff_x [expr %x - $click_x]
- set diff_y [expr %y - $click_y]
-
- set ow [expr int($iw + $diff_x + $diff_y)]
- set oh [expr int($aspect_r * $ow)]
-
- if { $ow > 64 } {
- resize %W $ow $oh
- #resize_window %W $ow $oh
- }
+ if { [info exists win_src(%W)] & [info exists win_target(%W)]} {
+ # %W is vw.frame.video
+ set src $win_src(%W)
+
+ # iw/ih mean viewing video size rightnow
+ set iw [%W width]
+ set ih [%W height]
+
+ set aspect_r [expr 1.0*$ih / $iw]
+ set diff_x [expr %x - $click_x]
+ set diff_y [expr %y - $click_y]
+
+ set ow [expr int($iw + $diff_x + $diff_y)]
+ set oh [expr int($aspect_r * $ow)]
+
+ if { $ow > 64 } {
+ resize %W $ow $oh
+ #resize_window %W $ow $oh
+ }
}
}
- switcher_register $v $src window_switch
+ #switcher_register $v $src window_switch
#
# Finally, bind the source to the window.
@@ -472,6 +566,136 @@
windowname $w [getid $src]
}
+proc set_hardware_render {v setting} {
+ global win_use_hw
+ if { $win_use_hw($v) == "software" && $setting == 1} {
+ set win_use_hw($v) "magic"
+ reallocate_renderer $v
+ } elseif { $setting == 0 } {
+ set win_use_hw($v) "software"
+ reallocate_renderer $v
+ }
+}
+proc set_window_glue {v setting} {
+ global window_glue
+ set window_glue($v) $setting
+}
+
+
+
+proc ag_update_motion { } {
+ global ag_motion_x ag_motion_y ag_motion_W
+ global ag_last_x ag_last_y
+ global button_active notifier_id
+
+# puts "update motion"
+
+ if [info exists ag_motion_x] {
+
+# puts "$ag_last_x $ag_last_y $ag_motion_x $ag_motion_y"
+ if {$ag_last_x != $ag_motion_x || $ag_last_y != $ag_motion_y} {
+
+ send_to_vtk M 0 $button_active $ag_motion_x $ag_motion_y $ag_motion_W
+ }
+ set ag_last_x $ag_motion_x
+ set ag_last_y $ag_motion_y
+ }
+
+ set notifier_id [after 100 ag_update_motion]
+}
+
+proc init_vtk {} {
+ set vtk_client ""
+ global server_socket
+
+ set server_socket ""
+
+ set v [option get . vtkServer Vic]
+
+ if { $v == "" } {
+ set v "yukon.mcs.anl.gov/46352"
+ }
+
+ if { $v != "" } {
+ set v1 [split $v "/"]
+ set host [lindex $v1 0]
+ set port [lindex $v1 1]
+
+ puts "have host=$host port=$port"
+
+ set server_socket ""
+ catch {
+ set server_socket [socket $host $port]
+ puts -nonewline $server_socket "VIC*"
+ flush $server_socket
+ }
+
+ if { $server_socket != "" } {
+ puts "connected to server $server_socket"
+# fconfigure $server_socket -translation binary
+ fconfigure $server_socket -buffering none
+ }
+ }
+
+# set mysock [socket -server server_connect 10000]
+# puts "mysock is $mysock"
+}
+
+proc fsend_to_vtk { string } {
+ global server_socket
+
+ if { $server_socket != "" } {
+ puts $server_socket $string
+ flush $server_socket
+ }
+}
+
+proc send_to_vtk_bin { type flags value x y window } {
+ global server_socket
+
+ if { $server_socket != ""} {
+ puts "sending $type $value $x $y"
+ set w [winfo width $window]
+ set h [winfo height $window]
+ set str [binary format a1cSSSSS $type 100 $value $x $y $w $h]
+ set l [string length $str]
+ binary scan $str c12 f
+ puts "sending length $l $f"
+ puts $server_socket $str
+ }
+}
+proc send_to_vtk { type flags value x y window } {
+ global server_socket
+
+ if { $server_socket != ""} {
+ puts "sending $type $value $x $y"
+ set w [winfo width $window]
+ set h [winfo height $window]
+ set str "$type $value $x $y $w $h"
+ set len [string length $str]
+ puts -nonewline $server_socket [format "%03d%s" $len $str]
+ }
+}
+
+proc server_connect { sock addr port } {
+ puts "got server connect $sock $addr $port"
+ global vtk_client
+ set vtk_client $sock
+ puts $vtk_client "hi there"
+}
+
+proc map_coordinates { x y window } {
+ set wx [winfo width $window]
+ set wy [winfo height $window]
+ set mx [expr double($x) / double($wx)]
+ set my [expr double($y) / double($wy)]
+ return [list $mx $my]
+}
+
+proc destroy_from_wm vw {
+ tk_dialog .destroy_dialog "Don't do that" "Press the 'd' key in the window to close a video window" "" 0 "OK"
+}
+
proc windowname { w name } {
if ![yesno suppressUserName] {
$w.bar.label configure -text $name
More information about the Sumover-dev
mailing list