hostside/stopgap-controller

   1 #!/usr/bin/tclsh8.2
   2 # used like this:
   3 # liberator:hostside> ssh bessar 'cd things/trains-bessar/hostside && ./stopgap-controller' | ./gui-displayer -
   4
   5 set testonly 0
   6 #set testonly 1
   7 set port /dev/ttya0
   8 #set port /dev/ttyS0
   9
  10 set ch(funcsevery) 10
  11 set ch(speeddirnevery) 30
  12 set ch(scale) 1
  13
  14 set ch(minint) 5000
  15 # unset always
  16 # set always 0
  17 set nmrawhich 0
  18 set lastptchosen xx
  19
  20 set polmsg(l) 908000
  21 set polmsg(x) 90f802
  22 set polmsg(y) 90807c
  23 set pname l
  24 set m {}
  25 set nmradiv 0
  26 set segs {xx yy}
  27 set segsasgot {xx yy}
  28 set pq {} ;# unset: cdu charged and waiting
  29 set speeddirn ff7f
  30 #set speeddirn ffff80c3fbcced7f
  31 #set speeddirn_fixed {speed126 2 80 0}
  32 set speeddirn_fixed {}
  33 set funcs ff7f
  34 # unset pointpos($point)
  35 # unset segdetect($seg) ;# unset: shown D0; {}: shown D1; or: after id, D1->0
  36
  37 proc gui {m} {
  38     puts "GUI $m"
  39 }
  40
  41 proc gui_init {} {
  42     global watchdog polarity segdetect
  43     gui "M A2 0"
  44     gui "M A5 0 J"
  45     gui "M A6 0 J"
  46     gui "EOE"
  47     if {[info exists watchdog]} { gui "P 1" }
  48     gui_polarity
  49     foreach seg [array names segdetect] {
  50         gui "D1 $seg"
  51     }
  52 }
  53
  54 proc debug {m} {
  55     puts $m
  56 }
  57
  58 proc tellpic_q {m} {
  59     global p testonly
  60     if {$testonly} return
  61     set b [binary format H* $m]
  62     puts -nonewline $p $b
  63 }
  64
  65 proc tellpic {m} {
  66     puts ">> $m"
  67     tellpic_q $m
  68 }
  69
  70 proc bgerror {m} {
  71     if {[catch {
  72         global errorInfo errorCode
  73         puts stderr "$m\n$errorCode\n$errorInfo"
  74         fail "bgerror $m"
  75     } emsg]} {
  76         exit 127
  77     }
  78 }
  79
  80 proc fail_now {} {
  81     global p
  82     debug "failing now"
  83     fconfigure $p -blocking yes
  84     gui "P 0"
  85     tellpic 10
  86     exit 1
  87 }
  88
  89 proc fail {m} {
  90     global watchdog p
  91     catch { after cancel $watchdog; unset watchdog }
  92     puts "failing $m"
  93     tellpic 9801 ;# 16ms
  94     after 1000 fail_now
  95     fileevent $p readable {}
  96 }
  97
  98 proc gui_polarity {} {
  99     global pname
 100     set 1 {}
 101     switch -exact $pname {
 102         l { lappend 0 X1 X3 X5 X7 X9; lappend 0 X2 X4 X6 X8 X10 }
 103         x { lappend 1 X1 X3 X5 X7 X9; lappend 0 X2 X4 X6 X8 X10 }
 104         y { lappend 0 X1 X3 X5 X7 X9; lappend 1 X2 X4 X6 X8 X10 }
 105     }
 106     foreach v {0 1} {
 107         foreach seg [set $v] {
 108             gui "R $v $seg"
 109         }
 110     }
 111 }
 112
 113 proc polarity {newpname} {
 114     global pname polmsg
 115     debug "polarising $newpname"
 116     if {![string compare $pname $newpname]} return
 117     tellpic $polmsg($newpname)
 118     set pname $newpname
 119     gui_polarity
 120 }
 121
 122 proc pt_now {how point pos xtra} {
 123     set msg a0[lindex $point $pos]
 124     debug "$how point $point pos=$pos msg=$msg$xtra"
 125     gui "M [lindex $point 2] [expr {!$pos}]"
 126     tellpic $msg
 127 }
 128 proc pt_must {point newpos} {
 129     upvar #0 pointpos($point) pos
 130     global pq
 131     if {[info exists pos] && $pos == $newpos} return
 132     set pos $newpos
 133     if {[info exists pq]} {
 134         lappend pq [list $point $pos]
 135         debug "queue point $point pos=$pos l=[llength $pq]"
 136         return
 137     }
 138     pt_now immed $point $pos {}
 139     set pq {}
 140 }
 141 proc pt_ifthenmust {ifpoint ifposwant thenpoint thenpos} {
 142     upvar #0 pointpos($ifpoint) ifpos
 143     if {![info exists ifpos] || $ifpos != $ifposwant} return
 144     pt_must $thenpoint $thenpos
 145 }
 146
 147 proc badwatchdog {} {
 148     global pq
 149     puts "watchdog - oh well"
 150     if {![info exists pq]} { set pq {} }
 151 }
 152
 153 proc pm_charged {} {
 154     global pq
 155     if {[llength $pq]} {
 156         set v [lindex $pq 0]
 157         set pq [lrange $pq 1 end]
 158         pt_now nowdo [lindex $v 0] [lindex $v 1] " l=[llength $pq]"
 159     } else {
 160         debug "cdu-charged"
 161         unset pq
 162     }
 163 }
 164
 165 proc randbyte {} {
 166     global rand
 167     set c [read $rand 1]; if {![string length $c]} { error "eof on rand" }
 168     binary scan $c H* x
 169     return $x
 170 }
 171
 172 proc pt_maybe {point oneisright} {
 173     global always lastptchosen
 174     if {[info exists always]} {
 175         set pos $always
 176     } else {
 177         if {![string compare $point $lastptchosen]} return
 178         set lastptchosen $point
 179         set x [randbyte]
 180         set pos [expr [regexp {^[89a-f]} $x] ? 1 : 0]
 181         debug "chose point $point pos=$pos (x=$x)"
 182     }
 183     pt_must $point $pos
 184 }
 185
 186 proc s0 {v seg} {
 187     upvar #0 segdetect($seg) segd
 188     if {![info exists segd]} {
 189         debug "segment $seg = already"
 190     } elseif {[string length $segd]} {
 191         debug "segment $seg = pending already"
 192     } else {
 193         debug "segment $seg = soon"
 194         set segd [after 100 s0t $seg]
 195     }
 196 }
 197 proc s0t {seg} {
 198     upvar #0 segdetect($seg) segd
 199     debug "segment $seg = now"
 200     unset segd
 201     gui "D0 $seg"
 202 }
 203 proc s1 {v seg} {
 204     upvar #0 segdetect($seg) segd
 205     if {![info exists segd]} {
 206         pm_detect $v
 207         debug "segment $seg ! (overwrites =)"
 208     } elseif {[string length $segd]} {
 209         debug "segment $seg ! (cancels =)"
 210         after cancel $segd
 211     } else {
 212         debug "segment $seg ! already"
 213         return
 214     }
 215     gui "D1 $seg"
 216     set segd {}
 217 }
 218
 219 proc pm_maydetect {d seg} {
 220     switch -exact $seg {
 221         06 { s$d $seg X10 }
 222         09 { s$d $seg X8 }
 223         0a { s$d $seg X6 }
 224         04 { s$d $seg X5 }
 225         02 { s$d $seg X7 }
 226         07 { s$d $seg X9 }
 227         14 { s$d $seg A5 }
 228         20 { s$d $seg A6 }
 229         1a { s$d $seg A4 }
 230         10 { s$d $seg A2 }
 231         03 { s$d $seg X1 }
 232         05 { s$d $seg X3 }
 233         16 { s$d $seg A3 }
 234         1c { s$d $seg A1 }
 235         08 { s$d $seg X2 }
 236         0b { s$d $seg X4 }
 237     }
 238 }
 239
 240 #proc pm_nodetect {seg} {
 241 #    global segsasgot
 242 #    if {![string compare $seg [lindex $segsasgot 1]]} {
 243 #       set segsasgot [list [lindex $segsasgot 1] [lindex $segsasgot 0]]
 244 #    }
 245 #}
 246
 247 proc pm_detect {seg} {
 248     global segs pname segsasgot
 249     if {[string compare $seg [lindex $segsasgot 1]]} {
 250         set segsasgot [list [lindex $segsasgot 1] $seg]
 251     }
 252     if {[lsearch -exact $segs $seg] < 0} {
 253         set segs $segsasgot
 254     }
 255     debug "pm_detect $seg ($segsasgot) ($segs) $pname$seg"
 256 #    if {[lsearch -exact {
 257 #       06 09 0a 04 02 07 14 20
 258 #       0b 08 1c 16
 259 #       1a 10 03 05
 260 #    } $seg] < 0} return
 261     switch -exact $pname$seg {
 262         l16 - l1c - l08 - l0b { polarity y }
 263         l10 - l1a - l03 - l05 { polarity x }
 264         x07 - x04 - x0a { polarity l }
 265         x16 - x1c - x14 - x0b { polarity y }
 266         y06 - y04 - y0a { polarity l }
 267         y20 - y10 - y1a - y05 { polarity x }
 268     }
 269     switch -exact $seg {
 270         04 - 0a { pt_must "00 01 X7" 1; pt_must "40 41 X8" 1 }
 271         05 { pt_must "00 01 X7" 0 }
 272         0b { pt_must "40 41 X8" 0 }
 273         16 - 1c { pt_must "02 03 A5" 0 }
 274         1a - 10 { pt_must "42 43 A6" 0 }
 275         14 { pt_ifthenmust "02 03 A5" 1 "42 43 A6" 1 }
 276         20 { pt_ifthenmust "42 43 A6" 1 "02 03 A5" 1 }
 277     }
 278     switch -exact [join $segs -] {
 279         02-07 { pt_maybe "02 03 A5" 1 }
 280         07-02 { pt_maybe "00 01 X7" 0 }
 281         09-06 { pt_maybe "42 43 A6" 0 }
 282         06-09 { pt_maybe "40 41 X8" 1 }
 283     }
 284 }
 285
 286 proc tellnmra {m} {
 287 #    global nmrawhich speeddirn funcs
 288 #    set m 0x$m
 289 #    for {set i 0} {$i < $m} {incr i} {
 290 #       tellpic_q [lindex [list $speeddirn $funcs] $nmrawhich]
 291 #       set nmrawhich [expr {!$nmrawhich}]
 292 #    }
 293 }
 294
 295 proc watchdog {} {
 296     global watchdog testonly speeddirn funcs nmradiv
 297     catch { after cancel $watchdog }
 298     set watchdog [after 50 watchdog]
 299     tellpic_q 9808 ;# 128ms
 300     if {[incr nmradiv] > 35} {
 301         tellpic_q $speeddirn$funcs
 302         set nmradiv 0
 303     }
 304 }
 305
 306 proc pm_hello {} {
 307     debug "got hello, starting up"
 308     tellpic 11
 309     gui "P 1"
 310     watchdog
 311     changewhat
 312     tellnmra 01
 313 }
 314
 315 proc fp {m} {
 316     debug "<< $m"
 317 }
 318
 319 proc frompic {m} {
 320     set v [lindex $m 1]
 321     switch -glob [lindex $m 0] {
 322         01 - 02 { tellnmra $m }
 323         09 { fp $m; pm_hello }
 324         07 { puts "short circuit"; exit 1 }
 325         0d { fp $m; badwatchdog }
 326         28 { fp $m; pm_charged }
 327         9[0-7] { fp $m; pm_maydetect 0 $v }
 328         9? { fp $m; pm_maydetect 1 $v }
 329         0a - [234567]? { puts "pic debug $m" }
 330         * { fp $m; fail "pic unknown $m" }
 331     }
 332 }
 333
 334 proc onreadp_test {} {
 335     if {![gets stdin m]} { return }
 336     frompic $m
 337 }
 338
 339 proc onreadp {} {
 340     global p m rand
 341     while 1 {
 342         set c [read $p 1]
 343         if {![string length $c]} {
 344             if {[eof $p]} { error "eof on device" }
 345             return
 346         }
 347         binary scan $c H* x
 348         if {![info exists rand]} {
 349             fp ...$x
 350             return
 351         }
 352         lappend m $x
 353         if {[regexp {^[0-7]} $x]} {
 354             if {![regexp {^x} $m]} {
 355                 frompic $m
 356             }
 357             set m {}
 358         }
 359     }
 360 }
 361
 362 proc newspeeddirn {} {
 363     set b1 0x[randbyte]
 364     set speed [expr {round(($b1 * $b1) / 65535.0 * 100.0 + 26.0)}]
 365     set b2 0x[randbyte]
 366     set dirn [expr {$b2 / 128}]
 367     set dirn 0
 368     debug "speeddirn b1=$b1 speed=$speed b2=$b2 dirn=$dirn"
 369     return "speed126 2 $speed $dirn"
 370 }
 371
 372 proc newfuncs {} {
 373     set b3 0x[randbyte]
 374     set value [expr {($b3 & 127) * 16}]
 375     debug "funcs b3=$b3 value=[format %x $value]"
 376     return "funcs5to8 2 $value"
 377 }
 378
 379 proc maybechange {thing} {
 380     global $thing ch
 381     upvar #0 ${thing}_fixed fixed
 382     if {![info exists fixed]} {
 383         set rb 0x[randbyte][randbyte]
 384         if {
 385             $rb / 65536.0 >
 386             1.0 / (($ch(${thing}every) - $ch(minint)*0.001) * $ch(scale))
 387         } {
 388             debug "maybechange $thing rb=$rb no"
 389             return 0
 390         }
 391         debug "maybechange $thing rb=$rb yes ..."
 392         set l [new$thing]
 393     } else {
 394         debug "fixed $thing $fixed"
 395         set l $fixed
 396         if {![llength $l]} { return 0 }
 397     }
 398     set bin [eval exec ./hostside-old -s/dev/stdout $l]
 399     binary scan $bin H* x
 400     debug "changed $thing=$x"
 401     set $thing ff$x
 402     return 1
 403 }
 404
 405 proc changewhat {} {
 406     global ch chwa
 407     catch { after cancel $chwa }
 408     if {[maybechange speeddirn] || [maybechange funcs]} {
 409         set interval $ch(minint)
 410     } else {
 411         set interval 1000
 412     }
 413     set chwa [after $interval changewhat]
 414 }
 415
 416 proc onreadcmd {} {
 417     if {[gets stdin l] < 0} {
 418         if {[eof stdin]} {
 419             puts "GUI exit 0"
 420             fail "stopgap-controller got eof, quitting"
 421             fileevent stdin readable {}
 422         }
 423         return
 424     }
 425     eval $l
 426 }
 427
 428 proc setup {} {
 429     global port p testonly
 430     if {!$testonly} {
 431         set p [open $port {RDWR NONBLOCK} 0]
 432
 433         exec stty -F $port min 1 time 0 -istrip -ocrnl -onlcr -onocr -opost \
 434                        -ctlecho -echo -echoe -echok -echonl -iexten -isig \
 435                        -icanon -icrnl \
 436             9600 clocal cread crtscts -hup -parenb cs8 -cstopb \
 437             -ixoff bs0 cr0 ff0 nl0 -ofill -olcuc
 438
 439         fconfigure $p -encoding binary -translation binary \
 440                 -blocking false -buffering none
 441
 442         fileevent $p readable onreadp
 443         fconfigure stdin -blocking false
 444         fileevent stdin readable onreadcmd
 445     } else {
 446         set p stdin
 447         fconfigure stdin -blocking false
 448         fileevent stdin readable onreadp_test
 449     }
 450
 451     after 250 setup_complete
 452 }
 453
 454 proc setup_complete {} {
 455     global rand
 456     set rand [open /dev/urandom {RDONLY} 0]
 457     fconfigure $rand -encoding binary -translation binary
 458     tellpic 0a
 459 }
 460
 461
 462 #----------
 463 # for keyboard control
 464
 465 proc ask_fast {} {
 466     global speeddirn_fixed; set speeddirn_fixed {speed126 2 126 0}
 467 }
 468 proc ask_slow {} {
 469     global speeddirn_fixed; set speeddirn_fixed {speed126 2 10 0}
 470 }
 471 proc ask_randspeed {} {
 472     global speeddirn_fixed; catch { unset speeddirn_fixed }
 473 }
 474
 475 setup
 476 gui_init
 477 vwait end