#!/usr/bin/wishx

#---------- 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
    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
    $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
    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)} {
	if {$newspeed > $gcommanded} return
	speedw-uninhibit $w 2
    }
    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-userinput-rel {w stepmap} {
    upvar #0 speed/$w s
    if {![string length $s(train)]} return
    upvar #0 train_commanded($s(train)) gcommanded
    if {[info exists s(queued)]} {
	set oldspeed $s(queued)
    } elseif {[info exists s(commanding)]} {
	set oldspeed $s(commanding)
    } else {
	set oldspeed $gcommanded
    }
    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 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
}

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

#---------- 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]]]
}

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

#---------- 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 {bus vendor product version concrete args} {
    global input_bindings
    set devid $bus:$vendor:$product:$version
    lappend input_bindings [list $devid $concrete $args]
}

proc bind-input-static {event sysfs concrete args} {
    global input_bindings input_statics
    set devid [get-unique static]
    lappend input_statics [list $devid $event $sysfs]
    lappend input_bindings [list $devid $concrete $args]
}

proc widgets-input-bindings {} {
    global input_bindings
    foreach binding $input_bindings {
	manyset $binding devid concrete xa
	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] $xa
    }
    pack .inputs -side top -fill x
}

# input/$bus:$vendor:$product:$version becomes `in' via upvar
#  $in(chan)        channel open onto evdev-manip; unset if none
#  $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

proc scan-input-bindings {} {
    global errorInfo errorCode unmatched_notified
    global input_bindings inputretryadd inputretrymax scaninputinterval
    global input_statics
    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($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
    foreach static $input_statics {
	manyset $static devid event sysfs
	lappend target($devid) [list $event $sysfs]
    }
    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
	}
	if {[info exists in(chan)]} continue
	set now [clock seconds]
	set newlast [expr {$in(laststart) + $inputretryadd}]
	if {$newlast > $now + $inputretrymax} continue
	if {$newlast < $now} { set newlast $now }
	set cmdl [ib-evcmd/$in(concrete) $devid $target($devid)]
	if {![llength $cmdl]} {
	    unset target($devid)
	    continue
	}
	lappend cmdl 2>@ stderr
	set in(laststart) $newlast
	catch-for-input-binding $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 $devid \
		    [list readable input-binding $in(chan) $devid]]
	}
    }
    foreach binding $input_bindings {
	manyset $binding devid concrete ctrlr
	upvar #0 input/$devid in
	if {![info exists in(concrete)]} continue
	if {[info exists target($devid)]} continue
	input-binding-notpresent $devid absent
    }
    after $scaninputinterval scan-input-bindings
}

proc input-binding-notpresent {devid why} {
    upvar #0 input/$devid in
    if {[info exists in(speedw)]} {
	speedw-setstate $in(speedw) disabled
    }
    if {![catch { info args ib-absent/$in(concret) }]} {
	ib-absent/$in(concrete) $devid $why
    }
}

proc input-binding-eof {chan devid} {
    upvar #0 input/$devid in
    fconfigure $in(chan) -blocking 1
    close $in(chan)
    error "evdev-manip exited" {} {CHILDSTATUS ? 0}
}

proc input-binding-inputline {chan l devid} {
    global showunbound
    upvar #0 input/$devid in
    if {![catch { info args ib-inputline/$in(concrete) }]} {
	# give the input binding first dibs
	if {[ib-inputline/$in(concrete) $devid $l]} return
    }
    regsub {^[^ ]+ } $l {} lr
    switch -glob -- $lr {
	{opened *} {
	    debug "ib $devid start << $l"
	    if {[info exists in(speedw)]} {
		speedw-setstate $in(speedw) normal
	    }
	}
	{[-0-9]*} {
	    manyset [split $lr] value kindl kindr codel coder
	    set proc ib-ev/$in(concrete)/${kindl}_${kindr}/${codel}_${coder}
	    if {[catch { info args $proc }]} {
		if {$showunbound} {
		    debug "ib $devid unbound $proc << $l"
		}
		return
	    }
	    $proc $devid $value
	}
	* {
	    debug "ib $devid ignored << $l"
	}
    }
}

proc catch-for-input-binding {devid body} {
    upvar #0 input/$devid in
    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 $devid died $m"
    catch { close $in(chan) }
    catch { unset in(chan) }

    input-binding-notpresent $devid "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 input_statics
    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 {} }
    if {![info exists input_statics]} { set input_statics {} }

    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