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

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