From e7b19054d26846a4f66ce7d49c0c532d0e38b1f1 Mon Sep 17 00:00:00 2001
From: ian <ian>
Date: Sat, 7 Jun 2008 19:16:25 +0000
Subject: [PATCH] wip gui

---
 hostside/gui | 230 +++++++++++++++++++++++++++------------------------
 1 file changed, 123 insertions(+), 107 deletions(-)

diff --git a/hostside/gui b/hostside/gui
index 0c0dcf8..c0ecf25 100755
--- a/hostside/gui
+++ b/hostside/gui
@@ -79,26 +79,23 @@ proc scmd {onresult ctrlr commandstr args} {
     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} { }
@@ -111,12 +108,9 @@ 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} {
+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) ----------
@@ -259,11 +253,16 @@ proc layout-data {} {
 #   $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
@@ -272,45 +271,76 @@ proc layout-data {} {
 # 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} {
@@ -336,82 +366,58 @@ 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} \
@@ -420,24 +426,22 @@ 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) ----------
@@ -459,6 +463,18 @@ proc train-event-eof {args} {
     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
 
-- 
2.30.2