#!/usr/bin/wishx
+#---------- general utilities ----------
+
source lib.tcl
proc pagew {page} { return ".picture-$page" }
pack $w
}
+proc bgerror {emsg} {
+ global errorCode errorInfo
+ catch {
+ puts stderr "UNEXPECTED BACKGROUND ERROR\n"
+ puts stderr "$errorCode\n$errorInfo\n$emsg"
+ }
+ exit 16
+}
+
+#---------- train set event registraton ----------
+
+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"
+}
+
+#---------- movpos (overlay buttons, keybindings, execution) ----------
+
proc movpos-button-gvars {mid} {
upvar #0 mp_details($mid) details
if {![info exists details]} { return 0 }
place $w -anchor center -x $x -y $y
}
-proc bgerror {emsg} {
- global errorCode errorInfo
- catch {
- puts stderr "UNEXPECTED BACKGROUND ERROR\n"
- puts stderr "$errorCode\n$errorInfo\n$emsg"
- }
- exit 16
-}
-
-proc gui-pipe-readable {args} {
- global gui_pipe
- while {[gets $gui_pipe l] >= 0} {
- debug "<gui-plan $l"
- }
- if {[eof $gui_pipe]} {
- close $gui_pipe
- error "gui-plan crashed"
- }
-}
-
proc movpos-invoked {mid} {
global movfeatcommand
movpos-button-gvars $mid
sconn "$movfeatcommand $seg $feat $new_posn"
}
-proc train-event-eof {} {
- error "lost connection to train set"
-}
-
-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
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]
- 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
+proc movpos-bindkey-1 {cpage key seg feat} {
+ global posdeviation
+ manyset [subseg-end-get-centroid $cpage $seg $feat {}] mx my
+ set mid $seg/$feat
+ 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 {$posdeviation / ($d + 1e-6)}]
+ set x [expr {$mx + $mul*$dx}]
+ set y [expr {$my + $mul*$dy}]
+ lappend poslocs [list $x $y]
}
-}
-
-register-event {^=failed} {} { error "multiplexer failed: $l" }
-register-event {^=denied} {} { error "multiplexer denied us: $l" }
-# register-event {^\+nack} {} { error "multiplexer does not understand" }
+ lappend poslocs [list $mx $my]
+ upvar #0 mp_details($mid) details
+ set details [list $cpage $key $seg $feat $poslocs]
-append event_dispatch_body {
- debug "ignored $l"
+ bind . <Key-[string tolower $key]> [list movpos-invoked $mid]
}
-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
-}
+#---------- computation of movpos button locations
proc layout-subseg-end {seg feat posn x y} {
global cpage
return [list [expr {$sx * 1.0 / $n}] [expr {$sy * 1.0 / $n}]]
}
-proc movpos-bindkey-1 {cpage key seg feat} {
- global posdeviation
- manyset [subseg-end-get-centroid $cpage $seg $feat {}] mx my
- set mid $seg/$feat
- 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 {$posdeviation / ($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]
-
- bind . <Key-[string tolower $key]> [list movpos-invoked $mid]
-}
-
proc layout-data {} {
global cpage
upvar #0 ld_sse/$cpage sse
}
}
+#---------- plan background (gui-plan subprocess) ----------
+
+proc gui-pipe-readable {args} {
+ global gui_pipe
+ while {[gets $gui_pipe l] >= 0} {
+ debug "<gui-plan $l"
+ }
+ if {[eof $gui_pipe]} {
+ close $gui_pipe
+ error "gui-plan crashed"
+ }
+}
+
+#---------- train set events of general interest, and setup ----------
+
+proc train-event-eof {} {
+ error "lost connection to train set"
+}
+
+register-event {^=connected} {} {
+ global pages gui_pipe server port
+
+ sconn "select-replay ?movpos_*_feat"
+
+ 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
+ }
+}
+
+register-event {^=failed} {} { error "multiplexer failed: $l" }
+register-event {^=denied} {} { error "multiplexer denied us: $l" }
+register-event {^\+nack} {} { error "multiplexer does not understand" }
+
+#---------- main program ----------
+
+append event_dispatch_body {
+ debug "ignored $l"
+}
+proc train-event-inputline {sconn l} $event_dispatch_body
+proc register-event {args} { error "too late!" }
+
+proc engage {} {
+ global server port sconn
+
+ set sconn [socket $server $port]
+ fconfig-trainproto $sconn
+ fileevent $sconn readable {readable train-event $sconn}
+
+ start_commandloop
+}
+
proc main {} {
global pages cpage
setting server railway {[[0-9a-z:].*}
~ijackson / trains.git / commitdiff