From: ian <ian>
Date: Sun, 1 Jun 2008 21:25:46 +0000 (+0000)
Subject: more or less proper placement of movpos letters
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ijackson/git?a=commitdiff_plain;h=664ea3d4ff0fea4303dd71df0ef7d3c897a547eb;p=trains.git

more or less proper placement of movpos letters
---

diff --git a/hostside/gui b/hostside/gui
index 2036083..c864504 100755
--- a/hostside/gui
+++ b/hostside/gui
@@ -4,6 +4,14 @@ source lib.tcl
 
 proc pagew {page} { return ".picture-$page" }
 
+proc debug {m} { puts $m }
+
+proc sconn {m} {
+    global sconn
+    puts "=> $m"
+    puts $sconn $m
+}
+
 proc widgets-dgram {} {
     global cpage geometry
     if {[string length $geometry]} { wm geometry . $geometry }
@@ -17,20 +25,28 @@ proc widgets-dgram {} {
 
 proc movpos-button-gvars {mid} {
     upvar #0 mp_details($mid) details
+    if {![info exists details]} { return 0 }
     uplevel 1 [list manyset $details cpage key seg feat poslocs]
     uplevel 1 { set w [pagew $cpage].movpos-$mid }
     upvar #0 mp_state($mid) state
-    uplevel 1 [list manyset $state posn moving]
+    uplevel 1 [list manyset $state posn]
+    return 1
+}
+
+proc movpos-button-sstate {mid} {
+    upvar #0 mp_state($mid) state
+    set state [uplevel 1 { list $posn } ]
 }
 
 proc widgets-movpos {} {
     global mp_details
     foreach mid [array names mp_details] {
 	upvar #0 mp_state($mid) state
-	set state {? stable}
+	set state {?}
 	movpos-button-gvars $mid
 	set w [pagew $cpage].movpos-$mid
-	button $w -text $key -command [list movpos-invoked $mid]
+	button $w -text $key -padx 0 -pady 0 -borderwidth 0 \
+		-command [list movpos-invoked $mid]
 	movpos-button-setdisplay $mid
     }
 }
@@ -42,8 +58,8 @@ proc movpos-button-setdisplay {mid} {
     #   whether a train's plan includes a different position
     #   whether autopoint
     movpos-button-gvars $mid
-    set fg black
-    set bg white
+    set fg white
+    set bg black
     $w configure -background $bg -foreground $fg \
 	    -activebackground $bg -activeforeground $fg
     switch -exact $posn {
@@ -51,7 +67,7 @@ proc movpos-button-setdisplay {mid} {
 	default { manyset [lindex $poslocs $posn] x y }
     }
     place $w -anchor center -x $x -y $y
-puts "    place $w -anchor center -x $x -y $y"
+puts "  $key $posn   place $w -anchor center -x $x -y $y"
 }
 
 proc bgerror {emsg} {
@@ -74,12 +90,45 @@ proc gui-pipe-readable {args} {
     }
 }
 
-proc engage {} {
-    global gui_pipe server port pages
-    global sconn
+proc train-event-eof {} {
+    error "lost connection to train set"
+}
 
-    set sconn [socket $server $port]
-    fconfig-trainproto $sconn
+set event_dispatch_body {}
+
+proc register-event {re args body} {
+    global event_dispatch_body
+    regsub -all {\W+} $re - proc
+    set proc "event/$proc/[join $args -]"
+    set suffix {}
+    set number 0
+    while {![catch { info args $proc$suffix }]} { set suffix [incr number] }
+    append proc $suffix
+	
+    proc $proc [concat l $args] $body
+    set al ""
+    foreach a $args { append al " \$$a" }
+
+    append event_dispatch_body \
+	    "    if {\[regexp [list $re] \$l dummy $args]} {\n" \
+	    "        debug \"$proc$al\"\n" \
+	    "        eval [list $proc] \[list \$l$al]\n" \
+	    "        return\n" \
+	    "    }\n"
+}
+
+register-event {^.movpos (\w+) feat (\w+) ([01]|\?) } {seg feat posn_new} {
+    set mid $seg/$feat
+    if {![movpos-button-gvars $mid]} return
+    set posn $posn_new
+    movpos-button-sstate $mid
+    movpos-button-setdisplay $mid
+}
+
+register-event {^=connected} {} {
+    global pages gui_pipe server port
+
+    sconn "select-replay ?movpos_*_feat"
 
     foreach page $pages {
 	set w [pagew $page]
@@ -93,6 +142,23 @@ proc engage {} {
 	fconfigure $gui_pipe -blocking no
 	fileevent $gui_pipe readable gui-pipe-readable
     }
+}
+
+register-event {^=failed} {} { error "multiplexer failed: $l" }
+register-event {^=denied} {} { error "multiplexer denied us: $l" }
+
+append event_dispatch_body {
+    puts "ignored $l"
+}
+
+proc train-event-inputline {sconn l} $event_dispatch_body
+
+proc engage {} {
+    global server port sconn
+
+    set sconn [socket $server $port]
+    fconfig-trainproto $sconn
+    fileevent $sconn readable {readable train-event $sconn}
 
     start_commandloop
 }
@@ -121,14 +187,15 @@ proc subseg-end-get-centroid {cpage seg feat posn} {
 }
 
 proc movpos-bindkey-1 {cpage key seg feat} {
-    manyset [subseg-end-get-centroid $cpage $seg $feat 0] mx my
+    global posdeviation
+    manyset [subseg-end-get-centroid $cpage $seg $feat {}] mx my
     set mid $seg/$feat
  puts "$mid centroid $mx $my"
     foreach posn {0 1} {
 	manyset [subseg-end-get-centroid $cpage $seg $feat $posn] x y
 	set dx [expr {$x-$mx}]; set dy [expr {$y-$my}]
 	set d [expr {sqrt($dx*$dx + $dy*$dy)}]
-	set mul [expr {10.0 / ($d + 1e-6)}]
+	set mul [expr {$posdeviation / ($d + 1e-6)}]
 	set x [expr {$mx + $mul*$dx}]
 	set y [expr {$my + $mul*$dy}]
 	lappend poslocs [list $x $y]
@@ -166,6 +233,7 @@ proc main {} {
     global pages cpage
     setting server railway {[[0-9a-z:].*}
     setting geometry {} {[-+]\d+[-+]\d+}
+    setting posdeviation 10 {\d+}
     uplevel #0 source gui-config
     parse-argv {}
     foreach cpage $pages {
diff --git a/hostside/gui-plan-testdata b/hostside/gui-plan-testdata
index 2c72d4a..064bad2 100644
--- a/hostside/gui-plan-testdata
+++ b/hostside/gui-plan-testdata
@@ -8,5 +8,5 @@ movpos X7 feat P ? point
 movpos X7 gunk P 1 point
 movpos A5 feat P 2 point
 movpos Q0 feat Q 0 two
-movpos X8 feat Q 0 three
+movpos X8 feat P 0 three
 picio out polarity <X2,X3,X4,Q3>
diff --git a/hostside/lib.tcl b/hostside/lib.tcl
index 36c7430..33c14ac 100644
--- a/hostside/lib.tcl
+++ b/hostside/lib.tcl
@@ -24,6 +24,11 @@ proc setting {varname defvalue regexp} {
     set re $regexp
 }
 
+proc readable {whatfor conn} {
+    while {[gets $conn l]>=0} { $whatfor-inputline $conn $l }
+    if {[eof $conn]} { $whatfor-eof $conn }
+}
+
 proc parse-argv {formalargs} {
     # formalargs: list; if list is [list *] then any is allowed
     # sets argv to list of non-option args
diff --git a/hostside/multiplex b/hostside/multiplex
index 3aaca94..1b97aba 100755
--- a/hostside/multiplex
+++ b/hostside/multiplex
@@ -338,11 +338,6 @@ proc client-disable-readable {conn} {
 
 #---------- general IO ----------
 
-proc readable {whatfor conn} {
-    while {[gets $conn l]>=0} { $whatfor-inputline $conn $l }
-    if {[eof $conn]} { $whatfor-eof $conn }
-}
-
 proc xmit-puts {conn msg} {
     global conns errorInfo
     if {![info exists conns($conn)]} return