#!/usr/bin/wishx

load chiark_tcl_hbytes-1.so

#---------- general utilities ----------

set tk_strictMotif 1

tk_setPalette background black foreground white

source lib.tcl

set default_speedstep_list {0 1 10 20 35 50 65 80 95 110 126}

set picturepadx 10
set picturepady 10

proc pagew {page} { return ".picture-$page" }
proc debug {m} { puts $m }

proc sconn {m} {
    global sconn
    debug "=> $m"
    puts $sconn $m
}

proc widgets-dgram {} {
    global cpage geometry picturepadx picturepady
    if {[string length $geometry]} { wm geometry . $geometry }
    set sizes [exec ./gui-plan-$cpage --sizes]
    set w [pagew $cpage]
    frame $w
    frame $w.picture -background {} \
	    -width [lindex $sizes 0] \
	    -height [lindex $sizes 1]
    pack $w.picture -padx $picturepadx -pady $picturepady
    pack $w
}

proc widgets-fullscreen-nowm {} {
    pack propagate . false
    foreach wh {width height} {
	. configure -$wh [winfo screen$wh .]
    }
}

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 {
    append l " "
}
set event_selections {}

proc register-event {selections args re body} {
    global event_dispatch_body event_selections

    eval lappend event_selections $selections

    foreach selection $selections {
	if {[regexp {^\w} $selection]} {
	    error "selection $selection lacks context char"
	}
    }
    if {[regexp {^\^\w} $re]} {
	error "re $re never matches context char"
    }

    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"
}

#---------- handling of commands we issue ----------

proc scmd {onresult ctrlr commandstr args} {
    # later, calls
    #   eval [list $onresult-ok|nak|error $ackornakmessage] $args
    global commands_queued
    sconn $commandstr
    lappend commands_queued [list $ctrlr $onresult $args]
}

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: $reporterrmsg"
    }
    set proc "$onresult-$oknakerr"
    if {![string compare $oknakerr nak] && [catch { info args $proc }]} {
	set proc "$onresult-err"
    }
    eval [list $proc $message] $args
}

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 " @$segment" }
    append m ": $error"
    scmd_result err $l $m
}
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} { }
proc routinecmd-ok {m args} { }

proc mustsucceed-err {m args} { error "unexpected error: $m" }
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 {message} {
    global report_problem_report
    eval $report_problem_report [list $message]
}

proc widget-problem-report {} {
    global problem_reports report_problem_report
    set problem_reports "\n\n\n\n\n"
    label .problem-report -anchor w -justify left -takefocus 0 \
	    -border 2 -relief sunken -width 80 -textvariable problem_reports
    pack .problem-report -side top
    set report_problem_report report-problem-report-widget
}

proc report-problem-report-widget {m} {
    global problem_reports
    set problem_reports [join [concat \
	        [lrange [split $problem_reports "\n"] 1 end] \
	        [list $m] \
	    ] "\n"]
}

#---------- movpos (overlay buttons, keybindings, execution) ----------

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]
    return 1
}

proc movpos-button-sstate {mid posn} {
    upvar #0 mp_state($mid) state
    set state $posn
    movpos-button-setdisplay $mid
}

proc movpos-all-unknown {} {
    global mp_details
    foreach mid [array names mp_details] {
	movpos-button-sstate $mid ?
    }
}

proc widgets-movpos {} {
    global mp_details
    foreach mid [array names mp_details] {
	upvar #0 mp_state($mid) state
	set state {?}
	movpos-button-gvars $mid
	set w [pagew $cpage].movpos-$mid
	button $w -text $key -padx 0 -pady 0 -borderwidth 0 \
		-command [list movpos-invoked $mid "plan $cpage"]
	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
    switch -exact $posn {
	?       { set poslocn 2;     set fg black; set bg white }
	default { set poslocn $posn; set fg white; set bg black }
    }
    $w configure -background $bg -foreground $fg \
	    -activebackground $bg -activeforeground $fg
    manyset [lindex $poslocs $poslocn] x y
    place $w -anchor center -x $x -y $y
}

proc movpos-invoked {mid ctrlr} {
    global movfeatcommand
    movpos-button-gvars $mid
    switch -exact $posn {
	0 { set new_posn 1 }
	default { set new_posn 0 }
    }
    scmd routinecmd $ctrlr "$movfeatcommand $seg $feat $new_posn"
}

register-event ?movpos_*_feat {seg feat posn_new} \
	{^.movpos (\w+) feat (\w+) ([01]|\?) } {
    set mid $seg/$feat
    if {![movpos-button-gvars $mid]} return
    set posn $posn_new
    movpos-button-sstate $mid $posn
}

proc movpos-bindkey-1 {cpage key seg feat adj0x adj0y adj1x adj1y} {
    global posdeviation picturepadx picturepady
    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 + $picturepadx + [set adj${posn}x]}]
	set y [expr {$my + $mul*$dy + $picturepady + [set adj${posn}y]}]
	lappend poslocs [list $x $y]
    }
    lappend poslocs [list [expr {$mx + $picturepadx + ($adj0x+$adj1x)*0.5}] \
			  [expr {$my + $picturepady + ($adj0y+$adj1y)*0.5}]]
    upvar #0 mp_details($mid) details
    set details [list $cpage $key $seg $feat $poslocs]

    bind . <Key-[string tolower $key]> [list movpos-invoked $mid "keyboard"]
}

#---------- computation of movpos button locations

proc layout-subseg-featmap {seg concfeatpos args} {
    global subsegfeatmap
    set subsegfeatmap($concfeatpos) $args
}
    
proc layout-subseg-end {seg feat posn x y} {
    global cpage
    upvar #0 subsegfeatmap($feat$posn) mapped
    if {[info exists mapped]} {
	foreach {feat posn} $mapped {
	    layout-subseg-end $seg $feat $posn $x $y
	}
	return
    }
    upvar #0 ld_sse/${cpage}($seg/$feat$posn) sse
    if {![info exists sse]} { set sse {{} {}} }
    manyset $sse lx ly
    lappend lx $x
    lappend ly $y
    set sse [list $lx $ly]
    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 lx ly
    set sx 0; set sy 0; set n [llength $lx]
    foreach x $lx y $ly { addexpr sx {$x}; addexpr sy {$y} }
    return [list [expr {$sx * 1.0 / $n}] [expr {$sy * 1.0 / $n}]]
}

proc layout-data {} {
    global cpage
    upvar #0 ld_sse/$cpage sse
    catch { unset sse }
    source ../layout/ours.dgram.segmap-info
    source ../layout/ours.dgram-$cpage.overlay-info

    upvar #0 movpos_bindings($cpage) bindings
    if {![info exists bindings]} {
	puts "no movpos bindings for $cpage"
	return
    }
    foreach binding $bindings {
	if {[regexp \
   {^([A-Z])([-+]\d*)?([-+]\d*)?([-+]\d*)?([-+]\d*)?\=(\w+)/([A-Z]+)$} \
		 $binding dummy key adj0x adj0y adj1x adj1y seg feat]} {
	    if {![string length $adj1x]} { set adj1x $adj0x; set adj1y $adj0y }
	    movpos-bindkey-1 $cpage $key $seg $feat \
		$adj0x.0 $adj0y.0 $adj1x.0 $adj1y.0
	} elseif {[regexp {^[A-Z]$} $binding] || [regexp {~} $binding]} {
	} else {
	    error "incomprehensible binding $binding on page $cpage"
	}
    }
}

#---------- speed ----------

# variables:
#   $train_commanded($train)    $speed_step
#   $train_direction($train)    forwards|backwards or unset
#   $speedws                    [list $w ...]
#
# speed/${w}(...) aka s(...):
#   $s(ctrlr)                   controller
#   $s(train)                   train selected, or something not \w+
#   $s(optionmenu)              optionmenu widget name
#   $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
# the odd increment/decrement.  But since we thread the requested
# speed via realtime, we do queue up our own increments/decrements
# while we're executing a speed command, to avoid loss of steps during
# quick motions.

# Interfaces for concrete controllers:
#   speedw-new $w $ctrlr
#   speedw-setstate $w disabled|normal        controller appears/disappears
#   speedw-userinput-abs $w $step
#   speedw-userinput-rel $w $stepmap
# where
#   eval {stepmap} [list $oldstep] => $newstep

set speedws {}

proc speedws-forall {command args} {
    global speedws
    foreach w $speedws { eval [list $command $w] $args }
}

proc speedws-fortrain {train command args} {
    global speedws
    foreach w $speedws {
	upvar #0 speed/$w s
	if {[string compare $s(train) $train]} continue
	eval [list $command $w] $args
    }
}

proc speedw-new {w ctrlr} {
    upvar #0 speed/$w s
    global speedws

    lappend speedws $w
    set s(ctrlr) $ctrlr
    set s(inhibit) 0

    frame $w -relief sunken -border 2
    label $w.ctrlr -state disabled -text $s(ctrlr)
    set s(optionmenu) [tk_optionMenu $w.train speed/${w}(train) {}]
    $w.train configure -textvariable {} -width 15
    label $w.speed -state disabled -width 4 \
	    -font -*-courier-bold-r-*-*-20-*-*-*-*-*-*-* \
	    -background black -foreground white
    pack $w.ctrlr $w.train $w.speed -side left
    
    speedw-notrains $w "(starting)"
}
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
    tractbrake-detach $s(train)
    set s(train) {}
    $w.train configure -text $whystr
    $w.speed 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 max} {
    upvar #0 speed/$w s
    set r $s(inhibit)
    if {$r>$max} { return -1 }
    set s(inhibit) 0
    $w.speed configure -foreground white
    return $r
}

proc speedw-setstate {w disnorm} {
    $w.ctrlr configure -state $disnorm
    $w.speed configure -state $disnorm
}

proc speedw-train-selectnext {w} {
    upvar #0 speed/$w s
    set max [$s(optionmenu) index end]
    for {set ix 0} {$ix <= $max} {incr ix} {
	set v [$s(optionmenu) entrycget $ix -value]
	if {![string compare $v $s(train)]} break
    }
    set activate [expr {($ix+1) % ($max+1)}]
    $s(optionmenu) invoke $activate
}

proc speedw-train-selected {w t} {
    upvar #0 speed/$w s
    if {![string compare $t $s(train)]} return
    tractbrake-detach $s(train)
    $w.train configure -text $t
    set s(inhibit) 1
    set s(train) $t
    $w.speed configure -foreground white
    speedw-redisplay-speed $w
}

proc speedw-redisplay-speed {w} {
    upvar #0 speed/$w s
    upvar #0 train_commanded($s(train)) gcommanded
    upvar #0 train_direction($s(train)) gdirection
    set t $gcommanded
    if {[info exists gdirection]} {
	switch -exact $gdirection {
	    forwards { set t "$t>" }
	    backwards { set t "<$t" }
	}
    }
    $w.speed configure -text $t
}

proc speedw-train-direction {w dirchange} {
    upvar #0 speed/$w s
    if {![string length $s(train)]} return
    scmd routinecmd $s(ctrlr) "direction $s(train) $dirchange"
}

proc speedw-trains-available {w l} {
    upvar #0 speed/$w s
    if {![llength $l]} { speedw-train-noneselected $w "(no trains)"; return }
    $s(optionmenu) delete 0 end
    $s(optionmenu) add radiobutton -label "(none)" -value {} \
	    -command [list speedw-train-noneselected $w "(no train selected)"]
    set l [lsort $l]
    foreach t $l {
	$s(optionmenu) add radiobutton -label $t -value $t \
		-command [list speedw-train-selected $w $t]
    }
    $w.train configure -state normal
    if {[llength $l]==1} {
	$s(optionmenu) invoke 1
    } elseif {[set ix [lsearch -exact $l $s(train)]] >= 0} {
	$s(optionmenu) invoke [expr {$ix+1}]
    } elseif {![string length $s(train)]} {
	$s(optionmenu) invoke 0
    } else {
	$w.train configure -text "$s(train) (not present)"
    }
}

proc speedw-userinput-abs {w speed} {
    upvar #0 speed/$w s
    if {![string length $s(train)]} return
    tractbrake-detach $s(train)
    if {!$speed} { speedw-uninhibit $w 2 }
    speedw-do-abs $w $speed
}

proc speedw-userinput-tractbrake {w tract brake} {
    upvar #0 speed/$w s
    if {![string length $s(train)]} return
    if {$s(inhibit)} return
    tractbrake-userinput $s(train) $tract $brake $w
}

proc speedw-do-abs {w speed} {
    upvar #0 speed/$w s
    set s(queued) $speed
    speedw-check $w
}

proc speedw-check {w} {
    upvar #0 speed/$w s
    if {![string length $s(train)]} return
    upvar #0 train_commanded($s(train)) gcommanded
    upvar #0 train_direction($s(train)) gdirection
    if {[info exists s(commanding)]} return
    if {![info exists s(queued)]} return
    set newspeed $s(queued)
    unset s(queued)
    if {$s(inhibit) && $newspeed > $gcommanded} return
    set s(commanding) $newspeed
    scmd speedw-commanded $s(ctrlr) "speed $s(train) $newspeed $gdirection" $w
}

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)
    speedw-check $w
}
proc speedw-commanded-err {m w} {
    upvar #0 speed/$w s
    unset s(commanding)
    speedw-inhibit $w
    speedw-check $w
}

proc speedw-currentspeed {w} {
    upvar #0 speed/$w s
    upvar #0 train_commanded($s(train)) gcommanded
    if {[info exists s(queued)]} {
	return $s(queued)
    } elseif {[info exists s(commanding)]} {
	return $s(commanding)
    } else {
	return $gcommanded
    }
}

proc speedw-userinput-rel {w stepmap} {
    upvar #0 speed/$w s
    if {![string length $s(train)]} return
    set oldspeed [speedw-currentspeed $w]
    set newspeed [eval $stepmap [list $oldspeed]]
    speedw-userinput-abs $w $newspeed
}

proc speedw-userinput-rel-steps {w delta steplist} {
    if {$delta<0} {
	if {[speedw-uninhibit $w 2]>1} { incr delta 1 }
	if {!$delta} return
    } else {
	speedw-uninhibit $w 1
    }
    speedw-userinput-rel $w [list speedw-stepmap-fromlist $steplist $delta]
}

proc speedw-userinput-tractbrake {w tract brake} {
    upvar #0 speed/$w s
    if {![string length $s(train)]} return
    speedw-uninhibit $w 1
    tractbrake-userinput $s(train) $tract $brake $w
}

proc speedws-train-problem {train} {
    speedws-fortrain $train speedw-inhibit
}

register-event ?train_*_at {train direction} \
	{^.train (\w+) at \S+ (forwards|backwards) } {
    upvar #0 train_direction($train) dirn
    set dirn $direction
    speedws-fortrain $train speedw-redisplay-speed
    tractbrake-ensure $train
}

register-event ?train_*_speed_commanding {train speed} \
	{^.train (\w+) speed commanding (\d+) } {
    upvar #0 train_commanded($train) cmd
    set cmd $speed
    speedws-fortrain $train speedw-redisplay-speed
}

proc speedws-stastate-hook {} {
    global train_direction stastate
    switch -exact -- $stastate {
	Run {
	    set trains [array names train_direction]
	    speedws-forall speedw-trains-available $trains
	}
	Resolving {
	    movpos-all-unknown
	}
	Finalising {
	    speedws-forall speedw-notrains "($stastate)"
	}
	default {
	    catch { unset train_commanded }
	    speedws-forall speedw-notrains "($stastate)"
	}
    }
}

register-event &train_*_signalling-problem {train problem} \
	{^\&train (\w+) signalling-problem (.*) $} {
    global speedws
    regsub {^(\S+) (\S+) \: } $problem {\1 @\2: } problem
    report-problem "event: $problem"
    speedws-train-problem $train
}

proc speedw-new-cooked {wunique desc} {
    set w .inputs.$wunique
    speedw-new $w $desc
    pack $w -side left -padx 10
    return $w
}

proc speedw-stepmap-fromlist {speedlist offset oldspeed} {
    if {![llength $speedlist]} {
	unset speedlist
	upvar #0 default_speedstep_list speedlist
    }
    set ixabove 0
    foreach entry $speedlist {
	if {$entry==$oldspeed} { set ixbelow $ixabove; break }
	if {$entry>$oldspeed} break
	set ixbelow $ixabove
	incr ixabove
    }
    set ix [expr {($offset>0 ? $ixbelow : $ixabove) + $offset}]
    if {$ix<0} { return 0 }
    if {$ix>=[llength $speedlist]} { return [lindex $speedlist end] }
    return [lindex $speedlist $ix]
}

#----- traction / brake (hidden behind speedw) ----------

proc tractbrake-queue-update {train} {
    upvar #0 tractbrake/$train tb
    set tb(queued) [after $tb(updms) \
			[list tractbrake-update $train]]
}

proc tractbrake-attach {train speedw} {
    # can safely be called when already attached
    upvar #0 tractbrake/$train tb
    upvar #0 speedcurve/$train sc
    set tb(speedw) $speedw
    if {[info exists tb(queued)]} return
    upvar #0 train_commanded($train) gcommanded
    setexpr tb(v) {[lindex $sc $gcommanded] / [lindex $sc 126]}
    tractbrake-queue-update $train
}
proc tractbrake-detach {train} {
    # can safely be called when already detached
    upvar #0 tractbrake/$train tb
    catch { after cancel $tb(queued) }
    catch { unset tb(queued) }
    tractbrake-reset $train
}
proc tractbrake-reset {train} {
    upvar #0 tractbrake/$train tb
    if {![info exists tb]} return
    set tb(A) 0
    set tb(B) 0
    set tb(a) 0
    set tb(b) 0
}

proc tractbrake-update {train} {
    upvar #0 tractbrake/$train tb
    upvar #0 tractbrake-params/$train pa
    unset tb(queued)
    foreach AB {A B} ab {a b} lm {lambda mu} {
	addexpr tb($ab) { $tb(updfact_$lm) * ( $tb($AB) - $tb($ab) ) - 1e-5 }
    }
    addexpr tb(v) {
	+ $tb(perupd_alpha) * $tb(a)
	- $tb(perupd_beta) * $tb(b)
	- $tb(perupd_omega) * $tb(v) * $tb(v)
	- $tb(perupd_phi)
    }
    set m "tractbrake $train"
    foreach v {A a B b v} { append m [format " %s=%6.4f" $v $tb($v)] }
    debug $m
    if {$tb(v) <= 0} {
	# stopped
	set tb(v) 0
	speedw-do-abs $tb(speedw) 0
	if {$tb(A) <= 0 && $tb(a) <= 0 &&
	    $tb(B) <= 0 && $tb(b) <= 0} {
	    # no throttle or brake, no need to requeue
	    return
	}
    } else {
	if {$tb(v) > 1.0} { set tb(v) 1.0 }
	upvar #0 speedcurve/$train sc
	upvar #0 train_commanded($train) gcommanded
	set step $gcommanded
	setexpr targetvel {$tb(v) * [lindex $sc 126]}
	while 1 {
	    set vel [lindex $sc $step]
	    if {$vel > $targetvel && $step > 0} {
		setexpr nextstep {$step - 1}
	    } elseif {$vel < $targetvel && $step < 126} {
		setexpr nextstep {$step + 1}
	    } else {
		break
	    }
	    set nextvel [lindex $sc $nextstep]
	    if {abs($nextvel-$targetvel) >= abs($vel-$targetvel)} {
		break
	    }
	    set step $nextstep
	}
	if {$step != $gcommanded} {
	    speedw-do-abs $tb(speedw) $step
	}
    }
    tractbrake-queue-update $train
}

proc tractbrake-userinput {train tract brake speedw} {
    upvar #0 tractbrake/$train tb
    if {![info exists tb]} {
	report-problem "event: no traction/brake parameters for $train"
	return
    }
    if {[string length $tract]} { set tb(A) $tract }
    if {[string length $brake]} { set tb(B) $brake }
    if {$tract || $brake} {
	tractbrake-attach $train $speedw
    }
}

proc tractbrake-ensure {train} {
    upvar #0 speedcurve/$train sc
    if {[info exists sc]} return ;# try this only once
    set sc 0

    if {[regexp {[^-+._0-9a-z]} $train]} { error "bad train $train ?" }

    if {[catch { set f [open $train.speeds.record] } emsg]} {
	global errorCode errorInfo
	switch -glob $errorCode {POSIX ENOENT *} {
	    report-problem "train $train: no traction/braking (no speed table)"
	    return
	}
	error $emsg $errorInfo $errorCode
    }
    while {[llength $sc] <= 126} { lappend sc x }
    while {[gets $f l] >= 0} {
	if {![regexp {^train (\S+) step (\d+)=([0-9.]+)$} $l \
		  dummy tr step velocity]} continue
	if {[string compare $tr $train] || $step<=0 || $step>126} {
	    error "bad velocity line $l ?" {} {TRACTBRAKE SKIP}
	}
	set sc [lreplace $sc $step $step $velocity]
    }
    close $f
    if {[lsearch -exact $sc x]>=0} {
	report-problem "train $train: no traction/braking\
            (incomplete speed table"
	return
    }

    upvar #0 tractbrake/$train tb
    defset tb(deadzone) 0.2
    defset tb(updms)    20
    defset tb(lambda)   0.600  ;# time constant for adj throttle
    defset tb(mu)       0.300  ;# time constant for apply/release breaks
    defset tb(inv_alpha)   20  ;# time constant for accelerate to max
    defset tb(omegaphi)    50  ;# (air resistance) / (rolling res) at max spd
    defset tb(inv_beta)    10  ;# time constant for service brake (over-est'd)
    defset tb(overpower) 1.03  ;# factor by which we are overpowered for max spd
    foreach lm {lambda mu} {
	setexpr tb(updfact_$lm) { $tb(updms) * 0.001 / $tb($lm) }
    }

    setexpr tb(alpha) { 1.0 / $tb(inv_alpha) }
    setexpr tb(beta) { 1.0 / $tb(inv_beta) }
    setexpr tb(phi) { $tb(alpha) / ($tb(omegaphi) + 1.0) / $tb(overpower) }
    setexpr tb(omega) { $tb(omegaphi) * $tb(phi) }

    foreach p {alpha beta omega phi} {
	setexpr tb(perupd_$p) { $tb($p) * 0.001 * $tb(updms) }
    }

    tractbrake-reset $train
}

#---------- concrete input bindings ----------

proc ib-suppressions {args} {
    set l {}
    foreach supp $args {
	set l [concat $l --redaction $supp --suppress]
    }
    return $l
}

proc ib-speedw-new {devid wunique desc} {
    upvar #0 input/$devid in
    set in(speedw) [speedw-new-cooked $wunique $desc]
}

#----- wheelmouse

proc ib-ev/wheelmouse/EV_REL/REL_WHEEL {devid value} {
    upvar #0 input/$devid in
    speedw-userinput-rel-steps $in(speedw) [expr {-$value}] {}
}

proc ib-selectnext {devid value} {
    if {$value!=1} return
    upvar #0 input/$devid in
    speedw-train-selectnext $in(speedw)
}
proc ib-changedirection {devid value} {
    upvar #0 input/$devid in
    if {!$value} return
    speedw-train-direction $in(speedw) change
}    

proc ib-ev/wheelmouse/EV_KEY/BTN_LEFT {devid value} {
    ib-selectnext $devid $value
}
proc ib-ev/wheelmouse/EV_KEY/BTN_RIGHT {devid value} {
    ib-changedirection $devid $value
}

proc ib-create/wheelmouse {devid wunique desc} {
    ib-speedw-new $devid $wunique $desc
}

proc ib-wheelmouse-redactions {} {
    return [ib-suppressions  \
	    {EV REL REL X} \
	    {EV REL REL Y}]
}

proc ib-evcmd/wheelmouse {devid target} {
    return [ib-evcmd-construct $devid $target [concat \
	    [list --grab] [ib-wheelmouse-redactions]]]
}

#----- gamepad

proc ib-create/gamepad {devid wunique desc} {
    ib-speedw-new $devid $wunique $desc
    upvar #0 input/$devid in
    set in(tractbrake_deadzone) 0.2
}

proc ib-ev/tractbrake/init {devid} {
    upvar #0 input-params/$devid pa
}

proc ib-ev/gamepad/EV_ABS/ABS_THROTTLE {devid value} {
    upvar #0 input/$devid in
    if {abs($value) < $in(tractbrake_deadzone)} {
	speedw-userinput-tractbrake $in(speedw) 0 0
	return
    }
    if {$value > 0} {
	speedw-userinput-tractbrake $in(speedw) $value 0
    } {
	speedw-userinput-tractbrake $in(speedw) 0 [expr {-$value}]
    }
}

#----- ebuyer wireless keyboard

proc ib-create/ebwikeb {devid wunique} {
    upvar #0 input/$devid in
    set in(desc) "main keyboard"
    ib-create/wheelmouse $devid $wunique $in(desc)
    set in(modifiers) 0
}

proc ib-evcmd/ebwikeb {devid target} {
    return [concat \
	    [list ./evdev-manip-ebwikeb --redact --stdin-monitor] \
	    [ib-wheelmouse-redactions] \
	    [ib-suppressions \
	        {0x01 02} \
	        {EV MSC} \
		{0x0c 01} \
		{0xffbc 88 0xffbc 00}]]
}

proc ib-ev/ebwikeb/EV_REL/REL_WHEEL {devid value} {
    ib-ev/wheelmouse/EV_REL/REL_WHEEL $devid $value
}

proc ib-ebwikeb-modifier {devid value bitval} {
    upvar #0 input/${devid}(modifiers) mod
    if {$value} {
	set mod [expr {$mod | $bitval}]
    } else {
	set mod [expr {$mod & ~$bitval}]
    }
}
proc ib-ev/ebwikeb/EV_KEY/KEY_LEFTSHIFT {devid value} {
    ib-ebwikeb-modifier $devid $value 0x0001
}
proc ib-ev/ebwikeb/EV_KEY/KEY_RIGHTSHIFT {devid value} {
    ib-ebwikeb-modifier $devid $value 0x0002
}
proc ib-ev/ebwikeb/EV_KEY/KEY_LEFTCTRL {devid value} {
    ib-ebwikeb-modifier $devid $value 0x0100
}
proc ib-ev/ebwikeb/EV_KEY/KEY_RIGHTCTRL {devid value} {
    ib-ebwikeb-modifier $devid $value 0x0200
}
proc ib-ev/ebwikeb/EV_KEY/KEY_CAPSLOCK {devid value} {
    ib-ebwikeb-modifier $devid $value 0x0400
}

proc ib-ev/ebwikeb/0xffbc_88/0xffbc_0d {devid value} {
    upvar #0 input/$devid in
    if {!$value} return
    if {$in(modifiers) & 0x00ff} {
	ib-selectnext $devid $value
    } else {
	ib-changedirection $devid $value
    }
}

proc ib-ev/ebwikeb/EV_KEY/KEY_BOOKMARKS {devid value} {
    upvar #0 input/$devid in
    if {!$value} return
    if {!($in(modifiers) & 0xff00)} return
    if {$in(modifiers) & 0x00ff} {
	set how stop
    } else {
	set how auto
    }
    scmd routinecmd $in(desc) "!realtime $how"
}

#----- static keybindings speed `controller'

proc bind-keyboard-speed {kslow kfast kseltrain kreverse desc} {
    set wunique [get-unique keyboardspeed]
    set w [speedw-new-cooked $wunique $desc]
    foreach delta {-1 +1} sf {slow fast} {
	bind . <Key-[set k$sf]> [list speedw-userinput-rel-steps $w $delta {}]
    }
    bind . <Key-$kseltrain> [list speedw-train-selectnext $w]
    bind . <Key-$kreverse> [list speedw-train-direction $w change]
    speedw-setstate $w normal
}

#----- Joytech "Neo S" USB PC gamepad

proc hidraw-descriptors/gamepad-neo-s {} {
    return xx
}

#proc hidraw-readable/gamepad-neo-s {chan hidraw devid} {
#    upvar #0 hidraw/$hidraw raw
#    # In my tests with tcl8.3 and tcl8.5, "read chan numbytes"
#    # on a nonblocking binary channel does only one read(2)
#    # provided that read(2) returns less than requested
#    while 1 {
#	set msg [hbytes raw2h [read $chan 256]]
#	if {![hbytes 
#	switch -glob [bhtes $msg {
#	    4a* { set want 8 }
#	    {} { set want 64 }
#	    * { error "unknown report number $raw(buf)" }
#	}
#	if {$want > $sofar} {
#	    set got [read $chan [expr {$want - $sofar}]]
#	    
#	}
#
#	set sofar [hbytes length $raw(buf)]
#	if {!$sofar} {
#	    set got [read $chan 64]
#	} else {
#	    
#	}
	

#---------- input device evdev binding ----------

proc ib-evcmd-construct {devid target xargs} {
    upvar #0 input/$devid in
    if {[llength $target] > 1} {
	debug "ib $devid - multiple devices, not supported"
	return {}
    }
    manyset [lindex $target 0] ev sysfs
    if {[regexp { } $ev]} { error "event device `$ev' contains space" }
    return [concat \
	    [list ./evdev-manip --redact] $xargs \
	    [list --stdin-monitor \
	          --expect-sysfs /sys$sysfs/$ev/dev \
		  /dev/input/$ev]]
}

proc bind-input-core {devid devkind devinfo concrete concargs} {
    global input_bindings
    lappend input_bindings [list $devkind $devid $devinfo $concrete $concargs]
}

proc bind-input {bus vendor product version concrete args} {
    bind-input-core evdev:$bus:$vendor:$product:$version \
	evdev [list $bus $vendor $product $version] \
	$concrete $args
}

proc bind-input-static {event sysfs concrete args} {
    bind-input-core [get-unique static] \
	static [list $event $sysfs] \
	$concrete $args
}

proc bind-input-raw {devtype concrete args} {
    set descriptors [exec ./hidrawconv-$devtype -d]
    bind-input-core hidraw:[get-unique $devtype] \
	hidraw [list $devtype $descriptors] \
	$concrete $args
}

proc widgets-input-bindings {} {
    global input_bindings
    foreach binding $input_bindings {
	manyset $binding devkind devid devinfo concrete concargs
	set cid [get-unique $concrete]
	upvar #0 input/$devid in
	set in(laststart) 0
	set in(concrete) $concrete
	eval [list ib-create/$concrete $devid $cid] $concargs
    }
    pack .inputs -side top -fill x
}

# input/$devid becomes `in' via upvar:
#  $in(chan)        channel open onto evdev-manip;
#                   unset if none, or hidraw, or something
#  $in(laststart)   last start time, [clock seconds]
#                      at every event we set this the current time
#                      but we insist on adding at least 5s
#                      and if that would make it > current time +15s
#                      we don't start
#  $in(speedw)      optional, may be set by ib-create

# hidraw/hidrawN becomes `hr' via upvar:
#  $raw(devid)      $devid (see above)
#  $raw(chan)       channel open onto /dev/hidrawN

proc input-concrete-start-try {devid concrete} {
    global inputretryadd inputretrymax
    upvar #0 input/$devid in
    set now [clock seconds]
    set newlast [expr {$in(laststart) + $inputretryadd}]
    if {$newlast > $now + $inputretrymax} { return 0 }
    if {$newlast < $now} { set newlast $now }
    set in(laststart) $newlast
}

proc input-bindings-list {devkind} {
    global input_bindings
    set o {}
    foreach b $input_bindings {
	manyset $b dk
    	if {[string compare $dk $devkind]} continue
	lappend o $b
    }
    return $o
}

proc scan-input-bindings {} {
    global errorInfo errorCode unmatched_notified old_hidraws
    global input_bindings scaninputinterval
    global input_rawbindings

    after $scaninputinterval scan-input-bindings

    # scan /proc/bus/input/devices for appropriate evdevs
    # results go in $target($devid)
    if {[catch {
	set f [open /proc/bus/input/devices]
    } emsg]} {
	if {[string match {POSIX ENOENT *} $errorCode]} return
	error $emsg $errorInfo $errorCode
    }
    while 1 {
	set r [gets $f l]
	if {$r <= 0} {
	    if {[info exists v(devid)] &&
	        [info exists v(sysfs)] &&
	        [info exists v(event)]} {
	        lappend target(evdev:$v(devid)) [list $v(event) $v(sysfs)]
	    }
	    catch { unset v }
	}
	if {$r < 0} {
	    break
	}
	append l "\n"
	if {[regexp \
 {^I: Bus=(\w+) Vendor=(\w+) Product=(\w+) Version=(\w+)\s} \
                 $l dummy bus vendor product version]} {
	    set v(devid) $bus:$vendor:$product:$version
	} elseif {[regexp {^S: Sysfs=(\S+)\s} $l dummy sysfs]} {
	    set v(sysfs) $sysfs
	} elseif {[regexp {^H: Handlers=(?:.*\s)?(event\d+)\s} $l dummy ev]} {
	    set v(event) $ev
	} else {
	    # ignored
	}
    }
    close $f

    # add as-if-scanned entries for static bindings to target
    # also check to see if we want hidraw
    foreach binding $input_bindings {
	manyset $binding devkind devid devinfo concrete concargs
	switch -exact $devkind static { } default continue
	lappend target($devid) [list $event $sysfs]
    }

    # scan /dev/hidraw*
    foreach binding [input-bindings-list hidraw] {
	manyset $binding devkind devid devinfo concrete concargs
	switch -exact $devkind hidraw { } default continue
	manyset $devinfo devtype descriptors
	set rawmap($descriptors) [list $devid $devtype $concrete]
    }
    if {[array exists rawmap]} {
	set new_hidraws [lsort [glob -nocomplain -directory /dev hidraw*]]
	foreach hidraw $new_hidraws {
	    upvar #0 hidraw/$hidraw raw
	    if {[info exists raw(chan)]} {
		set found($raw(devid)) 1
		continue
	    }
	    if {[lsearch -exact $old_hidraws $hidraw] >= 0} continue
	    if {[catch {
		set chan [open $hidraw r+]
		set descriptors [exec ./hidraw-ioctl -d <@ $chan]
		if {![info exists rawmap($descriptors)]} {
		    set m [exec ./hidraw-ioctl -i <@ $chan]
		    error "unknown descriptors (unmatched device) $hidraw $m >$descriptors<"
		}
	    } emsg]} {
		upvar #0 hidraw_notified($hidraw) notified
		if {![info exists notified] ||
		     [string compare $notified $emsg]} {
		    debug "ir $hidraw $emsg"
		    set notified $emsg
		}
		catch { close $chan }
		catch { unset chan }
		continue
	    }
	    manyset $rawmap($descriptors) devid devtype concrete
	    set found($devid) 1
	    if {![input-concrete-start-try $devid $concrete]} {
		catch { close $chan }
		continue
	    }
	    set raw(devid) $devid
	    set cmdl [list ./hidrawconv-$devtype -e <@ $chan 2>@ stderr]
	    set evch [open |$cmdl r]
	    set raw(chan) $evch
	    fconfigure $evch -blocking 0 -buffering line
	    fileevent $evch readable \
		[list catch-for-input-binding hidraw $hidraw \
		     [list readable input-binding-raw $evch $hidraw $devid]]
	    input-binding-present $devid 1 "hidraw $hidraw"
	}
	set old_hidraws $new_hidraws
    }

    # try to start the input binding for all the unstarted found targets
    foreach devid [array names target] {
	upvar #0 input/$devid in
	if {![info exists in(concrete)]} {
	    if {![info exists unmatched_notified($devid)]} {
		debug "ib $devid unmatched, ignored"
		set unmatched_notified($devid) 1
	    }
	    continue
	}
	set found($devid) 1
	if {[info exists in(chan)]} continue
	if {![input-concrete-start-try $devid $concrete]} continue

	set cmdl [ib-evcmd/$in(concrete) $devid $target($devid)]
	if {![llength $cmdl]} {
	    unset target($devid)
	    continue
	}
	lappend cmdl 2>@ stderr
	catch-for-input-binding evdev $devid {
	    debug "ib $devid running $cmdl"
	    set in(chan) [open |$cmdl r+]
	    fconfigure $in(chan) -blocking 0 -buffering line
	    fileevent $in(chan) readable \
		[list catch-for-input-binding evdev $devid \
		    [list readable input-binding $in(chan) $devid]]
	}
    }

    # anything not found, not present
    foreach binding $input_bindings {
	manyset $binding devkind devid devinfo concrete concargs
	switch -exact $devkind evdev - raw { } default continue
	upvar #0 input/$devid in
	if {![info exists in(concrete)]} continue
	if {[info exists found($devid)]} continue
	input-binding-present $devid 0 absent
    }
}

proc input-binding-present {devid yes why} {
    upvar #0 input/$devid in
    if {[info exists in(speedw)]} {
	speedw-setstate $in(speedw) [lindex {disabled normal} $yes]
    }
    set call "ib-[lindex {absent present} $yes]/$in(concrete)"
    if {![catch { info args $call }]} {
	$call $devid $why
    }
}

proc input-binding-eof {chan devid} {
    upvar #0 input/$devid in
    input-binding-eof-core $in(chan) "evdev-manip exited"
}

proc input-binding-eof-core {chan msg} {
    fconfigure $chan -blocking 1
    close $chan
    error $msg {} {CHILDSTATUS ? 0}
}

proc input-binding-raw-eof {chan hidraw devid} {
    upvar #0 hidraw/$hidraw raw
    input-binding-eof-core $raw(chan) "hidrawconv-* exited"
}

proc input-binding-inputline {chan l devid} {
    upvar #0 input/$devid in
    if {[input-binding-inputline-core-ib $devid $l]} return
    regsub {^[^ ]+ } $l {} lr
    switch -glob -- $lr {
	{opened *} {
	    debug "ib $devid start << $l"
	    input-binding-present $devid 1 "evdev open"
	}
	{[-0-9]*} {
	    manyset [split $lr] value kindl kindr codel coder
	    input-binding-inputline-core-ev $devid \
		${kindl}_${kindr}/${codel}_${coder} $value $l
	}
	* {
	    debug "ib $devid ignored << $l"
	}
    }
}

proc input-binding-inputline-core-ib {devid l} {
    # give the input binding first dibs
    upvar #0 input/$devid in
    if {[catch { info args ib-inputline/$in(concrete) }]} { return 0 }
    return [ib-inputline/$in(concrete) $devid $l]
}

proc input-binding-inputline-core-ev {devid kindcode value l} {
    global showunbound
    upvar #0 input/$devid in
    set proc ib-ev/$in(concrete)/$kindcode
    if {[catch { info args $proc }]} {
	if {$showunbound} {
	    debug "ib $devid unbound $proc << $l"
	}
	return
    }
    $proc $devid $value
}

proc input-binding-raw-inputline {chan l hidraw devid} {
    upvar #0 hidraw/$hidraw raw
    if {[input-binding-inputline-core-ib $devid $l]} return
    manyset [split $l] kind code value
    input-binding-inputline-core-ev $devid $kind/$code $value $l
}

proc catch-for-input-binding {devkind ident body} {
    global errorInfo errorCode
    set r [catch { uplevel 1 $body } rv]
    if {$r!=1} { return -code $r $rv }
    switch -glob $errorCode {
	{CHILDSTATUS *} { set m "exited with status [lindex $errorCode 2]" }
	{CHILDKILLED *} { set m "killed by signal [lindex $errorCode 3]" }
	{POSIX *} { set m "communication error: [lindex $errorCode 1]" }
	* { error $rv $errorInfo $errorCode }
    }
    debug "ib $devkind $ident died $m"
    input-binding-destroy/$devkind $ident $m
}

proc input-binding-destroy/evdev {devid m} {
    upvar #0 input/$devid in
    catch { close $in(chan) }
    catch { unset in(chan) }
    input-binding-present $devid 0 "died $m"
}

proc input-binding-destroy/hidraw {hidraw m} {
    upvar #0 hidraw/$hidraw raw
    catch { close $raw(chan) }
    catch { unset raw(chan) }
    input-binding-present $raw(devid) 0 "died $m"
}

proc engage-input-bindings {} {
    scan-input-bindings
}

#---------- 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 {args} {
    error "lost connection to train set"
}

register-event ?stastate {ctxch state} {^(.)stastate (\w+|\-) } {
    global ctrain trains stastate
    set stastate $state
    report-problem "stastate: $state"
    if {[string compare $ctxch |]} speedws-stastate-hook
}

register-event ?resolution {message} \
	{^.resolution (\S+ .*)$} {
    if {[string match "problems *" $message]} return
    report-problem "resolution: $message"
}

register-event ?warning {message} {^.warning (\S+ .*)$} {
    report-problem "warning: $message"
}

register-event {} {} {^=connected } {
    global pages gui_pipe server port event_selections

    scmd replayed {} "select-replay [concat $event_selections]"

    foreach page $pages {
	set w [pagew $page]
	tkwait visibility $w.picture

	set cmdl [list ./gui-plan-$page [winfo id $w.picture] @$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 replayed-err {m args} { error "replay failed: $m" }
proc replayed-ok {m args} {
    speedws-stastate-hook
}

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-server {} {
    global server port sconn

    set sconn [socket $server $port]
    fconfig-trainproto $sconn
    fileevent $sconn readable {readable train-event $sconn}
}

proc main {} {
    global pages cpage configfile input_bindings old_hidraws
    setting server railway {[[0-9a-z:].*}
    setting geometry {} {[-+]\d+[-+]\d+}
    setting posdeviation 5 {\d+}
    setting movfeatcommand {movfeat+} {(?:!movfeat|movfeat\+?\+?)}
    setting problemdisplayms 1000 {\d+}
    setting inputretryadd 5 {\d+}
    setting inputretrymax 15 {\d+}
    setting scaninputinterval 500 {\d+}
    setting showunbound 0 {[01]}

    set hostname [lindex [split [info hostname] .] 0]
    setting configfile gui-$hostname.config {.+}
    parse-argv {}

    frame .inputs
    if {![info exists input_bindings]} { set input_bindings {} }
    set old_hidraws {}

    uplevel #0 source gui-layout.config
    uplevel #0 source $configfile
    foreach cpage $pages {
	layout-data
	widgets-dgram
    }
    unset cpage
    widgets-movpos
    widgets-input-bindings
    widget-problem-report
    engage-server
    engage-input-bindings
    start_commandloop
}

main