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

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