From: ian <ian>
Date: Sat, 7 Jun 2008 16:43:51 +0000 (+0000)
Subject: wip; under construction with new speedw and sconn scmd stuff
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ijackson/git?a=commitdiff_plain;h=d0ecb15ccb1c1640a46920259dfb8fbff63474b3;p=trains.git

wip; under construction with new speedw and sconn scmd stuff
---

diff --git a/hostside/gui b/hostside/gui
index fcb22a9..0c0dcf8 100755
--- a/hostside/gui
+++ b/hostside/gui
@@ -9,8 +9,8 @@ source lib.tcl
 proc pagew {page} { return ".picture-$page" }
 
 proc debug {m} { puts $m }
-
 proc warning {m} { puts stderr $m }
+proc fixme {args} { puts stderr "####FIXME##### $args #####FIXME#####" }
 
 proc sconn {m} {
     global sconn
@@ -69,6 +69,56 @@ proc register-event {selections args re body} {
 	    "    }\n"
 }
 
+#---------- handling of commands we issue ----------
+
+proc scmd {onresult ctrlr commandstr args} {
+    # later, calls
+    #   eval [list $onresult-ok|nak|error $ackornakmessage] $args
+    global commands_queued
+    sconn $commandstr
+    lappend commands_queued [list $ctrlr $onresult $args]
+}
+
+proc scmd_result {oknakerr message reporterrtrain 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
+    }
+    eval [list "$onresult-$oknakerr" $message] $args
+}
+
+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
+}
+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 routinecmd-ok {m args} { }
+
+proc mustsucceed-nak {m args} { error "unexpected nak: $m" }
+proc mustsucceed-err {m args} { error "unexpected error: $m" }
+proc mustsucceed-ok {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} {
+    global report_problem_report
+    eval $report_problem_report [list "$ctrlr: $message"]
+    if {[string length $train]} {
+	speedws-train-problem $train
+    }
+}
+
 #---------- movpos (overlay buttons, keybindings, execution) ----------
 
 proc movpos-button-gvars {mid} {
@@ -94,7 +144,7 @@ proc widgets-movpos {} {
 	movpos-button-gvars $mid
 	set w [pagew $cpage].movpos-$mid
 	button $w -text $key -padx 0 -pady 0 -borderwidth 0 \
-		-command [list movpos-invoked $mid]
+		-command [list movpos-invoked $mid "plan $cpage"]
 	movpos-button-setdisplay $mid
     }
 }
@@ -117,14 +167,14 @@ proc movpos-button-setdisplay {mid} {
     place $w -anchor center -x $x -y $y
 }
 
-proc movpos-invoked {mid} {
+proc movpos-invoked {mid ctrlr} {
     global movfeatcommand
     movpos-button-gvars $mid
     switch -exact $posn {
 	0 { set new_posn 1 }
 	default { set new_posn 0 }
     }
-    sconn "$movfeatcommand $seg $feat $new_posn"
+    scmd routinecmd $ctrlr "$movfeatcommand $seg $feat $new_posn"
 }
 
 register-event ?movpos_*_feat {seg feat posn_new} \
@@ -153,7 +203,7 @@ proc movpos-bindkey-1 {cpage key seg feat} {
     upvar #0 mp_details($mid) details
     set details [list $cpage $key $seg $feat $poslocs]
 
-    bind . <Key-[string tolower $key]> [list movpos-invoked $mid]
+    bind . <Key-[string tolower $key]> [list movpos-invoked $mid "keyboard"]
 }
 
 #---------- computation of movpos button locations
@@ -206,13 +256,13 @@ proc layout-data {} {
 
 # 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(queuedupdown)            integer
+#   $s(commanding)              set if we have a speed command in the queue
 #   $s(lastproblem)             [clock clicks -milliseconds]
 #
 # We don't worry too much about races: in particular, we don't mind
@@ -228,6 +278,7 @@ proc speedw-new {w} {
 
     lappend $speedws $w
     set s(queuedupdown) 0
+    set s(commanding) 0
 
     frame $w -relief groove
     set s(optionmenu) [tk_optionMenu $w.train speed/${w}(train) {}]
@@ -292,8 +343,8 @@ proc speedw-report-problem {w message} {
     $w problem configure -text $message
 }
 
-proc speed-check-sendcommand {} {
-    global speed_commanding speedws
+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]
@@ -305,7 +356,7 @@ proc speed-check-sendcommand {} {
 fixme
 	set newspeed [speedud-calc-newspeed ]
 
-	sconn "speed $s(train) 4"
+	scmd fixme fixme "speed $s(train) 4"
     }
 }
 
@@ -338,6 +389,13 @@ proc speedws-forall {command args} {
     foreach w $speedws { eval [list $command $w] $args }
 }
 
+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
@@ -404,7 +462,7 @@ proc train-event-eof {args} {
 register-event {} {} {^=connected } {
     global pages gui_pipe server port event_selections
 
-    sconn "select-replay [concat $event_selections]"
+    scmd mustsucceed {} "select-replay [concat $event_selections]"
 
     foreach page $pages {
 	set w [pagew $page]