From: ian <ian>
Date: Sun, 1 Jun 2008 19:46:19 +0000 (+0000)
Subject: overlay locations put movpos buttons in right places etcl.
X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~ijackson/git?a=commitdiff_plain;h=295914c92fda545c2ff8a263da4aaad5109cc633;p=trains.git

overlay locations put movpos buttons in right places etcl.
---

diff --git a/hostside/gui b/hostside/gui
index 1e17c59..2036083 100755
--- a/hostside/gui
+++ b/hostside/gui
@@ -2,13 +2,56 @@
 
 source lib.tcl
 
-proc widgets {} {
-    set sizes [exec ./gui-plan-bot --sizes]
-    frame .picture -background {} \
+proc pagew {page} { return ".picture-$page" }
+
+proc widgets-dgram {} {
+    global cpage geometry
+    if {[string length $geometry]} { wm geometry . $geometry }
+    set sizes [exec ./gui-plan-$cpage --sizes]
+    set w [pagew $cpage]
+    frame $w -background {} \
 	    -width [lindex $sizes 0] \
 	    -height [lindex $sizes 1]
-    pack .picture
-    tkwait visibility .picture
+    pack $w
+}
+
+proc movpos-button-gvars {mid} {
+    upvar #0 mp_details($mid) details
+    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]
+}
+
+proc widgets-movpos {} {
+    global mp_details
+    foreach mid [array names mp_details] {
+	upvar #0 mp_state($mid) state
+	set state {? stable}
+	movpos-button-gvars $mid
+	set w [pagew $cpage].movpos-$mid
+	button $w -text $key -command [list movpos-invoked $mid]
+	movpos-button-setdisplay $mid
+    }
+}
+
+proc movpos-button-setdisplay {mid} {
+    # we want to display as much of these as possible:
+    #   position known ?   (actual position is done by button location)
+    #   moving or stable
+    #   whether a train's plan includes a different position
+    #   whether autopoint
+    movpos-button-gvars $mid
+    set fg black
+    set bg white
+    $w configure -background $bg -foreground $fg \
+	    -activebackground $bg -activeforeground $fg
+    switch -exact $posn {
+	? { manyset [lindex $poslocs 2] x y }
+	default { manyset [lindex $poslocs $posn] x y }
+    }
+    place $w -anchor center -x $x -y $y
+puts "    place $w -anchor center -x $x -y $y"
 }
 
 proc bgerror {emsg} {
@@ -32,27 +75,105 @@ proc gui-pipe-readable {args} {
 }
 
 proc engage {} {
-    global gui_pipe server port
+    global gui_pipe server port pages
     global sconn
 
     set sconn [socket $server $port]
     fconfig-trainproto $sconn
 
-    set cmdl [list ./gui-plan-bot [winfo id .picture] @$server,$port]
-    lappend cmdl 2>@ stderr
-    set gui_pipe [open |$cmdl r]
+    foreach page $pages {
+	set w [pagew $page]
+	tkwait visibility $w
+
+	set cmdl [list ./gui-plan-$page [winfo id $w] @$server,$port]
+	lappend cmdl 2>@ stderr
+	set gui_pipe [open |$cmdl r]
 
-    puts stderr "running $cmdl"
-    fconfigure $gui_pipe -blocking no
-    fileevent $gui_pipe readable gui-pipe-readable
+	puts stderr "running $cmdl"
+	fconfigure $gui_pipe -blocking no
+	fileevent $gui_pipe readable gui-pipe-readable
+    }
 
     start_commandloop
 }
 
+proc layout-subseg-end {seg feat posn x y} {
+    global cpage
+    upvar #0 ld_sse/${cpage}($seg/$feat$posn) sse
+    if {![info exists sse]} { set sse {0 0 0} }
+    manyset $sse n sx sy
+    incr n
+    set sx [expr {$sx + $x}]
+    set sy [expr {$sy + $y}]
+    set sse [list $n $sx $sy]
+ puts "$cpage $seg $feat $posn  $x $y : $sse"
+    if {[string length $posn]} { layout-subseg-end $seg $feat {} $x $y }
+}
+
+proc subseg-end-get-centroid {cpage seg feat posn} {
+    upvar #0 ld_sse/${cpage}($seg/$feat$posn) sse
+    if {![info exists sse]} {
+	puts "skipping binding of unknown $seg/$feat$posn"
+	return -code return
+    }
+    manyset $sse n sx sy
+    return [list [expr {$sx * 1.0 / $n}] [expr {$sy * 1.0 / $n}]]
+}
+
+proc movpos-bindkey-1 {cpage key seg feat} {
+    manyset [subseg-end-get-centroid $cpage $seg $feat 0] 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 x [expr {$mx + $mul*$dx}]
+	set y [expr {$my + $mul*$dy}]
+	lappend poslocs [list $x $y]
+    }
+    lappend poslocs [list $mx $my]
+    upvar #0 mp_details($mid) details
+    set details [list $cpage $key $seg $feat $poslocs]
+ puts "$mid  $details"
+}
+
+proc layout-data {} {
+    global cpage
+    upvar #0 ld_sse/$cpage sse
+    catch { unset sse }
+    set f ../layout/ours.dgram-$cpage.overlay-info
+    puts $f
+    source $f
+
+    upvar #0 movpos_bindings($cpage) bindings
+    if {![info exists bindings]} {
+	puts "no movpos bindings for $cpage"
+	return
+    }
+    foreach binding $bindings {
+	if {[regexp {^([A-Z])\=(\w+)/([A-Z]+)$} $binding dummy key seg feat]} {
+	    movpos-bindkey-1 $cpage $key $seg $feat
+	} elseif {[regexp {^[A-Z]$} $binding] || [regexp {~} $binding]} {
+	} else {
+	    error "incomprehensible binding $binding on page $cpage"
+	}
+    }
+}
+
 proc main {} {
+    global pages cpage
     setting server railway {[[0-9a-z:].*}
+    setting geometry {} {[-+]\d+[-+]\d+}
+    uplevel #0 source gui-config
     parse-argv {}
-    widgets
+    foreach cpage $pages {
+	layout-data
+	widgets-dgram
+    }
+    unset cpage
+    widgets-movpos
     engage
 }
 
diff --git a/hostside/gui-config b/hostside/gui-config
index e8bbc45..c7a4bc3 100644
--- a/hostside/gui-config
+++ b/hostside/gui-config
@@ -1,3 +1,9 @@
-movpos
-
+set pages {bot}
+set movpos_bindings(bot) {
+	Q	W	E	R=A6/J	T=A6/P	Y=X8/P
+					G=A2/P	H=X2/R
+	Z	X	C	V=A5/J	B=A5/P	N=X7/P
 
+	J		I	O
+	M		K	L
+}
diff --git a/hostside/lib.tcl b/hostside/lib.tcl
index 8367d7c..36c7430 100644
--- a/hostside/lib.tcl
+++ b/hostside/lib.tcl
@@ -1,4 +1,8 @@
 
+proc manyset {list args} {
+    foreach val $list var $args { upvar 1 $var my; set my $val }
+}
+
 proc start_commandloop {} {
     commandloop -async -prompt1 { return "% " } -prompt2 { return "> " }
 }