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