chiark - git - mdw - rocl/blob - elite-editor

   1 #! /usr/bin/wish
   2 #
   3 # $Id: elite-editor,v 1.4 2003/02/26 00:02:15 mdw Exp $
   4
   5 package require "elite" "1.0.0"
   6
   7 # --- Utility procedures ----------------------------------------------------
   8
   9 proc moan {msg} {
  10   global argv0
  11   tk_messageBox -message $msg -default ok -title $argv0 -type ok -icon error
  12 }
  13
  14 proc debug-array {name} {
  15   upvar \#0 $name a
  16   set tl .debug-$name
  17   if {[winfo exists .$tl]} { return }
  18   set s [array startsearch a]
  19   toplevel $tl
  20   set r 0
  21   set n 0
  22   while {[array anymore a $s]} {
  23     set k [array nextelement a $s]
  24     label $tl.k-$n -text $k -justify right
  25     entry $tl.v-$n -textvariable ${name}($k) -state disabled
  26     grid configure $tl.k-$n -row $r -column 0 -sticky e
  27     grid configure $tl.v-$n -row $r -column 1 -sticky we
  28     incr r
  29     incr n
  30   }
  31   array donesearch a $s
  32 }
  33
  34 proc write-file {name contents {trans binary}} {
  35   if {[file exists $name]} {
  36     if {[set rc [catch { file copy -force $name "$name.old" } err]]} {
  37       return -code $rc $err
  38     }
  39   }
  40   if {[set rc [catch {
  41     set f [open $name w]
  42     fconfigure $f -translation $trans
  43     puts -nonewline $f $contents
  44     close $f
  45   } err]]} {
  46     catch { close $f }
  47     catch { file rename -force "$name.old" $name }
  48     return -code $rc $err
  49   }
  50   return ""
  51 }
  52
  53 proc read-file {name {trans binary}} {
  54   set f [open $name]
  55   fconfigure $f -translation $trans
  56   set c [read $f]
  57   close $f
  58   return $c
  59 }
  60
  61 proc get-line-done {tl cmd} {
  62   if {![uplevel \#0 [concat $cmd [$tl.entry get]]]} {
  63     destroy $tl
  64   }
  65 }
  66
  67 proc get-line {tl title prompt def cmd} {
  68   if {[winfo exists $tl]} {
  69 #    raise $tl
  70     return
  71   }
  72   toplevel $tl
  73   wm title $tl $title
  74   label $tl.label -text "$prompt: "
  75   entry $tl.entry; $tl.entry insert 0 $def
  76   button $tl.ok -text OK -default active \
  77       -command [list get-line-done $tl $cmd]
  78   bind $tl <Return> [list get-line-done $tl $cmd]
  79   bind $tl <Escape> [list destroy $tl]
  80   pack $tl.label $tl.entry $tl.ok -side left -padx 2 -pady 2
  81 }
  82
  83 proc entry-on-change {widget what} {
  84   bind $widget <Return> $what
  85   bind $widget <FocusOut> $what
  86 }
  87
  88 #----- Map editing machinery ------------------------------------------------
  89
  90 tab col red orange yellow green blue magenta violet white
  91
  92 set seq 0
  93 set nwin 0
  94 array set default {scale 15 colourby off connect 0}
  95
  96 proc set-scale {seq sc} {
  97   if {![regexp {^\d+$} $sc]} {
  98     moan "bad scale factor `$sc'"
  99     return 1
 100   }
 101   map-setscale $seq $sc
 102   return 0
 103 }
 104
 105 proc new-view {gs} {
 106   set g [parse-galaxy-spec $gs]
 107   if {![llength $g]} {
 108     moan "bad galaxy spec `$gs'"
 109     return 1
 110   }
 111   destructure {ng g} $g
 112   map-new $ng $g
 113   return 0
 114 }
 115
 116 proc set-hyperspace-range {seq f} {
 117   if {![regexp {^\d+(\.\d+)?$} $f]} {
 118     moan "bad hyperspace range `$f'"
 119     return 1
 120   }
 121   map-set-fuel $seq [expr {$f * 10}]
 122   return 0
 123 }
 124
 125 # --- Colour-coding planets ---
 126
 127 proc colour-by {seq} {
 128   upvar \#0 map-$seq map
 129   set tl .map-$seq
 130   global col
 131   switch -exact -- $map(colourby) {
 132     off {
 133       foreach-world $map(galaxy) p {
 134         $tl.map itemconfigure $p(seed) -fill white -outline white
 135       }
 136     }
 137     economy {
 138       foreach-world $map(galaxy) p {
 139         set c [expr {7 - $p(economy)}]
 140         $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
 141       }
 142     }
 143     government {
 144       foreach-world $map(galaxy) p {
 145         set c $p(government)
 146         $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
 147       }
 148     }
 149     techlevel {
 150       foreach-world $map(galaxy) p {
 151         set c [expr {$p(techlevel) / 2}]
 152         $tl.map itemconfigure $p(seed) -fill $col($c) -outline $col($c)
 153       }
 154     }
 155   }
 156 }
 157
 158 proc set-colour-by {seq} {
 159   global default
 160   upvar \#0 map-$seq map
 161   set default(colourby) $map(colourby)
 162   colour-by $seq
 163 }
 164
 165 # --- Connectivity maps ---
 166
 167 proc show-connectivity {seq} {
 168   upvar \#0 map-$seq map
 169   upvar \#0 adj-$map(galaxy)-$map(fuel) adj
 170   upvar \#0 ww-$map(galaxy) ww
 171   set tl .map-$seq
 172   $tl.map delete conn
 173   if {!$map(connect)} {
 174     return
 175   }
 176   if {![info exists adj]} { adjacency $ww adj $map(fuel) }
 177   foreach {s x y} $ww {
 178     set done($s) 1
 179     foreach {ss xx yy} $adj($s) {
 180       if {[info exists done($ss)]} { continue }
 181       $tl.map create line \
 182           [to-map $seq $x] [to-map $seq $y] \
 183           [to-map $seq $xx] [to-map $seq $yy] \
 184           -fill darkblue -tags conn
 185     }
 186   }
 187   $tl.map lower conn sep
 188   show-path $seq
 189 }
 190
 191 proc set-connectivity {seq} {
 192   global default
 193   upvar \#0 map-$seq map
 194   set default(connect) $map(connect)
 195   show-connectivity $seq
 196 }
 197
 198 # --- Planet names ---
 199
 200 proc show-names {seq} {
 201   upvar \#0 map-$seq map
 202   set tl .map-$seq
 203   $tl.map delete names
 204   if {!$map(names)} {
 205     return
 206   }
 207   foreach-world $map(galaxy) p {
 208     set anc nw
 209     set px [to-map $seq $p(x)]
 210     set py [to-map $seq $p(y)]
 211     set offx [expr {$px + [to-map $seq 2]}]
 212     set offy [expr {$py + [to-map $seq 2]}]
 213     set what {}
 214     foreach {a ox oy dx x y xx yy} {
 215       nw   2  2   0   0   0  30  10
 216       nw   2  2 -10   0   0  30  10
 217       sw   2 -2   0   0 -10  30   0
 218       sw   2 -2 -10   0 -10  30   0
 219       se  -2 -2   0 -30 -10   0   0
 220       se  -2 -2  10 -30 -10   0   0
 221       ne  -2  2   0 -30   0   0  10
 222       ne  -2  2  10 -30   0   0  10
 223     } {
 224       set ox [expr {$px + [to-map $seq $ox] + $dx}]
 225       set oy [expr {$py + [to-map $seq $oy]}]
 226       if {![llength [$tl.map find overlapping \
 227           [expr {$ox + $x}] [expr {$ox + $y}] \
 228           [expr {$ox + $xx}] [expr {$ox + $yy}]]]} {
 229         set offx $ox
 230         set offy $oy
 231         set anc $a
 232         break
 233       }
 234       lappend what $a
 235     }
 236     $tl.map create text $offx $offy -text $p(name) \
 237         -fill white -anchor $a -tags names
 238   }
 239 }
 240
 241 proc set-names {seq} {
 242   global default
 243   upvar \#0 map-$seq map
 244   set default(names) $map(names)
 245   show-names $seq
 246 }
 247
 248 # --- Shortest path handling ---
 249
 250 proc show-path {seq} {
 251   upvar \#0 map-$seq map
 252   set tl .map-$seq
 253   $tl.map delete path
 254   if {![info exists map(path)]} { return }
 255   foreach n $map(path) {
 256     elite-worldinfo p $n
 257     if {[info exists x]} {
 258       $tl.map create line \
 259           [to-map $seq $x] [to-map $seq $y] \
 260           [to-map $seq $p(x)] [to-map $seq $p(y)] \
 261           -fill darkorange -tags path
 262     }
 263     set x $p(x)
 264     set y $p(y)
 265   }
 266   $tl.map lower path sep
 267 }
 268
 269 proc hide-path {seq} {
 270   upvar \#0 map-$seq map
 271   set tl .map-$seq
 272   $tl.map delete path
 273   unset map(path)
 274   $tl.menu.path entryconfigure 7 -state disabled
 275 }
 276
 277 proc show-shortest-path {seq weight} {
 278   upvar \#0 map-$seq map
 279   upvar \#0 adj-$map(galaxy)-$map(fuel) adj
 280   upvar \#0 ww-$map(galaxy) ww
 281   set tl .map-$seq
 282   $tl.map delete path
 283   if {[info exists map(path)]} { unset map(path) }
 284   if {![info exists map(select)] || ![info exists map(dest)]} {
 285     moan "no source or destination set"
 286     return
 287   }
 288   if {![info exists adj]} { adjacency $ww adj $map(fuel) }
 289   destructure {path weight} \
 290       [shortest-path adj $map(select) $map(dest) $weight]
 291   if {![llength $path]} {
 292     moan "no path exists"
 293     return
 294   }
 295   set map(path) $path
 296   $tl.menu.path entryconfigure 7 -state normal
 297   show-path $seq
 298 }
 299
 300 # --- Planet information box ---
 301
 302 proc do-getinfo {tag seq x y} {
 303   global economy government
 304   upvar \#0 info-$tag info
 305   set tl .world-info-$tag
 306   elite-worldinfo info [find-click $seq $x $y]
 307   if {[winfo exists $tl]} {
 308 #    raise $tl
 309   } else {
 310     toplevel $tl
 311     set r 0
 312     foreach {item label} {
 313       name      "Name"
 314       seed      "Seed"
 315       position  "Position"
 316       eco-name  "Economy"
 317       gov-name  "Government"
 318       techlevel "Tech. level"
 319       pop-str   "Population"
 320       prod-str  "Productivity"
 321       radius-km "Radius"
 322     } {
 323       label $tl.l-$item -text "$label: " -justify right
 324       entry $tl.$item -textvariable info-${tag}($item) -state disabled
 325       grid configure $tl.l-$item -row $r -column 0 -sticky e
 326       grid configure $tl.$item -row $r -column 1 -columnspan 2 -sticky we
 327       incr r
 328     }
 329     scrollbar $tl.descscr -orient vertical -command [list $tl.desc yview]
 330     text $tl.desc -wrap word -yscrollcommand [list $tl.descscr set] \
 331         -width 40 -height 4
 332     grid configure $tl.desc -row $r -column 0 -columnspan 2 -sticky nsew
 333     grid configure $tl.descscr -row $r -column 2 -sticky ns
 334     grid columnconfigure $tl 1 -weight 1
 335     grid rowconfigure $tl $r -weight 1
 336   }
 337   wm title $tl "Info: $info(name)"
 338   set info(position) "$info(x), $info(y)"
 339   set info(eco-name) $economy($info(economy))
 340   set info(gov-name) $government($info(government))
 341   set info(pop-str) \
 342       [format "%s billion (%s)" \
 343       [expr {$info(population)/10}] \
 344       $info(inhabitants)]
 345   set info(prod-str) [format "%d M Cr" $info(productivity)]
 346   set info(radius-km) [format "%d km" $info(radius)]
 347   $tl.desc configure -state normal
 348   $tl.desc delete 1.0 end
 349   $tl.desc insert end $info(description)
 350   $tl.desc configure -state disabled
 351 }
 352
 353 # --- Messing with selections ---
 354
 355 proc to-ly {seq x} {
 356   upvar \#0 map-$seq map
 357   return [expr {$x * $map(scale) / 10.0}]
 358 }
 359
 360 proc to-map {seq x} {
 361   upvar \#0 map-$seq map
 362   return [expr {$x * 10 / $map(scale)}]
 363 }
 364
 365 proc find-click {seq x y} {
 366   upvar \#0 map-$seq map
 367   upvar \#0 ww-$map(galaxy) ww
 368   set tl .map-$seq
 369
 370   set x [to-ly $seq [$tl.map canvasx $x]]
 371   set y [to-ly $seq [$tl.map canvasy $y]]
 372   set best 100000
 373   foreach {seed px py} $ww {
 374     set dx [expr {$x - $px}]
 375     set dy [expr {$y - $py}]
 376     set d [expr {$dx * $dx + $dy * $dy}]
 377     if {$d < $best} {
 378       set best $d
 379       set p $seed
 380     }
 381   }
 382   $tl.map delete here
 383
 384   if 0 {
 385     $tl.map create line \
 386         [expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] - 5}] \
 387         [expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] + 5}] \
 388         -tags here -fill green
 389     $tl.map create line \
 390         [expr {[to-map $seq $x] - 5}] [expr {[to-map $seq $y] + 5}] \
 391         [expr {[to-map $seq $x] + 5}] [expr {[to-map $seq $y] - 5}] \
 392         -tags here -fill green
 393   }
 394   return $p
 395 }
 396
 397 proc destination-world {seq} {
 398   upvar \#0 map-$seq map
 399   set tl .map-$seq
 400   if {![info exists map(dest)]} { return }
 401   $tl.map delete dest
 402   elite-worldinfo p $map(dest)
 403   set px [to-map $seq $p(x)]
 404   set py [to-map $seq $p(y)]
 405   $tl.map create line [expr {$px - 10}] $py [expr {$px + 10}] $py \
 406       -tags {dest cross} -fill darkorange
 407   $tl.map create line $px [expr {$py - 10}] $px [expr {$py + 10}] \
 408       -tags {dest cross} -fill darkorange
 409   $tl.map raise dest sel
 410 }
 411
 412 proc select-world {seq} {
 413   upvar \#0 map-$seq map
 414   set tl .map-$seq
 415   if {![info exists map(select)]} { return }
 416   $tl.map delete sel dest
 417   elite-worldinfo p $map(select)
 418   set r [to-map $seq $map(fuel)]
 419   set px [to-map $seq $p(x)]
 420   set py [to-map $seq $p(y)]
 421   $tl.map create line [expr {$px - 20}] $py [expr {$px + 20}] $py \
 422       -tags {sel cross} -fill darkred
 423   $tl.map create line $px [expr {$py - 20}] $px [expr {$py + 20}] \
 424       -tags {sel cross} -fill darkred
 425   $tl.map create oval \
 426       [expr {$px - $r}] [expr {$py - $r}] \
 427       [expr {$px + $r}] [expr {$py + $r}] \
 428       -tags {sel radius} -outline darkgreen
 429   $tl.map raise sel sep
 430 }
 431
 432 proc select-byname {seq name seed proc} {
 433   upvar \#0 map-$seq map
 434   set p [parse-planet-spec $map(galaxy) $map($name)]
 435   if {![string equal $p ""] && [in-galaxy-p $map(galaxy) $p]} {
 436     $proc $seq $p
 437   } elseif {[info exists map($seed)]} {
 438     bell
 439     set map($name) [worldname $map($seed)]
 440   } else {
 441     bell
 442     set map($name) ""
 443   }
 444 }
 445
 446 proc set-selection {seq p} {
 447   upvar \#0 map-$seq map
 448   set map(select) $p
 449   elite-worldinfo pp $p
 450   select-world $seq
 451   set map(sel-name) $pp(name)
 452   if {![info exists map(dest)]} {
 453     set-destination $seq $p
 454   } else {
 455     set-destination $seq $map(dest)
 456   }
 457   if {[info exists map(cmdr)]} {
 458     cmdr-set-world $map(cmdr) $p
 459   }
 460 }
 461
 462 proc do-select {seq x y} {
 463   set-selection $seq [find-click $seq $x $y]
 464 }
 465
 466 proc set-destination {seq p} {
 467   upvar \#0 map-$seq map
 468   if {![info exists map(select)]} {
 469     set-selection $seq $p
 470   } else {
 471     elite-worldinfo ps $map(select)
 472     elite-worldinfo pd $p
 473     set map(dest) $p
 474     destination-world $seq
 475     set map(dest-name) $pd(name)
 476     set map(distance) \
 477         [format "%.1f" \
 478         [expr {[world-distance $ps(x) $ps(y) $pd(x) $pd(y)] / 10.0}]]
 479   }
 480 }
 481
 482 proc do-destination {seq x y} {
 483   set-destination $seq [find-click $seq $x $y]
 484 }
 485
 486 # --- Redrawing a map ---
 487
 488 proc map-populate {seq} {
 489   global colourby-$seq connect-$seq
 490   upvar \#0 map-$seq map
 491   upvar \#0 ww-$map(galaxy) ww
 492   set tl .map-$seq
 493
 494   set scale $map(scale)
 495   $tl.map delete all
 496   $tl.map create line -10000 -20000 -10000 -20000 -fill black -tags sep
 497   if {![info exists ww]} { set ww [worldinfo $map(galaxy)] }
 498   foreach {seed x y} $ww {
 499     elite-worldinfo p $seed
 500     set x [expr {$x * 10 / $map(scale)}]
 501     set y [expr {$y * 10 / $map(scale)}]
 502     set r [expr {$p(radius) / (500 * $map(scale))}]
 503     $tl.map create oval \
 504         [expr {$x - $r}] [expr {$y - $r}] \
 505         [expr {$x + $r}] [expr {$y + $r}] \
 506         -fill white -outline white \
 507         -tags [list $seed world]
 508   }
 509
 510   colour-by $seq
 511   show-connectivity $seq
 512   show-names $seq
 513   select-world $seq
 514   destination-world $seq
 515 }
 516
 517 # --- Miscellaneous stuff ---
 518
 519 proc map-setscale {seq sc} {
 520   global default
 521   upvar \#0 map-$seq map
 522   set tl .map-$seq
 523   set wd [expr {10240/$sc + 40}]
 524   set ht [expr {5120/$sc} + 10]
 525   $tl.map configure -scrollregion [list -40 -10 $wd $ht]
 526   set map(scale) $sc
 527   set default(scale) $sc
 528   map-populate $seq
 529 }
 530
 531 proc map-destroy {seq} {
 532   global nwin
 533   upvar \#0 map-$seq map
 534   if {[info exists map(cmdr)]} {
 535     upvar \#0 cmdr-$map(cmdr) cmdr
 536     unset cmdr(map)
 537   }
 538   unset map
 539   destroy .map-$seq .set-scale-$seq
 540   incr nwin -1
 541   if {!$nwin} { exit }
 542 }
 543
 544 proc map-attach-cmdr {seq cmdr} {
 545   upvar \#0 map-$seq map
 546   set map(cmdr) $cmdr
 547   map-set-title $seq
 548   .map-$seq.menu.view entryconfigure 3 -state disabled
 549 }
 550
 551 proc map-set-title {seq} {
 552   upvar \#0 map-$seq map
 553   set tl .map-$seq
 554   set t "Galaxy $map(galaxy-num)"
 555   if {[info exists map(cmdr)]} {
 556     append t " (commander [cmdr-name $map(cmdr)])"
 557   }
 558   wm title $tl $t
 559 }
 560
 561 proc map-set-galaxy {seq ng g} {
 562   upvar \#0 map-$seq map
 563   if {[string equal $g $map(galaxy)]} { return }
 564   set map(galaxy-num) $ng
 565   map-set-title $seq
 566   set map(galaxy) $g
 567   map-populate $seq
 568   foreach i {select select-name dest dest-name} {
 569     catch { unset map($i) }
 570   }
 571 }
 572
 573 proc map-set-fuel {seq qty} {
 574   upvar \#0 map-$seq map
 575   set map(fuel) [expr {int($qty)}]
 576   select-world $seq
 577   show-connectivity $seq
 578 }
 579
 580 # --- Making a new map window ---
 581
 582 proc map-new {ng g} {
 583   global seq nwin default
 584   incr seq
 585   incr nwin
 586   upvar \#0 map-$seq map
 587
 588   array set map [array get default]
 589   set sc $map(scale)
 590   set map(galaxy) $g
 591   set map(galaxy-num) $ng
 592   set tl [toplevel .map-$seq]
 593   set wd [expr {10240/$sc + 80}]
 594   set ht [expr {5120/$sc + 20}]
 595   set vwd $wd; if {$vwd > 1120} { set vwd 768 }
 596   set vht $ht; if {$vht > 1024} { set vht 768 }
 597   set map(fuel) 70
 598   canvas $tl.map \
 599       -background black \
 600       -xscrollcommand [list $tl.hscr set] \
 601       -yscrollcommand [list $tl.vscr set] \
 602       -width $vwd -height $vht
 603   frame $tl.info
 604   label $tl.info.lhome -text "Home: "
 605   entry $tl.info.home -textvariable map-${seq}(sel-name)
 606   label $tl.info.ldest -text "Destination: "
 607   entry $tl.info.dest -textvariable map-${seq}(dest-name)
 608   label $tl.info.ldist -text "Distance: "
 609   entry $tl.info.dist -textvariable map-${seq}(distance) \
 610       -state disabled -width 6
 611   pack \
 612       $tl.info.lhome $tl.info.home \
 613       $tl.info.ldest $tl.info.dest \
 614       $tl.info.ldist $tl.info.dist \
 615       -side left
 616
 617   scrollbar $tl.hscr -orient horizontal \
 618       -command [list $tl.map xview]
 619   scrollbar $tl.vscr -orient vertical \
 620       -command [list $tl.map yview]
 621   menu $tl.menu
 622   menu $tl.menu.file
 623   $tl.menu.file add command -label "New commander" -command cmdr-new
 624   $tl.menu.file add command -label "Load commander..." \
 625       -command { cmdr-loadfile }
 626   $tl.menu.file add separator
 627   $tl.menu.file add command -label "Close" -command [list map-destroy $seq]
 628   $tl.menu.file add command -label "Quit" -command { exit }
 629   $tl.menu add cascade -label "File" -menu $tl.menu.file
 630   menu $tl.menu.view
 631   $tl.menu.view add command -label "New map..." \
 632       -command [list get-line .new-view "New map" "Galaxy" $ng new-view]
 633   $tl.menu.view add command -label "Set scale..." \
 634       -command [concat get-line .set-scale-$seq {"Set scale"} "Scale" \
 635       \[set map-${seq}(scale)\] [list [list set-scale $seq]]]
 636   $tl.menu.view add command -label "Set hyperspace range..." \
 637       -command [concat get-line .set-fuel-$seq {"Set hyperspace range"} \
 638       {"Hyperspace range"} \[expr \[set map-${seq}(fuel)\]/10.0\] \
 639       [list [list set-hyperspace-range $seq]]]
 640   $tl.menu.view add separator
 641   $tl.menu.view add radiobutton -label "Off" \
 642       -variable map-${seq}(colourby) -value off \
 643       -command [list set-colour-by $seq]
 644   $tl.menu.view add radiobutton -label "Economy" \
 645       -variable map-${seq}(colourby) -value economy \
 646       -command [list set-colour-by $seq]
 647   $tl.menu.view add radiobutton -label "Government" \
 648       -variable map-${seq}(colourby) -value government \
 649       -command [list set-colour-by $seq]
 650   $tl.menu.view add radiobutton -label "Tech level" \
 651       -variable map-${seq}(colourby) -value techlevel \
 652       -command [list set-colour-by $seq]
 653   $tl.menu.view add separator
 654   $tl.menu.view add checkbutton -label "Connectivity" \
 655       -variable map-${seq}(connect) \
 656       -command [list set-connectivity $seq]
 657   $tl.menu.view add checkbutton -label "Planet names" \
 658       -variable map-${seq}(names) \
 659       -command [list set-names $seq]
 660   $tl.menu add cascade -label "View" -menu $tl.menu.view
 661   menu $tl.menu.path
 662   $tl.menu.path add command -label "Minimize hops" \
 663       -command [list show-shortest-path $seq weight-hops]
 664   $tl.menu.path add command -label "Minimize fuel" \
 665       -command [list show-shortest-path $seq weight-fuel]
 666   $tl.menu.path add command -label "Maximize safety" \
 667       -command [list show-shortest-path $seq weight-safety]
 668   $tl.menu.path add command -label "Minimize safety" \
 669       -command [list show-shortest-path $seq weight-encounters]
 670   $tl.menu.path add command -label "Maximize trading" \
 671       -command [list show-shortest-path $seq weight-trading]
 672   $tl.menu.path add separator
 673   $tl.menu.path add command -label "Hide path" -state disabled \
 674       -command [list hide-path $seq]
 675   $tl.menu add cascade -label "Compute path" -menu $tl.menu.path
 676   $tl configure -menu $tl.menu
 677
 678   wm protocol $tl WM_DELETE_WINDOW [list map-destroy $seq]
 679
 680   grid $tl.map -column 0 -row 0 -sticky nsew
 681   grid $tl.hscr -column 0 -row 1 -sticky ew
 682   grid $tl.vscr -column 1 -row 0 -sticky ns
 683   grid rowconfigure $tl 0 -weight 1
 684   grid columnconfigure $tl 0 -weight 1
 685   grid $tl.info -column 0 -columnspan 2 -row 2 -sticky ew
 686
 687   bind $tl.map <3> [list do-select $seq %x %y]
 688   bind $tl.map <1> [list do-destination $seq %x %y]
 689   bind $tl.map <Double-1> [list do-getinfo dest $seq %x %y]
 690   bind $tl.map <Double-3> [list do-getinfo home $seq %x %y]
 691
 692   map-set-title $seq
 693   entry-on-change $tl.info.home \
 694       [list select-byname $seq sel-name select set-selection]
 695   entry-on-change $tl.info.dest \
 696       [list select-byname $seq dest-name dest set-destination]
 697   map-setscale $seq $sc
 698   return $seq
 699 }
 700
 701 #----- Commander editing machinery ------------------------------------------
 702
 703 # --- Validation and factor-of-10 fixing ---
 704
 705 proc fix-tenth {tag arrvar full op} {
 706   upvar \#0 $arrvar arr
 707   catch { set arr($tag) [format "%d" [expr {int($arr($full) * 10)}]] }
 708 }
 709
 710 proc numericp {min max n} {
 711   if {[catch { expr {$n + 0} }]} { return 0 }
 712   if {$n < $min || $n > $max} { return 0 }
 713   return 1
 714 }
 715
 716 proc integerp {min max n} {
 717   if {[catch { incr n 0}]} { return 0 }
 718   if {$n < $min || $n > $max} { return 0 }
 719   return 1
 720 }
 721
 722 proc galaxyp {s} {
 723   if {![regexp {^[0-9a-fA-F]{12}$} $s]} { return 0 }
 724   return 1
 725 }
 726
 727 proc cmdr-do-validate {seq widget check value} {
 728   upvar \#0 cmdr-$seq cmdr
 729   if {$cmdr(ok/$widget)} { incr cmdr(bogus) }
 730   if {![eval $check [list $value]]} {
 731     set cmdr(ok/$widget) 0
 732     $widget configure -foreground red
 733   } else {
 734     set cmdr(ok/$widget) 1
 735     $widget configure -foreground black
 736     incr cmdr(bogus) -1
 737   }
 738   return 1
 739 }
 740
 741 proc cmdr-validate-widget {seq widget check} {
 742   upvar \#0 cmdr-$seq cmdr
 743   set cmdr(ok/$widget) 1
 744   $widget configure -validate key \
 745       -vcmd [list cmdr-do-validate $seq $widget $check %P]
 746 }
 747
 748 # --- Cargo window handling ---
 749
 750 proc cmdr-set-fluc {seq} {
 751   upvar \#0 cmdr-$seq cmdr
 752   global products
 753   set tl .cmdr-$seq.cargo-qty
 754   if {!$cmdr(ok/$tl.fluc)} { bell; return }
 755   elite-market m $cmdr(world-seed) $cmdr(market-fluc)
 756   foreach {i .} $products {
 757     set cmdr(price-$i) [format "%.1f" [expr {[lindex $m($i) 0]/10.0}]]
 758   }
 759 }
 760
 761 proc cmdr-cargo {seq} {
 762   upvar \#0 cmdr-$seq cmdr
 763   set tl .cmdr-$seq.cargo-qty
 764   if {[winfo exists $tl]} {
 765 #    raise $tl
 766     return
 767   }
 768   toplevel $tl
 769   wm title $tl "Cargo for commander $cmdr(name)"
 770   global products
 771   set r 0
 772   label $tl.l-fluc -text "Fluctuation: " -justify right
 773   entry $tl.fluc -textvariable cmdr-${seq}(market-fluc) -justify right
 774   cmdr-validate-widget $seq $tl.fluc [list integerp 0 255]
 775   entry-on-change $tl.fluc [list cmdr-set-fluc $seq]
 776   grid configure $tl.l-fluc -row $r -column 0 -sticky e
 777   grid configure $tl.fluc -row $r -column 1 -columnspan 3 -sticky we
 778   incr r
 779   label $tl.l-item -text "Item" -justify center
 780   label $tl.l-price -text "Price" -justify center
 781   label $tl.l-station -text "Station" -justify center
 782   label $tl.l-hold -text "Hold" -justify center
 783   grid configure $tl.l-item -row $r -column 0 -sticky e
 784   grid configure $tl.l-price -row $r -column 1 -sticky we
 785   grid configure $tl.l-station -row $r -column 2 -sticky we
 786   grid configure $tl.l-hold -row $r -column 3 -sticky we
 787   incr r
 788   foreach {tag label} $products {
 789     label $tl.l-$tag -text "$label: " -justify right
 790     entry $tl.price-$tag -textvariable cmdr-${seq}(price-${tag}) \
 791         -justify right -state disabled -width 4
 792     foreach {pre col} {station 2 hold 3} {
 793       entry $tl.${pre}-${tag} -textvariable cmdr-${seq}(${pre}-${tag}) \
 794           -justify right -width 4
 795       cmdr-validate-widget $seq $tl.${pre}-${tag} [list integerp 0 255]
 796       grid configure $tl.${pre}-${tag} -row $r -column $col -stick we
 797     }
 798     grid configure $tl.l-$tag -row $r -column 0 -sticky e
 799     grid configure $tl.price-$tag -row $r -column 1 -sticky we
 800     incr r
 801   }
 802   grid columnconfigure $tl 1 -weight 1
 803   grid columnconfigure $tl 2 -weight 1
 804   grid columnconfigure $tl 3 -weight 1
 805 }
 806
 807 # --- Miscellaneous stuff ---
 808
 809 proc cmdr-destroy {seq} {
 810   upvar \#0 cmdr-$seq cmdr
 811   global nwin
 812   set tl .cmdr-$seq
 813   if {[info exists cmdr(map)]} { map-destroy $cmdr(map) }
 814   unset cmdr
 815   destroy $tl
 816   incr nwin -1
 817   if {!$nwin} { exit }
 818 }
 819
 820 proc cmdrdb-set {seq tag value} {
 821   upvar \#0 cmdr-$seq cmdr
 822   set tl .cmdr-$seq
 823   set cmdr($tag) $value
 824   $tl.$tag configure -state disabled
 825 }
 826
 827 proc cmdrdb-custom {seq tag} {
 828   set tl .cmdr-$seq
 829   $tl.$tag configure -state normal
 830 }
 831
 832 proc cmdr-set-world {seq p} {
 833   upvar \#0 cmdr-$seq cmdr
 834   elite-worldinfo i $p
 835   set cmdr(world-seed) $p
 836   set cmdr(world-name) $i(name)
 837   set cmdr(world-x) [expr {$i(x)/4}]
 838   set cmdr(world-y) [expr {$i(y)/2}]
 839   cmdr-set-fluc $seq
 840 }
 841
 842 proc cmdr-update-world {seq} {
 843   upvar \#0 cmdr-$seq cmdr
 844   upvar \#0 ww-$cmdr(gal-seed) ww
 845   if {![info exists ww]} { set ww [worldinfo $cmdr(gal-seed)] }
 846   set tl .cmdr-$seq
 847   set w [nearest-planet $ww \
 848       [expr {$cmdr(world-x) * 4}] [expr {$cmdr(world-y) * 2}]]
 849   if {[info exists cmdr(map)]} {
 850     if {$cmdr(std-gal)} {
 851       set ng $cmdr(gal-number)
 852     } else {
 853       set ng $cmdr(gal-seed)
 854     }
 855     map-set-galaxy $cmdr(map) $ng $cmdr(gal-seed)
 856     set-selection $cmdr(map) $w
 857   }
 858   cmdr-set-world $seq $w
 859 }
 860
 861 proc cmdr-set-gal-num {seq} {
 862   upvar \#0 cmdr-$seq cmdr
 863   set tl .cmdr-$seq
 864   if {!$cmdr(ok/$tl.gal-number)} { bell; return }
 865   if {$cmdr(std-gal)} {
 866     set cmdr(gal-seed) [galaxy $cmdr(gal-number)]
 867     cmdr-update-world $seq
 868   }
 869 }
 870
 871 proc cmdr-std-gal {seq} {
 872   upvar \#0 cmdr-$seq cmdr
 873   set tl .cmdr-$seq
 874   if {$cmdr(std-gal)} {
 875     if {!$cmdr(ok/$tl.gal-number)} { bell; return }
 876     set cmdr(gal-seed) [galaxy $cmdr(gal-number)]
 877     cmdr-update-world $seq
 878     $tl.gal-seed configure -state disabled
 879   } else {
 880     $tl.gal-seed configure -state normal
 881   }
 882 }
 883
 884 proc cmdr-set-fuel {seq} {
 885   upvar \#0 cmdr-$seq cmdr
 886   if {[info exists cmdr(map)]} {
 887     map-set-fuel $cmdr(map) $cmdr(fuel)
 888   }
 889 }
 890
 891 proc cmdr-name {seq} {
 892   upvar \#0 cmdr-$seq cmdr
 893   return $cmdr(name)
 894 }
 895
 896 proc cmdr-show-map {seq} {
 897   upvar \#0 cmdr-$seq cmdr
 898   if {[info exists cmdr(map)]} {
 899     return
 900   }
 901   if {$cmdr(std-gal)} {
 902     set ng $cmdr(gal-number)
 903   } else {
 904     set ng $cmdr(gal-seed)
 905   }
 906   set cmdr(map) [map-new $ng $cmdr(gal-seed)]
 907   map-attach-cmdr $cmdr(map) $seq
 908   map-set-fuel $cmdr(map) $cmdr(fuel)
 909   set-selection $cmdr(map) $cmdr(world-seed)
 910 }
 911
 912 proc cmdr-set-name {seq} {
 913   upvar \#0 cmdr-$seq cmdr
 914   if {[info exists cmdr(file)]} {
 915     set cmdr(name) [string toupper [file rootname [file tail $cmdr(file)]]]
 916   } else {
 917     set cmdr(name) JAMESON
 918   }
 919   set tl .cmdr-$seq
 920   wm title $tl "Commander $cmdr(name)"
 921   if {[info exists cmdr(map)]} { map-set-title $cmdr(map) }
 922   if {[winfo exists $tl.cargo-qty]} {
 923     wm title $tl.cargo-qty "Cargo for commander $cmdr(name)"
 924   }
 925 }
 926
 927 proc cmdr-check {seq} {
 928   upvar \#0 cmdr-$seq cmdr
 929   if {$cmdr(bogus)} {
 930     moan("invalid values in commander data -- fix items highlighted in red")
 931     return 0
 932   }
 933   return 1
 934 }
 935
 936 # --- Initial population ---
 937
 938 proc cmdr-open {seq} {
 939   upvar \#0 cmdr-$seq cmdr
 940   global cmdr-$seq
 941   set tl .cmdr-$seq
 942   global nwin
 943   toplevel $tl
 944   set laser {
 945     dropbox 255
 946     "None"      0
 947     "Pulse"     0x0f
 948     "Beam"      0x8f
 949     "Military"  0x97
 950     "Mining"    0x32
 951   }
 952   set r 0
 953   set cmdr(bogus) 0
 954   foreach {tag label kind} [list \
 955     mission             "Mission"               { entry 2 255 } \
 956     score               "Rating"                { dropbox 65535\
 957                                                   "Harmless"            0 \
 958                                                   "Mostly harmless"     8 \
 959                                                   "Poor"                6 \
 960                                                   "Average"            32 \
 961                                                   "Above average"      64 \
 962                                                   "Competent"         128 \
 963                                                   "Dangerous"         512 \
 964                                                   "Deadly"           2560 \
 965                                                   "Elite"            6400 } \
 966     legal-status        "Legal status"          { dropbox 255 \
 967                                                   "Clean"       0 \
 968                                                   "Offender"    1 \
 969                                                   "Fugitive"    50 } \
 970     world               "Location"              where \
 971     credits             "Credits"               { tenth 10 429496729.5 } \
 972     fuel                "Fuel"                  { tenth 4 25.5 } \
 973     missiles            "Missiles"              { entry 4 255 } \
 974     energy-unit         "Energy unit"           { dropbox 255 \
 975                                                   "None"        0 \
 976                                                   "Standard"    1 \
 977                                                   "Naval"       2 } \
 978     front-laser         "Front laser"           $laser \
 979     rear-laser          "Front laser"           $laser \
 980     left-laser          "Left laser"            $laser \
 981     right-laser         "Right laser"           $laser \
 982     ecm                 "ECM"                   toggle \
 983     fuel-scoop          "Fuel scoops"           toggle \
 984     energy-bomb         "Energy bomb"           toggle \
 985     escape-pod          "Escape pod"            toggle \
 986     docking-computer    "Docking computers"     toggle \
 987     gal-hyperdrive      "Galactic hyperdrive"   toggle \
 988     cargo               "Cargo capacity"        { entry 4 255 } \
 989     stuff               "Cargo"                 cargo \
 990   ] {
 991     switch -exact -- [lindex $kind 0] {
 992       entry {
 993         destructure {. wd max} $kind
 994         label $tl.l-$tag -text "$label: " -justify right
 995         entry $tl.$tag -textvariable cmdr-${seq}($tag) \
 996             -width $wd -justify right
 997         cmdr-validate-widget $seq $tl.$tag [list integerp 0 $max]
 998         grid configure $tl.l-$tag -row $r -column 0 -sticky e
 999         grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we
1000       }
1001       tenth {
1002         destructure {. wd max} $kind
1003         label $tl.l-$tag -text "$label: " -justify right
1004         entry $tl.$tag -textvariable cmdr-${seq}(div-$tag) \
1005             -width $wd -justify right
1006         set cmdr(div-$tag) [format "%.1f" [expr {$cmdr($tag) / 10.0}]]
1007         trace variable cmdr-${seq}(div-$tag) w [list fix-tenth $tag]
1008         cmdr-validate-widget $seq $tl.$tag [list numericp 0 $max]
1009         grid configure $tl.l-$tag -row $r -column 0 -sticky e
1010         grid configure $tl.$tag -row $r -column 1 -columnspan 2 -sticky we
1011       }
1012       toggle {
1013         checkbutton $tl.$tag -text $label -variable cmdr-${seq}($tag)
1014         grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky w
1015       }
1016       dropbox {
1017         label $tl.l-$tag -text "$label: " -justify right
1018         set menu $tl.m-$tag.menu
1019         menubutton $tl.m-$tag -textvariable cmdr-${seq}(r-${tag}) \
1020             -indicatoron 1 -relief raised -menu $menu -width 8 \
1021             -direction flush
1022         entry $tl.$tag -textvariable cmdr-${seq}($tag) \
1023             -justify right -width 4
1024         cmdr-validate-widget $seq $tl.$tag [list integerp 0 [lindex $kind 1]]
1025         menu $menu -tearoff 0
1026         set cmdr(r-$tag) "Custom"
1027         foreach {name value} [lrange $kind 2 end] {
1028           $menu add radiobutton -label "$name ($value)" \
1029               -value $name -variable cmdr-${seq}(r-$tag) \
1030               -command [list cmdrdb-set $seq $tag $value]
1031           if {$cmdr($tag) == $value} {
1032             set cmdr(r-$tag) $name
1033             set cmdr($tag) $value
1034             $tl.$tag configure -state disabled
1035           }
1036         }
1037         $menu add radiobutton -label "Custom" \
1038             -value "Custom" -variable cmdr-${seq}(r-$tag) \
1039             -command [list cmdrdb-custom $seq $tag]
1040         grid configure $tl.l-$tag -row $r -column 0 -sticky e
1041         grid configure $tl.m-$tag -row $r -column 1 -sticky we
1042         grid configure $tl.$tag -row $r -column 2 -sticky we
1043       }
1044       cargo {
1045         button $tl.$tag -text $label -command [list cmdr-cargo $seq]
1046         grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we
1047       }
1048       where {
1049         label $tl.l-gal-number -text "Galaxy number: " -justify right
1050         entry $tl.gal-number -textvariable cmdr-${seq}(gal-number) \
1051             -justify right -width 2
1052         cmdr-validate-widget $seq $tl.gal-number [list integerp 1 8]
1053         checkbutton $tl.std-gal -text "Standard galaxy" \
1054             -variable cmdr-${seq}(std-gal) -justify left \
1055             -command [list cmdr-std-gal $seq]
1056         entry-on-change $tl.gal-number [list cmdr-set-gal-num $seq]
1057         grid configure $tl.l-gal-number -row $r -column 0 -sticky e
1058         grid configure $tl.std-gal -row $r -column 1 -sticky w
1059         grid configure $tl.gal-number -row $r -column 2 -sticky we
1060         incr r
1061         label $tl.l-gal-seed -text "Galaxy seed: " -justify right
1062         entry $tl.gal-seed -textvariable cmdr-${seq}(gal-seed) -width 12
1063         cmdr-validate-widget $seq $tl.gal-seed galaxyp
1064         entry-on-change $tl.gal-seed [list cmdr-update-world $seq]
1065         grid configure $tl.l-gal-seed -row $r -column 0 -sticky e
1066         grid configure $tl.gal-seed -row $r \
1067             -column 1 -columnspan 2 -sticky we
1068         incr r
1069         if {[string equal $cmdr(gal-seed) [galaxy $cmdr(gal-number)]]} {
1070           set cmdr(std-gal) 1
1071           $tl.gal-seed configure -state disabled
1072         } else {
1073           set cmdr(std-gal) 0
1074         }
1075         label $tl.l-world-name -text "Planet: " -justify right
1076         entry $tl.world-name -textvariable cmdr-${seq}(world-name) \
1077             -state disabled -width 10 -justify left
1078         grid configure $tl.l-world-name -row $r -column 0 -sticky e
1079         grid configure $tl.world-name -row $r \
1080             -column 1 -columnspan 2 -sticky we
1081         incr r
1082         button $tl.$tag -text "Show galaxy map" \
1083             -command [list cmdr-show-map $seq]
1084         grid configure $tl.$tag -row $r -column 0 -columnspan 3 -sticky we
1085       }
1086       default {
1087         label $tl.l-$tag -text "($label)" -justify left
1088         grid configure $tl.l-$tag -row $r -column 0 -sticky w
1089       }
1090     }
1091     incr r
1092   }
1093   entry-on-change $tl.fuel [list cmdr-set-fuel $seq]
1094   menu $tl.menu
1095   menu $tl.menu.file
1096   $tl.menu.file add command -label "New commander" -command cmdr-new
1097   $tl.menu.file add command -label "Load commander..." \
1098       -command { cmdr-loadfile }
1099   $tl.menu.file add command -label "Save commander" \
1100       -command [list cmdr-save $seq]
1101   $tl.menu.file add command -label "Save as..." \
1102       -command [list cmdr-saveas $seq]
1103   $tl.menu.file add separator
1104   $tl.menu.file add command -label "Close" -command [list cmdr-destroy $seq]
1105   $tl.menu.file add command -label "Quit" -command { exit }
1106   $tl.menu add cascade -label "File" -menu $tl.menu.file
1107   $tl configure -menu $tl.menu
1108   grid columnconfigure $tl 2 -weight 1
1109   wm protocol $tl WM_DELETE_WINDOW [list cmdr-destroy $seq]
1110   set cmdr(ok/$tl.cargo-qty.fluc) 1
1111   cmdr-update-world $seq
1112   cmdr-set-name $seq
1113   incr nwin
1114   return $seq
1115 }
1116
1117 # --- File handling ---
1118
1119 proc cmdr-load {file} {
1120   global seq
1121   incr seq
1122   set c [read-file $file]
1123   upvar \#0 cmdr-$seq cmdr
1124   elite-unpackcmdr cmdr $c
1125   set cmdr(file) $file
1126   cmdr-open $seq
1127 }
1128
1129 set cmdr-filetypes {
1130   { "Commander file"    ".nkc" }
1131 }
1132
1133 proc cmdr-loadfile {} {
1134   global cmdr-filetypes
1135   set f [tk_getOpenFile \
1136       -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \
1137       -title "Load commander"]
1138   if {![string equal $f ""]} {
1139     cmdr-load $f
1140   }
1141 }
1142
1143 proc cmdr-save-file {seq file} {
1144   upvar \#0 cmdr-$seq cmdr
1145   set tl .cmdr-$seq
1146   if {[catch { write-file $file [elite-packcmdr cmdr] } err]} {
1147     moan $err
1148   } else {
1149     set cmdr(file) $file
1150     cmdr-set-name $seq
1151   }
1152 }
1153
1154 proc cmdr-saveas {seq} {
1155   upvar \#0 cmdr-$seq cmdr
1156   global cmdr-filetypes
1157   if {![cmdr-check $seq]} { return }
1158   set opts [list \
1159       -defaultextension ".nkc" -filetypes ${cmdr-filetypes} \
1160       -title "Save commander"]
1161   if {[info exists cmdr(file)]} {
1162     lappend opts -initialdir [file dirname $cmdr(file)]
1163     lappend opts -initialfile [file tail $cmdr(file)]
1164   } else {
1165     lappend opts -initialfile "JAMESON.nkc"
1166   }
1167   set f [eval tk_getSaveFile $opts]
1168   if {[string equal $f ""]} { return }
1169   cmdr-save-file $seq $f
1170 }
1171
1172 proc cmdr-save {seq} {
1173   upvar \#0 cmdr-$seq cmdr
1174   if {![info exists cmdr(file)]} {
1175     cmdr-saveas $seq
1176     return
1177   }
1178   if {![cmdr-check $seq]} { return }
1179   cmdr-save-file $seq $cmdr(file)
1180 }
1181
1182 proc cmdr-new {} {
1183   global seq galaxy1 products
1184   incr seq
1185   upvar \#0 cmdr-$seq cmdr
1186   array set cmdr {
1187     mission           0
1188     credits        1000
1189     fuel             70
1190     gal-number        1
1191     front-laser    0x0f
1192     rear-laser        0
1193     left-laser        0
1194     right-laser       0
1195     cargo            20
1196     missiles          3
1197     legal-status      0
1198     score             0
1199     market-fluc       0
1200   }
1201   set cmdr(gal-seed) $galaxy1
1202   foreach i {
1203     ecm fuel-scoop energy-bomb energy-unit docking-computer
1204     gal-hyperdrive escape-pod
1205   } { set cmdr($i) 0 }
1206   elite-worldinfo lave [find-world $galaxy1 "Lave"]
1207   set cmdr(world-x) [expr {$lave(x)/4}]
1208   set cmdr(world-y) [expr {$lave(y)/2}]
1209   elite-market mkt $lave(seed) 0
1210   foreach {t n} $products {
1211     destructure [list . cmdr(station-$t)] $mkt($t)
1212     set cmdr(hold-$t) 0
1213   }
1214   set cmdr(station-alien-items) 0
1215   cmdr-open $seq
1216 }
1217
1218 #----- Main program ---------------------------------------------------------
1219
1220 wm withdraw .
1221
1222 if {[llength $argv]} {
1223   foreach a $argv {
1224     set g [parse-galaxy-spec $a]
1225     if {[llength $g]} {
1226       destructure {ng g} $g
1227       map-new $ng $g
1228     } else {
1229       cmdr-load $a
1230     }
1231   }
1232 } else {
1233   map-new 1 $galaxy1
1234 }
1235 if {!$nwin} { exit }
1236
1237 #----- That's all, folks ----------------------------------------------------