speedw improvements

 - static keyboard bindings available
 - inhibition rationalised
 - some useful restructuring

diff --git a/hostside/gui b/hostside/gui
index 5406a37d15debb82b1514595ccf52a6a87ffa06c..d854b20ed6381163973b4efffd0e710c50ba131c 100755 (executable)
--- a/hostside/gui
+++ b/hostside/gui
@@ -8,6 +8,8 @@ tk_setPalette background black foreground white
 
 source lib.tcl
 
+set default_speedstep_list {0 1 10 20 35 50 65 80 95 110 126}
+
 proc pagew {page} { return ".picture-$page" }
 proc debug {m} { puts $m }
 
@@ -310,7 +312,7 @@ proc layout-data {} {
 # quick motions.
 
 # Interfaces for concrete controllers:
-#   speedw-new $w $ctrlr {stepmap}
+#   speedw-new $w $ctrlr
 #   speedw-setstate $w disabled|normal        controller appears/disappears
 #   speedw-userinput-abs $w $step
 #   speedw-userinput-rel $w $stepmap
@@ -467,6 +469,16 @@ proc speedw-userinput-rel {w stepmap} {
     speedw-userinput-abs $w $newspeed
 }
 
+proc speedw-userinput-rel-steps {w delta steplist} {
+    if {$delta<0} {
+       if {[speedw-uninhibit $w 2]>1} { incr delta 1 }
+       if {!$delta} return
+    } else {
+       speedw-uninhibit $w 1
+    }
+    speedw-userinput-rel $w [list speedw-stepmap-fromlist $steplist $delta]
+}
+
 proc speedws-train-problem {train} {
     speedws-forall speedw-train-problem $train
 }
@@ -507,14 +519,20 @@ register-event &train_*_signalling-problem {train problem} \
     speedws-train-problem $train
 }
 
-#---------- concrete input bindings ----------
-
-#----- wheelmouse
+proc speedw-new-cooked {wunique desc} {
+    set w .inputs.$wunique
+    speedw-new $w $desc
+    pack $w -side left -padx 10
+    return $w
+}
 
-proc ib-wheelmouse-stepmap {offset oldspeed} {
-    upvar #0 ib_wheelmouse_stepmap map
+proc speedw-stepmap-fromlist {speedlist offset oldspeed} {
+    if {![llength $speedlist]} {
+       unset speedlist
+       upvar #0 default_speedstep_list speedlist
+    }
     set ixabove 0
-    foreach entry $map {
+    foreach entry $speedlist {
        if {$entry==$oldspeed} { set ixbelow $ixabove; break }
        if {$entry>$oldspeed} break
        set ixbelow $ixabove
@@ -522,19 +540,30 @@ proc ib-wheelmouse-stepmap {offset oldspeed} {
     }
     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]
+    if {$ix>=[llength $speedlist]} { return [lindex $speedlist end] }
+    return [lindex $speedlist $ix]
 }
 
+#---------- concrete input bindings ----------
+
+proc ib-suppressions {args} {
+    set l {}
+    foreach supp $args {
+       set l [concat $l --redaction $supp --suppress]
+    }
+    return $l
+}
+
+proc ib-speedw-new {devid wunique desc} {
+    upvar #0 input/$devid in
+    set in(speedw) [speedw-new-cooked $wunique $desc]
+}
+
+#----- wheelmouse
+
 proc ib-ev/wheelmouse/EV_REL/REL_WHEEL {devid value} {
     upvar #0 input/$devid in
-    if {$value<0} {
-       if {[speedw-uninhibit $in(speedw) 2]>0} { incr value 1 }
-       if {!$value} return
-    } else {
-       speedw-uninhibit $in(speedw) 1
-    }
-    speedw-userinput-rel $in(speedw) [list ib-wheelmouse-stepmap $value]
+    speedw-userinput-rel-steps $in(speedw) $value {}
 }
 
 proc ib-selectnext {devid value} {
@@ -548,19 +577,7 @@ proc ib-ev/wheelmouse/EV_KEY/BTN_LEFT {devid value} {
 }
 
 proc ib-create/wheelmouse {devid wunique desc} {
-    upvar #0 input/$devid in
-    set w .inputs.$wunique
-    speedw-new $w $desc
-    pack $w -side left -padx 10
-    set in(speedw) $w
-}
-
-proc ib-suppressions {args} {
-    set l {}
-    foreach supp $args {
-       set l [concat $l --redaction $supp --suppress]
-    }
-    return $l
+    ib-speedw-new $devid $wunique $desc
 }
 
 proc ib-wheelmouse-redactions {} {
@@ -641,6 +658,19 @@ proc ib-ev/ebwikeb/EV_KEY/KEY_BOOKMARKS {devid value} {
     scmd routinecmd $in(desc) "!realtime $how"
 }
 
+#----- static keybindings speed `controller'
+
+proc bind-keyboard-speed {kslow kfast kseltrain kreverse desc} {
+    set wunique [get-unique keyboardspeed]
+    set w [speedw-new-cooked $wunique $desc]
+    foreach delta {-1 +1} sf {slow fast} {
+       bind . <Key-[set k$sf]> [list speedw-userinput-rel-steps $w $delta {}]
+    }
+    bind . <Key-$kseltrain> [list speedw-train-selectnext $w]
+    bind . <Key-$kreverse> [list speedw-train-direction $w change]
+    speedw-setstate $w normal
+}
+
 #---------- input device evdev binding ----------
 
 proc ib-evcmd-construct {devid target xargs} {
@@ -664,18 +694,22 @@ proc bind-input {bus vendor product version concrete args} {
     lappend input_bindings [list $devid $concrete $args]
 }
 
+proc bind-input-static {event sysfs concrete args} {
+    global input_bindings input_statics
+    set devid [get-unique static]
+    lappend input_statics [list $devid $event $sysfs]
+    lappend input_bindings [list $devid $concrete $args]
+}
+
 proc widgets-input-bindings {} {
     global input_bindings
-    frame .inputs
     foreach binding $input_bindings {
        manyset $binding devid concrete xa
-       upvar #0 concreteix($concrete) cix
-       if {![info exists cix]} { set cix 0 }
-       incr cix
+       set cid [get-unique $concrete]
        upvar #0 input/$devid in
        set in(laststart) 0
        set in(concrete) $concrete
-       eval [list ib-create/$concrete $devid $concrete$cix] $xa
+       eval [list ib-create/$concrete $devid $cid] $xa
     }
     pack .inputs -side top -fill x
 }
@@ -692,6 +726,7 @@ proc widgets-input-bindings {} {
 proc scan-input-bindings {} {
     global errorInfo errorCode unmatched_notified
     global input_bindings inputretryadd inputretrymax scaninputinterval
+    global input_statics
     if {[catch {
        set f [open /proc/bus/input/devices]
     } emsg]} {
@@ -725,6 +760,10 @@ proc scan-input-bindings {} {
        }
     }
     close $f
+    foreach static $input_statics {
+       manyset $static devid event sysfs
+       lappend target($devid) [list $event $sysfs]
+    }
     foreach devid [array names target] {
        upvar #0 input/$devid in
        if {![info exists in(concrete)]} {
@@ -915,8 +954,7 @@ proc engage-server {} {
 }
 
 proc main {} {
-    global pages cpage configfile input_bindings
-    set input_bindings {}
+    global pages cpage configfile input_bindings input_statics
     setting server railway {[[0-9a-z:].*}
     setting geometry {} {[-+]\d+[-+]\d+}
     setting posdeviation 10 {\d+}
@@ -930,6 +968,11 @@ proc main {} {
     set hostname [lindex [split [info hostname] .] 0]
     setting configfile gui-$hostname.config {.+}
     parse-argv {}
+
+    frame .inputs
+    if {![info exists input_bindings]} { set input_bindings {} }
+    if {![info exists input_statics]} { set input_statics {} }
+
     uplevel #0 source gui-layout.config
     uplevel #0 source $configfile
     foreach cpage $pages {

diff --git a/hostside/gui-layout.config b/hostside/gui-layout.config
index 9fb322e131490d7c5b73a6987e123b08916913d0..eddfa9cea1a6da6c1329da4682dc9196a1c16fe2 100644 (file)
--- a/hostside/gui-layout.config
+++ b/hostside/gui-layout.config
@@ -7,4 +7,3 @@ 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}

diff --git a/hostside/gui-liberator.config b/hostside/gui-liberator.config
index a384e0527b9158d15b068fc098c78d71d1c66fea..485f1c9c41ff3e125058735634fd1684a85f801d 100644 (file)
--- a/hostside/gui-liberator.config
+++ b/hostside/gui-liberator.config
@@ -1 +1,2 @@
 bind-input 0003 045e 0084 0390 wheelmouse "wheel mouse"
+bind-keyboard-speed bracketleft bracketright braceleft braceright "keys \[]{}"

diff --git a/hostside/lib.tcl b/hostside/lib.tcl
index 8d5a19988096cc7a1a954d12281662ce78043608..a0f711a4635742157db433bb94cb7133c8c23a5e 100644 (file)
--- a/hostside/lib.tcl
+++ b/hostside/lib.tcl
@@ -68,5 +68,11 @@ proc parse-argv {formalargs} {
     }
 }
 
+proc get-unique {prefix} {
+    upvar #0 unique_ix($prefix) ix
+    if {![info exists ix]} { set ix 0 }
+    return "$prefix[incr ix]"
+}
+
 setting port 2883 {\d+}