hostside/measure-speeds

   1 #!/usr/bin/tclsh8.3
   2
   3 # Put loco on track segment X5 ish, facing anticlockwise
   4 #  ./measure-speeds /dev/railway AX speed 2 50 0 `seq 1 126` |tee santafe.speeds
   5 #                                     loco^ ^. ^reverse
   6 #                                            `-fastest "slow" speed
   7
   8 # For stop distance at speed (say) 126,
   9 # Put loco on track segment X5 ish, facing ANTICLOCKWISE
  10 #  ./measure-speeds /dev/railway AX stop 2 50 0 40
  11 # OR put on track segment or C7 ish, facing CLOCKWISE
  12 #  ./measure-speeds /dev/railway C stop 2 50 0 40
  13
  14 # When committing, it would be best to include the command line arguments
  15 # in the commit message.
  16
  17 # debugging:
  18 # ./measure-speeds [stuff] 2>&1 | perl -pe '$|=1; s/\r/\n/g' | 3<&0 tclsh8.3 <(echo 'set f [open /dev/fd/3]; proc cm {} { clock clicks -milliseconds }; set z [cm]; while {[gets $f l]>=0} { puts [format "%-10s %s" [expr {[cm]-$z}] $l] }')
  19
  20 load chiark_tcl_hbytes-1.so
  21
  22 source lib.tcl
  23
  24 proc debug_r {m} { puts -nonewline stderr "$m\r" }
  25 proc debug {m} { puts stderr $m }
  26
  27 proc send-now {str} {
  28     global rwy
  29     puts -nonewline $rwy [hbytes h2raw $str]
  30 }
  31
  32 proc startup {} {
  33     global port rwy buf last_fast_speed noise funcs_msgs loco
  34     global detend settle_detend
  35     set detend {}
  36     set settle_detend {}
  37     set rwy [open $port r+]
  38     fconfigure $rwy -blocking no -buffering none -encoding binary \
  39             -translation binary
  40     send-now 10
  41     after 100
  42     send-now 10
  43     after 1000
  44     read -nonewline $rwy
  45     fileevent $rwy readable readable
  46     set buf {}
  47     set last_fast_speed -1
  48     set noise {}
  49     for {set i 0} {$i < 256} {incr i} { append noise \\x [hbytes random 1] }
  50 #    foreach f {funcs0to4 funcs5to8} {
  51 #    }
  52     foreach f {funcs5to8} {
  53         set m [exec ./adhoc-test -s/dev/stdout $f $loco 0x1fff]
  54         set m [hbytes raw2h $m]
  55         lappend funcs_msgs ffff$m {}
  56     }
  57     lappend funcs_msgs {}
  58 }
  59
  60 proc readable {} {
  61     global rwy buf
  62     append buf [hbytes raw2h [read $rwy]]
  63     while {[regexp {^((?:[89a-f].)*[0-7].)(.*)$} $buf dummy msg buf]} {
  64         proc-msg $msg
  65     }
  66 }
  67
  68 proc settle-cancel-after {} {
  69     global settle_after
  70     catch {
  71         after cancel $settle_after
  72         unset settle_after
  73     }
  74 }
  75
  76 proc proc-msg {msg} {
  77     global until detend settle_detend settle_time settle_after
  78     global pointing pointed
  79     switch -glob $msg {
  80         90?? {
  81             if {[lsearch $settle_detend $msg]<0} { debug_r "o $msg"; return }
  82             debug_r "= $msg"
  83             settle-cancel-after
  84             set settle_after [after $settle_time { set until 1}]
  85             return
  86         }
  87         01 - 02 - 03 - 20 return
  88         28 {
  89             if {[llength $pointing]} {
  90                 set point [lindex $pointing 0]
  91                 set pointing [lrange $pointing 1 end]
  92                 puts stderr "> $point"
  93                 send-now $point
  94             } else {
  95                 set pointed 1
  96             }
  97             return
  98         }
  99         98?? {
 100             if {[lsearch $detend $msg]<0} { debug_r "I $msg"; return }
 101             debug_r "* $msg"
 102             if {$settle_time>0} {
 103                 settle-cancel-after
 104             } else {
 105                 set until 1
 106             }
 107             return
 108         }
 109     }
 110     puts stderr "huh? $msg"
 111     exit 1
 112 }
 113
 114 proc use-segment {name_AX seg_AX name_C_unused seg_C} {
 115     global track segs
 116     set segs($name_AX) 98[set seg_$track]
 117 }
 118
 119 proc define-segments {} {
 120                 # For speed or stopping         For stopping distance
 121                 # stopping distance             tests only
 122     use-segment         A5 14                           C1 11
 123     use-segment         X7 02                           C9 2e
 124     use-segment         X5 04                           C8 34
 125     use-segment         X6 0a                           C7 32
 126     use-segment         X8 09                           C5 2f
 127 }
 128
 129 proc normalise1 {seg_unused feat_unused pos_unused hex} {
 130     global pointing
 131     lappend pointing $hex
 132 }
 133
 134 proc normalise_C {} {
 135     normalise1          C5 P 0  a045
 136     normalise1          C9 P 0  a021
 137     normalise1          C0 P 0  a067
 138 }
 139 proc normalise_AX {} {
 140     normalise1          X7 P 0  a001
 141     normalise1          X8 P 0  a041
 142     normalise1          A6 P 0  a043
 143     normalise1          A5 P 0  a003
 144     normalise1          A6 J 0  a060
 145     normalise1          A5 J 0  a005
 146 }
 147
 148 proc speed-msg {speed} {
 149     global loco reverse
 150     list speed126 $loco [expr {abs($speed)}] [expr {$speed<0 != $reverse}]
 151 }
 152
 153 proc run-until {speed new_detend} {
 154     global loco until detend settle_time settle_detend
 155     set detend $new_detend
 156     set settle_detend {}
 157     set settle_time -1
 158     catch { unset until }
 159     xmit [speed-msg $speed]
 160     vwait until
 161 }
 162
 163 proc run-until-not {speed new_detend new_settle} {
 164     global loco until detend settle_time settle_detend
 165     set detend $new_detend
 166     set settle_detend $new_detend
 167     hbytes xor settle_detend 0800
 168     set settle_time $new_settle
 169     catch { unset until }
 170     xmit [speed-msg $speed]
 171     vwait until
 172 }
 173
 174 proc instruct-speed-for {speed ms} {
 175     global loco until detend settle_detend
 176     catch { unset until }
 177     set detend {}
 178     set settle_detend {}
 179     xmit [speed-msg $speed]
 180     after $ms { set until 1 }
 181     vwait until
 182 }
 183
 184 proc instruct-stop-for {ms} {
 185     instruct-speed-for 0 $ms
 186 }
 187
 188 proc bgerror {m} {
 189     global errorInfo errorCode
 190     puts stderr "----------\nBGERROR\n$m\n$errorInfo\n$errorCode\n----------"
 191 }
 192
 193 proc xmit-now {until_funcs} {
 194     global xmit_after xmit_msg funcs_msgs
 195     set m $xmit_msg
 196     if {![incr until_funcs -1]} {
 197         set funcs_msg [lindex $funcs_msgs 0]
 198         set funcs_msgs [lreplace $funcs_msgs 0 0]
 199         lappend funcs_msgs $funcs_msg
 200         append m $funcs_msg
 201         set until_funcs 5
 202     }
 203     send-now $m
 204     set xmit_after [after 10 xmit-now $until_funcs]
 205 }
 206 proc xmit {nmral} {
 207     global xmit_msg xmit_after detend settle_detend settle_time funcs_msgs
 208     set msg [eval [list exec ./adhoc-test -s/dev/stdout] $nmral]
 209     set xmit_msg [hbytes raw2h $msg]
 210     debug "> $xmit_msg $nmral (E $detend $settle_detend $settle_time) \[$funcs_msgs]"
 211     catch { after cancel $xmit_after }
 212     xmit-now 10
 213 }
 214
 215 proc now-ms {} {
 216     clock clicks -milliseconds
 217 }
 218
 219 proc now-ms-click {{returnthis {}}} {
 220     if {[string length $returnthis]} { return $returnthis }
 221     global noise
 222     set now [now-ms]
 223 #    set f [open |[list sh -c {"$@" >/dev/dsp} x printf $noise]]
 224 #    fileevent $f readable [list close $f]
 225     return $now
 226 }
 227
 228 proc record-mm-per-s {how speed mm ms} {
 229     debug "                    $how $speed: $mm / $ms"
 230     set mmpers [expr {$mm*1.0/$ms}]
 231     puts [format "%s %3d %g" $how $speed $mmpers]
 232 }
 233 proc timing-start {{now {}}} {
 234     global start
 235     set start [now-ms-click $now]
 236 }
 237 proc timing-finish {{now {}}} {
 238     global start
 239     set finish [now-ms-click $now]
 240     return [expr {$finish-$start}]
 241 }
 242
 243 proc goto-slow-start-position {speed} {
 244     global last_fast_speed segs
 245     if {$last_fast_speed > 0} {
 246         run-until -100 [list $segs(X5) $segs(X6)]
 247     } elseif {$last_fast_speed == 0} {
 248         run-until -100 [list $segs(X5) $segs(X6) $segs(X7)]
 249     } elseif {$last_fast_speed < 0} {
 250         run-until 100 [list $segs(X5) $segs(X6) $segs(X8)]
 251     }
 252     run-until -40 [list $segs(X7) $segs(X5)]
 253     run-until-not -40 $segs(X5) 600
 254     instruct-speed-for -40 [expr {$speed*$speed}]
 255     instruct-stop-for 1000
 256 }
 257
 258 proc begin-slow-test {speed} {
 259     global segs
 260     debug "==================== $speed S ===================="
 261     goto-slow-start-position $speed
 262     run-until $speed $segs(X5)
 263 }
 264
 265 proc slow-speed-test {speed} {
 266     global segs last_fast_speed
 267     begin-slow-test $speed
 268     timing-start
 269     run-until $speed $segs(X6)
 270     record-mm-per-s S $speed 231 [timing-finish]
 271     instruct-stop-for 100
 272     set last_fast_speed 0
 273 }
 274
 275 proc slow-stop-test {speed} {
 276     begin-slow-test $speed
 277     finish-stop-test
 278 }
 279
 280 proc finish-stop-test {} {
 281     global forever
 282     after 10000 {
 283         send-now 10
 284         exit 0
 285     }
 286     run-until 0 {}
 287     vwait forever
 288 }
 289
 290 proc prepare-fast-test {speed} {
 291     global last_fast_speed segs
 292     debug "==================== $speed F ===================="
 293     set start [now-ms]
 294     set acceltime [expr {abs($last_fast_speed-$speed)*100}]
 295     debug "A $acceltime"
 296     set finish [expr {$start + $acceltime}]
 297     while 1 {
 298         # we go round and round, keeping track of roughly where we
 299         #  are, until there has been enough time to get the speed right
 300         run-until $speed $segs(X8)
 301         run-until $speed $segs(A5)
 302         set deficit [expr {$finish - [now-ms]}]
 303         debug "W $deficit"
 304         if {$deficit < 0} break
 305     }
 306     set last_fast_speed $speed
 307 }
 308
 309 proc fast-speed-test {speed} {
 310     global segs
 311     prepare-fast-test $speed
 312     set ms 0; set mm 0
 313     set mslaps 0; set mmlaps 0
 314     while {$ms < 2000} {
 315         run-until $speed $segs(X5)
 316         set now [now-ms-click]
 317         if {$ms} {
 318             incr mslaps [timing-finish $now]
 319             incr mmlaps 3624
 320             debug "++ $mmlaps / $mslaps"
 321         }
 322         timing-start $now
 323
 324         run-until $speed $segs(X6)
 325
 326         incr ms [timing-finish]
 327         incr mm 231
 328         debug "+- $mm / $ms"
 329         run-until-not $speed $segs(X6) 600
 330     }
 331     record-mm-per-s F $speed $mm $ms
 332     if {$mslaps} { record-mm-per-s L $speed $mmlaps $mslaps }
 333 }
 334
 335 proc fast-stop-test {speed} {
 336     global segs
 337     prepare-fast-test $speed
 338     run-until $speed $segs(X5)
 339     finish-stop-test
 340 }
 341
 342 proc run-test {how speed} {
 343     global track fastestslow
 344     if {[string compare $track AX] && [string compare $how stop]} {
 345         error "$track $how ?"
 346     }
 347     if {$speed<=$fastestslow} {
 348         slow-$how-test $speed
 349     } else {
 350         fast-$how-test $speed
 351     }
 352 }
 353
 354 manyset $argv port track how loco fastestslow reverse
 355
 356 define-segments
 357 startup
 358 normalise_$track
 359 send-now 11
 360 vwait pointed
 361
 362 foreach s [lrange $argv 6 end] {
 363     run-test $how $s
 364 }
 365 instruct-stop-for 1000
 366 send-now 10
 367 instruct-stop-for 500
 368 debug FINISHED