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 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 0x010 0x080 0x0f0 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 #unset askspeedix
  37 set askspeeds {10 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
 383     set b1 0x[randbyte]
 384     set speed [expr {round(($b1 * $b1) / 65535.0 * 100.0 + 26.0)}]
 385     set b2 0x[randbyte]
 386     set dirn [expr {$b2 / 128}]
 387     set dirn 0
 388     debug "speeddirn b1=$b1 speed=$speed b2=$b2 dirn=$dirn"
 389     return "speed126 $loco $speed $dirn"
 390 }
 391
 392 proc funcs_removebits {lr headent} {
 393     global funcsval
 394     set funcsval [format 0x%x [expr {$funcsval & ~$headent}]]
 395 }
 396 proc funcs_addbits {lr list} {
 397     global loco funcsval
 398     set headent [lindex $list 0]
 399     set val $funcsval
 400     set add $headent
 401     if {$add & 0x02} {
 402         set rand 0x[randbyte]0
 403         set add [expr {$add & $rand}]
 404         set val [expr {$val | $add}]
 405         debug "funcs $lr v=$funcsval add=$add new=$val rand=$rand ($list)"
 406     } else {
 407         set val [expr {$val | $add}]
 408         debug "funcs $lr v=$funcsval add=$add new=$val ($list)"
 409     }
 410     set funcsval $val
 411 }
 412
 413 proc funcsnmralist {} {
 414     global loco funcsval
 415     return "funcs5to8 $loco $funcsval"
 416 }
 417
 418 proc newfuncs {} {
 419     global loco funcsval
 420     foreach lr {l r} {
 421         upvar #0 funcs${lr}${loco} list
 422         set now [lindex $list 0]
 423         funcs_removebits $lr $now
 424         funcs_addbits $lr $list
 425     }
 426     return [funcsnmralist]
 427 }
 428
 429 proc nmrachange {thing argstring} {
 430     global $thing
 431     set bin [eval exec ./hostside-old -s/dev/stdout $argstring]
 432     binary scan $bin H* x
 433     debug "changed $thing=$x ($argstring)"
 434     set $thing ff$x
 435 }
 436
 437 proc maybechange {thing force} {
 438     global $thing ch
 439     upvar #0 ${thing}_fixed fixed
 440     if {![info exists fixed]} {
 441         if {$force} {
 442             debug "maybechange $thing forced ..."
 443         } else {
 444             set rb 0x[randbyte][randbyte]
 445             if {
 446                 $rb / 65536.0 >
 447                 1.0 / (($ch(${thing}every) - $ch(minint)*0.001) * $ch(scale))
 448             } {
 449                 debug "maybechange $thing rb=$rb no"
 450                 return 0
 451             }
 452             debug "maybechange $thing rb=$rb yes ..."
 453         }
 454         set l [new$thing]
 455     } else {
 456         debug "fixed $thing $fixed"
 457         set l $fixed
 458         if {![llength $l]} { return 0 }
 459     }
 460     nmrachange $thing $l
 461     return 1
 462 }
 463
 464 proc changewhat {} {
 465     global ch chwa
 466     catch { after cancel $chwa }
 467     if {[maybechange speeddirn 0] + [maybechange funcs 0]} {
 468         set interval $ch(minint)
 469     } else {
 470         set interval 1000
 471     }
 472     set chwa [after $interval changewhat]
 473 }
 474
 475 proc onreadcmd {} {
 476     if {[gets stdin l] < 0} {
 477         if {[eof stdin]} {
 478             puts "GUI exit 0"
 479             fail "stopgap-controller got eof, quitting"
 480             fileevent stdin readable {}
 481         }
 482         return
 483     }
 484     eval $l
 485 }
 486
 487 proc setup {} {
 488     global port p testonly stateshowpipe
 489     fconfigure stdout -buffering none
 490     if {!$testonly} {
 491         set p [open $port {RDWR NONBLOCK} 0]
 492
 493         exec stty -F $port min 1 time 0 -istrip -ocrnl -onlcr -onocr -opost \
 494                        -ctlecho -echo -echoe -echok -echonl -iexten -isig \
 495                        -icanon -icrnl \
 496             9600 clocal cread crtscts -hup -parenb cs8 -cstopb \
 497             -ixoff bs0 cr0 ff0 nl0 -ofill -olcuc
 498
 499         fconfigure $p -encoding binary -translation binary \
 500                 -blocking false -buffering none
 501
 502         fileevent $p readable onreadp
 503         fconfigure stdin -blocking false
 504         fileevent stdin readable onreadcmd
 505         set stateshowpipe [open /tmp/train-state w]
 506         fconfigure $stateshowpipe -buffering none
 507     } else {
 508         set p stdin
 509         fconfigure stdin -blocking false
 510         fileevent stdin readable onreadp_test
 511         set stateshowpipe [open /dev/null w]
 512     }
 513
 514     after 250 setup_complete
 515 }
 516
 517 proc setup_complete {} {
 518     global rand
 519 #    exec [xset s off]
 520     set rand [open /dev/urandom {RDONLY} 0]
 521     fconfigure $rand -encoding binary -translation binary
 522     tellpic 0a
 523 }
 524
 525 #----------
 526 # for keyboard control
 527
 528 proc updownfromlist {wholelistv ixv updown} {
 529     upvar #0 $wholelistv wholelist
 530     upvar #0 $ixv ix
 531     set ll [llength $wholelist]
 532     if {![info exists ix]} {
 533         set old ?
 534         set ix [expr {
 535             int($ll * 0.5 - 0.5 + 0.5 * $updown)
 536         }]
 537     } else {
 538         set old $ix
 539         incr ix $updown
 540         if {$ix < 0} { set ix 0 }
 541         if {$ix >= $ll} { set ix [expr {$ll - 1}] }
 542     }
 543     set val [lindex $wholelist $ix]
 544     debug "updownfromlist ix:$old->$ix /$ll $val ($wholelist)"
 545     return $val
 546 }
 547
 548 proc ask_speed {updown} {
 549     global speeddirn_fixed loco
 550     set speed [updownfromlist askspeeds askspeedix $updown]
 551     set speeddirn_fixed [list speed126 $loco $speed 0]
 552     maybechange speeddirn 1
 553 }
 554
 555 proc ask_randspeed {} {
 556     global speeddirn_fixed askspeedix
 557     catch { unset speeddirn_fixed }
 558     catch { unset askspeedix }
 559     maybechange speeddirn 1
 560 }
 561
 562 proc ask_funcs {lr} {
 563     global loco
 564     upvar #0 funcs${lr}${loco} list
 565     set now [lindex $list 0]
 566     funcs_removebits $lr $now
 567     set list [concat [lrange $list 1 end] $now]
 568     funcs_addbits $lr $list
 569     nmrachange funcs [funcsnmralist]
 570 }
 571
 572 proc ask_pointprob {updown} {
 573     global pointprob
 574     set pointprob [updownfromlist pointprobs pointprobix $updown]
 575 }
 576
 577 proc ask_pointrelabs {} {
 578     global pointabs
 579     set pointabs [expr {!$pointabs}]
 580 }
 581
 582 proc ask_show {} {
 583     global loco stateshowpipe pointprob pointabs askspeedix
 584     upvar #0 funcsr$loco fr
 585     upvar #0 funcsl$loco fl
 586     if {[info exists askspeedix]} { set spd $askspeedix } { set spd r }
 587     puts -nonewline $stateshowpipe [format \
 588             "\nL$loco P%03x%s F%03x S%s" \
 589             $pointprob [lindex {R A} $pointabs] \
 590             [expr {[lindex $fr 0] | [lindex $fl 0]}] \
 591             $spd]
 592 }
 593
 594 setup
 595 gui_init
 596 ask_show
 597 vwait end