:Begin:
:Function: formget_file
:Pattern: FormGet[formout_String]
:Arguments: {formout}
:ArgumentTypes: {Manual}
:ReturnType: Manual
:End:

:Begin:
:Function: formget_exec
:Pattern: FormGet[formcmd_String, formprogram_String]
:Arguments: {formcmd, formprogram}
:ArgumentTypes: {Manual}
:ReturnType: Manual
:End:

:Evaluate: _FormGet := (Message[FormGet::syntax]; Abort[])

:Begin:
:Function: formgetdebug
:Pattern: FormGetDebug[debug_Integer, logfile_:""]
:Arguments: {debug, logfile}
:ArgumentTypes: {Integer, Manual}
:ReturnType: Manual
:End:

:Evaluate: FormGet::syntax = "Bad syntax."

:Evaluate: FormGet::nofile = "Cannot open ``."

:Evaluate: FormGet::nooutput = "There was no output from FORM."

:Evaluate: FormGet::formerror = "`1`"

:Evaluate: FormGet::usage = "FormGet[formoutputfile] reads FORM output from formoutputfile.\nFormGet[formcmd, formprogram] runs formcmd on formprogram and reads the output."

/******************************************************************

FormGet.tm
[last modified 8 Apr 19, Thomas Hahn <hahn@feynarts.de>]

This program provides a Mathematica function FormGet which reads
output files of FORM into Mathematica.  (FORM is a computer algebra
system commonly used in high-energy physics.)

The output format of FORM is slightly different from Mathematica's
InputForm, and while the translations (e.g. round brackets into square
brackets for functions) are in most cases straightforward to perform with
any decent pattern-matching language like perl or awk, it becomes a pain
to program this for every FORM file one may want to read.

In addition, FormGet preserves the structure of the FORM output if it
was grouped into common factors with the bracket command.

COMPILATION:

Type "mcc -O -o FormGet FormGet.tm", then if you want, copy the
executable FormGet to some convenient location like /usr/local/bin.

USAGE:

Install the package in Mathematica: Install["FormGet"].
Read an existing FORM output file: FormGet["formoutputfile"].
Read output from a FORM pipe: FormGet["/path/to/form", "formprogram"].

OUTPUT:

An expression which is written out by FORM as

expr = a + b + c;

arrives in Mathematica as "expr -> a + b + c".  If several expressions
are present in the FORM file, a list of such rules is returned.

Bracketed parts are returned inside the function "Br".

The imaginary unit ("i_" in FORM) is converted to Mathematica's I, and
all underscores are replaced by "$" characters to make the expression
acceptable for Mathematica.

Identifiers with square brackets are returned as strings, i.e. are not
directly evaluated.  For instance, the FORM expression [a+b] + c becomes
"a+b" + c in Mathematica.

FormGet should normally steer clear of source listing and statistics
messages.  In the case of problems, however, please try turning off
source listing with "#-" and/or statistics with "nwrite statistics"
in FORM.

RESTRICTIONS:

In FORM it is possible to have noncommuting functions, whose product is
also written with the ordinary "*" operator.  Hence, if transferred to 
Mathematica using FormGet, the order of such a product will most likely 
get destroyed.  One way of working around this is something like

FormGetNC[file_] := Block[{Times = times}, FormGet[file]]

NCFunctions = a | b | c | d	(* the functions which are noncommuting *)

times[n__] := Times[n] /; FreeQ[{n}, NCFunctions]

times[n__] := NonCommutativeMultiply[n]

******************************************************************/

#include "mathlink.h"
#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <unistd.h>
#include <fcntl.h>
#include <signal.h>
#include <sys/wait.h>
#include <sys/types.h>
#include <assert.h>

typedef struct rhs {
  struct rhs *next;
  char expr[2048];
} RHS;

typedef struct expr {
  struct expr *next;
  RHS *rhs;
  int nrhs;
  char lhs[128];
} EXPR;

typedef const int cint;
typedef char *string;
typedef MLCONST char *cstring;

static int debug = 0;
static FILE *stddeb;

/******************************************************************/

static inline void MLMessage(MLINK mlp, cstring tag, cstring arg) {
  MLPutFunction(mlp, "EvaluatePacket", 1);

  MLPutFunction(mlp, "Message", (arg) ? 2 : 1);
  MLPutFunction(mlp, "MessageName", 2);
  MLPutSymbol(mlp, "FormGet");
  MLPutString(mlp, tag);
  if( arg ) MLPutString(mlp, arg);
  MLEndPacket(mlp);
  while( MLNextPacket(mlp) != RETURNPKT )
    MLNewPacket(mlp);
  MLNewPacket(mlp);	/* discard returned Null */
}

/******************************************************************/

static inline void MLFail(MLINK mlp, cstring tag, cstring arg) {
  MLMessage(mlp, tag, arg);
  MLPutSymbol(mlp, "$Failed");
  MLEndPacket(mlp);
}

/******************************************************************/

static inline void MLPutTerm(MLINK mlp, cstring s) {
  MLPutFunction(mlp, "ToExpression", 1);
  MLPutString(mlp, s);
}

/******************************************************************/

static void SendExpr(EXPR *expr, cint nexpr) {
  EXPR *ep, *epnext;
  RHS *rp, *rpnext;

  if( nexpr == 0 ) MLMessage(stdlink, "nooutput", NULL);
  MLPutFunction(stdlink, "List", nexpr);

  for( ep = expr; (epnext = ep->next); ep = epnext ) {
    MLPutFunction(stdlink, "Rule", 2);
    MLPutFunction(stdlink, "ToExpression", 1);
    MLPutString(stdlink, ep->lhs);
    if( debug & 2 )
      fprintf(stderr, "lhs = |%s|\nrhs %d parts", ep->lhs, ep->nrhs);
    MLPutFunction(stdlink, "ToExpression", 1);
    if( ep->nrhs > 1 ) MLPutFunction(stdlink, "StringJoin", ep->nrhs);
    for( rp = ep->rhs; rp; rp = rpnext ) {
      MLPutString(stdlink, rp->expr);
      if( debug & 4 ) fprintf(stderr, "expr = |%s|\n", rp->expr);
      rpnext = rp->next;
      free(rp);
    }
    free(ep);
  }
  free(ep);

  MLEndPacket(stdlink);
}

/******************************************************************/

static void FormGet(FILE *file) {
  char *s, *d, *x, last;
  char br[64], *brpos;
  int nexpr = -1, inexpr = 0, b = 0, verb = 0, n, nx;
  int justbr;
  char line[512], errmsg[512], *errend = errmsg;
  EXPR *cur, *expr, **nextexpr = &expr;
  RHS **nextrhs;

nextexpr:
  ++nexpr;
  *nextexpr = cur = malloc(sizeof(EXPR));
  nextexpr = &cur->next;
  *nextexpr = NULL;
  nextrhs = &cur->rhs;
  *nextrhs = NULL;
  cur->nrhs = 0;
  d = cur->lhs;
  n = sizeof(cur->lhs);
  nx = justbr = 0;
  brpos = NULL;
  last = '+';

nextline:
  do {
    if( fgets(line, sizeof line, file) == NULL ) {
      fclose(file);
      if( errend == errmsg ) SendExpr(expr, nexpr);
      else {
        errend[-1] = 0;		/* discard last \n */
        MLFail(stdlink, "formerror", errmsg);
      }
      return;
    }

    if( debug & 1 ) fputs(line, stderr);

    if( *line == '\n' ) continue;

    if( (s = strstr(line, "-->")) ||
        (s = strstr(line, "==>")) ||
        (s = strstr(line, "===")) ) {
      strncpy(errend, s + 4, errmsg + sizeof(errmsg) - errend);
      errend += strlen(errend);
      continue;
    }
  } while( errend > errmsg );

  if( inexpr == 0 ) {
    int tok = 0, verb = 0;
    char *eq;
    if( /* *line != ' ' || */
        ((eq = strchr(line, '=')) == NULL) ||
        strchr(eq + 1, '=') ) goto nextline;
    for( s = line; s < eq; ++s )
      switch( *s | verb ) {
      case ' ':
        tok |= 2*(tok & 1);
        break;
      case '[':
      case ']' + 256:
        verb ^= 256;
		/* fall through */
      default:
        if( tok == 3 ) goto nextline;
        tok |= 1;
      }
  }

#define ASSOCIATIVE strchr("+-*/^,([", last)

  if( justbr ) nx = 4, x = "    ", brpos = d;
  justbr = 0;

  for( s = line; *s; ++s ) {
    char c = *s;
    if( c <= ' ' ) continue;

    switch( c | verb ) {
    case ';':
      inexpr = 0;
      if( brpos && justbr == 0 ) {
        memcpy(brpos, "+Br[", 4);
        *d++ = ']';
      }
      *d = 0;
      goto nextexpr;
    case '=':
      inexpr = 1;
      n = 0;
      *d = 0;
      last = '+';
      continue;
    case '(':
      if( ASSOCIATIVE ) {
        if( b ) {
          br[b++] = ')';
          break;
        }
        nx = 2, x = "Br";
      }
      c = '[', br[b++] = ']' | (nx << 6);
      break;
    case ')':
    case ']':
      if( b > 0 ) c = br[--b];
      justbr |= c >> 7;
      c &= 0x7f;
      break;
    case '[':
      if( ASSOCIATIVE ) verb = 256, c = '\"';
      else br[b++] = ']';
      break;
    case ']' + 256:
      verb = 0;
      c = '\"';
      break;
    case '_':
      c = '$';
      break;
    case '?':
    case '\\':
      continue;
    }

    if( n <= nx + 2 ) {
      RHS *rhs = *nextrhs = malloc(sizeof(RHS));
      nextrhs = &rhs->next;
      *nextrhs = NULL;
      *d = 0;
      d = rhs->expr;
      n = sizeof(rhs->expr) - 1;
      ++cur->nrhs;
    }

    if( nx ) {
      memcpy(d, x, nx);
      d += nx;
      n -= nx;
      nx = 0;
    }
    *d++ = last = c;
    --n;
  }

  goto nextline;
}

/******************************************************************/

static void formget_file(void) {
  cstring formout;
  FILE *in;

  assert( MLGetString(stdlink, &formout) );

  in = fopen(formout, "r");
  if( in ) FormGet(in);
  else MLFail(stdlink, "nofile", formout);

  MLReleaseString(stdlink, formout);
}

/******************************************************************/

static void formget_exec(void) {
  FILE *in;
  int fd[2], status;
  pid_t pid;
  cstring formcmd, formprogram;
  cstring argv[16], *argp = argv;
  string p0, p;

  assert( MLGetString(stdlink, &formcmd) &&
          MLGetString(stdlink, &formprogram) &&
          (p = p0 = strdup(formcmd)) );
  do *argp++ = strsep(&p, "|"); while( p );
  argp[0] = formprogram;
  argp[1] = NULL;

  signal(SIGCHLD, SIG_IGN);
  assert( pipe(fd) != -1 && (pid = fork()) != -1 );

  if( pid == 0 ) {
    usleep(500);
    close(fd[0]);
    dup2(fd[1], 1);
    dup2(fd[1], 2);
    close(fd[1]);
    exit(execvp((char *)argv[0], (char **)argv));
  }

  close(fd[1]);
  in = fdopen(fd[0], "r");
  if( in ) FormGet(in);
  else MLFail(stdlink, "nofile", argv[0]);

  kill(pid, SIGKILL);
  wait(&status);

  free(p0);
  MLReleaseString(stdlink, formprogram);
  MLReleaseString(stdlink, formcmd);
}

/******************************************************************/

static void formgetdebug(cint deb) {
  cstring logfile;

  assert( MLGetString(stdlink, &logfile) );

  debug = deb;

  stddeb = stderr;
  if( *logfile ) {
    stddeb = fopen(logfile, "w");
    if( stddeb == NULL ) {
      MLFail(stdlink, "noopen", logfile);
      debug = 0;
      return;
    }
    setbuf(stddeb, NULL);
  }

  MLPutSymbol(stdlink, "True");
  MLEndPacket(stdlink);
}

/******************************************************************/

int main(int argc, char **argv) {
  int fd;

	/* make sure a pipe will not overlap with 0, 1, 2 */
  do fd = open("/dev/null", O_WRONLY); while( fd <= 2 );
  close(fd);

  return MLMain(argc, argv);
}