lappend commands_queued [list $ctrlr $onresult $args]
}
-proc scmd_result {oknakerr message reporterrtrain reporterrmsg} {
+proc scmd_result {oknakerr message reporterrmsg} {
global commands_queued
manyset [lindex $commands_queued 0] ctrlr onresult args
set commands_queued [lrange $commands_queued 1 end]
if {[string length $reporterrmsg]} {
- report-problem $ctrlr $reporterrtrain $reporterrmsg
+ report-problem "$ctrlr: $reporterrmsg"
}
eval [list "$onresult-$oknakerr" $message] $args
}
-register-event {} {} {^\+ack \S+ ok } { scmd_result ok $l {} "" }
+register-event {} {} {^\+ack \S+ ok } { scmd_result ok $l "" }
register-event {} {train segment error} \
{^\+ack \S+ SignallingPredictedProblem (\S+) (\S+) \: (.*) $} {
- set m $train
- if {![string compare - $segment]} { append m " at " $segment }
- append m ": " $error
- scmd_result err $l $train $m
+ scmd_result err $l "$train @$segment: $error"
}
-register-event {} {} {^\+ack } { scmd_result err $l {} $l }
-register-event {} {} {^\+nack \S+ } { scmd_result nak $l {} $l }
+register-event {} {} {^\+ack } { scmd_result err $l $l }
+register-event {} {} {^\+nack \S+ } { scmd_result nak $l $l }
proc routinecmd-nak {m args} { error "got nak to routine command: $m" }
proc routinecmd-err {m args} { }
proc report-problem-report-stderr {m} { puts stderr "*** $m" }
set report_problem_report report-problem-report-stderr
-proc report-problem {ctrlr train message} {
+proc report-problem {message} {
global report_problem_report
- eval $report_problem_report [list "$ctrlr: $message"]
- if {[string length $train]} {
- speedws-train-problem $train
- }
+ eval $report_problem_report [list $message]
}
#---------- movpos (overlay buttons, keybindings, execution) ----------
# $speedws [list $w ...]
#
# speed/${w}(...) aka s(...):
+# $s(ctrlr) controller
# $s(train) train selected, or something not \w+
# $s(optionmenu) optionmenu widget name
-# $s(queuedupdown) integer
-# $s(commanding) set if we have a speed command in the queue
-# $s(lastproblem) [clock clicks -milliseconds]
+# $s(kind) abs or rel
+# $s(commanding) step of command we have scmd'd, or unset
+# $s(queued) step of command we would like to queue
+# or unset if n/a
+# $s(inhibit) 0 all is well, can command any speed
+# 1 train newly selected, only rel can command higher speed
+# 2 can only command same or lower speed
#
# 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
# while we're executing a speed command, to avoid loss of steps during
# quick motions.
-proc speedw-new {w} {
+# for rel speedws:
+# $s(stepmap) from creator
+
+# Interfaces for concrete controllers:
+# speedw-new $w $ctrlr {stepmap}
+# speedw-setstate $w enabled|disabled controller appears/disappears
+# speedw-userinput-abs $w $step
+# speedw-userinput-rel $w $stepmap
+# where
+# eval {stepmap} [list $oldstep] => $newstep
+
+proc speedws-forall {command args} {
+ global speedws
+ foreach w $speedws { eval [list $command $w] $args }
+}
+
+proc speedw-new {w ctrlr} {
upvar #0 speed/$w s
global speedws
lappend $speedws $w
- set s(queuedupdown) 0
+ set s(ctrlr) $ctrlr
+ set s(inhibit) 0
set s(commanding) 0
frame $w -relief groove
+ label $w.ctrlr -state disabled -text $s(ctrlr)
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
+ $w.train configure -textvariable {} -width 100
+ label $w.speed -state disabled -width 40 \
+ -font -*-courier-bold-r-*-*-20-*-*-*-*-*-*-* \
+ -background black -foreground white
+ pack $w.ctrlr $w.train $w.speed -side left
- speedw-disable $w "starting"
+ speedw-notrains $w
}
-
-proc speedw-disable {w whystr} {
+proc speedw-notrains {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 {}
+ speedw-inhibit $w
+}
+
+proc speedw-inhibit {w} {
+ upvar #0 speed/$w s
+ set s(inhibit) 2
+ $w.speed configure -foreground red
+}
+proc speedw-uninhibit {w} {
+ upvar #0 speed/$w s
+ set s(inhibit) 0
+ $w.speed configure -foreground white
}
+
+proc speedw-setstate {w enadis} {
+ $w.ctrlr configure -state $enadis
+ $w.speed configure -state $enadis -
+}
+
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 {}
+ set s(inhibit) 1
+ $w.speed configure -foreground white
}
proc speedw-trains-available {w l} {
}
}
-proc speedw-report-problem {w message} {
+proc speedw-userinput-abs {w speed} {
upvar #0 speed/$w s
-
- set s(lastproblem) [clock clicks -milliseconds]
- $w problem configure -text $message
+ if {![string length $s(train)]} return
+ set $s(queued) $speed
+ speedw-check
}
-proc speedw-check-sendcommand {w} {
- global 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 ]
-
- scmd fixme fixme "speed $s(train) 4"
+proc speedw-check {w} {
+ upvar #0 speed/$w s
+ upvar #0 train_commanded($s(train)) gcommanded
+ if {[info exists s(commanding)]} return
+ if {![info exists s(queued)]} return
+ set newspeed $s(queued)
+ unset s(queued)
+ if {$s(inhibit)} {
+ if {$newspeed > $gcommanded} return
+ speedw-uninhibit $w
}
+ set s(commanding) $newspeed
+ scmd speedw-commanded $s(ctrlr) "speed $s(train) $newspeed" $w
}
-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
-
+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-err {m w} {
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 {}
- }
+ unset s(commanding)
+ speedw-inhibit $w
}
-proc speedws-forall {command args} {
- global speedws
- foreach w $speedws { eval [list $command $w] $args }
+proc speedw-userinput-rel {w stepmap} {
+ upvar #0 speed/$w s
+ if {![string length $s(train)]} return
+ upvar #0 train_commanded($s(train)) gcommanded
+ if {[info exists s(queued)]} {
+ set oldspeed $s(queued)
+ } elseif {[info exists s(commanding)]} {
+ set oldspeed $s(commanding)
+ } else {
+ set oldspeed $gcommanded
+ }
+ set newspeed [eval $s(stepmap) [list $oldspeed]]
+ speedw-userinput-abs $w $newspeed
}
proc speedws-train-problem {train} {
speedws-forall speedw-train-problem $train
}
proc speedw-train-problem {w train} {
- fixme "prevent forthcoming speed increase requests for just a bit"
-}
-
-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)"
- }
- }
+ upvar #0 speed/$w s
+ if {[string compare $s(train) $train]} return
+ speedw-inhibit $w
}
register-event ?train_*_speed_commanded {train speed} \
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"
+proc speedws-stastate-run {} {
+ global train_commanded
+ speedws-forall speedw-trains-available [array names train_commanded]
}
-register-event {} {ecode message} {^\+ack (\S+) speed (.*) $} {
- speed-command-ack "$ecode: $message"
+proc speedws-stastate-not-run {} {
+ global train_commanded
+ catch { unset train_commanded }
+ speedws-forall speedw-notrains "($stastate)"
}
register-event &train_*_signalling-problem {train problem} \
- {^\&train (\w+) signalling-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
- }
- }
+ regsub {^(\S+) (\S+) \: } $problem {\1 @\2: } problem
+ report-problem "event: $problem"
+ speedws-train-problem $train
}
#---------- plan background (gui-plan subprocess) ----------
error "lost connection to train set"
}
+register-event stastate {state} \
+ {^.stastate (\w+|\-) } {
+ global ctrain trains statstate
+
+ set stastate $state
+
+ switch -exact $stastate {
+ Run { speedws-stastate-run }
+ default { speedws-stastate-not-run }
+ }
+}
+
register-event {} {} {^=connected } {
global pages gui_pipe server port event_selections
~ijackson / trains.git / commitdiff