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

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