hostside/gui

   1 #!/usr/bin/wishx
   2
   3 load chiark_tcl_hbytes-1.so
   4
   5 #---------- general utilities ----------
   6
   7 set tk_strictMotif 1
   8
   9 tk_setPalette background black foreground white
  10
  11 source lib.tcl
  12
  13 set default_speedstep_list {0 1 10 20 35 50 65 80 95 110 126}
  14
  15 set picturepadx 10
  16 set picturepady 10
  17
  18 proc pagew {page} { return ".picture-$page" }
  19 proc debug {m} { puts $m }
  20
  21 proc sconn {m} {
  22     global sconn
  23     debug "=> $m"
  24     puts $sconn $m
  25 }
  26
  27 proc widgets-dgram {} {
  28     global cpage geometry picturepadx picturepady
  29     if {[string length $geometry]} { wm geometry . $geometry }
  30     set sizes [exec ./gui-plan-$cpage --sizes]
  31     set w [pagew $cpage]
  32     frame $w
  33     frame $w.picture -background {} \
  34             -width [lindex $sizes 0] \
  35             -height [lindex $sizes 1]
  36     pack $w.picture -padx $picturepadx -pady $picturepady
  37     pack $w
  38 }
  39
  40 proc widgets-fullscreen-nowm {} {
  41     pack propagate . false
  42     foreach wh {width height} {
  43         . configure -$wh [winfo screen$wh .]
  44     }
  45 }
  46
  47 proc bgerror {emsg} {
  48     global errorCode errorInfo
  49     catch {
  50         puts stderr "UNEXPECTED BACKGROUND ERROR\n"
  51         puts stderr "$errorCode\n$errorInfo\n$emsg"
  52     }
  53     exit 16
  54 }
  55
  56 #---------- train set event registraton ----------
  57
  58 set event_dispatch_body {
  59     append l " "
  60 }
  61 set event_selections {}
  62
  63 proc register-event {selections args re body} {
  64     global event_dispatch_body event_selections
  65
  66     eval lappend event_selections $selections
  67
  68     foreach selection $selections {
  69         if {[regexp {^\w} $selection]} {
  70             error "selection $selection lacks context char"
  71         }
  72     }
  73     if {[regexp {^\^\w} $re]} {
  74         error "re $re never matches context char"
  75     }
  76
  77     regsub -all {\W+} $re - proc
  78     set proc "event/$proc/[join $args -]"
  79     set suffix {}
  80     set number 0
  81     while {![catch { info args $proc$suffix }]} { set suffix [incr number] }
  82     append proc $suffix
  83
  84     proc $proc [concat l $args] $body
  85     set al ""
  86     foreach a $args { append al " \$$a" }
  87
  88     append event_dispatch_body \
  89             "    if {\[regexp [list $re] \$l dummy $args]} {\n" \
  90             "        debug \"$proc$al\"\n" \
  91             "        eval [list $proc] \[list \$l$al]\n" \
  92             "        return\n" \
  93             "    }\n"
  94 }
  95
  96 #---------- handling of commands we issue ----------
  97
  98 proc scmd {onresult ctrlr commandstr args} {
  99     # later, calls
 100     #   eval [list $onresult-ok|nak|error $ackornakmessage] $args
 101     global commands_queued
 102     sconn $commandstr
 103     lappend commands_queued [list $ctrlr $onresult $args]
 104 }
 105
 106 proc scmd_result {oknakerr message reporterrmsg} {
 107     global commands_queued
 108     manyset [lindex $commands_queued 0] ctrlr onresult args
 109     set commands_queued [lrange $commands_queued 1 end]
 110     if {[string length $reporterrmsg]} {
 111         report-problem "$ctrlr: $reporterrmsg"
 112     }
 113     set proc "$onresult-$oknakerr"
 114     if {![string compare $oknakerr nak] && [catch { info args $proc }]} {
 115         set proc "$onresult-err"
 116     }
 117     eval [list $proc $message] $args
 118 }
 119
 120 register-event {} {} {^\+ack \S+ ok } { scmd_result ok $l "" }
 121 register-event {} {train segment error} \
 122         {^\+ack \S+ SignallingPredictedProblem (\S+) (\S+) \: (.*) $} {
 123     set m $train
 124     if {[string compare - $segment]} { append m " @$segment" }
 125     append m ": $error"
 126     scmd_result err $l $m
 127 }
 128 register-event {} {} {^\+ack } { scmd_result err $l $l }
 129 register-event {} {} {^\+nack \S+ } { scmd_result nak $l $l }
 130
 131 proc routinecmd-nak {m args} { error "got nak to routine command: $m" }
 132 proc routinecmd-err {m args} { }
 133 proc routinecmd-ok {m args} { }
 134
 135 proc mustsucceed-err {m args} { error "unexpected error: $m" }
 136 proc mustsucceed-ok {m args} { }
 137
 138 proc report-problem-report-stderr {m} { puts stderr "*** $m" }
 139 set report_problem_report report-problem-report-stderr
 140
 141 proc report-problem {message} {
 142     global report_problem_report
 143     eval $report_problem_report [list $message]
 144 }
 145
 146 proc widget-problem-report {} {
 147     global problem_reports report_problem_report
 148     set problem_reports "\n\n\n\n\n"
 149     label .problem-report -anchor w -justify left -takefocus 0 \
 150             -border 2 -relief sunken -width 80 -textvariable problem_reports
 151     pack .problem-report -side top
 152     set report_problem_report report-problem-report-widget
 153 }
 154
 155 proc report-problem-report-widget {m} {
 156     global problem_reports
 157     set problem_reports [join [concat \
 158                 [lrange [split $problem_reports "\n"] 1 end] \
 159                 [list $m] \
 160             ] "\n"]
 161 }
 162
 163 #---------- movpos (overlay buttons, keybindings, execution) ----------
 164
 165 proc movpos-button-gvars {mid} {
 166     upvar #0 mp_details($mid) details
 167     if {![info exists details]} { return 0 }
 168     uplevel 1 [list manyset $details cpage key seg feat poslocs]
 169     uplevel 1 { set w [pagew $cpage].movpos-$mid }
 170     upvar #0 mp_state($mid) state
 171     uplevel 1 [list manyset $state posn]
 172     return 1
 173 }
 174
 175 proc movpos-button-sstate {mid posn} {
 176     upvar #0 mp_state($mid) state
 177     set state $posn
 178     movpos-button-setdisplay $mid
 179 }
 180
 181 proc movpos-all-unknown {} {
 182     global mp_details
 183     foreach mid [array names mp_details] {
 184         movpos-button-sstate $mid ?
 185     }
 186 }
 187
 188 proc widgets-movpos {} {
 189     global mp_details
 190     foreach mid [array names mp_details] {
 191         upvar #0 mp_state($mid) state
 192         set state {?}
 193         movpos-button-gvars $mid
 194         set w [pagew $cpage].movpos-$mid
 195         button $w -text $key -padx 0 -pady 0 -borderwidth 0 \
 196                 -command [list movpos-invoked $mid "plan $cpage"]
 197         movpos-button-setdisplay $mid
 198     }
 199 }
 200
 201 proc movpos-button-setdisplay {mid} {
 202     # we want to display as much of these as possible:
 203     #   position known ?   (actual position is done by button location)
 204     #   moving or stable
 205     #   whether a train's plan includes a different position
 206     #   whether autopoint
 207     movpos-button-gvars $mid
 208     switch -exact $posn {
 209         ?       { set poslocn 2;     set fg black; set bg white }
 210         default { set poslocn $posn; set fg white; set bg black }
 211     }
 212     $w configure -background $bg -foreground $fg \
 213             -activebackground $bg -activeforeground $fg
 214     manyset [lindex $poslocs $poslocn] x y
 215     place $w -anchor center -x $x -y $y
 216 }
 217
 218 proc movpos-invoked {mid ctrlr} {
 219     global movfeatcommand
 220     movpos-button-gvars $mid
 221     switch -exact $posn {
 222         0 { set new_posn 1 }
 223         default { set new_posn 0 }
 224     }
 225     scmd routinecmd $ctrlr "$movfeatcommand $seg $feat $new_posn"
 226 }
 227
 228 register-event ?movpos_*_feat {seg feat posn_new} \
 229         {^.movpos (\w+) feat (\w+) ([01]|\?) } {
 230     set mid $seg/$feat
 231     if {![movpos-button-gvars $mid]} return
 232     set posn $posn_new
 233     movpos-button-sstate $mid $posn
 234 }
 235
 236 proc movpos-bindkey-1 {cpage key seg feat adj0x adj0y adj1x adj1y} {
 237     global posdeviation picturepadx picturepady
 238     manyset [subseg-end-get-centroid $cpage $seg $feat {}] mx my
 239     set mid $seg/$feat
 240     foreach posn {0 1} {
 241         manyset [subseg-end-get-centroid $cpage $seg $feat $posn] x y
 242         set dx [expr {$x-$mx}]; set dy [expr {$y-$my}]
 243         set d [expr {sqrt($dx*$dx + $dy*$dy)}]
 244         set mul [expr {$posdeviation / ($d + 1e-6)}]
 245         set x [expr {$mx + $mul*$dx + $picturepadx + [set adj${posn}x]}]
 246         set y [expr {$my + $mul*$dy + $picturepady + [set adj${posn}y]}]
 247         lappend poslocs [list $x $y]
 248     }
 249     lappend poslocs [list [expr {$mx + $picturepadx + ($adj0x+$adj1x)*0.5}] \
 250                           [expr {$my + $picturepady + ($adj0y+$adj1y)*0.5}]]
 251     upvar #0 mp_details($mid) details
 252     set details [list $cpage $key $seg $feat $poslocs]
 253
 254     bind . <Key-[string tolower $key]> [list movpos-invoked $mid "keyboard"]
 255 }
 256
 257 #---------- computation of movpos button locations
 258
 259 proc layout-subseg-featmap {seg concfeatpos args} {
 260     global subsegfeatmap
 261     set subsegfeatmap($concfeatpos) $args
 262 }
 263
 264 proc layout-subseg-end {seg feat posn x y} {
 265     global cpage
 266     upvar #0 subsegfeatmap($feat$posn) mapped
 267     if {[info exists mapped]} {
 268         foreach {feat posn} $mapped {
 269             layout-subseg-end $seg $feat $posn $x $y
 270         }
 271         return
 272     }
 273     upvar #0 ld_sse/${cpage}($seg/$feat$posn) sse
 274     if {![info exists sse]} { set sse {{} {}} }
 275     manyset $sse lx ly
 276     lappend lx $x
 277     lappend ly $y
 278     set sse [list $lx $ly]
 279     if {[string length $posn]} { layout-subseg-end $seg $feat {} $x $y }
 280 }
 281
 282 proc subseg-end-get-centroid {cpage seg feat posn} {
 283     upvar #0 ld_sse/${cpage}($seg/$feat$posn) sse
 284     if {![info exists sse]} {
 285         puts "skipping binding of unknown $seg/$feat$posn"
 286         return -code return
 287     }
 288     manyset $sse lx ly
 289     set sx 0; set sy 0; set n [llength $lx]
 290     foreach x $lx y $ly { addexpr sx {$x}; addexpr sy {$y} }
 291     return [list [expr {$sx * 1.0 / $n}] [expr {$sy * 1.0 / $n}]]
 292 }
 293
 294 proc layout-data {} {
 295     global cpage
 296     upvar #0 ld_sse/$cpage sse
 297     catch { unset sse }
 298     source ../layout/ours.dgram.segmap-info
 299     source ../layout/ours.dgram-$cpage.overlay-info
 300
 301     upvar #0 movpos_bindings($cpage) bindings
 302     if {![info exists bindings]} {
 303         puts "no movpos bindings for $cpage"
 304         return
 305     }
 306     foreach binding $bindings {
 307         if {[regexp \
 308    {^([A-Z])([-+]\d*)?([-+]\d*)?([-+]\d*)?([-+]\d*)?\=(\w+)/([A-Z]+)$} \
 309                  $binding dummy key adj0x adj0y adj1x adj1y seg feat]} {
 310             if {![string length $adj1x]} { set adj1x $adj0x; set adj1y $adj0y }
 311             movpos-bindkey-1 $cpage $key $seg $feat \
 312                 $adj0x.0 $adj0y.0 $adj1x.0 $adj1y.0
 313         } elseif {[regexp {^[A-Z]$} $binding] || [regexp {~} $binding]} {
 314         } else {
 315             error "incomprehensible binding $binding on page $cpage"
 316         }
 317     }
 318 }
 319
 320 #---------- speed ----------
 321
 322 # variables:
 323 #   $train_commanded($train)    $speed_step
 324 #   $train_direction($train)    forwards|backwards or unset
 325 #   $speedws                    [list $w ...]
 326 #
 327 # speed/${w}(...) aka s(...):
 328 #   $s(ctrlr)                   controller
 329 #   $s(train)                   train selected, or something not \w+
 330 #   $s(optionmenu)              optionmenu widget name
 331 #   $s(kind)                    abs or rel
 332 #   $s(commanding)              step of command we have scmd'd, or unset
 333 #   $s(queued)                  step of command we would like to queue
 334 #                                or unset if n/a
 335 #   $s(inhibit)   0   all is well, can command any speed
 336 #                 1   train newly selected, only rel can command higher speed
 337 #                 2   can only command same or lower speed
 338 #
 339 # We don't worry too much about races: in particular, we don't mind
 340 # racing with other things trying to command the speed, and losing
 341 # the odd increment/decrement.  But since we thread the requested
 342 # speed via realtime, we do queue up our own increments/decrements
 343 # while we're executing a speed command, to avoid loss of steps during
 344 # quick motions.
 345
 346 # Interfaces for concrete controllers:
 347 #   speedw-new $w $ctrlr
 348 #   speedw-setstate $w disabled|normal        controller appears/disappears
 349 #   speedw-userinput-abs $w $step
 350 #   speedw-userinput-rel $w $stepmap
 351 # where
 352 #   eval {stepmap} [list $oldstep] => $newstep
 353
 354 set speedws {}
 355
 356 proc speedws-forall {command args} {
 357     global speedws
 358     foreach w $speedws { eval [list $command $w] $args }
 359 }
 360
 361 proc speedws-fortrain {train command args} {
 362     global speedws
 363     foreach w $speedws {
 364         upvar #0 speed/$w s
 365         if {[string compare $s(train) $train]} continue
 366         eval [list $command $w] $args
 367     }
 368 }
 369
 370 proc speedw-new {w ctrlr} {
 371     upvar #0 speed/$w s
 372     global speedws
 373
 374     lappend speedws $w
 375     set s(ctrlr) $ctrlr
 376     set s(inhibit) 0
 377
 378     frame $w -relief sunken -border 2
 379     label $w.ctrlr -state disabled -text $s(ctrlr)
 380     set s(optionmenu) [tk_optionMenu $w.train speed/${w}(train) {}]
 381     $w.train configure -textvariable {} -width 15
 382     label $w.speed -state disabled -width 4 \
 383             -font -*-courier-bold-r-*-*-20-*-*-*-*-*-*-* \
 384             -background black -foreground white
 385     pack $w.ctrlr $w.train $w.speed -side left
 386
 387     speedw-notrains $w "(starting)"
 388 }
 389 proc speedw-notrains {w whystr} {
 390     $w.train configure -state disabled
 391     speedw-train-noneselected $w $whystr
 392 }
 393 proc speedw-train-noneselected {w whystr} {
 394     upvar #0 speed/$w s
 395     tractbrake-detach $s(train)
 396     set s(train) {}
 397     $w.train configure -text $whystr
 398     $w.speed configure -text -
 399     speedw-inhibit $w
 400 }
 401
 402 proc speedw-inhibit {w} {
 403     upvar #0 speed/$w s
 404     set s(inhibit) 2
 405     $w.speed configure -foreground red
 406 }
 407 proc speedw-uninhibit {w max} {
 408     upvar #0 speed/$w s
 409     set r $s(inhibit)
 410     if {$r>$max} { return -1 }
 411     set s(inhibit) 0
 412     $w.speed configure -foreground white
 413     return $r
 414 }
 415
 416 proc speedw-setstate {w disnorm} {
 417     $w.ctrlr configure -state $disnorm
 418     $w.speed configure -state $disnorm
 419 }
 420
 421 proc speedw-train-selectnext {w} {
 422     upvar #0 speed/$w s
 423     set max [$s(optionmenu) index end]
 424     for {set ix 0} {$ix <= $max} {incr ix} {
 425         set v [$s(optionmenu) entrycget $ix -value]
 426         if {![string compare $v $s(train)]} break
 427     }
 428     set activate [expr {($ix+1) % ($max+1)}]
 429     $s(optionmenu) invoke $activate
 430 }
 431
 432 proc speedw-train-selected {w t} {
 433     upvar #0 speed/$w s
 434     if {![string compare $t $s(train)]} return
 435     tractbrake-detach $s(train)
 436     $w.train configure -text $t
 437     set s(inhibit) 1
 438     set s(train) $t
 439     $w.speed configure -foreground white
 440     speedw-redisplay-speed $w
 441 }
 442
 443 proc speedw-redisplay-speed {w} {
 444     upvar #0 speed/$w s
 445     upvar #0 train_commanded($s(train)) gcommanded
 446     upvar #0 train_direction($s(train)) gdirection
 447     set t $gcommanded
 448     if {[info exists gdirection]} {
 449         switch -exact $gdirection {
 450             forwards { set t "$t>" }
 451             backwards { set t "<$t" }
 452         }
 453     }
 454     $w.speed configure -text $t
 455 }
 456
 457 proc speedw-train-direction {w dirchange} {
 458     upvar #0 speed/$w s
 459     if {![string length $s(train)]} return
 460     scmd routinecmd $s(ctrlr) "direction $s(train) $dirchange"
 461 }
 462
 463 proc speedw-trains-available {w l} {
 464     upvar #0 speed/$w s
 465     if {![llength $l]} { speedw-train-noneselected $w "(no trains)"; return }
 466     $s(optionmenu) delete 0 end
 467     $s(optionmenu) add radiobutton -label "(none)" -value {} \
 468             -command [list speedw-train-noneselected $w "(no train selected)"]
 469     set l [lsort $l]
 470     foreach t $l {
 471         $s(optionmenu) add radiobutton -label $t -value $t \
 472                 -command [list speedw-train-selected $w $t]
 473     }
 474     $w.train configure -state normal
 475     if {[llength $l]==1} {
 476         $s(optionmenu) invoke 1
 477     } elseif {[set ix [lsearch -exact $l $s(train)]] >= 0} {
 478         $s(optionmenu) invoke [expr {$ix+1}]
 479     } elseif {![string length $s(train)]} {
 480         $s(optionmenu) invoke 0
 481     } else {
 482         $w.train configure -text "$s(train) (not present)"
 483     }
 484 }
 485
 486 proc speedw-userinput-abs {w speed} {
 487     upvar #0 speed/$w s
 488     if {![string length $s(train)]} return
 489     tractbrake-detach $s(train)
 490     if {!$speed} { speedw-uninhibit $w 2 }
 491     speedw-do-abs $w $speed
 492 }
 493
 494 proc speedw-userinput-tractbrake {w tract brake} {
 495     upvar #0 speed/$w s
 496     if {![string length $s(train)]} return
 497     if {$s(inhibit)} return
 498     tractbrake-userinput $s(train) $tract $brake $w
 499 }
 500
 501 proc speedw-do-abs {w speed} {
 502     upvar #0 speed/$w s
 503     if {$speed == [speedw-currentspeed $w]} return
 504     set s(queued) $speed
 505     speedw-check $w
 506 }
 507
 508 proc speedw-check {w} {
 509     upvar #0 speed/$w s
 510     if {![string length $s(train)]} return
 511     upvar #0 train_commanded($s(train)) gcommanded
 512     upvar #0 train_direction($s(train)) gdirection
 513     if {[info exists s(commanding)]} return
 514     if {![info exists s(queued)]} return
 515     set newspeed $s(queued)
 516     unset s(queued)
 517     if {$s(inhibit) && $newspeed > $gcommanded} return
 518     set s(commanding) $newspeed
 519     scmd speedw-commanded $s(ctrlr) "speed $s(train) $newspeed $gdirection" $w
 520 }
 521
 522 proc speedw-commanded-nak {m args} { error "got nak from speed: $m" }
 523 proc speedw-commanded-ok {m w} {
 524     upvar #0 speed/$w s
 525     unset s(commanding)
 526     speedw-check $w
 527 }
 528 proc speedw-commanded-err {m w} {
 529     upvar #0 speed/$w s
 530     unset s(commanding)
 531     speedw-inhibit $w
 532     speedw-check $w
 533 }
 534
 535 proc speedw-currentspeed {w} {
 536     upvar #0 speed/$w s
 537     upvar #0 train_commanded($s(train)) gcommanded
 538     if {[info exists s(queued)]} {
 539         return $s(queued)
 540     } elseif {[info exists s(commanding)]} {
 541         return $s(commanding)
 542     } else {
 543         return $gcommanded
 544     }
 545 }
 546
 547 proc speedw-userinput-rel {w stepmap} {
 548     upvar #0 speed/$w s
 549     if {![string length $s(train)]} return
 550     set oldspeed [speedw-currentspeed $w]
 551     set newspeed [eval $stepmap [list $oldspeed]]
 552     speedw-userinput-abs $w $newspeed
 553 }
 554
 555 proc speedw-userinput-rel-steps {w delta steplist} {
 556     if {$delta<0} {
 557         if {[speedw-uninhibit $w 2]>1} { incr delta 1 }
 558         if {!$delta} return
 559     } else {
 560         speedw-uninhibit $w 1
 561     }
 562     speedw-userinput-rel $w [list speedw-stepmap-fromlist $steplist $delta]
 563 }
 564
 565 proc speedw-userinput-tractbrake {w tract brake} {
 566     upvar #0 speed/$w s
 567     if {![string length $s(train)]} return
 568     debug [format "speedw-userinput-tractbrake %s %6.4f %6.4f" \
 569                $s(train) $tract $brake]
 570     speedw-uninhibit $w 1
 571     if {$s(inhibit)} { set tract 0 }
 572     tractbrake-userinput $s(train) $tract $brake $w
 573 }
 574
 575 proc speedw-uninhibit-tractbrake {w} {
 576     upvar #0 speed/$w s
 577     speedw-uninhibit $w 2
 578     if {![string length $s(train)]} return
 579     tractbrake-reset-speed $s(train)
 580 }
 581
 582 proc speedws-train-problem {train} {
 583     speedws-fortrain $train speedw-inhibit
 584 }
 585
 586 register-event ?train_*_at {train direction} \
 587         {^.train (\w+) at \S+ (forwards|backwards) } {
 588     upvar #0 train_direction($train) dirn
 589     set dirn $direction
 590     speedws-fortrain $train speedw-redisplay-speed
 591     tractbrake-ensure $train
 592 }
 593
 594 register-event ?train_*_speed_commanding {train speed} \
 595         {^.train (\w+) speed commanding (\d+) } {
 596     upvar #0 train_commanded($train) cmd
 597     set cmd $speed
 598     speedws-fortrain $train speedw-redisplay-speed
 599 }
 600
 601 proc speedws-stastate-hook {} {
 602     global train_direction stastate
 603     switch -exact -- $stastate {
 604         Run {
 605             set trains [array names train_direction]
 606             speedws-forall speedw-trains-available $trains
 607         }
 608         Resolving {
 609             movpos-all-unknown
 610         }
 611         Finalising {
 612             speedws-forall speedw-notrains "($stastate)"
 613         }
 614         default {
 615             catch { unset train_commanded }
 616             speedws-forall speedw-notrains "($stastate)"
 617         }
 618     }
 619 }
 620
 621 register-event &train_*_signalling-problem {train problem} \
 622         {^\&train (\w+) signalling-problem (.*) $} {
 623     global speedws
 624     regsub {^(\S+) (\S+) \: } $problem {\1 @\2: } problem
 625     report-problem "event: $problem"
 626     speedws-train-problem $train
 627 }
 628
 629 proc speedw-new-cooked {wunique desc} {
 630     set w .inputs.$wunique
 631     speedw-new $w $desc
 632     pack $w -side left -padx 10
 633     return $w
 634 }
 635
 636 proc speedw-stepmap-fromlist {speedlist offset oldspeed} {
 637     if {![llength $speedlist]} {
 638         unset speedlist
 639         upvar #0 default_speedstep_list speedlist
 640     }
 641     set ixabove 0
 642     foreach entry $speedlist {
 643         if {$entry==$oldspeed} { set ixbelow $ixabove; break }
 644         if {$entry>$oldspeed} break
 645         set ixbelow $ixabove
 646         incr ixabove
 647     }
 648     set ix [expr {($offset>0 ? $ixbelow : $ixabove) + $offset}]
 649     if {$ix<0} { return 0 }
 650     if {$ix>=[llength $speedlist]} { return [lindex $speedlist end] }
 651     return [lindex $speedlist $ix]
 652 }
 653
 654 #----- traction / brake (hidden behind speedw) ----------
 655
 656 proc tractbrake-queue-update {train} {
 657     upvar #0 tractbrake/$train tb
 658     set tb(queued) [after $tb(updms) \
 659                         [list tractbrake-update $train]]
 660 }
 661
 662 proc tractbrake-reset-speed {train} {
 663     upvar #0 tractbrake/$train tb
 664     if {![info exists tb]} return
 665     upvar #0 speedcurve/$train sc
 666     upvar #0 train_commanded($train) gcommanded
 667     setexpr tb(v) {[lindex $sc $gcommanded] / [lindex $sc 126]}
 668 }
 669 proc tractbrake-attach {train speedw} {
 670     # can safely be called when already attached
 671     upvar #0 tractbrake/$train tb
 672     set tb(speedw) $speedw
 673     if {[info exists tb(queued)]} return
 674     tractbrake-reset-speed $train
 675     tractbrake-queue-update $train
 676 }
 677 proc tractbrake-detach {train} {
 678     # can safely be called when already detached
 679     upvar #0 tractbrake/$train tb
 680     catch { after cancel $tb(queued) }
 681     catch { unset tb(queued) }
 682     tractbrake-reset $train
 683 }
 684 proc tractbrake-reset {train} {
 685     upvar #0 tractbrake/$train tb
 686     if {![info exists tb]} return
 687     set tb(A) 0
 688     set tb(B) 0
 689     set tb(a) 0
 690     set tb(b) 0
 691 }
 692
 693 proc tractbrake-update {train} {
 694     upvar #0 tractbrake/$train tb
 695     upvar #0 tractbrake-params/$train pa
 696     unset tb(queued)
 697     foreach AB {A B} ab {a b} lm {lambda mu} {
 698         addexpr tb($ab) { $tb(updfact_$lm) * ( $tb($AB) - $tb($ab) ) - 1e-5 }
 699     }
 700     addexpr tb(v) {
 701         + $tb(perupd_alpha) * $tb(a)
 702         - $tb(perupd_beta) * $tb(b)
 703         - $tb(perupd_omega) * $tb(v) * $tb(v)
 704         - $tb(perupd_phi)
 705     }
 706     set m "tractbrake $train"
 707     foreach v {A a B b v} { append m [format " %s=%6.4f" $v $tb($v)] }
 708     debug $m
 709     if {$tb(v) <= 0} {
 710         # stopped
 711         set tb(v) 0
 712         speedw-do-abs $tb(speedw) 0
 713         if {$tb(A) <= 0 && $tb(a) <= 0 &&
 714             $tb(B) <= 0 && $tb(b) <= 0} {
 715             # no throttle or brake, no need to requeue
 716             return
 717         }
 718     } else {
 719         if {$tb(v) > 1.0} { set tb(v) 1.0 }
 720         upvar #0 speedcurve/$train sc
 721         upvar #0 train_commanded($train) gcommanded
 722         set step $gcommanded
 723         setexpr targetvel {$tb(v) * [lindex $sc 126]}
 724         while 1 {
 725             set vel [lindex $sc $step]
 726             if {$vel > $targetvel && $step > 0} {
 727                 setexpr nextstep {$step - 1}
 728             } elseif {$vel < $targetvel && $step < 126} {
 729                 setexpr nextstep {$step + 1}
 730             } else {
 731                 break
 732             }
 733             set nextvel [lindex $sc $nextstep]
 734             if {abs($nextvel-$targetvel) >= abs($vel-$targetvel)} {
 735                 break
 736             }
 737             set step $nextstep
 738         }
 739         speedw-do-abs $tb(speedw) $step
 740     }
 741     tractbrake-queue-update $train
 742 }
 743
 744 proc tractbrake-userinput {train tract brake speedw} {
 745     upvar #0 tractbrake/$train tb
 746     if {![info exists tb]} {
 747         report-problem "event: no traction/brake parameters for $train"
 748         return
 749     }
 750     if {[string length $tract]} { set tb(A) $tract }
 751     if {[string length $brake]} { set tb(B) $brake }
 752     if {$tract || $brake} {
 753         tractbrake-attach $train $speedw
 754     }
 755 }
 756
 757 proc tractbrake-ensure {train} {
 758     upvar #0 speedcurve/$train sc
 759     global trainnum2train
 760     if {[info exists sc]} return ;# try this only once
 761     set sc 0
 762
 763     if {[regexp {[^-+._0-9a-z]} $train]} { error "bad train $train ?" }
 764
 765     if {[catch { set f [open $train.speeds.record] } emsg]} {
 766         global errorCode errorInfo
 767         switch -glob $errorCode {POSIX ENOENT *} {
 768             report-problem "train $train: no traction/braking (no speed table)"
 769             return
 770         }
 771         error $emsg $errorInfo $errorCode
 772     }
 773     while {[llength $sc] <= 126} { lappend sc x }
 774     while {[gets $f l] >= 0} {
 775         if {[regexp {^train (\S+) step (\d+)=([0-9.]+)$} $l \
 776                  dummy tr step velocity]} {
 777             if {[string compare $tr $train] || $step<=0 || $step>126} {
 778                 error "bad velocity line $train $l ?"
 779             }
 780             set sc [lreplace $sc $step $step $velocity]
 781         } elseif {[regexp {^train (\S+) is (\d+) } $l \
 782                        dummy tr trainnum]} {
 783             if {[string compare $tr $train]} {
 784                 error "bad train line $train $l ?"
 785             }
 786             set trainnum2train($trainnum) $tr
 787         } else {
 788             # fine, whatever
 789         }
 790     }
 791     close $f
 792     if {[lsearch -exact $sc x]>=0} {
 793         report-problem "train $train: no traction/braking\
 794             (incomplete speed table"
 795         return
 796     }
 797
 798     upvar #0 tractbrake/$train tb
 799     defset tb(deadzone) 0.2
 800     defset tb(updms)    20
 801     defset tb(lambda)   0.600  ;# time constant for adj throttle
 802     defset tb(mu)       0.300  ;# time constant for apply/release breaks
 803     defset tb(inv_alpha)   20  ;# time constant for accelerate to max
 804     defset tb(omegaphi)    50  ;# (air resistance) / (rolling res) at max spd
 805     defset tb(inv_beta)    10  ;# time constant for service brake (over-est'd)
 806     defset tb(overpower) 1.03  ;# factor by which we are overpowered for max spd
 807     foreach lm {lambda mu} {
 808         setexpr tb(updfact_$lm) { $tb(updms) * 0.001 / $tb($lm) }
 809     }
 810
 811     setexpr tb(alpha) { 1.0 / $tb(inv_alpha) }
 812     setexpr tb(beta) { 1.0 / $tb(inv_beta) }
 813     setexpr tb(phi) { $tb(alpha) / ($tb(omegaphi) + 1.0) / $tb(overpower) }
 814     setexpr tb(omega) { $tb(omegaphi) * $tb(phi) }
 815
 816     foreach p {alpha beta omega phi} {
 817         setexpr tb(perupd_$p) { $tb($p) * 0.001 * $tb(updms) }
 818     }
 819
 820     tractbrake-reset $train
 821 }
 822
 823 #---------- concrete input bindings ----------
 824
 825 proc ib-suppressions {args} {
 826     set l {}
 827     foreach supp $args {
 828         set l [concat $l --redaction $supp --suppress]
 829     }
 830     return $l
 831 }
 832
 833 proc ib-speedw-new {devid wunique desc} {
 834     upvar #0 input/$devid in
 835     set in(speedw) [speedw-new-cooked $wunique $desc]
 836 }
 837
 838 #----- wheelmouse
 839
 840 proc ib-ev/wheelmouse/EV_REL/REL_WHEEL {devid value} {
 841     upvar #0 input/$devid in
 842     speedw-userinput-rel-steps $in(speedw) [expr {-$value}] {}
 843 }
 844
 845 proc ib-selectnext {devid value} {
 846     if {$value!=1} return
 847     upvar #0 input/$devid in
 848     speedw-train-selectnext $in(speedw)
 849 }
 850 proc ib-changedirection {devid value} {
 851     upvar #0 input/$devid in
 852     if {!$value} return
 853     speedw-train-direction $in(speedw) change
 854 }
 855
 856 proc ib-ev/wheelmouse/EV_KEY/BTN_LEFT {devid value} {
 857     ib-selectnext $devid $value
 858 }
 859 proc ib-ev/wheelmouse/EV_KEY/BTN_RIGHT {devid value} {
 860     ib-changedirection $devid $value
 861 }
 862
 863 proc ib-create/wheelmouse {devid wunique desc} {
 864     ib-speedw-new $devid $wunique $desc
 865 }
 866
 867 proc ib-wheelmouse-redactions {} {
 868     return [ib-suppressions  \
 869             {EV REL REL X} \
 870             {EV REL REL Y}]
 871 }
 872
 873 proc ib-evcmd/wheelmouse {devid target} {
 874     return [ib-evcmd-construct $devid $target [concat \
 875             [list --grab] [ib-wheelmouse-redactions]]]
 876 }
 877
 878 #----- gamepad
 879
 880 proc ib-create/gamepad {devid wunique desc} {
 881     ib-speedw-new $devid $wunique $desc
 882     upvar #0 input/$devid in
 883     set in(main_deadzone_y) 0.2
 884     set in(main_deadzone_x) 0.5
 885     set in(main_x) 0
 886     set in(main_y) 0
 887     set in(main_active) {}
 888 }
 889
 890 proc ib-ev/gamepad/EV_ABS/ABS_THROTTLE {d v} { ib-gamepad-main $d y $v }
 891 proc ib-ev/gamepad/EV_ABS/ABS_RUDDER {d v} { ib-gamepad-main $d x $v }
 892
 893 proc ib-gamepad-main {devid xy value} {
 894     upvar #0 input/$devid in
 895     if { abs($value) < $in(main_deadzone_$xy) } { set value 0 }
 896     set last $in(main_$xy)
 897     set in(main_$xy) $value
 898
 899     set active {}
 900     foreach txy {x y} {
 901         if { $in(main_$txy) } {
 902             if {[string length $active]} return
 903             set active $txy
 904         }
 905     }
 906     debug [format "ib-gamepad-main %s %s %6.4f,%6.4f %s %s" \
 907                $devid $xy $in(main_x) $in(main_y) $in(main_active) $active]
 908     if {![string length $active]} {
 909         if {[string length $in(main_active)]} {
 910             speedw-userinput-tractbrake $in(speedw) 0 0
 911         }
 912     } else {
 913         if {[string length $in(main_active)] &&
 914             [string compare $active $in(main_active)]} {
 915             return
 916         }
 917         set value $in(main_$active)
 918         switch -exact $active {
 919             y {
 920                 if {$value < 0} {
 921                     speedw-userinput-tractbrake $in(speedw) [expr {-$value}] 0
 922                 } {
 923                     speedw-userinput-tractbrake $in(speedw) 0 $value
 924                 }
 925             }
 926             x {
 927                 if { abs($value) < 0.75 } return
 928                 if {[string length $in(main_active)]} return
 929                 speedw-train-direction $in(speedw) \
 930                     [expr { $value < 0 ? "backwards" : "forwards" }]
 931             }
 932             default {
 933                 error "$active ?"
 934             }
 935         }
 936     }
 937     set in(main_active) $active
 938 }
 939
 940 proc ib-ev/gamepad/EV_KEY/BTN_1 {d v} { ib-gamepad-btn 1 $d $v }
 941 proc ib-ev/gamepad/EV_KEY/BTN_2 {d v} { ib-gamepad-btn 2 $d $v }
 942 proc ib-ev/gamepad/EV_KEY/BTN_3 {d v} { ib-gamepad-btn 3 $d $v }
 943 proc ib-ev/gamepad/EV_KEY/BTN_4 {d v} { ib-gamepad-btn 4 $d $v }
 944 proc ib-ev/gamepad/EV_KEY/BTN_5 {d v} { ib-gamepad-btn 5 $d $v }
 945 proc ib-ev/gamepad/EV_KEY/BTN_6 {d v} { ib-gamepad-btn 6 $d $v }
 946
 947 proc ib-gamepad-btn {num devid value} {
 948     upvar #0 input/$devid in
 949     if {!$value} return
 950     if {[string length $in(main_active)]} return
 951     upvar #0 trainnum2train($num) tr
 952     if {![info exists tr]} {
 953         speedw-train-noneselected $in(speedw) "no train $num"
 954     } else {
 955         speedw-train-selected $in(speedw) $tr
 956     }
 957 }
 958
 959 proc ib-ev/gamepad/EV_KEY/BTN_TOP2 {devid value} {
 960     upvar #0 input/$devid in
 961     if {!$value} return
 962     if {[string length $in(main_active)]} return
 963     speedw-uninhibit-tractbrake $in(speedw)
 964 }
 965
 966 #----- ebuyer wireless keyboard
 967
 968 proc ib-create/ebwikeb {devid wunique} {
 969     upvar #0 input/$devid in
 970     set in(desc) "main keyboard"
 971     ib-create/wheelmouse $devid $wunique $in(desc)
 972     set in(modifiers) 0
 973 }
 974
 975 proc ib-evcmd/ebwikeb {devid target} {
 976     return [concat \
 977             [list ./evdev-manip-ebwikeb --redact --stdin-monitor] \
 978             [ib-wheelmouse-redactions] \
 979             [ib-suppressions \
 980                 {0x01 02} \
 981                 {EV MSC} \
 982                 {0x0c 01} \
 983                 {0xffbc 88 0xffbc 00}]]
 984 }
 985
 986 proc ib-ev/ebwikeb/EV_REL/REL_WHEEL {devid value} {
 987     ib-ev/wheelmouse/EV_REL/REL_WHEEL $devid $value
 988 }
 989
 990 proc ib-ebwikeb-modifier {devid value bitval} {
 991     upvar #0 input/${devid}(modifiers) mod
 992     if {$value} {
 993         set mod [expr {$mod | $bitval}]
 994     } else {
 995         set mod [expr {$mod & ~$bitval}]
 996     }
 997 }
 998 proc ib-ev/ebwikeb/EV_KEY/KEY_LEFTSHIFT {devid value} {
 999     ib-ebwikeb-modifier $devid $value 0x0001
1000 }
1001 proc ib-ev/ebwikeb/EV_KEY/KEY_RIGHTSHIFT {devid value} {
1002     ib-ebwikeb-modifier $devid $value 0x0002
1003 }
1004 proc ib-ev/ebwikeb/EV_KEY/KEY_LEFTCTRL {devid value} {
1005     ib-ebwikeb-modifier $devid $value 0x0100
1006 }
1007 proc ib-ev/ebwikeb/EV_KEY/KEY_RIGHTCTRL {devid value} {
1008     ib-ebwikeb-modifier $devid $value 0x0200
1009 }
1010 proc ib-ev/ebwikeb/EV_KEY/KEY_CAPSLOCK {devid value} {
1011     ib-ebwikeb-modifier $devid $value 0x0400
1012 }
1013
1014 proc ib-ev/ebwikeb/0xffbc_88/0xffbc_0d {devid value} {
1015     upvar #0 input/$devid in
1016     if {!$value} return
1017     if {$in(modifiers) & 0x00ff} {
1018         ib-selectnext $devid $value
1019     } else {
1020         ib-changedirection $devid $value
1021     }
1022 }
1023
1024 proc ib-ev/ebwikeb/EV_KEY/KEY_BOOKMARKS {devid value} {
1025     upvar #0 input/$devid in
1026     if {!$value} return
1027     if {!($in(modifiers) & 0xff00)} return
1028     if {$in(modifiers) & 0x00ff} {
1029         set how stop
1030     } else {
1031         set how auto
1032     }
1033     scmd routinecmd $in(desc) "!realtime $how"
1034 }
1035
1036 #----- static keybindings speed `controller'
1037
1038 proc bind-keyboard-speed {kslow kfast kseltrain kreverse desc} {
1039     set wunique [get-unique keyboardspeed]
1040     set w [speedw-new-cooked $wunique $desc]
1041     foreach delta {-1 +1} sf {slow fast} {
1042         bind . <Key-[set k$sf]> [list speedw-userinput-rel-steps $w $delta {}]
1043     }
1044     bind . <Key-$kseltrain> [list speedw-train-selectnext $w]
1045     bind . <Key-$kreverse> [list speedw-train-direction $w change]
1046     speedw-setstate $w normal
1047 }
1048
1049 #----- Joytech "Neo S" USB PC gamepad
1050
1051 proc hidraw-descriptors/gamepad-neo-s {} {
1052     return xx
1053 }
1054
1055 #proc hidraw-readable/gamepad-neo-s {chan hidraw devid} {
1056 #    upvar #0 hidraw/$hidraw raw
1057 #    # In my tests with tcl8.3 and tcl8.5, "read chan numbytes"
1058 #    # on a nonblocking binary channel does only one read(2)
1059 #    # provided that read(2) returns less than requested
1060 #    while 1 {
1061 #       set msg [hbytes raw2h [read $chan 256]]
1062 #       if {![hbytes
1063 #       switch -glob [bhtes $msg {
1064 #           4a* { set want 8 }
1065 #           {} { set want 64 }
1066 #           * { error "unknown report number $raw(buf)" }
1067 #       }
1068 #       if {$want > $sofar} {
1069 #           set got [read $chan [expr {$want - $sofar}]]
1070 #
1071 #       }
1072 #
1073 #       set sofar [hbytes length $raw(buf)]
1074 #       if {!$sofar} {
1075 #           set got [read $chan 64]
1076 #       } else {
1077 #
1078 #       }
1079
1080
1081 #---------- input device evdev binding ----------
1082
1083 proc ib-evcmd-construct {devid target xargs} {
1084     upvar #0 input/$devid in
1085     if {[llength $target] > 1} {
1086         debug "ib $devid - multiple devices, not supported"
1087         return {}
1088     }
1089     manyset [lindex $target 0] ev sysfs
1090     if {[regexp { } $ev]} { error "event device `$ev' contains space" }
1091     return [concat \
1092             [list ./evdev-manip --redact] $xargs \
1093             [list --stdin-monitor \
1094                   --expect-sysfs /sys$sysfs/$ev/dev \
1095                   /dev/input/$ev]]
1096 }
1097
1098 proc bind-input-core {devid devkind devinfo concrete concargs} {
1099     global input_bindings
1100     lappend input_bindings [list $devkind $devid $devinfo $concrete $concargs]
1101 }
1102
1103 proc bind-input {bus vendor product version concrete args} {
1104     bind-input-core evdev:$bus:$vendor:$product:$version \
1105         evdev [list $bus $vendor $product $version] \
1106         $concrete $args
1107 }
1108
1109 proc bind-input-static {event sysfs concrete args} {
1110     bind-input-core [get-unique static] \
1111         static [list $event $sysfs] \
1112         $concrete $args
1113 }
1114
1115 proc bind-input-raw {devtype concrete args} {
1116     set descriptors [exec ./hidrawconv-$devtype -d]
1117     bind-input-core hidraw:[get-unique $devtype] \
1118         hidraw [list $devtype $descriptors] \
1119         $concrete $args
1120 }
1121
1122 proc widgets-input-bindings {} {
1123     global input_bindings
1124     foreach binding $input_bindings {
1125         manyset $binding devkind devid devinfo concrete concargs
1126         set cid [get-unique $concrete]
1127         upvar #0 input/$devid in
1128         set in(laststart) 0
1129         set in(concrete) $concrete
1130         eval [list ib-create/$concrete $devid $cid] $concargs
1131     }
1132     pack .inputs -side top -fill x
1133 }
1134
1135 # input/$devid becomes `in' via upvar:
1136 #  $in(chan)        channel open onto evdev-manip;
1137 #                   unset if none, or hidraw, or something
1138 #  $in(laststart)   last start time, [clock seconds]
1139 #                      at every event we set this the current time
1140 #                      but we insist on adding at least 5s
1141 #                      and if that would make it > current time +15s
1142 #                      we don't start
1143 #  $in(speedw)      optional, may be set by ib-create
1144
1145 # hidraw/hidrawN becomes `hr' via upvar:
1146 #  $raw(devid)      $devid (see above)
1147 #  $raw(chan)       channel open onto /dev/hidrawN
1148
1149 proc input-concrete-start-try {devid concrete} {
1150     global inputretryadd inputretrymax
1151     upvar #0 input/$devid in
1152     set now [clock seconds]
1153     set newlast [expr {$in(laststart) + $inputretryadd}]
1154     if {$newlast > $now + $inputretrymax} { return 0 }
1155     if {$newlast < $now} { set newlast $now }
1156     set in(laststart) $newlast
1157 }
1158
1159 proc input-bindings-list {devkind} {
1160     global input_bindings
1161     set o {}
1162     foreach b $input_bindings {
1163         manyset $b dk
1164         if {[string compare $dk $devkind]} continue
1165         lappend o $b
1166     }
1167     return $o
1168 }
1169
1170 proc scan-input-bindings {} {
1171     global errorInfo errorCode unmatched_notified old_hidraws
1172     global input_bindings scaninputinterval
1173     global input_rawbindings
1174
1175     after $scaninputinterval scan-input-bindings
1176
1177     # scan /proc/bus/input/devices for appropriate evdevs
1178     # results go in $target($devid)
1179     if {[catch {
1180         set f [open /proc/bus/input/devices]
1181     } emsg]} {
1182         if {[string match {POSIX ENOENT *} $errorCode]} return
1183         error $emsg $errorInfo $errorCode
1184     }
1185     while 1 {
1186         set r [gets $f l]
1187         if {$r <= 0} {
1188             if {[info exists v(devid)] &&
1189                 [info exists v(sysfs)] &&
1190                 [info exists v(event)]} {
1191                 lappend target(evdev:$v(devid)) [list $v(event) $v(sysfs)]
1192             }
1193             catch { unset v }
1194         }
1195         if {$r < 0} {
1196             break
1197         }
1198         append l "\n"
1199         if {[regexp \
1200  {^I: Bus=(\w+) Vendor=(\w+) Product=(\w+) Version=(\w+)\s} \
1201                  $l dummy bus vendor product version]} {
1202             set v(devid) $bus:$vendor:$product:$version
1203         } elseif {[regexp {^S: Sysfs=(\S+)\s} $l dummy sysfs]} {
1204             set v(sysfs) $sysfs
1205         } elseif {[regexp {^H: Handlers=(?:.*\s)?(event\d+)\s} $l dummy ev]} {
1206             set v(event) $ev
1207         } else {
1208             # ignored
1209         }
1210     }
1211     close $f
1212
1213     # add as-if-scanned entries for static bindings to target
1214     # also check to see if we want hidraw
1215     foreach binding $input_bindings {
1216         manyset $binding devkind devid devinfo concrete concargs
1217         switch -exact $devkind static { } default continue
1218         lappend target($devid) [list $event $sysfs]
1219     }
1220
1221     # scan /dev/hidraw*
1222     foreach binding [input-bindings-list hidraw] {
1223         manyset $binding devkind devid devinfo concrete concargs
1224         switch -exact $devkind hidraw { } default continue
1225         manyset $devinfo devtype descriptors
1226         set rawmap($descriptors) [list $devid $devtype $concrete]
1227     }
1228     if {[array exists rawmap]} {
1229         set new_hidraws [lsort [glob -nocomplain -directory /dev hidraw*]]
1230         foreach hidraw $new_hidraws {
1231             upvar #0 hidraw/$hidraw raw
1232             if {[info exists raw(chan)]} {
1233                 set found($raw(devid)) 1
1234                 continue
1235             }
1236             if {[lsearch -exact $old_hidraws $hidraw] >= 0} continue
1237             if {[catch {
1238                 set chan [open $hidraw r+]
1239                 set descriptors [exec ./hidraw-ioctl -d <@ $chan]
1240                 if {![info exists rawmap($descriptors)]} {
1241                     set m [exec ./hidraw-ioctl -i <@ $chan]
1242                     error "unknown descriptors (unmatched device) $hidraw $m >$descriptors<"
1243                 }
1244             } emsg]} {
1245                 upvar #0 hidraw_notified($hidraw) notified
1246                 if {![info exists notified] ||
1247                      [string compare $notified $emsg]} {
1248                     debug "ir $hidraw $emsg"
1249                     set notified $emsg
1250                 }
1251                 catch { close $chan }
1252                 catch { unset chan }
1253                 continue
1254             }
1255             manyset $rawmap($descriptors) devid devtype concrete
1256             set found($devid) 1
1257             if {![input-concrete-start-try $devid $concrete]} {
1258                 catch { close $chan }
1259                 continue
1260             }
1261             set raw(devid) $devid
1262             set cmdl [list ./hidrawconv-$devtype -e <@ $chan 2>@ stderr]
1263             set evch [open |$cmdl r]
1264             set raw(chan) $evch
1265             fconfigure $evch -blocking 0 -buffering line
1266             fileevent $evch readable \
1267                 [list catch-for-input-binding hidraw $hidraw \
1268                      [list readable input-binding-raw $evch $hidraw $devid]]
1269             input-binding-present $devid 1 "hidraw $hidraw"
1270         }
1271         set old_hidraws $new_hidraws
1272     }
1273
1274     # try to start the input binding for all the unstarted found targets
1275     foreach devid [array names target] {
1276         upvar #0 input/$devid in
1277         if {![info exists in(concrete)]} {
1278             if {![info exists unmatched_notified($devid)]} {
1279                 debug "ib $devid unmatched, ignored"
1280                 set unmatched_notified($devid) 1
1281             }
1282             continue
1283         }
1284         set found($devid) 1
1285         if {[info exists in(chan)]} continue
1286         if {![input-concrete-start-try $devid $concrete]} continue
1287
1288         set cmdl [ib-evcmd/$in(concrete) $devid $target($devid)]
1289         if {![llength $cmdl]} {
1290             unset target($devid)
1291             continue
1292         }
1293         lappend cmdl 2>@ stderr
1294         catch-for-input-binding evdev $devid {
1295             debug "ib $devid running $cmdl"
1296             set in(chan) [open |$cmdl r+]
1297             fconfigure $in(chan) -blocking 0 -buffering line
1298             fileevent $in(chan) readable \
1299                 [list catch-for-input-binding evdev $devid \
1300                     [list readable input-binding $in(chan) $devid]]
1301         }
1302     }
1303
1304     # anything not found, not present
1305     foreach binding $input_bindings {
1306         manyset $binding devkind devid devinfo concrete concargs
1307         switch -exact $devkind evdev - raw { } default continue
1308         upvar #0 input/$devid in
1309         if {![info exists in(concrete)]} continue
1310         if {[info exists found($devid)]} continue
1311         input-binding-present $devid 0 absent
1312     }
1313 }
1314
1315 proc input-binding-present {devid yes why} {
1316     upvar #0 input/$devid in
1317     if {[info exists in(speedw)]} {
1318         speedw-setstate $in(speedw) [lindex {disabled normal} $yes]
1319     }
1320     set call "ib-[lindex {absent present} $yes]/$in(concrete)"
1321     if {![catch { info args $call }]} {
1322         $call $devid $why
1323     }
1324 }
1325
1326 proc input-binding-eof {chan devid} {
1327     upvar #0 input/$devid in
1328     input-binding-eof-core $in(chan) "evdev-manip exited"
1329 }
1330
1331 proc input-binding-eof-core {chan msg} {
1332     fconfigure $chan -blocking 1
1333     close $chan
1334     error $msg {} {CHILDSTATUS ? 0}
1335 }
1336
1337 proc input-binding-raw-eof {chan hidraw devid} {
1338     upvar #0 hidraw/$hidraw raw
1339     input-binding-eof-core $raw(chan) "hidrawconv-* exited"
1340 }
1341
1342 proc input-binding-inputline {chan l devid} {
1343     upvar #0 input/$devid in
1344     if {[input-binding-inputline-core-ib $devid $l]} return
1345     regsub {^[^ ]+ } $l {} lr
1346     switch -glob -- $lr {
1347         {opened *} {
1348             debug "ib $devid start << $l"
1349             input-binding-present $devid 1 "evdev open"
1350         }
1351         {[-0-9]*} {
1352             manyset [split $lr] value kindl kindr codel coder
1353             input-binding-inputline-core-ev $devid \
1354                 ${kindl}_${kindr}/${codel}_${coder} $value $l
1355         }
1356         * {
1357             debug "ib $devid ignored << $l"
1358         }
1359     }
1360 }
1361
1362 proc input-binding-inputline-core-ib {devid l} {
1363     # give the input binding first dibs
1364     upvar #0 input/$devid in
1365     if {[catch { info args ib-inputline/$in(concrete) }]} { return 0 }
1366     return [ib-inputline/$in(concrete) $devid $l]
1367 }
1368
1369 proc input-binding-inputline-core-ev {devid kindcode value l} {
1370     global showunbound
1371     upvar #0 input/$devid in
1372     set proc ib-ev/$in(concrete)/$kindcode
1373     if {[catch { info args $proc }]} {
1374         if {$showunbound} {
1375             debug "ib $devid unbound $proc << $l"
1376         }
1377         return
1378     }
1379     $proc $devid $value
1380 }
1381
1382 proc input-binding-raw-inputline {chan l hidraw devid} {
1383     upvar #0 hidraw/$hidraw raw
1384     if {[input-binding-inputline-core-ib $devid $l]} return
1385     manyset [split $l] kind code value
1386     input-binding-inputline-core-ev $devid $kind/$code $value $l
1387 }
1388
1389 proc catch-for-input-binding {devkind ident body} {
1390     global errorInfo errorCode
1391     set r [catch { uplevel 1 $body } rv]
1392     if {$r!=1} { return -code $r $rv }
1393     switch -glob $errorCode {
1394         {CHILDSTATUS *} { set m "exited with status [lindex $errorCode 2]" }
1395         {CHILDKILLED *} { set m "killed by signal [lindex $errorCode 3]" }
1396         {POSIX *} { set m "communication error: [lindex $errorCode 1]" }
1397         * { error $rv $errorInfo $errorCode }
1398     }
1399     debug "ib $devkind $ident died $m"
1400     input-binding-destroy/$devkind $ident $m
1401 }
1402
1403 proc input-binding-destroy/evdev {devid m} {
1404     upvar #0 input/$devid in
1405     catch { close $in(chan) }
1406     catch { unset in(chan) }
1407     input-binding-present $devid 0 "died $m"
1408 }
1409
1410 proc input-binding-destroy/hidraw {hidraw m} {
1411     upvar #0 hidraw/$hidraw raw
1412     catch { close $raw(chan) }
1413     catch { unset raw(chan) }
1414     input-binding-present $raw(devid) 0 "died $m"
1415 }
1416
1417 proc engage-input-bindings {} {
1418     scan-input-bindings
1419 }
1420
1421 #---------- plan background (gui-plan subprocess) ----------
1422
1423 proc gui-pipe-readable {args} {
1424     global gui_pipe
1425     while {[gets $gui_pipe l] >= 0} {
1426         debug "<gui-plan $l"
1427     }
1428     if {[eof $gui_pipe]} {
1429         close $gui_pipe
1430         error "gui-plan crashed"
1431     }
1432 }
1433
1434 #---------- train set events of general interest, and setup ----------
1435
1436 proc train-event-eof {args} {
1437     error "lost connection to train set"
1438 }
1439
1440 register-event ?stastate {ctxch state} {^(.)stastate (\w+|\-) } {
1441     global ctrain trains stastate
1442     set stastate $state
1443     report-problem "stastate: $state"
1444     if {[string compare $ctxch |]} speedws-stastate-hook
1445 }
1446
1447 register-event ?resolution {message} \
1448         {^.resolution (\S+ .*)$} {
1449     if {[string match "problems *" $message]} return
1450     report-problem "resolution: $message"
1451 }
1452
1453 register-event ?warning {message} {^.warning (\S+ .*)$} {
1454     report-problem "warning: $message"
1455 }
1456
1457 register-event {} {} {^=connected } {
1458     global pages gui_pipe server port event_selections showguiplan
1459
1460     scmd replayed {} "select-replay [concat $event_selections]"
1461
1462     if {!$showguiplan} return
1463
1464     foreach page $pages {
1465         set w [pagew $page]
1466         tkwait visibility $w.picture
1467
1468         set cmdl [list ./gui-plan-$page [winfo id $w.picture] @$server,$port]
1469         lappend cmdl 2>@ stderr
1470         set gui_pipe [open |$cmdl r]
1471
1472         puts stderr "running $cmdl"
1473         fconfigure $gui_pipe -blocking no
1474         fileevent $gui_pipe readable gui-pipe-readable
1475     }
1476 }
1477 proc replayed-err {m args} { error "replay failed: $m" }
1478 proc replayed-ok {m args} {
1479     speedws-stastate-hook
1480 }
1481
1482 register-event {} {} {^=failed } { error "multiplexer failed: $l" }
1483 register-event {} {} {^=denied } { error "multiplexer denied us: $l" }
1484 register-event {} {} {^\+nack } { error "multiplexer does not understand" }
1485
1486 #---------- main program ----------
1487
1488 append event_dispatch_body {
1489     debug "ignored $l"
1490 }
1491 proc train-event-inputline {sconn l} $event_dispatch_body
1492 proc register-event {args} { error "too late!" }
1493
1494 proc engage-server {} {
1495     global server port sconn
1496
1497     set sconn [socket $server $port]
1498     fconfig-trainproto $sconn
1499     fileevent $sconn readable {readable train-event $sconn}
1500 }
1501
1502 proc main {} {
1503     global pages cpage configfile input_bindings old_hidraws
1504     setting server railway {[[0-9a-z:].*}
1505     setting geometry {} {[-+]\d+[-+]\d+}
1506     setting posdeviation 5 {\d+}
1507     setting movfeatcommand {movfeat+} {(?:!movfeat|movfeat\+?\+?)}
1508     setting problemdisplayms 1000 {\d+}
1509     setting inputretryadd 5 {\d+}
1510     setting inputretrymax 15 {\d+}
1511     setting scaninputinterval 500 {\d+}
1512     setting showunbound 0 {[01]}
1513     setting showguiplan 1 {[01]}
1514
1515     set hostname [lindex [split [info hostname] .] 0]
1516     setting configfile gui-$hostname.config {.+}
1517     parse-argv {}
1518
1519     frame .inputs
1520     if {![info exists input_bindings]} { set input_bindings {} }
1521     set old_hidraws {}
1522
1523     uplevel #0 source gui-layout.config
1524     uplevel #0 source $configfile
1525     foreach cpage $pages {
1526         layout-data
1527         widgets-dgram
1528     }
1529     unset cpage
1530     widgets-movpos
1531     widgets-input-bindings
1532     widget-problem-report
1533     engage-server
1534     engage-input-bindings
1535     start_commandloop
1536 }
1537
1538 main