overlay locations put movpos buttons in right places etcl.

diff --git a/hostside/gui b/hostside/gui
index 1e17c594231d9bbe4cabd0c631db1b1b464f629d..2036083139682c1b5c805adcc99dbe02a88226e5 100755 (executable)
--- 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 e8bbc45fda5efdef3749b3ffeae85fa7c17bf515..c7a4bc3421e670ae9deb137e1f7975446e3e4e05 100644 (file)
--- 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 8367d7c785fb4cab56c0c235ad48d71562e5a3fc..36c74302f28962aceaeb3852e15b96ee248be1f2 100644 (file)
--- 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 "> " }
 }