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

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