From: ian <ian>
Date: Fri, 6 Jun 2008 20:57:52 +0000 (+0000)
Subject: wip, speed stuff
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ijackson/git?a=commitdiff_plain;h=8b73b8b32b4581c2ae372404e1b32616a0c94f01;p=trains.git

wip, speed stuff
---

diff --git a/hostside/gui b/hostside/gui
index 8045697..afcfb30 100755
--- a/hostside/gui
+++ b/hostside/gui
@@ -2,12 +2,16 @@
 
 #---------- 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"
@@ -36,7 +40,9 @@ proc bgerror {emsg} {
 
 #---------- train set event registraton ----------
 
-set event_dispatch_body {}
+set event_dispatch_body {
+    append l " "
+}
 set event_selections {}
 
 proc register-event {selections args re body} {
@@ -196,6 +202,186 @@ proc layout-data {} {
     }
 }
 
+#---------- 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} {
@@ -215,7 +401,7 @@ proc train-event-eof {} {
     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]"
@@ -234,9 +420,9 @@ register-event {} {} {^=connected} {
     }
 }
 
-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 ----------
 
@@ -262,6 +448,7 @@ proc main {} {
     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 {
diff --git a/hostside/gui-plan-testdata b/hostside/gui-plan-testdata
index 58fb7f3..27db520 100644
--- a/hostside/gui-plan-testdata
+++ b/hostside/gui-plan-testdata
@@ -1,3 +1,4 @@
+stastate -
 train shinkansen has X7/P0. X5. X6. Q1. X8/P0.! X10* X12 Q2 A6/P0
 picio out on
 detect X8 1
@@ -11,3 +12,4 @@ movpos Q0 feat Q 0 two
 movpos X8 feat P 0 three
 picio out polarity <X2,X3,X4,Q3>
 train shinkansen speed commanded 100
+stastate Run