hostside/measure-speeds

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