#---------- general utilities ----------
+set tk_strictMotif 1
+
source lib.tcl
proc pagew {page} { return ".picture-$page" }
proc debug {m} { puts $m }
+proc warning {m} { puts stderr $m }
+
proc sconn {m} {
global sconn
debug "=> $m"
#---------- train set event registraton ----------
-set event_dispatch_body {}
+set event_dispatch_body {
+ append l " "
+}
set event_selections {}
proc register-event {selections args re body} {
}
}
+#---------- speed ----------
+
+# variables:
+# $train_commanded($train) $speed_step
+# $speed_commanding $w of the one we're commanding, or unset
+# $speedws [list $w ...]
+#
+# speed/${w}(...) aka s(...):
+# $s(train) train selected, or something not \w+
+# $s(optionmenu) optionmenu widget name
+# $s(queuedupdown) integer, always set
+# $s(lastproblem) [clock clicks -milliseconds]
+#
+# We don't worry too much about races: in particular, we don't mind
+# racing with other things trying to command the speed, and losing
+# the odd increment/decrement. But since we thread the requested
+# speed via realtime, we do queue up our own increments/decrements
+# while we're executing a speed command, to avoid loss of steps during
+# quick motions.
+
+proc speedw-new {w} {
+ upvar #0 speed/$w s
+ global speedws
+
+ lappend $speedws $w
+ set s(queuedupdown) 0
+
+ frame $w -relief groove
+ set s(optionmenu) [tk_optionMenu $w.train speed/${w}(train) {}]
+ $w.train configure -textvariable {}
+ label $w.speed -width 100
+ label $w.problem -width 300
+ pack $w.problem -side bottom
+ pack $w.speed -side right
+ pack $w.train
+
+ speedw-disable $w "starting"
+}
+
+proc speedw-disable {w whystr} {
+ $w.train configure -state disabled
+ speedw-train-noneselected $w $whystr
+}
+
+proc speedw-train-noneselected {w whystr} {
+ upvar #0 speed/$w s
+ set s(train) {}
+ set s(lastproblem) [clock clicks -milliseconds]
+ $w.train configure -text "($whystr)"
+ $w.speed configure -textvariable {} -text -
+ $w.problem configure -text {}
+}
+proc speedw-train-selected {w t} {
+ upvar #0 speed/$w s
+ set s(queuedupdown) 0
+ $w.train configure -text $t
+ $w.speed configure -text {} -textvariable train_commanded($t)
+ $w.problem configure -text {}
+}
+
+proc speedw-trains-available {w l} {
+ upvar #0 speed/$w s
+ if {![llength $l]} { speedw-set-disabled $w "no trains"; return }
+ $s(optionmenu) delete 0 end
+ $s(optionmenu) add radiobutton -label "(none)" -value {} \
+ -command [list speedw-train-noneselected $w "(no train selected)"]
+ set l [lsort $l]
+ foreach t $l {
+ $s(optionmenu) add radiobutton -label $t -value $t \
+ -command [list speedw-train-selected $w $t]
+ }
+ $w.train configure -state normal
+ if {[llength $l]==1} {
+ $s(optionmenu) invoke 1
+ } elseif {[set ix [lsearch -exact $l $s(train)] >= 0]} {
+ $s(optionmenu) invoke [expr {$ix+1}]
+ } elseif {![string length $s(train)]} {
+ $s(optionmenu) invoke 0
+ } else {
+ $w.train configure -text "$s(train) (not present)"
+ }
+}
+
+proc speedw-report-problem {w message} {
+ upvar #0 speed/$w s
+
+ set s(lastproblem) [clock clicks -milliseconds]
+ $w problem configure -text $message
+}
+
+proc speed-check-sendcommand {} {
+ global speed_commanding speedws
+ if {[info exists speed_commanding]} return
+ for {set i 0} {$i < [llength $speedws]} {incr i} {
+ set w [lindex $speedws $i]
+ upvar #0 speed/$w s
+ if {!$s(queuedupdown)} continue
+ # right:
+ set speedws [lreplace $speedws $i $i]
+ lappend speedws $w
+fixme
+ set newspeed [speedud-calc-newspeed ]
+
+ sconn "speed $s(train) 4"
+ }
+}
+
+proc speed-command-ack {message} {
+ global speed_commanding problemdisplayms
+
+ if {![info exists speed_commanding]} {
+ warning "unexpected ack speed when not commanding"
+ return
+ }
+ set w $speed_commanding
+ unset speed_commanding
+ speed-check-sendcommand
+
+ upvar #0 speed/$w s
+ if {[string compare $train $s(train)]} {
+ warning "unexpected train $train, expected $s(train)"
+ return
+ }
+ if {[string length $message]} {
+ speedw-report-problem $w $message
+ } elseif {[clock clicks -milliseconds] - $s(lastproblem) \
+ > $problemdisplayms} {
+ $w problem configure -text {}
+ }
+}
+
+proc speedws-forall {command args} {
+ global speedws
+ foreach w $speedws { eval [list $command $w] $args }
+}
+
+register-event stastate {state} \
+ {^stastate (\w+|\-) } {
+ global ctrain trains statstate
+
+ set stastate $state
+
+ switch -exact $stastate {
+ Run {
+ set trainsl [array names trains]
+ speedws-forall speedw-trains-available $trainsl
+ }
+ default {
+ catch { unset trains }
+ speedws-forall speedw-disable "($stastate)"
+ }
+ }
+}
+
+register-event ?train_*_speed_commanded {train speed} \
+ {^.train (\w+) speed commanded (\d+) } {
+ upvar #0 train_commanded($train) cmd
+ set cmd $speed
+}
+
+register-event {} {} {^\+ack \S+ speed ok } { speed-command-ack "" }
+register-event {} {train segment message} \
+ {^\+ack \S+ speed \S+ SignallingPredictedProblem (\S+) (\S+) \: (.*) $} {
+ speed-command-ack "$segment $message"
+}
+register-event {} {ecode message} {^\+ack (\S+) speed (.*) $} {
+ speed-command-ack "$ecode: $message"
+}
+
+register-event &train_*_signalling-problem {train problem} \
+ {^\&train (\w+) signalling-problem (.*)$} {
+ global speedws
+ foreach w $speedws {
+ upvar #0 speed/$w s
+ if {![string compare $s(train) $train]} {
+ speedw-report-problem $w $problem
+ }
+ }
+}
+
#---------- plan background (gui-plan subprocess) ----------
proc gui-pipe-readable {args} {
error "lost connection to train set"
}
-register-event {} {} {^=connected} {
+register-event {} {} {^=connected } {
global pages gui_pipe server port event_selections
sconn "select-replay [concat $event_selections]"
}
}
-register-event {} {} {^=failed} { error "multiplexer failed: $l" }
-register-event {} {} {^=denied} { error "multiplexer denied us: $l" }
-register-event {} {} {^\+nack} { error "multiplexer does not understand" }
+register-event {} {} {^=failed } { error "multiplexer failed: $l" }
+register-event {} {} {^=denied } { error "multiplexer denied us: $l" }
+register-event {} {} {^\+nack } { error "multiplexer does not understand" }
#---------- main program ----------
setting geometry {} {[-+]\d+[-+]\d+}
setting posdeviation 10 {\d+}
setting movfeatcommand {movfeat++} {(?:!movfeat|movfeat\+?\+?)}
+ setting problemdisplayms 1000 {\d+}
uplevel #0 source gui-config
parse-argv {}
foreach cpage $pages {
~ijackson / trains.git / commitdiff