hostside/stopgap-controller

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