[rocl] / elite-editor

#! /usr/bin/wish
#
# $Id: elite-editor,v 1.8 2003/03/07 00:43:12 mdw Exp $

package require "elite" "1.0.1"

# --- Utility procedures ----------------------------------------------------

proc moan {msg} {
  global argv0
  tk_messageBox -message $msg -default ok -title $argv0 -type ok -icon error
}

proc debug-array {name} {
  upvar \#0 $name a
  set tl .debug-$name
  if {[winfo exists .$tl]} { return }
  set s [array startsearch a]
  toplevel $tl
  set r 0
  set n 0
  while {[array anymore a $s]} {
    set k [array nextelement a $s]
    label $tl.k-$n -text $k -justify right
    entry $tl.v-$n -textvariable ${name}($k) -state disabled
    grid configure $tl.k-$n -row $r -column 0 -sticky e
    grid configure $tl.v-$n -row $r -column 1 -sticky we
    incr r
    incr n
  }
  array donesearch a $s
}

proc get-line-done {tl cmd} {
  if {![uplevel \#0 [concat $cmd [$tl.entry get]]]} {
    destroy $tl
  }
}

proc get-line {tl title prompt def cmd} {
  if {[winfo exists $tl]} {
#    raise $tl
    return
  }
  toplevel $tl
  wm title $tl $title
  label $tl.label -text "$prompt: "
  entry $tl.entry; $tl.entry insert 0 $def
  button $tl.ok -text OK -default active \
      -command [list get-line-done $tl $cmd]
  bind $tl <Return> [list get-line-done $tl $cmd]
  bind $tl <Escape> [list destroy $tl]
  pack $tl.label $tl.entry $tl.ok -side left -padx 2 -pady 2
}

proc entry-on-change {widget what} {
  bind $widget <Return> $what
  bind $widget <FocusOut> $what
}

#----- Map editing machinery ------------------------------------------------

tab col red orange yellow green blue magenta violet white

set seq 0
set nwin 0
array set default {scale 15 colourby off connect 0}

proc set-scale {seq sc} {
  if {![regexp {^\d+$} $sc]} {
    moan "bad scale factor `$sc'"
    return 1
  }
  map-setscale $seq $sc
  return 0
}

proc new-view {gs} {
  set g [parse-galaxy-spec $gs]
  if {![llength $g]} {
    moan "bad galaxy spec `$gs'"
    return 1
  }
  destructure {ng g} $g
  map-new $ng $g
  return 0
}

proc set-hyperspace-range {seq f} {
  if {![regexp {^\d+(\.\d+)?$} $f]} {
    moan "bad hyperspace range `$f'"
    return 1
  }
  map-set-fuel $seq [expr {$f * 10}]
  return 0
}

# --- Colour-coding planets ---

proc colour-by {seq} {
  upvar \#0 map-$seq map
  set tl .map-$seq
  global col
  switch -exact -- $map(colourby) {
    off { 
      foreach-world $map(galaxy) p {
	$tl.map itemconfigure $p(seed) -fill white -outline white
      }
    }
    economy {
      foreach-world $map(galaxy) p {
	set c [expr {7 - $p(economy)}]
	$tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
      }
    }
    government {
      foreach-world $map(galaxy) p {
	set c $p(government)
	$tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
      }
    }
    techlevel {
      foreach-world $map(galaxy) p {
	set c [expr {$p(techlevel) / 2}]
	$tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
      }
    }
  }
}

proc set-colour-by {seq} {
  global default
  upvar \#0 map-$seq map
  set default(colourby) $map(colourby)
  colour-by $seq
}

# --- Connectivity maps ---

proc show-connectivity {seq} {
  upvar \#0 map-$seq map
  upvar \#0 adj-$map(galaxy)-$map(fuel) adj
  upvar \#0 ww-$map(galaxy) ww
  set tl .map-$seq
  $tl.map delete conn
  if {!$map(connect)} {
    show-path $seq
    return
  }
  if {![info exists adj]} { elite-adjacency adj $ww $map(fuel) }
  foreach {s x y} $ww {
    set done($s) 1
    foreach {ss xx yy} $adj($s) {
      if {[info exists done($ss)]} { continue }
      $tl.map create line \
	  [to-map $seq $x] [to-map $seq $y] \
	  [to-map $seq $xx] [to-map $seq $yy] \
	  -fill darkblue -tags conn
    }
  }
  $tl.map lower conn sep
  show-path $seq
}

proc set-connectivity {seq} {
  global default
  upvar \#0 map-$seq map
  set default(connect) $map(connect)
  show-connectivity $seq
}

# --- Planet names ---

proc show-names {seq} {
  upvar \#0 map-$seq map
  set tl .map-$seq
  $tl.map delete names
  if {!$map(names)} {
    return
  }
  foreach-world $map(galaxy) p {
    set anc nw
    set px [to-map $seq $p(x)]
    set py [to-map $seq $p(y)]
    set offx [expr {$px + [to-map $seq 2]}]
    set offy [expr {$py + [to-map $seq 2]}]
    set what {}
    foreach {a ox oy dx x y xx yy} {
      nw   2  2   0   0   0  30  10
      nw   2  2 -10   0   0  30  10
      sw   2 -2   0   0 -10  30   0
      sw   2 -2 -10   0 -10  30   0
      se  -2 -2   0 -30 -10   0   0
      se  -2 -2  10 -30 -10   0   0
      ne  -2  2   0 -30   0   0  10
      ne  -2  2  10 -30   0   0  10
    } {
      set ox [expr {$px + [to-map $seq $ox] + $dx}]
      set oy [expr {$py + [to-map $seq $oy]}]
      if {![llength [$tl.map find overlapping \
	  [expr {$ox + $x}] [expr {$ox + $y}] \
	  [expr {$ox + $xx}] [expr {$ox + $yy}]]]} {
	set offx $ox
	set offy $oy
	set anc $a
	break
      }
      lappend what $a
    }
    $tl.map create text $offx $offy -text $p(name) \
	-fill white -anchor $a -tags names
  }
}

proc set-names {seq} {
  global default
  upvar \#0 map-$seq map
  set default(names) $map(names)
  show-names $seq
}

# --- Shortest path handling ---

proc show-path {seq} {
  upvar \#0 map-$seq map
  set tl .map-$seq
  $tl.map delete path
  if {![info exists map(path)]} { return }
  foreach n $map(path) {
    elite-worldinfo p $n
    if {[info exists x]} {
      $tl.map create line \
	  [to-map $seq $x] [to-map $seq $y] \
	  [to-map $seq $p(x)] [to-map $seq $p(y)] \
	  -fill darkorange -tags path
    }
    set x $p(x)
    set y $p(y)
  }
  $tl.map lower path sep
}

proc hide-path {seq} {
  upvar \#0 map-$seq map
  set tl .map-$seq
  $tl.map delete path
  unset map(path)
  foreach i {2 3 11} {
    $tl.menu.path entryconfigure $i -state disabled
  }
}

proc path-to-text {seq} { 
  upvar \#0 map-$seq map
  set t {}
  foreach n $map(path) {
    append t [world-summary $n] "\n"
  }
  return $t
}

proc save-path {seq} {
  set file [tk_getSaveFile -initialfile "path" -title "Save path"]
  if {[string equal $file ""]} { return }
  if {[catch { write-file $file [path-to-text $seq] auto } err]} {
    moan $err
  }
}

proc list-path {seq} {
  upvar \#0 map-$seq map
  set tl .map-$seq.path
  if {[winfo exists $tl]} {
    # raise $tl
  } else {
    toplevel $tl
    wm title $tl "Path listing"
    scrollbar $tl.hscr -orient horizontal -command [list $tl.text xview]
    scrollbar $tl.vscr -orient vertical -command [list $tl.text yview]
    text $tl.text -wrap none -width 80 -height 20 \
	-xscrollcommand [list $tl.hscr set] \
	-yscrollcommand [list $tl.vscr set]
    grid configure $tl.text -row 0 -column 0 -sticky nsew
    grid configure $tl.hscr -row 1 -column 0 -sticky ew
    grid configure $tl.vscr -row 0 -column 1 -sticky ns
    grid rowconfigure $tl 0 -weight 1
    grid columnconfigure $tl 0 -weight 1
  }
  $tl.text configure -state normal
  $tl.text delete 1.0 end
  $tl.text insert end [path-to-text $seq]
  $tl.text configure -state disabled
}  

proc load-path {seq} {
  upvar \#0 map-$seq map
  set tl .map-$seq
  set file [tk_getOpenFile -title "Load path"]
  if {[catch {
    set f [open $file]
    set path {}
    while {[gets $f line] >= 0} {
      if {[regexp {^\s*(\#|$)} $line]} { continue }
      if {[regexp {\m[0-9a-f]{12}\M} $line p]} {
      } else {
	set p [parse-planet-spec $map(galaxy) [lindex $line 0]]
	if {[string equal $p ""]} {
	  error "unrecognized path line `$line'"
	}
      }
      lappend path $p
    }
    if {![in-galaxy-p $map(galaxy) $path]} {
      error "not all worlds in this galaxy"
    }
    close $f
  } err]} {
    catch { close $f }
    moan $err
    return
  }
  set map(path) $path
  foreach i {2 3 11} {
    $tl.menu.path entryconfigure $i -state normal
  }
  show-path $seq
}  

proc show-shortest-path {seq weight} {
  upvar \#0 map-$seq map
  upvar \#0 adj-$map(galaxy)-$map(fuel) adj
  upvar \#0 ww-$map(galaxy) ww
  set tl .map-$seq
  $tl.map delete path
  if {[info exists map(path)]} { unset map(path) }
  if {![info exists map(select)] || ![info exists map(dest)]} {
    moan "no source or destination set"
    return
  }
  if {![info exists adj]} { elite-adjacency adj $ww $map(fuel) }
  destructure {path weight} \
      [shortest-path adj $map(select) $map(dest) $weight]
  if {![llength $path]} {
    moan "no path exists"
    return
  }
  set map(path) $path
  foreach i {2 3 11} {
    $tl.menu.path entryconfigure $i -state normal
  }
  show-path $seq
}

# --- Planet information box ---

proc show-worldinfo {tag p} {
  global economy government
  upvar \#0 info-$tag info
  set tl .world-info-$tag
  elite-worldinfo info $p
  if {[winfo exists $tl]} {
#    raise $tl
  } else {
    toplevel $tl
    set r 0
    foreach {item label} {
      name	"Name"
      seed	"Seed"
      position	"Position"
      eco-name	"Economy"
      gov-name	"Government"
      techlevel	"Tech. level"
      pop-str	"Population"
      prod-str	"Productivity"
      radius-km	"Radius"
    } {
      label $tl.l-$item -text "$label: " -justify right
      entry $tl.$item -textvariable info-${tag}($item) -state disabled
      grid configure $tl.l-$item -row $r -column 0 -sticky e
      grid configure $tl.$item -row $r -column 1 -columnspan 2 -sticky we
      incr r
    }
    scrollbar $tl.descscr -orient vertical -command [list $tl.desc yview]
    text $tl.desc -wrap word -yscrollcommand [list $tl.descscr set] \
	-width 40 -height 4
    grid configure $tl.desc -row $r -column 0 -columnspan 2 -sticky nsew
    grid configure $tl.descscr -row $r -column 2 -sticky ns
    grid columnconfigure $tl 1 -weight 1
    grid rowconfigure $tl $r -weight 1
  }
  wm title $tl "Info: $info(name)"
  set info(position) "$info(x), $info(y)"
  set info(eco-name) $economy($info(economy))
  set info(gov-name) $government($info(government))
  set info(pop-str) \
      [format "%s billion (%s)" \
      [expr {$info(population)/10}] \
      $info(inhabitants)]
  set info(prod-str) [format "%d M Cr" $info(productivity)]
  set info(radius-km) [format "%d km" $info(radius)]
  $tl.desc configure -state normal
  $tl.desc delete 1.0 end
  $tl.desc insert end $info(description)
  $tl.desc configure -state disabled
}

proc do-getinfo {tag seq x y} {
  show-worldinfo $tag [find-click $seq $x $y]
}

# --- Messing with selections ---

proc to-ly {seq x} {
  upvar \#0 map-$seq map
  return [expr {$x * $map(scale) / 10.0}]
}

proc to-map {seq x} {
  upvar \#0 map-$seq map
  return [expr {$x * 10 / $map(scale)}]
}

proc find-click {seq x y} {
  upvar \#0 map-$seq map
  upvar \#0 ww-$map(galaxy) ww
  set tl .map-$seq

  set x [to-ly $seq [$tl.map canvasx $x]]
  set y [to-ly $seq [$tl.map canvasy $y]]
  set best 100000
  foreach {seed px py} $ww {
    set dx [expr {$x - $px}]
    set dy [expr {$y - $py}]
    set d [expr {$dx * $dx + $dy * $dy}]
    if {$d < $best} {
      set best $d
      set p $seed
    }
  }
  $tl.map delete here

  if 0 {
    $tl.map create line \
	[expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] - 5}] \
	[expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] + 5}] \
	-tags here -fill green
    $tl.map create line \
	[expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] + 5}] \
	[expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] - 5}] \
	-tags here -fill green
  }
  return $p
}

proc destination-world {seq} {
  upvar \#0 map-$seq map
  set tl .map-$seq
  if {![info exists map(dest)]} { return }
  $tl.map delete dest
  elite-worldinfo p $map(dest)
  set px [to-map $seq $p(x)]
  set py [to-map $seq $p(y)]
  $tl.map create line [expr {$px - 10}] $py [expr {$px + 10}] $py \
      -tags {dest cross} -fill darkorange
  $tl.map create line $px [expr {$py - 10}] $px [expr {$py + 10}] \
      -tags {dest cross} -fill darkorange
  $tl.map raise dest sel
}

proc select-world {seq} {
  upvar \#0 map-$seq map
  set tl .map-$seq
  if {![info exists map(select)]} { return }
  $tl.map delete sel dest
  elite-worldinfo p $map(select)
  set r [to-map $seq $map(fuel)]
  set px [to-map $seq $p(x)]
  set py [to-map $seq $p(y)]
  $tl.map create line [expr {$px - 20}] $py [expr {$px + 20}] $py \
      -tags {sel cross} -fill darkred
  $tl.map create line $px [expr {$py - 20}] $px [expr {$py + 20}] \
      -tags {sel cross} -fill darkred
  $tl.map create oval \
      [expr {$px - $r}] [expr {$py - $r}] \
      [expr {$px + $r}] [expr {$py + $r}] \
      -tags {sel radius} -outline darkgreen
  $tl.map raise sel sep
}

proc select-byname {seq name seed proc} {
  upvar \#0 map-$seq map
  set p [parse-planet-spec $map(galaxy) $map($name)]
  if {![string equal $p ""] && [in-galaxy-p $map(galaxy) $p]} {
    $proc $seq $p
    return 1
  } elseif {[info exists map($seed)]} {
    bell
    set map($name) [worldname $map($seed)]
    return 0
  } else {
    bell
    set map($name) ""
    return 0
  }
}

proc info-byname {seq name seed proc} {
  upvar \#0 map-$seq map
  if {[select-byname $seq $name $seed $proc]} {
    show-worldinfo $seed $map($seed)
  }
}

proc set-selection {seq p} {
  upvar \#0 map-$seq map
  if {[info exists map(cmdr)]} {
    set p [cmdr-set-world $map(cmdr) $p]
  }
  set map(select) $p
  elite-worldinfo pp $p
  select-world $seq
  set map(sel-name) $pp(name)
  if {![info exists map(dest)]} {
    set-destination $seq $p
  } else {
    set-destination $seq $map(dest)
  }
}  

proc do-select {seq x y} {
  set-selection $seq [find-click $seq $x $y]
}

proc set-destination {seq p} {
  upvar \#0 map-$seq map
  if {![info exists map(select)]} {
    set-selection $seq $p
  } else {
    elite-worldinfo ps $map(select)
    elite-worldinfo pd $p
    set map(dest) $p
    destination-world $seq
    set map(dest-name) $pd(name)
    set map(distance) \
	[format "%.1f" \
	[expr {[elite-distance $ps(x) $ps(y) $pd(x) $pd(y)] / 10.0}]]
  }
}

proc do-destination {seq x y} {
  set-destination $seq [find-click $seq $x $y]
}

# --- Redrawing a map ---

proc map-populate {seq} {
  global colourby-$seq connect-$seq
  upvar \#0 map-$seq map
  upvar \#0 ww-$map(galaxy) ww
  set tl .map-$seq

  set scale $map(scale)
  $tl.map delete all
  $tl.map create line -10000 -20000 -10000 -20000 -fill black -tags sep
  if {![info exists ww]} { set ww [elite-galaxylist $map(galaxy)] }
  foreach {seed x y} $ww {
    elite-worldinfo p $seed
    set x [expr {$x * 10 / $map(scale)}]
    set y [expr {$y * 10 / $map(scale)}]
    set r [expr {$p(radius) / (500 * $map(scale))}]
    $tl.map create oval \
	[expr {$x - $r}] [expr {$y - $r}] \
	[expr {$x + $r}] [expr {$y + $r}] \
	-fill white -outline white \
	-tags [list $seed world]
  }

  colour-by $seq
  show-connectivity $seq
  show-names $seq
  select-world $seq
  destination-world $seq
}

# --- Miscellaneous stuff ---

proc map-setscale {seq sc} {
  global default
  upvar \#0 map-$seq map
  set tl .map-$seq
  set wd [expr {10240/$sc + 40}]
  set ht [expr {5120/$sc} + 10]
  $tl.map configure -scrollregion [list -40 -10 $wd $ht]
  set map(scale) $sc
  set default(scale) $sc
  map-populate $seq
}

proc map-destroy {seq} {
  global nwin
  upvar \#0 map-$seq map
  if {[info exists map(cmdr)]} {
    upvar \#0 cmdr-$map(cmdr) cmdr
    unset cmdr(map)
  }
  unset map
  destroy .map-$seq .set-scale-$seq
  incr nwin -1
  if {!$nwin} { exit }
}

proc map-attach-cmdr {seq cmdr} {
  upvar \#0 map-$seq map
  set map(cmdr) $cmdr
  map-set-title $seq
  .map-$seq.menu.view entryconfigure 3 -state disabled
}

proc map-set-title {seq} {
  upvar \#0 map-$seq map
  set tl .map-$seq
  set t "Galaxy $map(galaxy-num)"
  if {[info exists map(cmdr)]} {
    append t " (commander [cmdr-name $map(cmdr)])"
  }
  wm title $tl $t
}

proc map-set-galaxy {seq ng g} {
  upvar \#0 map-$seq map  
  if {[string equal $g $map(galaxy)]} { return }
  set map(galaxy-num) $ng
  map-set-title $seq
  set map(galaxy) $g
  map-populate $seq
  foreach i {select select-name dest dest-name} {
    catch { unset map($i) }
  }
}

proc map-set-fuel {seq qty} {
  upvar \#0 map-$seq map
  set map(fuel) [expr {int($qty)}]
  select-world $seq
  show-connectivity $seq
}

# --- Making a new map window ---

proc map-new {ng g} {
  global seq nwin default
  incr seq
  incr nwin
  upvar \#0 map-$seq map

  array set map [array get default]
  set sc $map(scale)
  set map(galaxy) $g
  set map(galaxy-num) $ng
  set tl [toplevel .map-$seq]
  set wd [expr {10240/$sc + 80}]
  set ht [expr {5120/$sc + 20}]
  set vwd $wd; if {$vwd > 1120} { set vwd 768 }
  set vht $ht; if {$vht > 1024} { set vht 768 }
  set map(fuel) 70
  canvas $tl.map \
      -background black \
      -xscrollcommand [list $tl.hscr set] \
      -yscrollcommand [list $tl.vscr set] \
      -width $vwd -height $vht
  frame $tl.info
  label $tl.info.lhome -text "Home: "
  entry $tl.info.home -textvariable map-${seq}(sel-name)
  label $tl.info.ldest -text "Destination: "
  entry $tl.info.dest -textvariable map-${seq}(dest-name)
  label $tl.info.ldist -text "Distance: "
  entry $tl.info.dist -textvariable map-${seq}(distance) \
      -state disabled -width 6
  pack \
      $tl.info.lhome $tl.info.home \
      $tl.info.ldest $tl.info.dest \
      $tl.info.ldist $tl.info.dist \
      -side left
  
  scrollbar $tl.hscr -orient horizontal \
      -command [list $tl.map xview]
  scrollbar $tl.vscr -orient vertical \
      -command [list $tl.map yview]
  menu $tl.menu
  menu $tl.menu.file
  $tl.menu.file add command -label "New commander" -command cmdr-new
  $tl.menu.file add command -label "Load commander..." \
      -command { cmdr-loadfile }
  $tl.menu.file add separator
  $tl.menu.file add command -label "Close" -command [list map-destroy $seq]
  $tl.menu.file add command -label "Quit" -command { exit }
  $tl.menu add cascade -label "File" -menu $tl.menu.file
  menu $tl.menu.view
  $tl.menu.view add command -label "New map..." \
      -command [list get-line .new-view "New map" "Galaxy" $ng new-view]
  $tl.menu.view add command -label "Set scale..." \
      -command [concat get-line .set-scale-$seq {"Set scale"} "Scale" \
      \[set map-${seq}(scale)\] [list [list set-scale $seq]]]
  $tl.menu.view add command -label "Set hyperspace range..." \
      -command [concat get-line .set-fuel-$seq {"Set hyperspace range"} \
      {"Hyperspace range"} \[expr \[set map-${seq}(fuel)\]/10.0\] \
      [list [list set-hyperspace-range $seq]]]
  $tl.menu.view add separator
  $tl.menu.view add radiobutton -label "Off" \
      -variable map-${seq}(colourby) -value off \
      -command [list set-colour-by $seq]
  $tl.menu.view add radiobutton -label "Economy" \
      -variable map-${seq}(colourby) -value economy \
      -command [list set-colour-by $seq]
  $tl.menu.view add radiobutton -label "Government" \
      -variable map-${seq}(colourby) -value government \
      -command [list set-colour-by $seq]
  $tl.menu.view add radiobutton -label "Tech level" \
      -variable map-${seq}(colourby) -value techlevel \
      -command [list set-colour-by $seq]
  $tl.menu.view add separator
  $tl.menu.view add checkbutton -label "Connectivity" \
      -variable map-${seq}(connect) \
      -command [list set-connectivity $seq]
  $tl.menu.view add checkbutton -label "Planet names" \
      -variable map-${seq}(names) \
      -command [list set-names $seq]
  $tl.menu add cascade -label "View" -menu $tl.menu.view
  menu $tl.menu.path
  $tl.menu.path add command -label "Load path..." \
      -command [list load-path $seq]
  $tl.menu.path add command -label "Save path..." -state disabled \
      -command [list save-path $seq] 
  $tl.menu.path add command -label "List path..." -state disabled \
      -command [list list-path $seq]
  $tl.menu.path add separator
  $tl.menu.path add command -label "Minimize hops" \
      -command [list show-shortest-path $seq weight-hops]
  $tl.menu.path add command -label "Minimize fuel" \
      -command [list show-shortest-path $seq weight-fuel]
  $tl.menu.path add command -label "Maximize safety" \
      -command [list show-shortest-path $seq weight-safety]
  $tl.menu.path add command -label "Minimize safety" \
      -command [list show-shortest-path $seq weight-encounters]
  $tl.menu.path add command -label "Maximize trading" \
      -command [list show-shortest-path $seq weight-trading]
  $tl.menu.path add separator
  $tl.menu.path add command -label "Hide path" -state disabled \
      -command [list hide-path $seq]
  $tl.menu add cascade -label "Path" -menu $tl.menu.path
  $tl configure -menu $tl.menu

  wm protocol $tl WM_DELETE_WINDOW [list map-destroy $seq]

  grid $tl.map -column 0 -row 0 -sticky nsew
  grid $tl.hscr -column 0 -row 1 -sticky ew
  grid $tl.vscr -column 1 -row 0 -sticky ns
  grid rowconfigure $tl 0 -weight 1
  grid columnconfigure $tl 0 -weight 1
  grid $tl.info -column 0 -columnspan 2 -row 2 -sticky ew

  bind $tl.map <3> [list do-select $seq %x %y]
  bind $tl.map <1> [list do-destination $seq %x %y]
  bind $tl.map <Double-1> [list do-getinfo dest $seq %x %y]
  bind $tl.map <Double-3> [list do-getinfo select $seq %x %y]

  map-set-title $seq
  entry-on-change $tl.info.home \
      [list select-byname $seq sel-name select set-selection]
  entry-on-change $tl.info.dest \
      [list select-byname $seq dest-name dest set-destination]
  bind $tl.info.home <Control-Return> \
      [list info-byname $seq sel-name select set-selection]
  bind $tl.info.dest <Control-Return> \
      [list info-byname $seq dest-name dest set-destination]
  map-setscale $seq $sc
  return $seq
}

#----- Commander editing machinery ------------------------------------------

# --- Validation and factor-of-10 fixing ---

proc fix-tenth {tag arrvar full op} {
  upvar \#0 $arrvar arr
  catch { set arr($tag) [format "%d" [expr {int($arr($full) * 10)}]] }
}

proc numericp {min max n} {
  if {[catch { expr {$n + 0} }]} { return 0 }
  if {$n < $min || $n > $max} { return 0 }
  return 1
}

proc integerp {min max n} {
  if {[catch { incr n 0}]} { return 0 }
  if {$n < $min || $n > $max} { return 0 }
  return 1
}

proc galaxyp {s} {
  if {![regexp {^[0-9a-fA-F]{12}$} $s]} { return 0 }
  return 1
}  

proc cmdr-do-validate {seq widget check value} {
  upvar \#0 cmdr-$seq cmdr
  if {$cmdr(ok/$widget)} { incr cmdr(bogus) }
  if {![eval $check [list $value]]} {
    set cmdr(ok/$widget) 0
    $widget configure -foreground red
  } else {
    set cmdr(ok/$widget) 1
    $widget configure -foreground black
    incr cmdr(bogus) -1
  }
  return 1
}

proc cmdr-validate-widget {seq widget check} {
  upvar \#0 cmdr-$seq cmdr
  set cmdr(ok/$widget) 1
  $widget configure -validate key \
      -vcmd [list cmdr-do-validate $seq $widget $check %P]
}

# --- Cargo window handling ---

proc cmdr-set-fluc {seq} {
  upvar \#0 cmdr-$seq cmdr
  global products
  set tl .cmdr-$seq.cargo-qty
  if {!$cmdr(ok/$tl.fluc)} { bell; return }
  elite-market m $cmdr(world-seed) $cmdr(market-fluc)
  foreach {i .} $products {
    set cmdr(price-$i) [format "%.1f" [expr {[lindex $m($i) 0]/10.0}]]
  }
}

proc cmdr-cargo {seq} {
  upvar \#0 cmdr-$seq cmdr
  set tl .cmdr-$seq.cargo-qty
  if {[winfo exists $tl]} {
#    raise $tl
    return
  }
  toplevel $tl
  wm title $tl "Cargo for commander $cmdr(name)"
  global products
  set r 0
  label $tl.l-fluc -text "Fluctuation: " -justify right
  entry $tl.fluc -textvariable cmdr-${seq}(market-fluc) -justify right
  cmdr-validate-widget $seq $tl.fluc [list integerp 0 255]
  entry-on-change $tl.fluc [list cmdr-set-fluc $seq]
  grid configure $tl.l-fluc -row $r -column 0 -sticky e
  grid configure $tl.fluc -row $r -column 1 -columnspan 3 -sticky we
  incr r
  label $tl.l-item -text "Item" -justify center
  label $tl.l-price -text "Price" -justify center
  label $tl.l-station -text "Station" -justify center
  label $tl.l-hold -text "Hold" -justify center
  grid configure $tl.l-item -row $r -column 0 -sticky e
  grid configure $tl.l-price -row $r -column 1 -sticky we
  grid configure $tl.l-station -row $r -column 2 -sticky we
  grid configure $tl.l-hold -row $r -column 3 -sticky we
  incr r
  foreach {tag label} $products {
    label $tl.l-$tag -text "$label: " -justify right
    entry $tl.price-$tag -textvariable cmdr-${seq}(price-${tag}) \
	-justify right -state disabled -width 4
    foreach {pre col} {station 2 hold 3} {
      entry $tl.${pre}-${tag} -textvariable cmdr-${seq}(${pre}-${tag}) \
	  -justify right -width 4
      cmdr-validate-widget $seq $tl.${pre}-${tag} [list integerp 0 255]
      grid configure $tl.${pre}-${tag} -row $r -column $col -stick we
    }
    grid configure $tl.l-$tag -row $r -column 0 -sticky e
    grid configure $tl.price-$tag -row $r -column 1 -sticky we
    incr r
  }
  grid columnconfigure $tl 1 -weight 1
  grid columnconfigure $tl 2 -weight 1
  grid columnconfigure $tl 3 -weight 1
}

# --- Miscellaneous stuff ---

proc cmdr-destroy {seq} {
  upvar \#0 cmdr-$seq cmdr
  global nwin
  set tl .cmdr-$seq
  if {[info exists cmdr(map)]} { map-destroy $cmdr(map) }
  unset cmdr
  destroy $tl
  incr nwin -1
  if {!$nwin} { exit }
}

proc cmdrdb-set {seq tag value} {
  upvar \#0 cmdr-$seq cmdr
  set tl .cmdr-$seq
  set cmdr($tag) $value
  $tl.$tag configure -state disabled
}

proc cmdrdb-custom {seq tag} {
  set tl .cmdr-$seq
  $tl.$tag configure -state normal
}

proc cmdr-set-world {seq p} {
  upvar \#0 cmdr-$seq cmdr
  upvar \#0 ww-$cmdr(gal-seed) ww
  elite-worldinfo i $p
  set pp [nearest-planet $ww $i(x) $i(y)]
  if {![string equal $p $pp]} {
    set n $i(name)
    elite-worldinfo i $pp
    moan "world $n is coincident with $i(name); substituting"
  }
  set cmdr(world-seed) $i(seed)
  set cmdr(world-name) $i(name)
  set cmdr(world-x) [expr {$i(x)/4}]
  set cmdr(world-y) [expr {$i(y)/2}]
  cmdr-set-fluc $seq
  return $i(seed)
}

proc cmdr-update-world {seq} {
  upvar \#0 cmdr-$seq cmdr
  upvar \#0 ww-$cmdr(gal-seed) ww
  if {![info exists ww]} { set ww [elite-galaxylist $cmdr(gal-seed)] }
  set tl .cmdr-$seq
  set w [nearest-planet $ww \
      [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]]
  if {[info exists cmdr(map)]} {
    if {$cmdr(std-gal)} {
      set ng $cmdr(gal-number)
    } else {
      set ng $cmdr(gal-seed)
    }
    map-set-galaxy $cmdr(map) $ng $cmdr(gal-seed)
    set-selection $cmdr(map) $w
  }
  cmdr-set-world $seq $w
}

proc cmdr-set-gal-num {seq} {
  upvar \#0 cmdr-$seq cmdr
  set tl .cmdr-$seq
  if {!$cmdr(ok/$tl.gal-number)} { bell; return }
  if {$cmdr(std-gal)} {
    set cmdr(gal-seed) [galaxy $cmdr(gal-number)]
    cmdr-update-world $seq
  }
}

proc cmdr-std-gal {seq} {
  upvar \#0 cmdr-$seq cmdr
  set tl .cmdr-$seq
  if {$cmdr(std-gal)} {
    if {!$cmdr(ok/$tl.gal-number)} { bell; return }
    set cmdr(gal-seed) [galaxy $cmdr(gal-number)]
    cmdr-update-world $seq
    $tl.gal-seed configure -state disabled
  } else {
    $tl.gal-seed configure -state normal
  }
}

proc cmdr-set-fuel {seq} {
  upvar \#0 cmdr-$seq cmdr
  if {[info exists cmdr(map)]} {
    map-set-fuel $cmdr(map) $cmdr(fuel)
  }
}

proc cmdr-name {seq} {
  upvar \#0 cmdr-$seq cmdr
  return $cmdr(name)
}

proc cmdr-show-map {seq} {
  upvar \#0 cmdr-$seq cmdr
  if {[info exists cmdr(map)]} {
    return
  }
  if {$cmdr(std-gal)} {
    set ng $cmdr(gal-number)
  } else {
    set ng $cmdr(gal-seed)
  }
  set cmdr(map) [map-new $ng $cmdr(gal-seed)]
  map-attach-cmdr $cmdr(map) $seq
  map-set-fuel $cmdr(map) $cmdr(fuel)
  set-selection $cmdr(map) $cmdr(world-seed)
}

proc cmdr-set-name {seq} {
  upvar \#0 cmdr-$seq cmdr
  if {[info exists cmdr(file)]} {
    set cmdr(name) [string toupper [file rootname [file tail $cmdr(file)]]]
  } else {
    set cmdr(name) JAMESON
  }
  set tl .cmdr-$seq
  wm title $tl "Commander $cmdr(name)"
  if {[info exists cmdr(map)]} { map-set-title $cmdr(map) }
  if {[winfo exists $tl.cargo-qty]} {
    wm title $tl.cargo-qty "Cargo for commander $cmdr(name)"
  }
}

proc cmdr-check {seq} {
  upvar \#0 cmdr-$seq cmdr
  if {$cmdr(bogus)} {
    moan("invalid values in commander data -- fix items highlighted in red")
    return 0
  }
  return 1
}

# --- Initial population ---

proc cmdr-open {seq} {
  upvar \#0 cmdr-$seq cmdr
  global cmdr-$seq
  set tl .cmdr-$seq
  global nwin
  toplevel $tl
  set laser {
    dropbox 255
    "None"	0
    "Pulse"	0x0f
    "Beam"	0x8f
    "Military"	0x97
    "Mining"	0x32
  }
  set r 0
  set cmdr(bogus) 0
  foreach {tag label kind} [list \
    mission		"Mission"		{ entry 2 255 } \
    score		"Rating"		{ dropbox 65535\
    						  "Harmless"		0 \
						  "Mostly harmless"     8 \
						  "Poor"	       16 \
						  "Average"            32 \
						  "Above average"      64 \
						  "Competent"         128 \
						  "Dangerous"         512 \
						  "Deadly"           2560 \
						  "Elite"            6400 } \
    legal-status	"Legal status"		{ dropbox 255 \
						  "Clean"	0 \
						  "Offender"	1 \
						  "Fugitive"	50 } \
    world		"Location"		where \
    credits		"Credits"		{ tenth 10 429496729.5 } \
    fuel		"Fuel"			{ tenth 4 25.5 } \
    missiles		"Missiles"		{ entry 4 255 } \
    energy-unit		"Energy unit"		{ dropbox 255 \
    						  "None"	0 \
						  "Standard"	1 \
						  "Naval"	2 } \
    front-laser		"Front laser"		$laser \
    rear-laser		"Front laser"		$laser \
    left-laser		"Left laser"		$laser \
    right-laser		"Right laser"		$laser \
    ecm			"ECM"			toggle \
    fuel-scoop		"Fuel scoops"		toggle \
    energy-bomb		"Energy bomb"		toggle \
    escape-pod		"Escape pod"		toggle \
    docking-computer	"Docking computers"	toggle \
    gal-hyperdrive	"Galactic hyperdrive"	toggle \
    cargo		"Cargo capacity"	{ entry 4 255 } \
    stuff		"Cargo"			cargo \
  ] {
    switch -exact -- [lindex $kind 0] {
      entry {
	destructure {. wd max} $kind
	label $tl.l-$tag -text "$label: " -justify right
	entry $tl.$tag -textvariable cmdr-${seq}($tag) \
	    -width $wd -justify right
	cmdr-validate-widget $seq $tl.$tag [list integerp 0 $max]
	grid configure $tl.l-$tag -row $r -column 0 -sticky e
	grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we
      }
      tenth {
	destructure {. wd max} $kind
	label $tl.l-$tag -text "$label: " -justify right
	entry $tl.$tag -textvariable cmdr-${seq}(div-$tag) \
	    -width $wd -justify right
	set cmdr(div-$tag) [format "%.1f" [expr {$cmdr($tag) / 10.0}]]
	trace variable cmdr-${seq}(div-$tag) w [list fix-tenth $tag]
	cmdr-validate-widget $seq $tl.$tag [list numericp 0 $max]
	grid configure $tl.l-$tag -row $r -column 0 -sticky e
	grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we
      }
      toggle {
	checkbutton $tl.$tag -text $label -variable cmdr-${seq}($tag)
	grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky w
      }
      dropbox {
	label $tl.l-$tag -text "$label: " -justify right
	set menu $tl.m-$tag.menu
	menubutton $tl.m-$tag -textvariable cmdr-${seq}(r-${tag}) \
	    -indicatoron 1 -relief raised -menu $menu -width 8 \
	    -direction flush
	entry $tl.$tag -textvariable cmdr-${seq}($tag) \
	    -justify right -width 4
	cmdr-validate-widget $seq $tl.$tag [list integerp 0 [lindex $kind 1]]
	menu $menu -tearoff 0
	set cmdr(r-$tag) "Custom"
	foreach {name value} [lrange $kind 2 end] {
	  $menu add radiobutton -label "$name ($value)" \
	      -value $name -variable cmdr-${seq}(r-$tag) \
	      -command [list cmdrdb-set $seq $tag $value]
	  if {$cmdr($tag) == $value} {
	    set cmdr(r-$tag) $name
	    set cmdr($tag) $value
	    $tl.$tag configure -state disabled
	  }
	}
	$menu add radiobutton -label "Custom" \
	    -value "Custom" -variable cmdr-${seq}(r-$tag) \
	    -command [list cmdrdb-custom $seq $tag]
	grid configure $tl.l-$tag -row $r -column 0 -sticky e
	grid configure $tl.m-$tag -row $r -column 1 -sticky we
	grid configure $tl.$tag -row $r -column 2 -sticky we
      }
      cargo {
	button $tl.$tag -text $label -command [list cmdr-cargo $seq]
	grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we
      }
      where {
	label $tl.l-gal-number -text "Galaxy number: " -justify right
	entry $tl.gal-number -textvariable cmdr-${seq}(gal-number) \
	    -justify right -width 2
	cmdr-validate-widget $seq $tl.gal-number [list integerp 1 8]
	checkbutton $tl.std-gal -text "Standard galaxy" \
	    -variable cmdr-${seq}(std-gal) -justify left \
	    -command [list cmdr-std-gal $seq]	  
	entry-on-change $tl.gal-number [list cmdr-set-gal-num $seq]
	grid configure $tl.l-gal-number -row $r -column 0 -sticky e
	grid configure $tl.std-gal -row $r -column 1 -sticky w
	grid configure $tl.gal-number -row $r -column 2 -sticky we
	incr r
	label $tl.l-gal-seed -text "Galaxy seed: " -justify right
	entry $tl.gal-seed -textvariable cmdr-${seq}(gal-seed) -width 12
	cmdr-validate-widget $seq $tl.gal-seed galaxyp
	entry-on-change $tl.gal-seed [list cmdr-update-world $seq]
	grid configure $tl.l-gal-seed -row $r -column 0 -sticky e
	grid configure $tl.gal-seed -row $r \
	    -column 1 -columnspan 2 -sticky we
	incr r
	if {[string equal $cmdr(gal-seed) [galaxy $cmdr(gal-number)]]} {
	  set cmdr(std-gal) 1
	  $tl.gal-seed configure -state disabled
	} else {
	  set cmdr(std-gal) 0
	}
	label $tl.l-world-name -text "Planet: " -justify right
	entry $tl.world-name -textvariable cmdr-${seq}(world-name) \
	    -state disabled -width 10 -justify left
	grid configure $tl.l-world-name -row $r -column 0 -sticky e
	grid configure $tl.world-name -row $r \
	    -column 1 -columnspan 2 -sticky we
	incr r
	button $tl.$tag -text "Show galaxy map" \
	    -command [list cmdr-show-map $seq]
	grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we
      }
      default {
	label $tl.l-$tag -text "($label)" -justify left
	grid configure $tl.l-$tag -row $r -column 0 -sticky w
      }
    }
    incr r
  }
  entry-on-change $tl.fuel [list cmdr-set-fuel $seq]
  menu $tl.menu
  menu $tl.menu.file
  $tl.menu.file add command -label "New commander" -command cmdr-new
  $tl.menu.file add command -label "Load commander..." \
      -command { cmdr-loadfile }
  $tl.menu.file add command -label "Save commander" \
      -command [list cmdr-save $seq]
  $tl.menu.file add command -label "Save as..." \
      -command [list cmdr-saveas $seq]
  $tl.menu.file add separator
  $tl.menu.file add command -label "Close" -command [list cmdr-destroy $seq]
  $tl.menu.file add command -label "Quit" -command { exit }
  $tl.menu add cascade -label "File" -menu $tl.menu.file
  $tl configure -menu $tl.menu
  grid columnconfigure $tl 2 -weight 1
  wm protocol $tl WM_DELETE_WINDOW [list cmdr-destroy $seq]
  set cmdr(ok/$tl.cargo-qty.fluc) 1
  cmdr-update-world $seq
  cmdr-set-name $seq
  incr nwin
  return $seq
}

# --- File handling ---

proc cmdr-load {file} {
  global seq
  incr seq
  set c [read-file $file]
  upvar \#0 cmdr-$seq cmdr
  elite-unpackcmdr cmdr $c
  set cmdr(file) $file
  cmdr-open $seq
}

set cmdr-filetypes {
  { "Commander file"	".nkc" }
}

proc cmdr-loadfile {} {
  global cmdr-filetypes
  set f [tk_getOpenFile \
      -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \
      -title "Load commander"]
  if {![string equal $f ""]} {
    cmdr-load $f
  }
}

proc cmdr-save-file {seq file} {
  upvar \#0 cmdr-$seq cmdr
  set tl .cmdr-$seq
  if {[catch { write-file $file [elite-packcmdr cmdr] } err]} {
    moan $err
  } else {
    set cmdr(file) $file
    cmdr-set-name $seq
  }
}

proc cmdr-saveas {seq} {
  upvar \#0 cmdr-$seq cmdr
  global cmdr-filetypes
  if {![cmdr-check $seq]} { return }
  set opts [list \
      -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \
      -title "Save commander"]
  if {[info exists cmdr(file)]} {
    lappend opts -initialdir [file dirname $cmdr(file)]
    lappend opts -initialfile [file tail $cmdr(file)]
  } else {
    lappend opts -initialfile "JAMESON.nkc"
  }
  set f [eval tk_getSaveFile $opts]
  if {[string equal $f ""]} { return }
  cmdr-save-file $seq $f
}

proc cmdr-save {seq} {
  upvar \#0 cmdr-$seq cmdr
  if {![info exists cmdr(file)]} {
    cmdr-saveas $seq
    return
  }
  if {![cmdr-check $seq]} { return }
  cmdr-save-file $seq $cmdr(file)
}

proc cmdr-new {} {
  global seq
  incr seq
  upvar \#0 cmdr-$seq cmdr
  jameson cmdr
  cmdr-open $seq
}

#----- Main program ---------------------------------------------------------

wm withdraw .

bind Entry <Control-u> { %W delete 0 end }

if {[llength $argv]} {
  foreach a $argv {
    switch -glob -- $a {
      "-jameson" {
	cmdr-new
      }
      "-*" {
	puts stderr "$argv0: unknown option: $a"
	exit 1
      }
      default {
	set g [parse-galaxy-spec $a]
	if {[llength $g]} {
	  destructure {ng g} $g
	  map-new $ng $g
	} else {
	  cmdr-load $a
	}
      }
    }
  }
} else {
  map-new 1 $galaxy1
}
if {!$nwin} { exit }

#----- That's all, folks ----------------------------------------------------