hostside/gui

   1 #!/usr/bin/wishx
   2
   3 #---------- general utilities ----------
   4
   5 set tk_strictMotif 1
   6
   7 tk_setPalette background black foreground white
   8
   9 source lib.tcl
  10
  11 set default_speedstep_list {0 1 10 20 35 50 65 80 95 110 126}
  12
  13 proc pagew {page} { return ".picture-$page" }
  14 proc debug {m} { puts $m }
  15
  16 proc sconn {m} {
  17     global sconn
  18     debug "=> $m"
  19     puts $sconn $m
  20 }
  21
  22 proc widgets-dgram {} {
  23     global cpage geometry
  24     if {[string length $geometry]} { wm geometry . $geometry }
  25     set sizes [exec ./gui-plan-$cpage --sizes]
  26     set w [pagew $cpage]
  27     frame $w -background {} \
  28             -width [lindex $sizes 0] \
  29             -height [lindex $sizes 1]
  30     pack $w
  31 }
  32
  33 proc widgets-fullscreen-nowm {} {
  34     pack propagate . false
  35     foreach wh {width height} {
  36         . configure -$wh [winfo screen$wh .]
  37     }
  38 }
  39
  40 proc bgerror {emsg} {
  41     global errorCode errorInfo
  42     catch {
  43         puts stderr "UNEXPECTED BACKGROUND ERROR\n"
  44         puts stderr "$errorCode\n$errorInfo\n$emsg"
  45     }
  46     exit 16
  47 }
  48
  49 #---------- train set event registraton ----------
  50
  51 set event_dispatch_body {
  52     append l " "
  53 }
  54 set event_selections {}
  55
  56 proc register-event {selections args re body} {
  57     global event_dispatch_body event_selections
  58
  59     eval lappend event_selections $selections
  60
  61     foreach selection $selections {
  62         if {[regexp {^\w} $selection]} {
  63             error "selection $selection lacks context char"
  64         }
  65     }
  66     if {[regexp {^\^\w} $re]} {
  67         error "re $re never matches context char"
  68     }
  69
  70     regsub -all {\W+} $re - proc
  71     set proc "event/$proc/[join $args -]"
  72     set suffix {}
  73     set number 0
  74     while {![catch { info args $proc$suffix }]} { set suffix [incr number] }
  75     append proc $suffix
  76
  77     proc $proc [concat l $args] $body
  78     set al ""
  79     foreach a $args { append al " \$$a" }
  80
  81     append event_dispatch_body \
  82             "    if {\[regexp [list $re] \$l dummy $args]} {\n" \
  83             "        debug \"$proc$al\"\n" \
  84             "        eval [list $proc] \[list \$l$al]\n" \
  85             "        return\n" \
  86             "    }\n"
  87 }
  88
  89 #---------- handling of commands we issue ----------
  90
  91 proc scmd {onresult ctrlr commandstr args} {
  92     # later, calls
  93     #   eval [list $onresult-ok|nak|error $ackornakmessage] $args
  94     global commands_queued
  95     sconn $commandstr
  96     lappend commands_queued [list $ctrlr $onresult $args]
  97 }
  98
  99 proc scmd_result {oknakerr message reporterrmsg} {
 100     global commands_queued
 101     manyset [lindex $commands_queued 0] ctrlr onresult args
 102     set commands_queued [lrange $commands_queued 1 end]
 103     if {[string length $reporterrmsg]} {
 104         report-problem "$ctrlr: $reporterrmsg"
 105     }
 106     set proc "$onresult-$oknakerr"
 107     if {![string compare $oknakerr nak] && [catch { info args $proc }]} {
 108         set proc "$onresult-err"
 109     }
 110     eval [list $proc $message] $args
 111 }
 112
 113 register-event {} {} {^\+ack \S+ ok } { scmd_result ok $l "" }
 114 register-event {} {train segment error} \
 115         {^\+ack \S+ SignallingPredictedProblem (\S+) (\S+) \: (.*) $} {
 116     set m $train
 117     if {[string compare - $segment]} { append m " @$segment" }
 118     append m ": $error"
 119     scmd_result err $l $m
 120 }
 121 register-event {} {} {^\+ack } { scmd_result err $l $l }
 122 register-event {} {} {^\+nack \S+ } { scmd_result nak $l $l }
 123
 124 proc routinecmd-nak {m args} { error "got nak to routine command: $m" }
 125 proc routinecmd-err {m args} { }
 126 proc routinecmd-ok {m args} { }
 127
 128 proc mustsucceed-err {m args} { error "unexpected error: $m" }
 129 proc mustsucceed-ok {m args} { }
 130
 131 proc report-problem-report-stderr {m} { puts stderr "*** $m" }
 132 set report_problem_report report-problem-report-stderr
 133
 134 proc report-problem {message} {
 135     global report_problem_report
 136     eval $report_problem_report [list $message]
 137 }
 138
 139 proc widget-problem-report {} {
 140     global problem_reports report_problem_report
 141     set problem_reports "\n\n\n\n\n\n"
 142     label .problem-report -anchor w -justify left -takefocus 0 \
 143             -border 2 -relief sunken -width 80 -textvariable problem_reports
 144     pack .problem-report -side top
 145     set report_problem_report report-problem-report-widget
 146 }
 147
 148 proc report-problem-report-widget {m} {
 149     global problem_reports
 150     set problem_reports [join [concat \
 151                 [lrange [split $problem_reports "\n"] 1 end] \
 152                 [list $m] \
 153             ] "\n"]
 154 }
 155
 156 #---------- movpos (overlay buttons, keybindings, execution) ----------
 157
 158 proc movpos-button-gvars {mid} {
 159     upvar #0 mp_details($mid) details
 160     if {![info exists details]} { return 0 }
 161     uplevel 1 [list manyset $details cpage key seg feat poslocs]
 162     uplevel 1 { set w [pagew $cpage].movpos-$mid }
 163     upvar #0 mp_state($mid) state
 164     uplevel 1 [list manyset $state posn]
 165     return 1
 166 }
 167
 168 proc movpos-button-sstate {mid} {
 169     upvar #0 mp_state($mid) state
 170     set state [uplevel 1 { list $posn } ]
 171 }
 172
 173 proc widgets-movpos {} {
 174     global mp_details
 175     foreach mid [array names mp_details] {
 176         upvar #0 mp_state($mid) state
 177         set state {?}
 178         movpos-button-gvars $mid
 179         set w [pagew $cpage].movpos-$mid
 180         button $w -text $key -padx 0 -pady 0 -borderwidth 0 \
 181                 -command [list movpos-invoked $mid "plan $cpage"]
 182         movpos-button-setdisplay $mid
 183     }
 184 }
 185
 186 proc movpos-button-setdisplay {mid} {
 187     # we want to display as much of these as possible:
 188     #   position known ?   (actual position is done by button location)
 189     #   moving or stable
 190     #   whether a train's plan includes a different position
 191     #   whether autopoint
 192     movpos-button-gvars $mid
 193     set fg white
 194     set bg black
 195     $w configure -background $bg -foreground $fg \
 196             -activebackground $bg -activeforeground $fg
 197     switch -exact $posn {
 198         ? { manyset [lindex $poslocs 2] x y }
 199         default { manyset [lindex $poslocs $posn] x y }
 200     }
 201     place $w -anchor center -x $x -y $y
 202 }
 203
 204 proc movpos-invoked {mid ctrlr} {
 205     global movfeatcommand
 206     movpos-button-gvars $mid
 207     switch -exact $posn {
 208         0 { set new_posn 1 }
 209         default { set new_posn 0 }
 210     }
 211     scmd routinecmd $ctrlr "$movfeatcommand $seg $feat $new_posn"
 212 }
 213
 214 register-event ?movpos_*_feat {seg feat posn_new} \
 215         {^.movpos (\w+) feat (\w+) ([01]|\?) } {
 216     set mid $seg/$feat
 217     if {![movpos-button-gvars $mid]} return
 218     set posn $posn_new
 219     movpos-button-sstate $mid
 220     movpos-button-setdisplay $mid
 221 }
 222
 223 proc movpos-bindkey-1 {cpage key seg feat} {
 224     global posdeviation
 225     manyset [subseg-end-get-centroid $cpage $seg $feat {}] mx my
 226     set mid $seg/$feat
 227     foreach posn {0 1} {
 228         manyset [subseg-end-get-centroid $cpage $seg $feat $posn] x y
 229         set dx [expr {$x-$mx}]; set dy [expr {$y-$my}]
 230         set d [expr {sqrt($dx*$dx + $dy*$dy)}]
 231         set mul [expr {$posdeviation / ($d + 1e-6)}]
 232         set x [expr {$mx + $mul*$dx}]
 233         set y [expr {$my + $mul*$dy}]
 234         lappend poslocs [list $x $y]
 235     }
 236     lappend poslocs [list $mx $my]
 237     upvar #0 mp_details($mid) details
 238     set details [list $cpage $key $seg $feat $poslocs]
 239
 240     bind . <Key-[string tolower $key]> [list movpos-invoked $mid "keyboard"]
 241 }
 242
 243 #---------- computation of movpos button locations
 244
 245 proc layout-subseg-end {seg feat posn x y} {
 246     global cpage
 247     upvar #0 ld_sse/${cpage}($seg/$feat$posn) sse
 248     if {![info exists sse]} { set sse {0 0 0} }
 249     manyset $sse n sx sy
 250     incr n
 251     set sx [expr {$sx + $x}]
 252     set sy [expr {$sy + $y}]
 253     set sse [list $n $sx $sy]
 254     if {[string length $posn]} { layout-subseg-end $seg $feat {} $x $y }
 255 }
 256
 257 proc subseg-end-get-centroid {cpage seg feat posn} {
 258     upvar #0 ld_sse/${cpage}($seg/$feat$posn) sse
 259     if {![info exists sse]} {
 260         puts "skipping binding of unknown $seg/$feat$posn"
 261         return -code return
 262     }
 263     manyset $sse n sx sy
 264     return [list [expr {$sx * 1.0 / $n}] [expr {$sy * 1.0 / $n}]]
 265 }
 266
 267 proc layout-data {} {
 268     global cpage
 269     upvar #0 ld_sse/$cpage sse
 270     catch { unset sse }
 271     set f ../layout/ours.dgram-$cpage.overlay-info
 272     source $f
 273
 274     upvar #0 movpos_bindings($cpage) bindings
 275     if {![info exists bindings]} {
 276         puts "no movpos bindings for $cpage"
 277         return
 278     }
 279     foreach binding $bindings {
 280         if {[regexp {^([A-Z])\=(\w+)/([A-Z]+)$} $binding dummy key seg feat]} {
 281             movpos-bindkey-1 $cpage $key $seg $feat
 282         } elseif {[regexp {^[A-Z]$} $binding] || [regexp {~} $binding]} {
 283         } else {
 284             error "incomprehensible binding $binding on page $cpage"
 285         }
 286     }
 287 }
 288
 289 #---------- speed ----------
 290
 291 # variables:
 292 #   $train_commanded($train)    $speed_step
 293 #   $train_direction($train)    forwards|backwards or unset
 294 #   $speedws                    [list $w ...]
 295 #
 296 # speed/${w}(...) aka s(...):
 297 #   $s(ctrlr)                   controller
 298 #   $s(train)                   train selected, or something not \w+
 299 #   $s(optionmenu)              optionmenu widget name
 300 #   $s(kind)                    abs or rel
 301 #   $s(commanding)              step of command we have scmd'd, or unset
 302 #   $s(queued)                  step of command we would like to queue
 303 #                                or unset if n/a
 304 #   $s(inhibit)   0   all is well, can command any speed
 305 #                 1   train newly selected, only rel can command higher speed
 306 #                 2   can only command same or lower speed
 307 #
 308 # We don't worry too much about races: in particular, we don't mind
 309 # racing with other things trying to command the speed, and losing
 310 # the odd increment/decrement.  But since we thread the requested
 311 # speed via realtime, we do queue up our own increments/decrements
 312 # while we're executing a speed command, to avoid loss of steps during
 313 # quick motions.
 314
 315 # Interfaces for concrete controllers:
 316 #   speedw-new $w $ctrlr
 317 #   speedw-setstate $w disabled|normal        controller appears/disappears
 318 #   speedw-userinput-abs $w $step
 319 #   speedw-userinput-rel $w $stepmap
 320 # where
 321 #   eval {stepmap} [list $oldstep] => $newstep
 322
 323 set speedws {}
 324
 325 proc speedws-forall {command args} {
 326     global speedws
 327     foreach w $speedws { eval [list $command $w] $args }
 328 }
 329
 330 proc speedws-fortrain {train command args} {
 331     global speedws
 332     foreach w $speedws {
 333         upvar #0 speed/$w s
 334         if {[string compare $s(train) $train]} continue
 335         eval [list $command $w] $args
 336     }
 337 }
 338
 339 proc speedw-new {w ctrlr} {
 340     upvar #0 speed/$w s
 341     global speedws
 342
 343     lappend speedws $w
 344     set s(ctrlr) $ctrlr
 345     set s(inhibit) 0
 346
 347     frame $w -relief sunken -border 2
 348     label $w.ctrlr -state disabled -text $s(ctrlr)
 349     set s(optionmenu) [tk_optionMenu $w.train speed/${w}(train) {}]
 350     $w.train configure -textvariable {} -width 15
 351     label $w.speed -state disabled -width 4 \
 352             -font -*-courier-bold-r-*-*-20-*-*-*-*-*-*-* \
 353             -background black -foreground white
 354     pack $w.ctrlr $w.train $w.speed -side left
 355
 356     speedw-notrains $w "(starting)"
 357 }
 358 proc speedw-notrains {w whystr} {
 359     $w.train configure -state disabled
 360     speedw-train-noneselected $w $whystr
 361 }
 362 proc speedw-train-noneselected {w whystr} {
 363     upvar #0 speed/$w s
 364     set s(train) {}
 365     $w.train configure -text $whystr
 366     $w.speed configure -text -
 367     speedw-inhibit $w
 368 }
 369
 370 proc speedw-inhibit {w} {
 371     upvar #0 speed/$w s
 372     set s(inhibit) 2
 373     $w.speed configure -foreground red
 374 }
 375 proc speedw-uninhibit {w max} {
 376     upvar #0 speed/$w s
 377     set r $s(inhibit)
 378     if {$r>$max} { return -1 }
 379     set s(inhibit) 0
 380     $w.speed configure -foreground white
 381     return $r
 382 }
 383
 384 proc speedw-setstate {w disnorm} {
 385     $w.ctrlr configure -state $disnorm
 386     $w.speed configure -state $disnorm
 387 }
 388
 389 proc speedw-train-selectnext {w} {
 390     upvar #0 speed/$w s
 391     set max [$s(optionmenu) index end]
 392     for {set ix 0} {$ix <= $max} {incr ix} {
 393         set v [$s(optionmenu) entrycget $ix -value]
 394         if {![string compare $v $s(train)]} break
 395     }
 396     set activate [expr {($ix+1) % ($max+1)}]
 397     $s(optionmenu) invoke $activate
 398 }
 399
 400 proc speedw-train-selected {w t} {
 401     upvar #0 speed/$w s
 402     $w.train configure -text $t
 403     set s(inhibit) 1
 404     set s(train) $t
 405     $w.speed configure -foreground white
 406     speedw-redisplay-speed $w
 407 }
 408
 409 proc speedw-redisplay-speed {w} {
 410     upvar #0 speed/$w s
 411     upvar #0 train_commanded($s(train)) gcommanded
 412     upvar #0 train_direction($s(train)) gdirection
 413     set t $gcommanded
 414     if {[info exists gdirection]} {
 415         switch -exact $gdirection {
 416             forwards { set t "$t>" }
 417             backwards { set t "<$t" }
 418         }
 419     }
 420     $w.speed configure -text $t
 421 }
 422
 423 proc speedw-train-direction {w dirchange} {
 424     upvar #0 speed/$w s
 425     if {![string length $s(train)]} return
 426     scmd routinecmd $s(ctrlr) "direction $s(train) $dirchange"
 427 }
 428
 429 proc speedw-trains-available {w l} {
 430     upvar #0 speed/$w s
 431     if {![llength $l]} { speedw-train-noneselected $w "(no trains)"; return }
 432     $s(optionmenu) delete 0 end
 433     $s(optionmenu) add radiobutton -label "(none)" -value {} \
 434             -command [list speedw-train-noneselected $w "(no train selected)"]
 435     set l [lsort $l]
 436     foreach t $l {
 437         $s(optionmenu) add radiobutton -label $t -value $t \
 438                 -command [list speedw-train-selected $w $t]
 439     }
 440     $w.train configure -state normal
 441     if {[llength $l]==1} {
 442         $s(optionmenu) invoke 1
 443     } elseif {[set ix [lsearch -exact $l $s(train)]] >= 0} {
 444         $s(optionmenu) invoke [expr {$ix+1}]
 445     } elseif {![string length $s(train)]} {
 446         $s(optionmenu) invoke 0
 447     } else {
 448         $w.train configure -text "$s(train) (not present)"
 449     }
 450 }
 451
 452 proc speedw-userinput-abs {w speed} {
 453     upvar #0 speed/$w s
 454     if {![string length $s(train)]} return
 455     set s(queued) $speed
 456     speedw-check $w
 457 }
 458
 459 proc speedw-check {w} {
 460     upvar #0 speed/$w s
 461     if {![string length $s(train)]} return
 462     upvar #0 train_commanded($s(train)) gcommanded
 463     upvar #0 train_direction($s(train)) gdirection
 464     if {[info exists s(commanding)]} return
 465     if {![info exists s(queued)]} return
 466     set newspeed $s(queued)
 467     unset s(queued)
 468     if {$s(inhibit)} {
 469         if {$newspeed > $gcommanded} return
 470         speedw-uninhibit $w 2
 471     }
 472     set s(commanding) $newspeed
 473     scmd speedw-commanded $s(ctrlr) "speed $s(train) $newspeed $gdirection" $w
 474 }
 475
 476 proc speedw-commanded-nak {m args} { error "got nak from speed: $m" }
 477 proc speedw-commanded-ok {m w} {
 478     upvar #0 speed/$w s
 479     unset s(commanding)
 480     speedw-check $w
 481 }
 482 proc speedw-commanded-err {m w} {
 483     upvar #0 speed/$w s
 484     unset s(commanding)
 485     speedw-inhibit $w
 486     speedw-check $w
 487 }
 488
 489 proc speedw-userinput-rel {w stepmap} {
 490     upvar #0 speed/$w s
 491     if {![string length $s(train)]} return
 492     upvar #0 train_commanded($s(train)) gcommanded
 493     if {[info exists s(queued)]} {
 494         set oldspeed $s(queued)
 495     } elseif {[info exists s(commanding)]} {
 496         set oldspeed $s(commanding)
 497     } else {
 498         set oldspeed $gcommanded
 499     }
 500     set newspeed [eval $stepmap [list $oldspeed]]
 501     speedw-userinput-abs $w $newspeed
 502 }
 503
 504 proc speedw-userinput-rel-steps {w delta steplist} {
 505     if {$delta<0} {
 506         if {[speedw-uninhibit $w 2]>1} { incr delta 1 }
 507         if {!$delta} return
 508     } else {
 509         speedw-uninhibit $w 1
 510     }
 511     speedw-userinput-rel $w [list speedw-stepmap-fromlist $steplist $delta]
 512 }
 513
 514 proc speedws-train-problem {train} {
 515     speedws-fortrain $train speedw-inhibit
 516 }
 517
 518 register-event ?train_*_at {train direction} \
 519         {^.train (\w+) at \S+ (forwards|backwards) } {
 520     upvar #0 train_direction($train) dirn
 521     set dirn $direction
 522     speedws-fortrain $train speedw-redisplay-speed
 523 }
 524
 525 register-event ?train_*_speed_commanding {train speed} \
 526         {^.train (\w+) speed commanding (\d+) } {
 527     upvar #0 train_commanded($train) cmd
 528     set cmd $speed
 529     speedws-fortrain $train speedw-redisplay-speed
 530 }
 531
 532 proc speedws-stastate-hook {} {
 533     global train_commanded stastate
 534     switch -exact -- $stastate {
 535         Run {
 536             set trains [array names train_commanded]
 537             speedws-forall speedw-trains-available $trains
 538         }
 539         Finalising {
 540             speedws-forall speedw-notrains "($stastate)"
 541         }
 542         default {
 543             catch { unset train_commanded }
 544             speedws-forall speedw-notrains "($stastate)"
 545         }
 546     }
 547 }
 548
 549 register-event &train_*_signalling-problem {train problem} \
 550         {^\&train (\w+) signalling-problem (.*) $} {
 551     global speedws
 552     regsub {^(\S+) (\S+) \: } $problem {\1 @\2: } problem
 553     report-problem "event: $problem"
 554     speedws-train-problem $train
 555 }
 556
 557 proc speedw-new-cooked {wunique desc} {
 558     set w .inputs.$wunique
 559     speedw-new $w $desc
 560     pack $w -side left -padx 10
 561     return $w
 562 }
 563
 564 proc speedw-stepmap-fromlist {speedlist offset oldspeed} {
 565     if {![llength $speedlist]} {
 566         unset speedlist
 567         upvar #0 default_speedstep_list speedlist
 568     }
 569     set ixabove 0
 570     foreach entry $speedlist {
 571         if {$entry==$oldspeed} { set ixbelow $ixabove; break }
 572         if {$entry>$oldspeed} break
 573         set ixbelow $ixabove
 574         incr ixabove
 575     }
 576     set ix [expr {($offset>0 ? $ixbelow : $ixabove) + $offset}]
 577     if {$ix<0} { return 0 }
 578     if {$ix>=[llength $speedlist]} { return [lindex $speedlist end] }
 579     return [lindex $speedlist $ix]
 580 }
 581
 582 #---------- concrete input bindings ----------
 583
 584 proc ib-suppressions {args} {
 585     set l {}
 586     foreach supp $args {
 587         set l [concat $l --redaction $supp --suppress]
 588     }
 589     return $l
 590 }
 591
 592 proc ib-speedw-new {devid wunique desc} {
 593     upvar #0 input/$devid in
 594     set in(speedw) [speedw-new-cooked $wunique $desc]
 595 }
 596
 597 #----- wheelmouse
 598
 599 proc ib-ev/wheelmouse/EV_REL/REL_WHEEL {devid value} {
 600     upvar #0 input/$devid in
 601     speedw-userinput-rel-steps $in(speedw) $value {}
 602 }
 603
 604 proc ib-selectnext {devid value} {
 605     if {$value!=1} return
 606     upvar #0 input/$devid in
 607     speedw-train-selectnext $in(speedw)
 608 }
 609 proc ib-changedirection {devid value} {
 610     upvar #0 input/$devid in
 611     if {!$value} return
 612     speedw-train-direction $in(speedw) change
 613 }
 614
 615 proc ib-ev/wheelmouse/EV_KEY/BTN_LEFT {devid value} {
 616     ib-selectnext $devid $value
 617 }
 618 proc ib-ev/wheelmouse/EV_KEY/BTN_RIGHT {devid value} {
 619     ib-changedirection $devid $value
 620 }
 621
 622 proc ib-create/wheelmouse {devid wunique desc} {
 623     ib-speedw-new $devid $wunique $desc
 624 }
 625
 626 proc ib-wheelmouse-redactions {} {
 627     return [ib-suppressions  \
 628             {EV REL REL X} \
 629             {EV REL REL Y}]
 630 }
 631
 632 proc ib-evcmd/wheelmouse {devid target} {
 633     return [ib-evcmd-construct $devid $target [concat \
 634             [list --grab] [ib-wheelmouse-redactions]]]
 635 }
 636
 637 #----- ebuyer wireless keyboard
 638
 639 proc ib-create/ebwikeb {devid wunique} {
 640     upvar #0 input/$devid in
 641     set in(desc) "main keyboard"
 642     ib-create/wheelmouse $devid $wunique $in(desc)
 643     set in(modifiers) 0
 644 }
 645
 646 proc ib-evcmd/ebwikeb {devid target} {
 647     return [concat \
 648             [list ./evdev-manip --redact --stdin-monitor] \
 649             [ib-wheelmouse-redactions] \
 650             [ib-suppressions \
 651                 {0x01 02} \
 652                 {EV MSC} \
 653                 {0x0c 01} \
 654                 {0xffbc 88 0xffbc 00}] \
 655             [list --evdev /dev/input/event2 \
 656                   --evdev /dev/input/event3 \
 657                   --hiddev /dev/hiddev0]]
 658 }
 659
 660 proc ib-ev/ebwikeb/EV_REL/REL_WHEEL {devid value} {
 661     ib-ev/wheelmouse/EV_REL/REL_WHEEL $devid $value
 662 }
 663 proc ib-ev/ebwikeb/EV_KEY/BTN_RIGHT {devid value} {
 664     ib-changedirection $devid $value
 665 }
 666
 667 proc ib-ebwikeb-modifier {devid value bitval} {
 668     upvar #0 input/${devid}(modifiers) mod
 669     if {$value} {
 670         set mod [expr {$mod | $bitval}]
 671     } else {
 672         set mod [expr {$mod & ~$bitval}]
 673     }
 674 }
 675 proc ib-ev/ebwikeb/EV_KEY/KEY_LEFTSHIFT {devid value} {
 676     ib-ebwikeb-modifier $devid $value 0x0001
 677 }
 678 proc ib-ev/ebwikeb/EV_KEY/KEY_RIGHTSHIFT {devid value} {
 679     ib-ebwikeb-modifier $devid $value 0x0002
 680 }
 681 proc ib-ev/ebwikeb/EV_KEY/KEY_LEFTCTRL {devid value} {
 682     ib-ebwikeb-modifier $devid $value 0x0100
 683 }
 684 proc ib-ev/ebwikeb/EV_KEY/KEY_RIGHTCTRL {devid value} {
 685     ib-ebwikeb-modifier $devid $value 0x0200
 686 }
 687 proc ib-ev/ebwikeb/EV_KEY/KEY_CAPSLOCK {devid value} {
 688     ib-ebwikeb-modifier $devid $value 0x0400
 689 }
 690
 691 proc ib-ev/ebwikeb/0xffbc_88/0xffbc_0d {devid value} {
 692     ib-selectnext $devid $value
 693 }
 694
 695 proc ib-ev/ebwikeb/EV_KEY/KEY_BOOKMARKS {devid value} {
 696     upvar #0 input/$devid in
 697     if {!$value} return
 698     if {!($in(modifiers) & 0xff00)} return
 699     if {$in(modifiers) & 0x00ff} {
 700         set how stop
 701     } else {
 702         set how auto
 703     }
 704     scmd routinecmd $in(desc) "!realtime $how"
 705 }
 706
 707 #----- static keybindings speed `controller'
 708
 709 proc bind-keyboard-speed {kslow kfast kseltrain kreverse desc} {
 710     set wunique [get-unique keyboardspeed]
 711     set w [speedw-new-cooked $wunique $desc]
 712     foreach delta {-1 +1} sf {slow fast} {
 713         bind . <Key-[set k$sf]> [list speedw-userinput-rel-steps $w $delta {}]
 714     }
 715     bind . <Key-$kseltrain> [list speedw-train-selectnext $w]
 716     bind . <Key-$kreverse> [list speedw-train-direction $w change]
 717     speedw-setstate $w normal
 718 }
 719
 720 #---------- input device evdev binding ----------
 721
 722 proc ib-evcmd-construct {devid target xargs} {
 723     upvar #0 input/$devid in
 724     if {[llength $target] > 1} {
 725         debug "ib $devid - multiple devices, not supported"
 726         return {}
 727     }
 728     manyset [lindex $target 0] ev sysfs
 729     if {[regexp { } $ev]} { error "event device `$ev' contains space" }
 730     return [concat \
 731             [list ./evdev-manip --redact] $xargs \
 732             [list --stdin-monitor \
 733                   --expect-sysfs /sys$sysfs/$ev/dev \
 734                   /dev/input/$ev]]
 735 }
 736
 737 proc bind-input {bus vendor product version concrete args} {
 738     global input_bindings
 739     set devid $bus:$vendor:$product:$version
 740     lappend input_bindings [list $devid $concrete $args]
 741 }
 742
 743 proc bind-input-static {event sysfs concrete args} {
 744     global input_bindings input_statics
 745     set devid [get-unique static]
 746     lappend input_statics [list $devid $event $sysfs]
 747     lappend input_bindings [list $devid $concrete $args]
 748 }
 749
 750 proc widgets-input-bindings {} {
 751     global input_bindings
 752     foreach binding $input_bindings {
 753         manyset $binding devid concrete xa
 754         set cid [get-unique $concrete]
 755         upvar #0 input/$devid in
 756         set in(laststart) 0
 757         set in(concrete) $concrete
 758         eval [list ib-create/$concrete $devid $cid] $xa
 759     }
 760     pack .inputs -side top -fill x
 761 }
 762
 763 # input/$bus:$vendor:$product:$version becomes `in' via upvar
 764 #  $in(chan)        channel open onto evdev-manip; unset if none
 765 #  $in(laststart)   last start time, [clock seconds]
 766 #                      at every event we set this the current time
 767 #                      but we insist on adding at least 5s
 768 #                      and if that would make it > current time +15s
 769 #                      we don't start
 770 #  $in(speedw)      optional, may be set by ib-create
 771
 772 proc scan-input-bindings {} {
 773     global errorInfo errorCode unmatched_notified
 774     global input_bindings inputretryadd inputretrymax scaninputinterval
 775     global input_statics
 776     if {[catch {
 777         set f [open /proc/bus/input/devices]
 778     } emsg]} {
 779         if {[string match {POSIX ENOENT *} $errorCode]} return
 780         error $emsg $errorInfo $errorCode
 781     }
 782     while 1 {
 783         set r [gets $f l]
 784         if {$r <= 0} {
 785             if {[info exists v(devid)] &&
 786                 [info exists v(sysfs)] &&
 787                 [info exists v(event)]} {
 788                 lappend target($v(devid)) [list $v(event) $v(sysfs)]
 789             }
 790             catch { unset v }
 791         }
 792         if {$r < 0} {
 793             break
 794         }
 795         append l "\n"
 796         if {[regexp \
 797  {^I: Bus=(\w+) Vendor=(\w+) Product=(\w+) Version=(\w+)\s} \
 798                  $l dummy bus vendor product version]} {
 799             set v(devid) $bus:$vendor:$product:$version
 800         } elseif {[regexp {^S: Sysfs=(\S+)\s} $l dummy sysfs]} {
 801             set v(sysfs) $sysfs
 802         } elseif {[regexp {^H: Handlers=(?:.*\s)?(event\d+)\s} $l dummy ev]} {
 803             set v(event) $ev
 804         } else {
 805             # ignored
 806         }
 807     }
 808     close $f
 809     foreach static $input_statics {
 810         manyset $static devid event sysfs
 811         lappend target($devid) [list $event $sysfs]
 812     }
 813     foreach devid [array names target] {
 814         upvar #0 input/$devid in
 815         if {![info exists in(concrete)]} {
 816             if {![info exists unmatched_notified($devid)]} {
 817                 debug "ib $devid unmatched, ignored"
 818                 set unmatched_notified($devid) 1
 819             }
 820             continue
 821         }
 822         if {[info exists in(chan)]} continue
 823         set now [clock seconds]
 824         set newlast [expr {$in(laststart) + $inputretryadd}]
 825         if {$newlast > $now + $inputretrymax} continue
 826         if {$newlast < $now} { set newlast $now }
 827         set cmdl [ib-evcmd/$in(concrete) $devid $target($devid)]
 828         if {![llength $cmdl]} {
 829             unset target($devid)
 830             continue
 831         }
 832         lappend cmdl 2>@ stderr
 833         set in(laststart) $newlast
 834         catch-for-input-binding $devid {
 835             debug "ib $devid running $cmdl"
 836             set in(chan) [open |$cmdl r+]
 837             fconfigure $in(chan) -blocking 0 -buffering line
 838             fileevent $in(chan) readable [list catch-for-input-binding $devid \
 839                     [list readable input-binding $in(chan) $devid]]
 840         }
 841     }
 842     foreach binding $input_bindings {
 843         manyset $binding devid concrete ctrlr
 844         upvar #0 input/$devid in
 845         if {![info exists in(concrete)]} continue
 846         if {[info exists target($devid)]} continue
 847         input-binding-notpresent $devid absent
 848     }
 849     after $scaninputinterval scan-input-bindings
 850 }
 851
 852 proc input-binding-notpresent {devid why} {
 853     upvar #0 input/$devid in
 854     if {[info exists in(speedw)]} {
 855         speedw-setstate $in(speedw) disabled
 856     }
 857     if {![catch { info args ib-absent/$in(concret) }]} {
 858         ib-absent/$in(concrete) $devid $why
 859     }
 860 }
 861
 862 proc input-binding-eof {chan devid} {
 863     upvar #0 input/$devid in
 864     fconfigure $in(chan) -blocking 1
 865     close $in(chan)
 866     error "evdev-manip exited" {} {CHILDSTATUS ? 0}
 867 }
 868
 869 proc input-binding-inputline {chan l devid} {
 870     global showunbound
 871     upvar #0 input/$devid in
 872     if {![catch { info args ib-inputline/$in(concrete) }]} {
 873         # give the input binding first dibs
 874         if {[ib-inputline/$in(concrete) $devid $l]} return
 875     }
 876     regsub {^[^ ]+ } $l {} lr
 877     switch -glob -- $lr {
 878         {opened *} {
 879             debug "ib $devid start << $l"
 880             if {[info exists in(speedw)]} {
 881                 speedw-setstate $in(speedw) normal
 882             }
 883         }
 884         {[-0-9]*} {
 885             manyset [split $lr] value kindl kindr codel coder
 886             set proc ib-ev/$in(concrete)/${kindl}_${kindr}/${codel}_${coder}
 887             if {[catch { info args $proc }]} {
 888                 if {$showunbound} {
 889                     debug "ib $devid unbound $proc << $l"
 890                 }
 891                 return
 892             }
 893             $proc $devid $value
 894         }
 895         * {
 896             debug "ib $devid ignored << $l"
 897         }
 898     }
 899 }
 900
 901 proc catch-for-input-binding {devid body} {
 902     upvar #0 input/$devid in
 903     global errorInfo errorCode
 904     set r [catch { uplevel 1 $body } rv]
 905     if {$r!=1} { return -code $r $rv }
 906     switch -glob $errorCode {
 907         {CHILDSTATUS *} { set m "exited with status [lindex $errorCode 2]" }
 908         {CHILDKILLED *} { set m "killed by signal [lindex $errorCode 3]" }
 909         {POSIX *} { set m "communication error: [lindex $errorCode 1]" }
 910         * { error $rv $errorInfo $errorCode }
 911     }
 912     debug "ib $devid died $m"
 913     catch { close $in(chan) }
 914     catch { unset in(chan) }
 915
 916     input-binding-notpresent $devid "died $m"
 917 }
 918
 919 proc engage-input-bindings {} {
 920     scan-input-bindings
 921 }
 922
 923 #---------- plan background (gui-plan subprocess) ----------
 924
 925 proc gui-pipe-readable {args} {
 926     global gui_pipe
 927     while {[gets $gui_pipe l] >= 0} {
 928         debug "<gui-plan $l"
 929     }
 930     if {[eof $gui_pipe]} {
 931         close $gui_pipe
 932         error "gui-plan crashed"
 933     }
 934 }
 935
 936 #---------- train set events of general interest, and setup ----------
 937
 938 proc train-event-eof {args} {
 939     error "lost connection to train set"
 940 }
 941
 942 register-event ?stastate {ctxch state} {^(.)stastate (\w+|\-) } {
 943     global ctrain trains stastate
 944     set stastate $state
 945     report-problem "stastate: $state"
 946     if {[string compare $ctxch |]} speedws-stastate-hook
 947 }
 948
 949 register-event ?resolution {message} \
 950         {^.resolution (\S+ .*)$} {
 951     if {[string match "problems *" $message]} return
 952     report-problem "resolution: $message"
 953 }
 954
 955 register-event ?warning {message} {^.warning (\S+ .*)$} {
 956     report-problem "warning: $message"
 957 }
 958
 959 register-event {} {} {^=connected } {
 960     global pages gui_pipe server port event_selections
 961
 962     scmd replayed {} "select-replay [concat $event_selections]"
 963
 964     foreach page $pages {
 965         set w [pagew $page]
 966         tkwait visibility $w
 967
 968         set cmdl [list ./gui-plan-$page [winfo id $w] @$server,$port]
 969         lappend cmdl 2>@ stderr
 970         set gui_pipe [open |$cmdl r]
 971
 972         puts stderr "running $cmdl"
 973         fconfigure $gui_pipe -blocking no
 974         fileevent $gui_pipe readable gui-pipe-readable
 975     }
 976 }
 977 proc replayed-err {m args} { error "replay failed: $m" }
 978 proc replayed-ok {m args} {
 979     speedws-stastate-hook
 980 }
 981
 982 register-event {} {} {^=failed } { error "multiplexer failed: $l" }
 983 register-event {} {} {^=denied } { error "multiplexer denied us: $l" }
 984 register-event {} {} {^\+nack } { error "multiplexer does not understand" }
 985
 986 #---------- main program ----------
 987
 988 append event_dispatch_body {
 989     debug "ignored $l"
 990 }
 991 proc train-event-inputline {sconn l} $event_dispatch_body
 992 proc register-event {args} { error "too late!" }
 993
 994 proc engage-server {} {
 995     global server port sconn
 996
 997     set sconn [socket $server $port]
 998     fconfig-trainproto $sconn
 999     fileevent $sconn readable {readable train-event $sconn}
1000 }
1001
1002 proc main {} {
1003     global pages cpage configfile input_bindings input_statics
1004     setting server railway {[[0-9a-z:].*}
1005     setting geometry {} {[-+]\d+[-+]\d+}
1006     setting posdeviation 10 {\d+}
1007     setting movfeatcommand {movfeat+} {(?:!movfeat|movfeat\+?\+?)}
1008     setting problemdisplayms 1000 {\d+}
1009     setting inputretryadd 5 {\d+}
1010     setting inputretrymax 15 {\d+}
1011     setting scaninputinterval 500 {\d+}
1012     setting showunbound 0 {[01]}
1013
1014     set hostname [lindex [split [info hostname] .] 0]
1015     setting configfile gui-$hostname.config {.+}
1016     parse-argv {}
1017
1018     frame .inputs
1019     if {![info exists input_bindings]} { set input_bindings {} }
1020     if {![info exists input_statics]} { set input_statics {} }
1021
1022     uplevel #0 source gui-layout.config
1023     uplevel #0 source $configfile
1024     foreach cpage $pages {
1025         layout-data
1026         widgets-dgram
1027     }
1028     unset cpage
1029     widgets-movpos
1030     widgets-input-bindings
1031     widget-problem-report
1032     engage-server
1033     engage-input-bindings
1034     start_commandloop
1035 }
1036
1037 main