A multidimensional vector/matrix type which is updateable in place.

[rocl] / elite-pairs

#! /usr/bin/tclsh
#
# $Id: elite-pairs,v 1.4 2003/03/07 00:41:46 mdw Exp $

package require "elite" "1.0.1"

proc ok {s vv expr} {
  global argv0
  set ip [interp create]
  foreach v $vv {
    upvar 1 $v var
    if {[array exists var]} {
      foreach {k d} [array get var] {
	$ip eval [list set ${v}($k) $d]
      }
    } else {
      $ip eval [list set $v $var]
    }
  }
  elite-worldinfo p $s
  foreach {k v} [array get p] {
    $ip eval [list set $k $v]
  }
  if {[catch { $ip eval [list expr $expr] } rc]} {
    puts stderr "$argv0: error in expression: $rc"
    exit 1
  }
  interp delete $ip
  return $rc
}

set g $galaxy1
set d 70
set v 0
for {set i 0} {$i < [llength $argv]} {incr i} {
  set a [lindex $argv $i]
  switch -glob -- $a {
    "-g" {
      incr i
      set a [lindex $argv $i]
      set g [parse-galaxy-spec $a]
      if {[string equal $g ""]} {
	puts stderr "$argv0: bad galaxy string `$a'"
	exit 1
      }
      destructure {. g} $g
    }
    "-d" {
      incr i
      set d [expr {int([lindex $argv $i] * 10)}]
    }
    "-v" {
      incr v
    }
    "-q" {
      incr v -1
    }
    "--" {
      incr i
      break
    }
    "-*" {
      puts stderr "usage: $argv0 \[-qv\] \[-g GALAXY\] \[-d DIST\] AEXPR BEXPR"
      exit 1
    }
    default {
      break
    }    
  }
}
if {$i != [llength $argv] - 2} {
  puts stderr "usage: $argv0 \[-g GALAXY\] \[-d DIST\] AEXPR BEXPR"
  exit 1
}
destructure {aexpr bexpr} [lrange $argv $i end]
set ww [elite-galaxylist $g]
elite-adjacency adj $ww $d
unset a
foreach {s x y} $ww {
  if {![ok $s {} $aexpr]} { continue }
  elite-worldinfo a $s
  set l {}
  foreach {ss xx yy} $adj($s) {
    set d [elite-distance $x $y $xx $yy]
    if {[ok $ss {a d} $bexpr]} {
      set d [expr {[elite-distance $x $y $xx $yy]/10.0}]
      if {$v} {
	puts [format "%s (%.1f LY)" [world-summary $s] $d]
	puts [world-summary $ss]
	puts ""
      } else {
	puts [format "%-11s %-11s (%.1f LY)" $a(name) [worldname $ss] $d]
      }
    }
  }
}