Probability adjustment.

diff --git a/make-probes.tcl b/make-probes.tcl
index b8b520f6475ba48b1616983aa35929944bfecc66..9026c99a20848e7fdfcc30e8a2c32b86eac097d1 100755 (executable)
--- a/make-probes.tcl
+++ b/make-probes.tcl
@@ -94,7 +94,9 @@ proc choice-int {min max} {
 proc choice-prob {cv def} {
     set prob [config $cv $def]
     set rv 0x[random-bytes 3]
-    return [expr {$rv < double($prob)*0x1000000}]
+    set rv [expr {$rv < double($prob)*0x1000000}]
+    debug 2 "choice-prob $rv <- $prob ($cv)"
+    return $rv
 }
 
 proc choice-mult {args} {
@@ -106,8 +108,12 @@ proc choice-mult {args} {
     set args [lreplace $args end end]
     foreach {val p} $args {
        set cump [expr {$cump + double($p)}]
-       if {$x < $cump} { return $val }
+       if {$x < $cump} {
+ debug 2 "choice-mult $val <= [concat $args [list $def]]"
+           return $val
+       }
     }
+ debug 2 "choice-mult $def <- [concat $args [list $def]]"
     return $def
 }
 
@@ -124,11 +130,30 @@ proc config {cv def} {
 }
 
 
-proc define {enum val name argnames body} {
+proc define {enum val mult name argnames body} {
+    # mult may be:
+    #   *    full share of `known' enum values
+    #   ?    only as often as `random' enum values
+    # Or *<pct> or ?<pct> meaning <pct>/100 times as often as * or ?.
+
     upvar #0 enum/val2name/$enum v2n
+    upvar #0 enum/val2mult/$enum v2m
     upvar #0 enum/name2val/$enum n2v
+    foreach kind {? *} {
+       upvar #0 enum/total$kind/$enum total$kind
+       if {![info exists total$kind]} { set total$kind 0 }
+    }
+
+    regsub {^[?*]$} $mult {&100} mult
+    if {![regexp {^([?*])([0-9]+)$} $mult dummy kind times]} {
+       error "invalid mult $mult"
+    }
+
     set v2n($val) $name
+    set v2m($val) [list $kind $times]
     set n2v($name) $val
+    incr total$kind $times
+
     proc enum/val/$enum/$val $argnames $body
 }
 
@@ -193,20 +218,50 @@ proc get/enum-rand {s v min max} {
     return [get-enum-got $s $v $rv]
 }
 
-proc get/enum-def {s v} {
-    upvar #0 enum/val2name/$s-$v v2n
-    set rv [choice-int 1 [array size v2n]]
-    set rv [lindex [lsort [array names v2n]] [expr {$rv-1}]]
+proc enum-prepare-choice-list {s v nvalues prand} {
+    upvar #0 "enum/choice-list/$s-${v}($nvalues $prand)" cl
+    upvar #0 enum/val2mult/$s-$v v2m
+    upvar #0 enum/total*/$s-$v total*org
+    upvar #0 enum/total?/$s-$v total?
+
+    set total* ${total*org}
+    if {!${total*}} { set total* [expr {double(${total*org}) + 0.001}] }
+    
+    set pr $prand
+    if {!${total?}} { set pr 0.0 }
+    set pm? [expr {$pr / (100.0*double($nvalues))}]
+    set pm* [expr {(1.0 - $pr) / double(${total*})}]
+    debug 1 "epcl $s-$v $nvalues $prand: pr $pr  ? pm ${pm?} total ${total?}  * pm ${pm*} total ${total*}"
+
+    set cl {}
+    foreach rv [lsort [array names v2m]] {
+       manyset $v2m($rv) kind times
+       set p [expr { double($times) * [set pm$kind] }]
+       debug 1 "epcl $s-$v $nvalues $prand:   $rv $kind$times := $p"
+       lappend cl $rv $p
+    }
+    if {${total*org}} {
+       set cl [lreplace $cl end end]
+    } else {
+       lappend cl *
+    }
+}
+
+proc get/enum-def {s v min max prand} {
+    set nvalues [expr {$max-$min+1}]
+    upvar #0 "enum/choice-list/$s-${v}($nvalues $prand)" cl
+    if {![info exists cl]} { enum-prepare-choice-list $s $v $nvalues $prand }
+    set rv [eval choice-mult $cl]
+    if {"$rv" == "*"} { set rv [choice-int $min $max] }
     return [get-enum-got $s $v $rv]
 }
 
 proc get/enum {s v min max prand} {
-    get-for $s-$v
-    get any choice $prand
+    set any [choice-prob $s-$v-any $prand]
     if {$any} {
        return [get/enum-rand $s $v $min $max]
     } else {
-       return [get/enum-def $s $v]
+       return [get/enum-def $s $v $min $max $prand]
     }
 }
 
@@ -522,7 +577,7 @@ proc gen_1_ip {mtu source_spec dest_spec} {
        get frag number 0 0x1fff
     }
     get-config ttl 255 number 0 255
-    get proto enum 1 255 0.05
+    get proto enum 0 255 0.2
     set flags [expr {$df*2 + $mf}]
 
     set header_checksum 0
@@ -557,7 +612,7 @@ proc gen_1_ip {mtu source_spec dest_spec} {
     return $ip
 }
 
-define ip-proto 1 icmp {mtu} {
+define ip-proto 1 *50 icmp {mtu} {
     # RFC792
     get-for icmp
     get type enum 0 255 0.2
@@ -576,7 +631,7 @@ define ip-proto 1 icmp {mtu} {
 }
 
 proc define-icmp-type-vanilla {num name} {
-    define icmp-type $num $name {mbl} "icmp-vanilla \$mbl [list $name]"
+    define icmp-type $num * $name {mbl} "icmp-vanilla \$mbl [list $name]"
 }
 proc icmp-vanilla {mbl typename} {
     get-for icmp-$typename
@@ -586,24 +641,24 @@ proc icmp-vanilla {mbl typename} {
 }
 
 define-icmp-type-vanilla 3 unreach
-define icmp-unreach-code 0 net {} {}
-define icmp-unreach-code 1 host {} {}
-define icmp-unreach-code 2 proto {} {}
-define icmp-unreach-code 3 port {} {}
-define icmp-unreach-code 4 fragneeded {} {}
-define icmp-unreach-code 5 sourceroutefail {} {}
+define icmp-unreach-code 0 * net {} {}
+define icmp-unreach-code 1 * host {} {}
+define icmp-unreach-code 2 * proto {} {}
+define icmp-unreach-code 3 * port {} {}
+define icmp-unreach-code 4 * fragneeded {} {}
+define icmp-unreach-code 5 * sourceroutefail {} {}
 
 define-icmp-type-vanilla 11 timeout
-define icmp-timeout-code 0 intransit {} {}
-define icmp-timeout-code 1 fragment {} {}
+define icmp-timeout-code 0 * intransit {} {}
+define icmp-timeout-code 1 * fragment {} {}
 
 define-icmp-type-vanilla 12 parameters
-define icmp-parameters-code 0 seepointer {} {}
+define icmp-parameters-code 0 * seepointer {} {}
 
 define-icmp-type-vanilla 4 sourcequench
-define icmp-sourcequench-code 0 quench {} {}
+define icmp-sourcequench-code 0 * quench {} {}
 
-define icmp-type 5 redirect {mbl} {
+define icmp-type 5 * redirect {mbl} {
     get-for icmp-redirect
     get code enum 0 255 0.4
     get gateway v4addr
@@ -618,13 +673,13 @@ define icmp-type 5 redirect {mbl} {
     return [list $body $code]
 }
 
-define icmp-redirect-code 0 net {} {}
-define icmp-redirect-code 1 host {} {}
-define icmp-redirect-code 2 net+tos {} {}
-define icmp-redirect-code 3 host+tos {} {}
+define icmp-redirect-code 0 * net {} {}
+define icmp-redirect-code 1 * host {} {}
+define icmp-redirect-code 2 * net+tos {} {}
+define icmp-redirect-code 3 * host+tos {} {}
 
-define icmp-type 8 ping {mbl} { icmp-echo $mbl }
-define icmp-type 0 pong {mbl} { icmp-echo $mbl }
+define icmp-type 8 * ping {mbl} { icmp-echo $mbl }
+define icmp-type 0 * pong {mbl} { icmp-echo $mbl }
 proc icmp-echo {mbl} {
     get-for icmp-echo
     get code enum 0 255 0.4
@@ -640,10 +695,10 @@ proc icmp-echo {mbl} {
     }
     return [list $body $code]
 }
-define icmp-echo-code 0 echo {} {}
+define icmp-echo-code 0 * echo {} {}
 
-define icmp-type 13 timestamp {mbl} { icmp-timestamp }
-define icmp-type 14 timestampreply {mbl} { icmp-timestamp }
+define icmp-type 13 * timestamp {mbl} { icmp-timestamp }
+define icmp-type 14 * timestampreply {mbl} { icmp-timestamp }
 proc icmp-timestamp {} {
     get-for icmp-timestamp
     get code enum 0 255 0.4
@@ -665,10 +720,10 @@ proc icmp-timestamp {} {
     }
     return [list $body $code]
 }
-define icmp-timestamp-code 0 timestamp {} {}
+define icmp-timestamp-code 0 * timestamp {} {}
 
-define icmp-type 15 inforequest {mbl} { icmp-inforeq }
-define icmp-type 16 inforeply {mbl} { icmp-inforeq }
+define icmp-type 15 * inforequest {mbl} { icmp-inforeq }
+define icmp-type 16 * inforeply {mbl} { icmp-inforeq }
 proc icmp-inforeq {} {
     get-for icmp-inforeq
     get code enum 0 255 0.4
@@ -681,13 +736,13 @@ proc icmp-inforeq {} {
     }
     return [list $body $code]
 }
-define icmp-inforeq-code 0 timestamp {} {}
+define icmp-inforeq-code 0 * timestamp {} {}
 
 # MAYADD ICMP traceroute RFC1393
 # MAYADD ICMP router discovery RFC1256
 
 
-define ip-proto 4 ip {mtu} {
+define ip-proto 4 * ip {mtu} {
     # RFC2003
     get-for ip-ip
     get source v4addr
@@ -696,7 +751,7 @@ define ip-proto 4 ip {mtu} {
 }
 
 
-define ip-proto 2 igmp {mtu} {
+define ip-proto 2 ? igmp {mtu} {
     get-for igmp
     get type enum 0 255 0.5
     get timeout number 0 255
@@ -722,13 +777,13 @@ define ip-proto 2 igmp {mtu} {
     return $igmp
 }
 
-define igmp-type 17 membquery {} {}
-define igmp-type 16 membreport {} {}
-define igmp-type 23 leavegroup {} {}
-define igmp-type 18 membreport {} {}
+define igmp-type 17 * membquery {} {}
+define igmp-type 16 * membreport {} {}
+define igmp-type 23 * leavegroup {} {}
+define igmp-type 18 * membreport {} {}
 
 
-define ip-proto 51 ah {mtu} {
+define ip-proto 51 ? ah {mtu} {
     # RFC1826
     get-for ah
     get next number 0 255
@@ -756,7 +811,7 @@ proc udp-rport {} {
     return $port
 }
 
-define ip-proto 17 udp {mtu} {
+define ip-proto 17 * udp {mtu} {
     # RFC768
     get-for udp
 
@@ -765,14 +820,15 @@ define ip-proto 17 udp {mtu} {
            checksum_none 0.20 \
            checksum_good]
 
+    set prand 0.50
     get style choice-mult \
+           random $prand \
            request 0.15 \
            reply 0.15 \
-           servers 0.20 \
-           random
+           servers
 
     if {"$style" != "random"} {
-       get port enum-def
+       get port enum-def 0 255 $prand
        set def_port $port
     } else {
        set def_port x
@@ -830,7 +886,7 @@ define ip-proto 17 udp {mtu} {
     return $udp
 }
 
-define udp-port 50 remailck {mtu style} {
+define udp-port 50 ?200 remailck {mtu style} {
     # RFC1339
     get-for remailck
     if {"$style" == "request"} {
@@ -923,7 +979,7 @@ define udp-port 50 remailck {mtu style} {
     return $payload
 }
 
-define remailck-auth 31 passwd {mtu} {
+define remailck-auth 31 * passwd {mtu} {
     get-for remailck-passwd
     get passwd string 6 8 \
            0123456789abcdefghijklmnopqrstuvxwyz \
@@ -931,8 +987,8 @@ define remailck-auth 31 passwd {mtu} {
     return $passwd
 }
 
-define udp-port 67 dhcpserv {mtu style} { return [dhcp $mtu] }
-define udp-port 68 dhcpclient {mtu style} { return [dhcp $mtu] }
+define udp-port 67 ? dhcpserv {mtu style} { return [dhcp $mtu] }
+define udp-port 68 ? dhcpclient {mtu style} { return [dhcp $mtu] }
 proc dhcp {mtu} {
     get-for dhcp
     get op enum 0 255 0.2
@@ -974,12 +1030,12 @@ proc dhcp {mtu} {
 
     return $dhcp
 }
-define dhcp-op 1 request {} {}
-define dhcp-op 2 reply {} {}
-define dhcp-htype 1 ethernet {} {}
+define dhcp-op 1 * request {} {}
+define dhcp-op 2 * reply {} {}
+define dhcp-htype 1 * ethernet {} {}
 
 
-define ip-proto 6 tcp {mtu} {
+define ip-proto 6 * tcp {mtu} {
     # RFC793
     get-for tcp
 
@@ -1115,7 +1171,7 @@ define ip-proto 6 tcp {mtu} {
     return $packet
 }
 
-define tcp-opt 2 mss {mdl} {
+define tcp-opt 2 * mss {mdl} {
     get-for tcp-opt
     get mss hex 0 0xffff
     assemble od {