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