From 20e9de10230439c982b36f4ba7b883206643ed5d Mon Sep 17 00:00:00 2001 From: ian Date: Sun, 20 Jul 2008 16:38:03 +0000 Subject: [PATCH] speedw improvements - static keyboard bindings available - inhibition rationalised - some useful restructuring --- hostside/gui | 115 +++++++++++++++++++++++----------- hostside/gui-layout.config | 1 - hostside/gui-liberator.config | 1 + hostside/lib.tcl | 6 ++ 4 files changed, 86 insertions(+), 37 deletions(-) diff --git a/hostside/gui b/hostside/gui index 5406a37..d854b20 100755 --- 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 . [list speedw-userinput-rel-steps $w $delta {}] + } + bind . [list speedw-train-selectnext $w] + bind . [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 9fb322e..eddfa9c 100644 --- 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 a384e05..485f1c9 100644 --- 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 8d5a199..a0f711a 100644 --- 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+} -- 2.30.2