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