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