Changeset 953

Timestamp:

11/05/99 11:15:49 (14 years ago)

Author:

piers

Message:

Adding layered support and PVH codec:
cf-main.tcl - new rtp_types for ldct,pvh.
cf-network.tcl - create network sockets for send/recv layers. Added auto addr generation for layers
ui-ctrlmenu.tcl - $encoder loop_layer (numLayers+1) after $encoder transmitter $V(session)

adds pvh to 411 format list. Creates pvh encoder button, pvh_shs proc

ui-main.tcl - $decoder maxChannel numLayers for pvh format
ui-srclist.tcl - create layers when new src object is created
ui-resource.tcl - added numLayers resource

Location:

vic/trunk/tcl

Files:

• cf-main.tcl (modified) (2 diffs)
• cf-network.tcl (modified) (6 diffs)
• ui-ctrlmenu.tcl (modified) (13 diffs)
• ui-main.tcl (modified) (2 diffs)
• ui-resource.tcl (modified) (1 diff)
• ui-srclist.tcl (modified) (1 diff)

vic/trunk/tcl/cf-main.tcl

@@ -33 +33 @@
 
 set rtp_type(126) raw
+set rtp_type(20) ldct
+set rtp_type(21) pvh
 set rtp_type(22) bvc
 set rtp_type(25) cellb
@@ -47 +49 @@
 
 proc vic_main {} {
-        global V tcl_platform env
+        global V tcl_platform
+
         set V(class) Vic    
         set V(app) vic

vic/trunk/tcl/cf-network.tcl

@@ -36 +36 @@
 #
 proc net_open_ip { sessionType session dst } {
-        global V
+        global V numLayers
         set c $V(class)
 
@@ -93 +93 @@
                 set port [expr $port &~ 1]
         }
+
+#Layer 0
+        set layer 0
         set dn [new network ip]
         if { [$dn open $addr $port $ttl] == 0 } {
@@ -112 +115 @@
         set V(data-net) $dn
 
+        if { $numLayers > 0 } {
+                set oct [split $addr .]
+                set base [lindex $oct 0].[lindex $oct 1].[lindex $oct 2]
+                set off [lindex $oct 3]
+                set ismulticast [in_multicast $addr]
+
+                while { $numLayers > $layer } {
+                        incr port 
+                        incr layer
+                        if { $ismulticast } {
+                                incr off
+                        }
+                        set dn [new network ip]
+                        $dn open $base.$off $port $ttl
+                        $session data-net $dn $layer
+
+                        if { $sessionType != "nv" } {
+                                if { $sessionType == "ivs" } {
+                                        incr port 2
+                                } else {
+                                        incr port
+                                }
+                                set cn [new network ip]
+                                $cn open $base.$off $port $ttl
+                                $session ctrl-net $cn $layer
+                        }
+                }
+        }
         #
         # if the max bandwidth wasn't set, pick one based on the
@@ -154 +185 @@
 }
 
-#
-# $dst is an "atm-host"
-#
-proc net_open_atm { sessionType session dst } {
-        global V
-
-        set dataSAP 4092
-        set ctrlSAP 4090
-        set dn [new network atm]
-        if { $dn == "" } {
-                warn "not compiled with ATM support"
-                exit 1
-        }
-        #XXX should be able to configure qos parameters
-        if { [$dn open $dst $dataSAP 256 64 128 128 2 1] < 0 } {
-                warn "cannot open atm connection to $dst"
-                exit 1
-        }
-        $session data-net $dn
-        set cn [new network atm]
-        if { [$cn open $dst $ctrlSAP 128 64 24 24 2 1] < 0 } {
-                warn "cannot open atm control connection to $dst"
-                exit 1
-        }
-        $session ctrl-net $cn
-        set V(ctrl-net) $cn
-        set V(data-net) $dn
-}
-
-#
-# $dst has form ip-addr/rtip-port
-#
-proc net_open_rtip { sessionType session dst } {
-        global V
-
-        set dst [split $dst /]
-        set n [llength $dst]
-        if { $n != 2 } {
-                warn  "must specify both address and port (i.e., addr/port) for RTIP"
-                exit 1
-        }
-        set addr [lindex $dst 0]
-        set port [lindex $dst 1]
-        set dn [new network rtip]
-        if { [$dn open $addr $port [resource rtipXmin] [resource rtipXave] \
-                [resource rtipI] [resource rtipSmax] [resource rtipD] \
-                [resource rtipJ] [resource rtipZ] [resource rtipW] \
-                [resource rtipU]  [resource rtipType]] < 0 } {
-                warn "cannot open RTIP connection to $addr/$port"
-                exit 1
-        }
-        # just send control over data port
-        $session data-net $dn
-        $session ctrl-net $dn
-        set V(ctrl-net) $cn
-        set V(data-net) $dn
-}
-
-proc init_network {} {
-        set netType [resource network]
-        if { [string first ":" [resource defaultHostSpec]] > 0 } {
-                set netType ip6
-        }
-        if { [info procs net_open_$netType] == "" } {
-                warn "$netType not a recognized network type"
-                exit 1
-        }
-        set sessionType [resource sessionType]
-        if { $sessionType == "rtpv2" || $sessionType == "vic" } {
-                set sessionType rtp
-        }
-        global V
-        set V(sessionType) $sessionType
-        set V(session) [new session $V(media)/$sessionType]
-        if { $V(session) == "" } {
-                warn "'$sessionType' not a recognized session type"
-                exit 1
-        }
-        net_open_$netType $sessionType $V(session) [resource defaultHostSpec]
-
-        $V(session) max-bandwidth [resource maxbw]
-        $V(session) lip-sync [yesno lipSync]
-
-        set key [resource sessionKey]
-        if { $key != "" } {
-                crypt_set $key
-        }
-}
-
-proc in_multicast addr {
-        return [expr ([lindex [split $addr .] 0] & 0xf0) == 0xe0]
-}
-
-proc crypt_format {key sessionType} {
-        if {$sessionType == "vat"} {
-                set fmt VAT
-        } else {
-                set k [string first / $key]
-                if { $k < 0 } {
-                        set fmt DES1
-                } else {
-                        set fmt [string range $key 0 [expr $k - 1]]
-                        set key [string range $key [expr $k + 1] end]
-                }
-        }
-        return "$fmt $key"
-}
-
-proc crypt_set key {
-        global doEncryption entryTab V
-        set L [crypt_format $key $V(sessionType)]
-        set fmt [lindex $L 0]
-        set key [lindex $L 1]
-        set dc data-crypt:$fmt
-        set cc ctrl-crypt:$fmt
-        if ![info exists V($dc)] {
-                set crypt [new crypt $fmt/data]
-                if { $crypt == "" } {
-                        open_dialog "no $fmt enryption support"
-                        return -1
-                }
-                set V($dc) $crypt
-                set V($cc) [new crypt $fmt/ctrl]
-        }
-        if [$V($dc) key $key] {
-                $V($cc) key $key
-                $V(data-net) crypt $V($dc)
-                $V(ctrl-net) crypt $V($cc)
-                set V(encrypt) 1
-                return 0
-        } else {
-                open_dialog "your key is cryptographically weak"
-                crypt_clear
-                return -1
-        }
-}
-
-proc crypt_clear {} {
-        global V
-        $V(data-net) crypt ""
-        $V(ctrl-net) crypt ""
-        set V(encrypt) 0
-}
-
+
+# IPv6 network type
 #
 # $dst has form addr/port/fmt/ttl (last two optional)
 #
 proc net_open_ip6 { sessionType session dst } {
-        global V
+        global V numLayers 
+
         set c $V(class)
 
@@ -381 +271 @@
         }
         set V(data-net) $dn
+
+        if { $numLayers > 0 } {
+                set base [string range $addr 0 [string last : $addr]]
+                set off [string range $addr [expr {[string last : $addr]+1}] end]
+
+                set ismulticast [in6_multicast $addr]
+
+                while { $numLayers > $layer } {
+                        incr port 
+                        incr layer
+                        if { $ismulticast } {
+                                incr off
+                        }
+                        set dn [new network ip]
+                        $dn open $base.$off $port $ttl
+                        $session data-net $dn $layer
+
+                        if { $sessionType != "nv" } {
+                                if { $sessionType == "ivs" } {
+                                        incr port 2
+                                } else {
+                                        incr port
+                                }
+                                set cn [new network ip]
+                                $cn open $base.$off $port $ttl
+                                $session ctrl-net $cn $layer
+                        }
+                }
+        }
 
         #
@@ -423 +342 @@
         }
 }
+
+#
+# $dst is an "atm-host"
+#
+proc net_open_atm { sessionType session dst } {
+        global V
+
+        set dataSAP 4092
+        set ctrlSAP 4090
+        set dn [new network atm]
+        if { $dn == "" } {
+                warn "not compiled with ATM support"
+                exit 1
+        }
+        #XXX should be able to configure qos parameters
+        if { [$dn open $dst $dataSAP 256 64 128 128 2 1] < 0 } {
+                warn "cannot open atm connection to $dst"
+                exit 1
+        }
+        $session data-net $dn
+        set cn [new network atm]
+        if { [$cn open $dst $ctrlSAP 128 64 24 24 2 1] < 0 } {
+                warn "cannot open atm control connection to $dst"
+                exit 1
+        }
+        $session ctrl-net $cn
+        set V(ctrl-net) $cn
+        set V(data-net) $dn
+}
+
+#
+# $dst has form ip-addr/rtip-port
+#
+proc net_open_rtip { sessionType session dst } {
+        global V
+
+        set dst [split $dst /]
+        set n [llength $dst]
+        if { $n != 2 } {
+                warn  "must specify both address and port (i.e., addr/port) for RTIP"
+                exit 1
+        }
+        set addr [lindex $dst 0]
+        set port [lindex $dst 1]
+        set dn [new network rtip]
+        if { [$dn open $addr $port [resource rtipXmin] [resource rtipXave] \
+                [resource rtipI] [resource rtipSmax] [resource rtipD] \
+                [resource rtipJ] [resource rtipZ] [resource rtipW] \
+                [resource rtipU]  [resource rtipType]] < 0 } {
+                warn "cannot open RTIP connection to $addr/$port"
+                exit 1
+        }
+        # just send control over data port
+        $session data-net $dn
+        $session ctrl-net $dn
+        set V(ctrl-net) $cn
+        set V(data-net) $dn
+}
+
+proc init_network {} {
+        global numLayers
+        
+        set numLayers [resource numLayers]
+        set netType [resource network]
+        # Auto detect IPv6 addresses
+        if { [string first ":" [resource defaultHostSpec]] > 0 } {
+                set netType ip6
+        }
+        # Check for ipv6 as well as ip6 as a netType
+        if { $netType == "ipv6" } {
+                set netType ip6
+        }
+        if { [info procs net_open_$netType] == "" } {
+                warn "$netType not a recognized network type"
+                exit 1
+        }
+        set sessionType [resource sessionType]
+        if { $sessionType == "rtpv2" || $sessionType == "vic" } {
+                set sessionType rtp
+        }
+        global V
+        set V(sessionType) $sessionType
+        set V(session) [new session $V(media)/$sessionType]
+        if { $V(session) == "" } {
+                warn "'$sessionType' not a recognized session type"
+                exit 1
+        }
+        net_open_$netType $sessionType $V(session) [resource defaultHostSpec]
+
+
+        $V(session) max-bandwidth [resource maxbw]
+        $V(session) lip-sync [yesno lipSync]
+
+        set key [resource sessionKey]
+        if { $key != "" } {
+                crypt_set $key
+        }
+}
+
+proc in_multicast addr {
+        return [expr ([lindex [split $addr .] 0] & 0xf0) == 0xe0]
+}
+
+proc in6_multicast addr {
+        return [expr (0x[lindex [split $addr :] 0] & 0xff00) == 0xff00]
+}
+
+proc crypt_format {key sessionType} {
+        if {$sessionType == "vat"} {
+                set fmt VAT
+        } else {
+                set k [string first / $key]
+                if { $k < 0 } {
+                        set fmt DES1
+                } else {
+                        set fmt [string range $key 0 [expr $k - 1]]
+                        set key [string range $key [expr $k + 1] end]
+                }
+        }
+        return "$fmt $key"
+}
+
+proc crypt_set key {
+        global doEncryption entryTab V
+        set L [crypt_format $key $V(sessionType)]
+        set fmt [lindex $L 0]
+        set key [lindex $L 1]
+        set dc data-crypt:$fmt
+        set cc ctrl-crypt:$fmt
+        if ![info exists V($dc)] {
+                set crypt [new crypt $fmt/data]
+                if { $crypt == "" } {
+                        open_dialog "no $fmt enryption support"
+                        return -1
+                }
+                set V($dc) $crypt
+                set V($cc) [new crypt $fmt/ctrl]
+        }
+        if [$V($dc) key $key] {
+                $V($cc) key $key
+                $V(data-net) crypt $V($dc)
+                $V(ctrl-net) crypt $V($cc)
+                set V(encrypt) 1
+                return 0
+        } else {
+                open_dialog "your key is cryptographically weak"
+                crypt_clear
+                return -1
+        }
+}
+
+proc crypt_clear {} {
+        global V
+        $V(data-net) crypt ""
+        $V(ctrl-net) crypt ""
+        set V(encrypt) 0
+}

vic/trunk/tcl/ui-ctrlmenu.tcl

@@ -277 +277 @@
 }
 
-set transmitButtonState 0
+set  transmitButtonState 0
+
 proc transmit { } {
-        global transmitButtonState videoFormat videoDevice V useJPEGforH261 useHardwareComp
+        global transmitButtonState videoFormat videoDevice V useJPEGforH261 useHardwareComp numLayers
         if ![have grabber] {
                 set DA [$videoDevice attributes]
@@ -319 +320 @@
 
                 $encoder transmitter $V(session)
+
+                $encoder loop_layer [expr {$numLayers + 1}]
+                
                 set V(encoder) $encoder
                 set ff [$grabtarget frame-format]
@@ -535 +539 @@
         }
         if [inList 411 $formats] {
-                set fmtList "$fmtList bvc"
+                set fmtList "$fmtList bvc pvh"
         }
         if [inList cif $sizes] {
@@ -686 +690 @@
 }
 
-proc format_col { w n0 n1 n2 } {
+proc format_col3 { w n0 n1 n2 } {
         set f [smallfont]
         frame $w
@@ -702 +706 @@
         global formatButtons
         lappend formatButtons $w.b0 $w.b1 $w.b2
+
+        #format_col $w.p0 nv nvdct cellb 
+        #format_col $w.p1 jpeg h261 bvc
+        #format_col $w.p2 h263+ h263 raw
+}
+
+proc format_col { w n0 n1 } {
+        set f [smallfont]
+        frame $w
+        if { [string first : $n0] > 0 } { 
+                set reliefn0 ridge
+                set n0 [ string range $n0 0 [expr {[string length $n0] -2 }] ]
+        } else {
+                set reliefn0 flat
+        }
+        if { [string first : $n1] > 0 } { 
+                set reliefn1 ridge
+                set n1 [ string range $n1 0 [expr {[string length $n1] -2 }] ]
+        } else {
+                set reliefn1 flat
+        }
+        radiobutton $w.b0 -text $n0 -relief $reliefn0 -font $f -anchor w \
+                -variable videoFormat -value $n0 -padx 0 -pady 0 \
+                -command "select_format $n0" -state disabled
+        radiobutton $w.b1 -text $n1 -relief $reliefn1 -font $f -anchor w \
+                -variable videoFormat -value $n1 -padx 0 -pady 0 \
+                -command "select_format $n1" -state disabled
+        pack $w.b0 $w.b1 -fill x 
+
+        global formatButtons
+        lappend formatButtons $w.b0 $w.b1
+
+        #format_col $w.p0 nv nvdct 
+        #format_col $w.p1 jpeg h261
+        #format_col $w.p2 h263+ h263
+        #format_col $w.p3 raw cellb
+        #format_col $w.p4 pvh bvc
+}
+
+proc set_numLayers { value } {
+        global transmitButtonState numLayers V layerscale layervalue
+
+        $layervalue configure -text $value
+        
+        if $transmitButtonState {
+                $V(encoder) loop_layer [expr {$numLayers + 1}]
+                $V(decoder) maxChannel $numLayers
+        }
+}
+
+proc layer_frame { w n0 } {
+        global numLayers
+        set f [smallfont]
+
+        radiobutton $w.b0 -text $n0 -relief flat -font $f -anchor w \
+                -variable videoFormat -value $n0 -padx 0 -pady 0 \
+                -command "select_format $n0" -state disabled
+        
+        scale $w.scale -orient horizontal -width 12 \
+                -label "Number of layers" \
+                -variable numLayers \
+                -relief groove -showvalue 1 -from 0 -to [resource numLayers] \
+        -command "set_numLayers"
+        
+        pack $w.b0 $w.scale -fill x -side left
+
+        global formatButtons
+        lappend formatButtons $w.b0
+}
+
+proc build.layer_scale w {
+        global numLayers layerscale layervalue
+
+        set f [smallfont]
+
+        frame $w.tb
+        label $w.title -text "Layers" -font $f -anchor w
+        label $w.tb.value -text 0 -font $f -width 3
+        scale $w.tb.scale -font $f -orient horizontal \
+                -showvalue 0 -from 0 -to $numLayers \
+                -variable numLayers \
+                -width 12 -relief groove \
+        -command "set_numLayers"
+
+
+        set layerscale $w.tb.scale
+        set layervalue $w.tb.value
+
+        $layervalue configure -text $numLayers
+
+#$layerscale configure -state disabled
+
+        pack $w.tb.scale -side left -fill x -expand 1
+        pack $w.tb.value -side left
+        pack $w.title -padx 2 -side left
+        pack $w.tb -fill x -padx 6 -side left -expand 1
 }
 
 proc build.format w {
-        format_col $w.p0 nv nvdct cellb 
-        format_col $w.p1 jpeg h261 bvc
-        format_col $w.p2 h263+ h263 raw
-
-        set f [smallfont]
+        format_col $w.p0 nv nvdct 
+        format_col $w.p1 jpeg h261
+        format_col $w.p2 h263+ h263
+        format_col $w.p3 raw cellb
+        format_col $w.p4 bvc pvh:
+        
+        #frame $w.layer -relief groove -borderwidth 2 -width 50
+        #layer_frame $w.layer pvh
 
         frame $w.glue0
         frame $w.glue1
 
-        pack $w.glue0 -side left -fill x -expand 1
-        pack $w.p0 $w.p1 $w.p2 -side left
-        pack $w.glue1 -side left -fill x -expand 1
+        #pack $w.layer -side bottom -fill x -expand 1
+        #pack $w.glue0 -side left -fill x -expand 1
+        pack $w.p0 $w.p1 $w.p2 $w.p3 $w.p4 -side left
+        #pack $w.glue1 -side left -fill x -expand 1
 
 }
@@ -1006 +1110 @@
 
         frame $w.f.h0 -relief flat
-        frame $w.f.h1 -relief flat
+        frame $w.f.quality -relief flat
+#       frame $w.f.layer -relief flat
         frame $w.f.h0.eb -relief flat
         frame $w.f.h0.format -relief groove -borderwidth 2
@@ -1016 +1121 @@
         build.size $w.f.h0.size
 
-        build.q $w.f.h1
+        build.q $w.f.quality
+#build.layer_scale $w.f.h2
 
         pack $w.f.h0.eb -side left -anchor n -fill y -padx 6 -pady 4
@@ -1024 +1130 @@
 
         pack $w.f.h0 -fill x -pady 4
-        pack $w.f.h1 -fill x -pady 6
+#       pack $w.f.layer -fill x 
+        pack $w.f.quality -fill x -pady 6
         pack $w.title $w.f -fill x
 }
@@ -1087 +1194 @@
 proc nvdct_setq value {
         nv_setq $value
+        global qvalue
+        $qvalue configure -text $value
 }
 
@@ -1124 +1233 @@
 }
 
+set pvh_shmap { 0 1 2 1 }
+set pvh_shs {
+        { lum-dct 0 5-1--11- }
+        { lum-dct 1 ---5111- }
+        { lum-dct 2 --51-11- }
+        { lum-sbc 0 ----4--2 }
+        { lum-sbc 1 ----4--2 }
+        { lum-sbc 2 ----4--2 }
+        { chm     0 -5---1-- }
+        { chm     1 ---5-1-- }
+        { chm     2 --5--1-- }
+}
+
+#
+# Format specific routine to map generic quality <i>value</i>
+# into actions that program the underlying PVH codec.
+#
+#VideoPipeline instproc 
+#
+proc pvh_setq value {
+#       $self instvar encoder_
+#       if ![info exists encoder_] {
+#               return -1
+#       }
+        if [have grabber] {
+                #encoder q $value
+
+                #XXX ignore value and just set up the bit allocation
+                #XXX should have variable strategies here
+                global pvh_shmap pvh_shs
+                set n [llength $pvh_shmap]
+                set i 0
+                while { $i < $n } {
+                        encoder shmap $i [lindex $pvh_shmap $i]
+                        incr i
+                }
+                set i 0
+                foreach tuple $pvh_shs {
+                        set compID [lindex $tuple 0]
+                        set shID [lindex $tuple 1]
+                        set pattern [lindex $tuple 2]
+                        encoder comp $compID $shID $pattern
+                }
+                global qvalue
+                $qvalue configure -text $value
+                
+                return 0
+        }
+        #XXX
+        return -1
+}
+
 #
 # If the capture device is open, close it.  If transmission
@@ -1169 +1330 @@
 
 proc select_format fmt {
-        global qscale qlabel videoDevice videoFormat qscale_val lastFmt
-
-        if { $fmt == "h261" } {
+        global qscale qlabel videoDevice videoFormat qscale_val lastFmt layerscale
+
+        if { $fmt == "h261" || $fmt == "pvh"} {
                 # H.261 supports only QCIF/CIF
                 disable_large_button
         } else {
                 enable_large_button
+        }
+
+        if { $fmt == "pvh"} {
+                set w .menu.encoder.f.layer
+                if ![winfo exists $w] {
+                        frame $w
+                        build.layer_scale $w
+                }
+                pack $w -before .menu.encoder.f.quality  -fill x
+        } else {
+                pack forget .menu.encoder.f.layer
         }
 
@@ -1191 +1363 @@
         set qual [resource quality]
         if { $qual > 0 } {
-                puts "vic: quality found "
                 $qscale set [resource quality]
         } else { if [info exists qscale_val($fmt)] {
@@ -1304 +1475 @@
 proc build.xmit w {
         set f [smallfont]
+
         label $w.label -text Transmission
         frame $w.frame -relief sunken -borderwidth 2
         pack $w.label -fill x
         pack $w.frame -fill both -expand 1
-
         frame $w.frame.buttons
         build.buttons $w.frame.buttons

vic/trunk/tcl/ui-main.tcl

@@ -593 +593 @@
 
 proc create_decoder src {
-        set decoder [new decoder [rtp_format $src]]
+        global numLayers
+
+        set format [rtp_format $src]
+        set decoder [new decoder $format]
         if { $decoder == "" } {
                 # don't support this format
                 set decoder [new decoder null]
         }
+##LL
+        if { $format == "pvh" } {
+                $decoder maxChannel $numLayers
+        }
         $src handler $decoder
         return $decoder
@@ -610 +617 @@
 #
 proc activate src {
+        global V
+
         if [yesno relateInterface] {
-                create_decoder $src
+                set V(decoder) [create_decoder $src]
                 after idle "really_activate_relate $src"
         } else {
-                create_decoder $src
+                set V(decoder) [create_decoder $src]
         #
         # give decoder a chance see a packet so it can

vic/trunk/tcl/ui-resource.tcl

@@ -199 +199 @@
         option add Vic.flowLabel 0 startupFile
 
+        option add Vic.numLayers 0 startupFile
+
         option add Vic.foundry adobe startupFile
 

vic/trunk/tcl/ui-srclist.tcl

@@ -72 +72 @@
 # those not actually sending video).
 #
+# This also sets up the layers within each source object
+#
 proc register src {
-        global srcstate srclist srclist_bottom nametag
+        global srcstate srclist srclist_bottom nametag numLayers
+
         set srcstate($src) 1
+
+        set layer 0
+        $src layer $layer [new SourceLayer]
+
+        # Create SourceLayer objs within the src as required
+        while { $numLayers > $layer } {
+                incr layer
+                $src layer $layer [new SourceLayer]
+        }
+        
         if [info exists srclist] {
                 set f [mediumfont]