hostside/measure-speeds

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