can set speeds we think

diff --git a/hostside/gui b/hostside/gui
index 279aa9cf348daead77bdb9131ca805eff4c878d0..c083ef483f0bcb225c9906048d218eef314f483d 100755 (executable)
--- a/hostside/gui
+++ b/hostside/gui
@@ -285,9 +285,6 @@ proc layout-data {} {
 # while we're executing a speed command, to avoid loss of steps during
 # quick motions.
 
-# for rel speedws:
-#   $s(stepmap)                 from creator
-
 # Interfaces for concrete controllers:
 #   speedw-new $w $ctrlr {stepmap}
 #   speedw-setstate $w disabled|normal        controller appears/disappears
@@ -310,7 +307,6 @@ proc speedw-new {w ctrlr} {
     lappend speedws $w
     set s(ctrlr) $ctrlr
     set s(inhibit) 0
-    set s(commanding) 0
 
     frame $w -relief groove -border 1
     label $w.ctrlr -state disabled -text $s(ctrlr)
@@ -340,10 +336,13 @@ proc speedw-inhibit {w} {
     set s(inhibit) 2
     $w.speed configure -foreground red
 }
-proc speedw-uninhibit {w} {
+proc speedw-uninhibit {w max} {
     upvar #0 speed/$w s
+    set r $s(inhibit)
+    if {$r>$max} { return -1 }
     set s(inhibit) 0
     $w.speed configure -foreground white
+    return $r
 }
 
 proc speedw-setstate {w disnorm} {
@@ -356,6 +355,7 @@ proc speedw-train-selected {w t} {
     $w.train configure -text $t
     $w.speed configure -text {} -textvariable train_commanded($t)
     set s(inhibit) 1
+    set s(train) $t
     $w.speed configure -foreground white
 }
 
@@ -385,8 +385,8 @@ proc speedw-trains-available {w l} {
 proc speedw-userinput-abs {w speed} {
     upvar #0 speed/$w s
     if {![string length $s(train)]} return
-    set $s(queued) $speed
-    speedw-check
+    set s(queued) $speed
+    speedw-check $w
 }
 
 proc speedw-check {w} {
@@ -398,18 +398,23 @@ proc speedw-check {w} {
     unset s(queued)
     if {$s(inhibit)} {
        if {$newspeed > $gcommanded} return
-       speedw-uninhibit $w
+       speedw-uninhibit $w 2
     }
     set s(commanding) $newspeed
     scmd speedw-commanded $s(ctrlr) "speed $s(train) $newspeed" $w
 }
 
 proc speedw-commanded-nak {m args} { error "got nak from speed: $m" }
-proc speedw-commanded-ok {m w} { upvar #0 speed/$w s; unset s(commanding) }
+proc speedw-commanded-ok {m w} {
+    upvar #0 speed/$w s
+    unset s(commanding)
+    speedw-check $w
+}
 proc speedw-commanded-err {m w} {
     upvar #0 speed/$w s
     unset s(commanding)
     speedw-inhibit $w
+    speedw-check $w
 }
 
 proc speedw-userinput-rel {w stepmap} {
@@ -423,7 +428,7 @@ proc speedw-userinput-rel {w stepmap} {
     } else {
        set oldspeed $gcommanded
     }
-    set newspeed [eval $s(stepmap) [list $oldspeed]]
+    set newspeed [eval $stepmap [list $oldspeed]]
     speedw-userinput-abs $w $newspeed
 }
 
@@ -444,7 +449,7 @@ register-event ?train_*_speed_commanded {train speed} \
 
 proc speedws-stastate-hook {} {
     global train_commanded stastate
-    switch -exact $stastate {
+    switch -exact -- $stastate {
        Run {
            set trains [array names train_commanded]
            speedws-forall speedw-trains-available $trains
@@ -464,6 +469,33 @@ register-event &train_*_signalling-problem {train problem} \
     speedws-train-problem $train
 }
 
+#---------- concrete input bindings ----------
+
+proc ib-wheelmouse-stepmap {offset oldspeed} {
+    upvar #0 ib_wheelmouse_stepmap map
+    set ixabove 0
+    foreach entry $map {
+       if {$entry==$oldspeed} { set ixbelow $ixabove; break }
+       if {$entry>$oldspeed} break
+       set ixbelow $ixabove
+       incr ixabove
+    }
+    set ix [expr {($offset>0 ? $ixbelow : $ixabove) + $offset}]
+    if {$ix<0} { return 0 }
+    if {$ix>=[llength $map]} { return [lindex $map end] }
+    return [lindex $map $ix]
+}
+
+proc ib-wheelmouse-EV_REL/REL_WHEEL {w value} {
+    if {$value<0} {
+       if {[speedw-uninhibit $w 2]>0} { incr value 1 }
+       if {!$value} return
+    } else {
+       speedw-uninhibit $w 1
+    }
+    speedw-userinput-rel $w [list ib-wheelmouse-stepmap $value]
+}
+
 #---------- input device evdev binding ----------
 
 proc bind-input {bus vendor product version concrete ctrlr} {
@@ -548,12 +580,12 @@ proc scan-input-bindings {} {
        if {$newlast < $now} { set newlast $now }
        set in(laststart) $newlast
        manyset [lindex $target($key) 0] ev sysfs
-       set cmdl [list ./evdev-manip --grab --stdin-monitor \
+       set cmdl [list 2>@ stderr ./evdev-manip --grab --stdin-monitor \
                --expect-sysfs /sys$sysfs/$ev/dev \
                /dev/input/$ev]
        catch-for-input-binding $key {
            debug "i-b $key running $cmdl"
-           set in(chan) [open |$cmdl r]
+           set in(chan) [open |$cmdl r+]
            fconfigure $in(chan) -blocking 0 -buffering line
            fileevent $in(chan) readable [list catch-for-input-binding $key \
                    [list readable input-binding $in(chan) $key]]
@@ -587,7 +619,7 @@ proc input-binding-inputline {chan l key} {
            manyset [split $l] dummy dummy kind code value
            set proc ib-$in(concrete)-$kind/$code
            if {[catch { info args $proc }]} return
-           $proc $value
+           $proc $in(w) $value
        }
        {report-from *} { }
        {synch *} { }
@@ -641,7 +673,7 @@ proc train-event-eof {args} {
 register-event ?stastate {ctxch state} {^(.)stastate (\w+|\-) } {
     global ctrain trains stastate
     set stastate $state
-    if {[string compare ctxch |]} speedws-stastate-hook
+    if {[string compare $ctxch |]} speedws-stastate-hook
 }
 
 register-event {} {} {^=connected } {
@@ -676,7 +708,10 @@ register-event {} {} {^\+nack } { error "multiplexer does not understand" }
 append event_dispatch_body {
     debug "ignored $l"
 }
-proc train-event-inputline {sconn l} $event_dispatch_body
+proc train-event-inputline {sconn l} "
+puts stderr \"<<<\$l\"
+$event_dispatch_body
+"
 proc register-event {args} { error "too late!" }
 
 proc engage-server {} {

diff --git a/hostside/gui-config b/hostside/gui-config
index 9b86f114ffefb9d9e8df6665812e279b12b125cf..d08a941a21676ac05b7ed5468ec77cfa5fcb6eb0 100644 (file)
--- a/hostside/gui-config
+++ b/hostside/gui-config
@@ -7,4 +7,5 @@ set movpos_bindings(bot) {
        J               I       O
        M               K       L
 }
+set ib_wheelmouse_stepmap {0 1 10 20 35 50 65 80 95 110 126}
 bind-input 0003 045e 0084 0390 wheelmouse "wheel mouse"

diff --git a/hostside/gui-plan-testdata b/hostside/gui-plan-testdata
index 27db520f3537a0b4de1b80f5b9b2be3a1bb48fe5..5891eb574869d90ce474c9b7f1c9a1d9ef05aee1 100644 (file)
--- a/hostside/gui-plan-testdata
+++ b/hostside/gui-plan-testdata
@@ -11,5 +11,13 @@ movpos A5 feat P 2 point
 movpos Q0 feat Q 0 two
 movpos X8 feat P 0 three
 picio out polarity <X2,X3,X4,Q3>
-train shinkansen speed commanded 100
+train shinkansen speed commanded 0
 stastate Run
+train shinkansen speed commanded 100
+
+executing speed
+train shinkansen speed commanded 95
+ack speed ok
+
+executing speed
+ack speed SignallingPredictedProblem shinkansen X3 : some burblings