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