gen_cxform_auto.pl

#!/packages/bin/perl -w
#
# gen_mappings.pl  --  make a C file containing mappings to coord xforms
#
# $Id: gen_cxform_auto.pl,v 1.1.1.1 2005/02/25 20:41:41 rboller Exp $
#
# 2003/09/12: Modified by Ryan Boller to remove references to CVS
#
($ME = $0) =~ s,.*/,,;

use strict;
use vars qw($ME  $INFILE  $RCSID $RCSID_INFILE $MANUAL_VERSION
			%MAPS_TO %MAPS_FROM  @SYSTEMS);

###############################################################################
# BEGIN user-configurable section

$INFILE = "cxform-manual.c";

# CVS-related code commented out
#my $x = "";
#$RCSID = " \$Id: gen_cxform_auto.pl,v 1.1.1.1 2005/02/25 20:41:41 rboller Exp $x";
#$RCSID = filter_rcsid($RCSID);

# Version of this script
$RCSID = "1.40";

# Version of cxform-manual file
$MANUAL_VERSION = "1.30";

# Security
$ENV{PATH}   = "/packages/bin:/usr/bin:/bin";
delete $ENV{CDPATH};
delete $ENV{IFS};

# END   user-configurable section
###############################################################################

initialize($INFILE);

#
# Create an output file
#
my $OUT = $INFILE;  $OUT =~ s/-manual/-auto/;
my $TMP = $OUT . ".TMP";  unlink $TMP;
my $BAK = $OUT . ".BAK";

open OUT, "> $TMP"	or die "$ME: open( >$TMP ): $!\n";

print  OUT <<EOP;
static char const Ident[] = \"\@(\#) \$XX: $OUT   c:$RCSID_INFILE pl:$RCSID \$\";
/*
** This file is automatically generated.  *** DO NOT EDIT BY HAND! ***
**
** Generated by the script \`$ME\', version $RCSID,
** from input \`$INFILE\' version $RCSID_INFILE.
**
** This code is simply a set of wrapper functions for the basic 
** coordinate transformations (J2000 to GEI, GEI to GSE, and so on).
** Although there are only a small set of "real" transforms, we want
** to be able to go from one to another without having to think (after
** all, that\'s what computers are for).  
**
** This module performs the mappings for going from any coordinate
** system to any other.  It also provides the front end "cxform()",
** so the source/destination frames can be passed as strings, instead
** of having to hardcode "gse_to_gsm()" or whatever.
*/

\#include <stdio.h>
\#include <string.h>
\#include "cxform.h"


/*
** First, though, we want a way to convert from a char string ("GSE")
** to a numeric representation.  Here we define an enum listing all
** the known coordinate systems, plus UNKNOWN.  We then define a
** complicated-looking function that looks at the input string, char
** by char, and returns the numeric representation of the desired
** coordinate system.  Note that upper/lower case combos are fine.
*/
EOP

#
# Make an ENUM out of all the known systems, and write a function
# that converts from ASCII input ("gse", "GSE", "gSm") to the enum.
#
printf OUT "enum systems { UNKNOWN, %s };\n", join(", ",@SYSTEMS);

print OUT <<EOP;
enum systems system_number( const char *system )
{
  if (system == NULL)
    return UNKNOWN;

EOP

gencase("  ", 0, @SYSTEMS);		# This function does all the work...

print  OUT "}\n";

################
#
# Now define prototypes for all the conversion functions
#
################
print  OUT <<EOP;


/*
** The following boring list of prototypes is for the benefit of cxform().
**
** The first cluster, below, lists the functions defined in $INFILE
*/
EOP
# First, a list of prototypes for external (manual) functions
foreach my $from (@SYSTEMS) {
  foreach my $to (@SYSTEMS) {
    next if $from eq $to;
    next unless grep($_ eq $to, @{$MAPS_TO{$from}});

    printf OUT "extern int %5s_twixt_%-5s ", lc $from, lc $to;
    print  OUT "(double t, Vec in, Vec out, Direction d);\n";
  }
}

# Next, a list of automatically-defined functions
print  OUT <<EOP;

/*
** This second (long) cluster defines the wrappers we generate automatically.
*/
EOP
foreach my $from (@SYSTEMS) {
  foreach my $to (@SYSTEMS) {
    next if $from eq $to;

    printf OUT "static int %5s_to_%-5s (double t, Vec in, Vec out);\n",
    	       lc $from, lc $to;
  }
}


################
#
# Now write a mapping function that, when called with a FROM and TO 
# coordinate system, and a time, does the appropriate mapping.
#
################
print OUT <<EOP;

static char cxform_err_buf[1024];
char *cxform_err(void)
{
  return cxform_err_buf;
}


/*
** Here\'s the main code.  Simple, actually.  All we do is:
**
**    1) determine the source ("from") and destination ("to") frames,
**       and make sure they are valid ones.
**
**    2) call the appropriate <from>_to_<to>() function.
**
** The <from>_to_<to> functions are declared further down below (except
** for the "real" transformation functions, which are in $INFILE).
*/
int cxform(const char *from, const char *to, double t, Vec v_in, Vec v_out)
{
  enum systems from_n, to_n;

  cxform_err_buf[0] = '\\0';

  if (from == NULL) {
    strcpy(cxform_err_buf, "No source frame given.");
    return 1;
  }
  if (to == NULL) {
    strcpy(cxform_err_buf, "No destination frame given.");
    return 1;
  }

  if ((from_n = system_number(from)) == UNKNOWN) {
    sprintf(cxform_err_buf, "Source frame '%s' is unknown;", from);
    strcat(cxform_err_buf, " must be one of: @SYSTEMS");
    return 1;
  }
  if ((to_n   = system_number(to)) == UNKNOWN) {
    sprintf(cxform_err_buf, "Destination frame '%s' is unknown;", to);
    strcat(cxform_err_buf, " must be one of: @SYSTEMS");
    return 1;
  }

  /*
  ** Check to see if the source and destination are the same.  If so,
  ** return the input vector as output.
  */
  if (from_n == to_n) {
    int i;
    for (i=0; i<3; i++)
      v_out[i] = v_in[i];

    return 0;
  }

  /* For the "default" cases in the switches below */
  strcpy(cxform_err_buf, "Internal error -- this is impossible");

  /*
  ** Find the source, then find the dest, then call the appropriate xform.
  */
  switch (from_n) {
EOP

foreach my $from (@SYSTEMS) {
  printf OUT "    case %s:\n", $from;
  printf OUT "      switch (to_n) {\n";

  foreach my $to (@SYSTEMS) {
    next if $from eq $to;
    printf OUT "        case %s:\n", $to;
    printf OUT "          return %s_to_%s(t,v_in,v_out);\n", lc $from, lc $to;
  }
  print  OUT "        default:\t\t/* Cannot happen */\n";
  print  OUT "          return 1;\n";
  printf OUT "      }\n";
}
print  OUT <<EOP;
    default:\t\t/*Cannot happen */
      return 1;
  }

  /* We should never get here */
  strcat(cxform_err_buf, "INTERNAL ERROR: switch statements fell through!");
  return 2;
}
EOP

##################
#
# Generate the real code
#
##################
print OUT <<EOP;


/*
** Stub routines... all we do is call one of The Six, in various orders
*/
EOP

foreach my $from (@SYSTEMS) {
  foreach my $to (@SYSTEMS) {
    next if $from eq $to;

    write_wrapper_function($from, $to);
  }
}


# Close the file, make read-only, and move into place
close OUT or die "$ME: close( $TMP ): $!\n";
chmod 0444, $TMP;
rename       $OUT, $BAK;
rename $TMP, $OUT;
system("diff", "-u", $BAK, $OUT);


#
# Now write a DLM definition file
#
my $DLM = $INFILE;  $DLM =~ s/-manual//;        $DLM =~ s/\.c$/.dlm/;
   $TMP = $DLM . ".TMP";  unlink $TMP;
   $BAK = $DLM . ".BAK";

open OUT, "> $TMP"	or die "$ME: open( >$TMP ): $!\n";

printf OUT <<EOP, version($RCSID, $RCSID_INFILE), date_and_time(), whoami();
MODULE       CXFORM
DESCRIPTION  Ed Santiago and Ryan Boller\'s Coordinate Transform package
VERSION      %s
BUILD_DATE   %s
SOURCE       %s
FUNCTION     CXFORM      0 15
EOP

# Same as above: close the file, chmod, and move.
close OUT	or die "$ME: close( $TMP ): $!\n";
chmod 0444, $TMP;
rename       $DLM, $BAK;
rename $TMP, $DLM;
system("diff", "-u", $BAK, $DLM);

exit 0;


###################
#  date_and_time  #  returns a string of the form YYYY-MM-DD HH:MM
###################
sub date_and_time {
  use Time::localtime;
  return sprintf("%04d-%02d-%02d %02d:%02d",
		 localtime->year+1900,
		 localtime->mon + 1,
		 localtime->mday,
		 localtime->hour,
		 localtime->min);
}


############
#  whoami  #  returns a string of the form "user@host.domain"
############
sub whoami {
  use Net::Domain qw(hostfqdn);

  my $username = getlogin() || (getpwuid($<))[0] || "Unknown";
  my $hostname = hostfqdn();

  # Hostname removed due to inaccurate e-mail address
  return $username;  # sprintf("%s\@%s", $username, $hostname);
}









################################################################
sub initialize {
  my $infile = shift;

  use Tie::IxHash;
  my %seen;
  tie %seen, "Tie::IxHash";

  # CVS functionality removed - version number is set in header
  $RCSID_INFILE = $MANUAL_VERSION;  # "<unknown>";

  # Reread the infile, looking for the RCS ID and for "_twixt_" declarations
  open(IN, $infile) or die "$ME: in initialize(): open( $infile ): $!\n";
  while (<IN>) {
#    if(/(\$ Id: \s .* \$)/x) {
#      $RCSID_INFILE = filter_rcsid($1);
#    }
    if (/^(\s*(\S+)\s+)?(\w+)_twixt_(\w+)\s*\(\s*const double et/) {
      my ($from, $to) = (uc $3, uc $4);

      push(@{$MAPS_TO{$from}}, $to);
      push(@{$MAPS_FROM{$to}}, $from);
      $seen{$from}++;
      $seen{$to}++;
    }
  }
  close IN;

  @SYSTEMS = keys %seen;
}


##################
#  filter_rcsid  #  from the RCS "Id" string, extract the version number.
##################
sub filter_rcsid($) {
  my $id = shift;
  local $_;

  if ($id =~ /Id:\s+(\S+),v\s+([\d\.]+)\s+/) {
    my ($fname, $version) = ($1, $2);

    #
    # If this version is not up-to-date, add an "x", indicating "experimental"
    #
    open(CVSTATUS, "cvs status $1 |")	or die "$ME: open( cvstatus ): $!\n";
    while (<CVSTATUS>) {
      if (/Status:\s+(\S.*\S)\s*$/) {
	if ($1 ne "Up-to-date") {
	  $version .= "x";
	}
      }
    }
    close CVSTATUS			or die "$ME: close( cvstatus ): $!\n";

    return $version;
  }

  return $id;
}


sub gencase {
  my ($indent, $pos, @systems) = @_;

  printf OUT "%sswitch (system[%d]) {\n", $indent, $pos;

  my (%letters) = map { uc substr($_, $pos, 1) => $_ } @systems;
  foreach my $letter (sort keys %letters) {
    if ($letter ne '') {
      my $c = sprintf("%s  case '%s':", $indent, lc $letter);
      printf OUT "%-47s /* %s */\n", $c, 
                  join(", ", grep(substr($_, $pos, 1) eq $letter, @systems));
      printf OUT "%s  case '%s':\n",$indent,uc $letter if $letter =~ /[a-z]/i;

      gencase($indent . "    ", 
	      $pos+1, 
	      grep(substr($_, $pos, 1) eq $letter, @systems));
    } else {
      printf OUT "%s  case '\\0':\n",  $indent;
      printf OUT "%s    return %s;\n", $indent, $letters{$letter};
    }
  }

  printf OUT "%s  default:\n", $indent;
  printf OUT "%s    return UNKNOWN;\n", $indent;
  printf OUT "%s}\n", $indent;
}







################################################################

sub write_wrapper_function {
  my ($from, $to) = @_;

  # See if we have a direct transformation from "from" to "to".
  my @seq = sequence($from, $to);

  # If there isn't, we must die!
  die  "no way to go from '$from' to '$to'!\n"		if @seq == 0;

  printf OUT <<EOP, $from, $to, lc $from, lc $to;

/*
** %s to %s
*/
int %s_to_%s(double t, Vec v_in, Vec v_out)
{
EOP

  # Loop starting at 1 (not 0), since we're already in the frame of seq[0]
  my $indent = "  return";

  for (my $i=1; $i < @seq; $i++) {
    my $invert = 0;

    # Obtain the names of the previous frame ("from") and the destination.
    my $f1 = lc $seq[$i-1];               $f1 =~ s/-1$//;
    my $f2 = lc $seq[$i];      $invert = ($f2 =~ s/-1$//);

    # If the destination has a "-1", what we do is call f2_to_f1 and xpose.
    if ($invert) {
      ($f1, $f2) = ($f2, $f1);
    }

    my $v1  = ($i == 1 ? "v_in " : "v_out");
    my $dir = ($invert ? "BACK" : "FORWARD");

    # Emit calls only to gen-yoo-wine manually defined functions
    my $l = sprintf("%s %5s_twixt_%-5s(t, %s, v_out, %s)", $indent, 
		    $f1, $f2, $v1, $dir);

    # If this is the last step in the sequence, append a semicolon
    $l .= ";"	if $i == $#seq;

    # Append a /* comment */ showing the actual order of the transformation
    my (@f1f2) = @seq[$i-1..$i];  map { s/-1$// } @f1f2;
    printf OUT "%-55s /* %5s to %-5s */\n", $l, @f1f2;

    # After the first call, chain any subsequent calls together via "or".
    # This has the result of returning as soon as any one of the chain
    # returns non-zero (i.e., error status).  If none return nonzero,
    # we just return 0.
    if ($indent =~ /return/) {
      $indent =~ s/./ /g;
      $indent =~ s/..$/||/;
    }

  }
  printf OUT "}\n";
  return;
}


sub sequence($$..) {
  my ($from, $to, @exclude) = @_;

  # Try a forward (recursive) search
  foreach my $intermediate (@{$MAPS_TO{$from}}) {
    return ($from, $to)		if ($intermediate eq $to);

    next if grep(/^$intermediate(-1)?$/, @exclude);

    my @seq = sequence($intermediate, $to, @exclude, $from);
    if (@seq > 0) {
      return ($from, @seq);
    }
  }

  # ...and do the same, in reverse
  foreach my $intermediate (@{$MAPS_FROM{$from}}) {
    return ($from, $to . "-1")		if ($intermediate eq $to);

    next if grep(/^$intermediate(-1)?$/, @exclude);

    my @seq = sequence($intermediate, $to, @exclude, $from);
    if (@seq > 0) {
      return ($from, $seq[0] . "-1", @seq[1..$#seq]);
    }
  }

  # Nope, there's no way to get there from here.  
  #
  # No matter, though.  It's possible that we were recursively called
  # down the wrong branch, and our caller will find a solution down
  # another path.
  return ();
}


#############
#  version  #  returns a nicely formatted version string for the .dlm file
#############
sub version {
 
  # Subroutine bypassed due to errors
  return $_[0];
	
  open(IN, "VERSION") or die "$ME: open( VERSION ): $!\n";
  my $version_official = <IN>;
  chop $version_official;
  close IN;

  return sprintf("%s (development: pl:%s,c:%s)",$version_official,@_);
}