hostside/measure-speeds

   1 #!/usr/bin/tclsh8.3
   2
   3 # Put loco on track segment X5 ish, facing anticlockwise
   4 #  ./measure-speeds /dev/railway 2 0 `seq 1 126` |tee santafe.speeds
   5 #                                  ^reverse
   6
   7 # debugging:
   8 # ./measure-speeds /dev/railway 1 1 `seq 1 126` 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] }')
   9
  10 load chiark_tcl_hbytes-1.so
  11
  12 proc debug_r {m} { puts -nonewline stderr "$m\r" }
  13 proc debug {m} { puts stderr $m }
  14
  15 proc send-now {str} {
  16     global rwy
  17     puts -nonewline $rwy [hbytes h2raw $str]
  18 }
  19
  20 proc startup {} {
  21     global port rwy buf last_fast_speed noise funcs_msgs loco
  22     set rwy [open $port r+]
  23     fconfigure $rwy -blocking no -buffering none -encoding binary \
  24             -translation binary
  25     send-now 10
  26     after 1000
  27     read -nonewline $rwy
  28     send-now 11
  29     fileevent $rwy readable readable
  30     set buf {}
  31     set last_fast_speed 0
  32     set noise {}
  33     for {set i 0} {$i < 256} {incr i} { append noise \\x [hbytes random 1] }
  34 #    foreach f {funcs0to4 funcs5to8} {
  35 #    }
  36     foreach f {funcs5to8} {
  37         set m [exec ./hostside-old -s/dev/stdout $f $loco 0x1fff]
  38         set m [hbytes raw2h $m]
  39         lappend funcs_msgs ffff$m {}
  40     }
  41     lappend funcs_msgs {}
  42 }
  43
  44 proc readable {} {
  45     global rwy buf
  46     append buf [hbytes raw2h [read $rwy]]
  47     while {[regexp {^((?:[89a-f].)*[0-7].)(.*)$} $buf dummy msg buf]} {
  48         proc-msg $msg
  49     }
  50 }
  51
  52 proc settle-cancel-after {} {
  53     global settle_after
  54     catch {
  55         after cancel $settle_after
  56         unset settle_after
  57     }
  58 }
  59
  60 proc proc-msg {msg} {
  61     global until detend settle_detend settle_time settle_after
  62     switch -glob $msg {
  63         90?? {
  64             if {[lsearch $settle_detend $msg]<0} { debug_r "o $msg"; return }
  65             debug_r "= $msg"
  66             settle-cancel-after
  67             set settle_after [after $settle_time { set until 1}]
  68             return
  69         }
  70         01 - 02 - 03 return
  71         28 return
  72         98?? {
  73             if {[lsearch $detend $msg]<0} { debug_r "I $msg"; return }
  74             debug_r "* $msg"
  75             if {$settle_time>0} {
  76                 settle-cancel-after
  77             } else {
  78                 set until 1
  79             }
  80             return
  81         }
  82     }
  83     puts stderr "huh? $msg"
  84     exit 1
  85 }
  86
  87 #
  88 # A6 06
  89 # A5 14
  90 #
  91 # X7 02
  92 # X5 04
  93 # X6 0a
  94 # X8 09
  95 #
  96
  97 proc speed-msg {speed} {
  98     global loco reverse
  99     list speed126 $loco [expr {abs($speed)}] [expr {$speed<0 != $reverse}]
 100 }
 101
 102 proc run-until {speed new_detend} {
 103     global loco until detend settle_time settle_detend
 104     set detend $new_detend
 105     set settle_detend {}
 106     set settle_time -1
 107     catch { unset until }
 108     xmit [speed-msg $speed]
 109     vwait until
 110 }
 111
 112 proc run-until-not {speed new_detend new_settle} {
 113     global loco until detend settle_time settle_detend
 114     set detend $new_detend
 115     set settle_detend $new_detend
 116     hbytes xor settle_detend 0800
 117     set settle_time $new_settle
 118     catch { unset until }
 119     xmit [speed-msg $speed]
 120     vwait until
 121 }
 122
 123 proc instruct-speed-for {speed ms} {
 124     global loco until detend settle_detend
 125     catch { unset until }
 126     set detend {}
 127     set settle_detend {}
 128     xmit [speed-msg $speed]
 129     after $ms { set until 1 }
 130     vwait until
 131 }
 132
 133 proc instruct-stop-for {ms} {
 134     instruct-speed-for 0 $ms
 135 }
 136
 137 proc bgerror {m} {
 138     global errorInfo errorCode
 139     puts stderr "----------\nBGERROR\n$m\n$errorInfo\n$errorCode\n----------"
 140 }
 141
 142 proc xmit-now {until_funcs} {
 143     global xmit_after xmit_msg funcs_msgs
 144     set m $xmit_msg
 145     if {![incr until_funcs -1]} {
 146         set funcs_msg [lindex $funcs_msgs 0]
 147         set funcs_msgs [lreplace $funcs_msgs 0 0]
 148         lappend funcs_msgs $funcs_msg
 149         append m $funcs_msg
 150         set until_funcs 5
 151     }
 152     send-now $m
 153     set xmit_after [after 10 xmit-now $until_funcs]
 154 }
 155 proc xmit {nmral} {
 156     global xmit_msg xmit_after detend settle_detend settle_time funcs_msgs
 157     set msg [eval [list exec ./hostside-old -s/dev/stdout] $nmral]
 158     set xmit_msg [hbytes raw2h $msg]
 159     debug "> $xmit_msg $nmral (E $detend $settle_detend $settle_time) \[$funcs_msgs]"
 160     catch { after cancel $xmit_after }
 161     xmit-now 10
 162 }
 163
 164 proc now-ms {} {
 165     clock clicks -milliseconds
 166 }
 167
 168 proc now-ms-click {{returnthis {}}} {
 169     if {[string length $returnthis]} { return $returnthis }
 170     global noise
 171     set now [now-ms]
 172 #    set f [open |[list sh -c {"$@" >/dev/dsp} x printf $noise]]
 173 #    fileevent $f readable [list close $f]
 174     return $now
 175 }
 176
 177 proc record-mm-per-s {how speed mm ms} {
 178     debug "                    $how $speed: $mm / $ms"
 179     set mmpers [expr {$mm*1.0/$ms}]
 180     puts [format "%s %3d %g" $how $speed $mmpers]
 181 }
 182 proc timing-start {{now {}}} {
 183     global start
 184     set start [now-ms-click $now]
 185 }
 186 proc timing-finish {{now {}}} {
 187     global start
 188     set finish [now-ms-click $now]
 189     return [expr {$finish-$start}]
 190 }
 191
 192 proc goto-slow-start-position {speed} {
 193     global last_fast_speed
 194     if {$last_fast_speed >= 0} {
 195         run-until -100 {9804 980a}
 196         set last_fast_speed -1
 197     }
 198     run-until -40 {9802 9804}
 199     run-until-not -40 9804 600
 200     instruct-speed-for -40 [expr {$speed*$speed}]
 201     instruct-stop-for 1000
 202 }
 203
 204 proc begin-slow-test {speed} {
 205     debug "==================== $speed S ===================="
 206     goto-slow-start-position $speed
 207     run-until $speed 9804
 208 }
 209
 210 proc slow-speed-test {speed} {
 211     begin-slow-test $speed
 212     timing-start
 213     run-until $speed 980a
 214     record-mm-per-s S $speed 231 [timing-finish]
 215     instruct-stop-for 100
 216 }
 217
 218 proc slow-stop-test {speed} {
 219     begin-slow-test $speed
 220     finish-stop-test
 221 }
 222
 223 proc finish-stop-test {} {
 224     global forever
 225     after 10000 {
 226         send-now 10
 227         exit 0
 228     }
 229     run-until 0 {}
 230     vwait forever
 231 }
 232
 233 proc prepare-fast-test {speed} {
 234     global last_fast_speed
 235     debug "==================== $speed F ===================="
 236     set start [now-ms]
 237     set acceltime [expr {abs($last_fast_speed-$speed)*100}]
 238     debug "A $acceltime"
 239     set finish [expr {$start + $acceltime}]
 240     while 1 {
 241         # we go round and round, keeping track of roughly where we
 242         #  are, until there has been enough time to get the speed right
 243         run-until $speed 9809
 244         run-until $speed 9814
 245         set deficit [expr {$finish - [now-ms]}]
 246         debug "W $deficit"
 247         if {$deficit < 0} break
 248     }
 249     set last_fast_speed $speed
 250 }
 251
 252 proc fast-speed-test {speed} {
 253     prepare-fast-test $speed
 254     set ms 0; set mm 0
 255     set mslaps 0; set mmlaps 0
 256     while {$ms < 2000} {
 257         run-until $speed 9804
 258         set now [now-ms-click]
 259         if {$ms} {
 260             incr mslaps [timing-finish $now]
 261             incr mmlaps 3624
 262             debug "++ $mmlaps / $mslaps"
 263         }
 264         timing-start $now
 265
 266         run-until $speed 980a
 267
 268         incr ms [timing-finish]
 269         incr mm 231
 270         debug "+- $mm / $ms"
 271         run-until-not $speed 980a 600
 272     }
 273     record-mm-per-s F $speed $mm $ms
 274     if {$mslaps} { record-mm-per-s L $speed $mmlaps $mslaps }
 275 }
 276
 277 proc fast-stop-test {speed} {
 278     prepare-fast-test $speed
 279     run-until $speed 9804
 280     finish-stop-test
 281 }
 282
 283 proc run-test {how speed} {
 284     if {$speed<50} {
 285         slow-$how-test $speed
 286     } else {
 287         fast-$how-test $speed
 288     }
 289 }
 290
 291 set port [lindex $argv 0]
 292 set loco [lindex $argv 1]
 293 set reverse [lindex $argv 2]
 294
 295 startup
 296
 297 foreach s [lrange $argv 3 end] {
 298     if {[regexp {^s(\d+)} $s dummy s]} {
 299         run-test stop $s
 300     } else {
 301         run-test speed $s
 302     }
 303 }
 304 instruct-stop-for 1000
 305 send-now 10
 306 instruct-stop-for 500
 307 debug FINISHED