/* simi.c

   written by Don Maszle
   16 October 1991
   
   Copyright (c) 1993.  Don Maszle, Frederic Bois.  All rights reserved.

   -- Revisions -----
     Logfile:  %F%
    Revision:  %I%
        Date:  %G%
     Modtime:  %U%
      Author:  @a
   -- SCCS  ---------

   Contains input routines for simulation.
*/

#include <stdio.h>
#include <stdlib.h>
#include <string.h>
#include <ctype.h>
#include <float.h>
#include <assert.h>

#ifdef __DOS__
#include <malloc.h>	/* NON-ANSI _memavl() call */
#endif

#include "sim.h"
#include "_string.h"

PSTRLEX vrgszlexArgs[ARGS_MAX];

/* Keyword Map Structure */

typedef struct tagKM {
  PSTR szKeyword;
  int  iKWCode;			/* Enumeration code of Keyword KM_* */
  WORD  fContext;		/* Bit flags of valid context for KW */
} KM, *PKM;	/* Keyword Map */

KM vrgkmKeywordMap[] = {		/* Global Keyword - code map */
  
      /* Simulation syntax */

  {"Experiment",    KM_EXPERIMENT,	CN_GLOBAL},
  
  {"OutputFile",    KM_OUTPUTFILE,	CN_GLOBAL},	/* Regular out file */

/*  {"Gibbs",         KM_GIBBS,	        CN_GLOBAL},	/* Gibbs estim spec */
  {"MonteCarlo",    KM_MONTECARLO,	CN_GLOBAL},	/* Monte Carlo spec */
  {"Distrib",       KM_MCVARY,		CN_GLOBAL},	/* MC Variable mod */
  {"MCVary",        KM_MCVARY,		CN_GLOBAL},	/* Obsolete!! */
  {"SetPoints",     KM_SETPOINTS,	CN_GLOBAL},	/* Forced point runs*/
  {"Optimize",      KM_OPTIMIZE,	CN_GLOBAL},	/* not implemented */

  {"Integrate",	    KM_INTEGRATE,	CN_GLOBAL | CN_EXPERIMENT},
  {"Simulate",	    KM_SIMULATE,	CN_GLOBAL | CN_EXPERIMENT},

  {"Print",	    KM_PRINT,		CN_EXPERIMENT},

  /* If a type is not seen before the first section is found, that section
     becomes the type.  Subsequent statements are ignored. */
  {"SimType",	KM_SIMTYPE,  CN_GLOBAL}, /* Optional SimType */
  
  {"End",	KM_END,	     CN_GLOBAL},	/* Optional End statement */
  {"end",	KM_END,	     CN_GLOBAL},	/* Optional End statement */
  {"END",	KM_END,	     CN_GLOBAL},	/* Optional End statement */

	/* Function arguments */

  {"DefaultSim",    KM_DEFAULTSIM,   CN_FUNCARG}, /* For SimType() only */

  {"no",	KM_NO,		CN_FUNCARG},	/* Use YesNoFromLex() */
  {"No",	KM_NO,		CN_FUNCARG},
  {"yes",	KM_YES,		CN_FUNCARG},
  {"Yes",	KM_YES,		CN_FUNCARG},

  {"uniform",   KM_UNIFORM,	CN_FUNCARG},	/* Use McvFromLex() */
  {"Uniform",	KM_UNIFORM,	CN_FUNCARG},
  {"uni",	KM_UNIFORM,	CN_FUNCARG},
  {"Uni",	KM_UNIFORM,	CN_FUNCARG},
  {"loguni",	KM_LOGUNIFORM,	CN_FUNCARG},
  {"LogUni",	KM_LOGUNIFORM,	CN_FUNCARG},
  {"loguniform",KM_LOGUNIFORM,	CN_FUNCARG},
  {"LogUniform",KM_LOGUNIFORM,	CN_FUNCARG},
  {"Beta",      KM_BETA,	CN_FUNCARG},
  {"beta",      KM_BETA,	CN_FUNCARG},
  {"lognormal",KM_LOGNORMAL,	CN_FUNCARG},
  {"LogNormal",KM_LOGNORMAL,	CN_FUNCARG},
  {"normal",   KM_NORMAL,	CN_FUNCARG},
  {"Normal",   KM_NORMAL,	CN_FUNCARG},
  {"truncnormal",   KM_TRUNCNORMAL,	CN_FUNCARG},
  {"TruncNormal",   KM_TRUNCNORMAL,	CN_FUNCARG},
  {"trunclognormal",   KM_TRUNCLOGNORMAL,	CN_FUNCARG},
  {"TruncLogNormal",   KM_TRUNCLOGNORMAL,	CN_FUNCARG},
  {"Chi2",   KM_CHI2,	CN_FUNCARG},
  {"chi2",   KM_CHI2,	CN_FUNCARG},
  {"sine",   KM_SINE,	CN_FUNCARG},
  {"Sine",   KM_SINE,	CN_FUNCARG},
  
  {"gear",	KM_GEAR,	CN_FUNCARG},	/* Use ImFromLex() */
  {"Gear",	KM_GEAR,	CN_FUNCARG},
  {"jacobian",	KM_JACOBIAN,	CN_FUNCARG},
  {"Jacobian",	KM_JACOBIAN,	CN_FUNCARG},
  
				    /* Variables names valid in all CN_ */
  {"", 0, CN_ALL}  /* End flag */
  
};  /* vrgkmKeywordMap[] */


/* GetKeywordCode
   
   Returns the code of the szKeyword given.  If the string is not
   a valid keyword or abbreviation, returns 0.
   
   If pfContext is non-NULL, contexts in which the code is valid is
   returned here.
*/

int GetKeywordCode (PSTR szKeyword, PINT pfContext)
{
  PKM pkm = &vrgkmKeywordMap[0];
  
  while (*pkm->szKeyword && Strcmp (szKeyword, pkm->szKeyword))
    pkm++;
  
  if (pfContext)
    *pfContext = pkm->fContext;		/* Set iContext flag */
  return (pkm->iKWCode);		/* Return Keyword Code or 0 */

}  /* GetKeywordCode */



/* GetKeyword
   
   Returns the first string of the KM_ keyword map code given.  If the
   code is not a valid keyword code, returns NULL.
*/

PSTR GetKeyword (int iKWCode)
{
  PKM pkm = &vrgkmKeywordMap[0];
  
  while (*pkm->szKeyword && iKWCode != pkm->iKWCode)
    pkm++;
  
  return (pkm->szKeyword);		/* Return Keyword Code or 0 */

}  /* GetKeyword */


/* YesNoFromLex
   
   Converts an string input argument into a Boolean,
   Yes being TRUE and No being FALSE.  Also, a numeric argument
   is converted to Yes if it is non-zero.
*/

BOOL YesNoFromLex (PSTR szLex)
{
  int ikwcode = GetKeywordCode (szLex, NULL);
  BOOL bReturn;
  
  bReturn = (!isalpha(szLex[0]) ? atoi(szLex)
	     : ikwcode == KM_YES ? TRUE
             : ikwcode == KM_NO ? FALSE
	     : FALSE);

  return bReturn;
}  /* YesNoFromLex */


/* ImFromLex
   
   Converts an string input argument into the correct IM_
   integration method.
*/

long ImFromLex (PSTR szLex)
{
  int ikwcode = GetKeywordCode (szLex, NULL);
  long lReturn;
  
  lReturn = (!isalpha(szLex[0]) ? atoi(szLex)
	     : ikwcode == KM_GEAR ? IM_GEAR
             : ikwcode == KM_JACOBIAN ? IM_JACOB
	     : IM_DEFAULT);

  return (lReturn);
}  /* ImFromLex */



/*  McvFromLex
   
   Converts a string input argument into the correct MCV_
   Monte Carlo variation distribution type.
*/

int  McvFromLex (PSTR szLex)
{
  int ikwcode = GetKeywordCode (szLex, NULL);
  int iReturn;
  
  iReturn = (ikwcode == KM_UNIFORM      ? MCV_UNIFORM
             : ikwcode == KM_LOGUNIFORM ? MCV_LOGUNIFORM
             : ikwcode == KM_BETA       ? MCV_BETA
             : ikwcode == KM_NORMAL     ? MCV_NORMAL
             : ikwcode == KM_LOGNORMAL  ? MCV_LOGNORMAL
             : ikwcode == KM_TRUNCNORMAL ? MCV_TRUNCNORMAL
             : ikwcode == KM_TRUNCLOGNORMAL  ? MCV_TRUNCLOGNORMAL
             : ikwcode == KM_CHI2        ? MCV_CHI2
             : ikwcode == KM_SINE        ? MCV_SINE
	     : (-1));

  return iReturn;
}  /* McvFromLex */





/* GetTerminator
   
   Tries to read a statement terminator.  Reports Errors.
*/

int GetTerminator (PINPUTBUF pibIn, PSTR szLex)
{
  int iErr;
  
  if (iErr = !GetPunct (pibIn, szLex, CH_STMTTERM)) {
    szLex[1] = CH_STMTTERM;
    ReportError (pibIn, RE_EXPECTED, szLex, NULL);
  }  /* if */
  return (iErr);
}  /* GetTerminator */
  

BOOL GetSimType (PINPUTBUF pibIn)
{
#define NAT_ARGS 1 	/* the type */

static int vrgiAtArgTypes[NAT_ARGS] = {LX_IDENTIFIER};

  PANALYSIS panal = (PANALYSIS) pibIn->pInfo;

  int  iAT = AT_DEFAULTSIM;
  int  iKwCode = 0;
  BOOL bErr=!GetFuncArgs (pibIn, NAT_ARGS, vrgiAtArgTypes, vrgszlexArgs[0]);

  if (!bErr) {
    iKwCode = GetKeywordCode (vrgszlexArgs[0], NULL);
    switch (iKwCode) {

    case KM_MONTECARLO:
      iAT = AT_MONTECARLO;
      break;

    case KM_SETPOINTS:
      iAT = AT_SETPOINTS;
      break;

    case KM_GIBBS:
      iAT = AT_GIBBS;
      break;

    case KM_DEFAULTSIM:
      iAT = AT_DEFAULTSIM;
      break;

    default:
      ReportError (pibIn, RE_SPECERR | RE_WARNING, "Ignoring unknown SimType ",
		   vrgszlexArgs[0]);
      break;
    }  /* switch */
  }  /* if */
  else
    fprintf (stderr, "Syntax: %s (Normal | MonteCarlo | SetPoints | Gibbs)\n"
	     "  -- if not specified, the first spec section will be used.\n\n",
	     GetKeyword(KM_SIMTYPE));

  if (!bErr) {
    if (!panal->iType)
      panal->iType = iAT;
    else
      fprintf (stderr, "** Ignoring SimType() specification.\n"
	       "   Place SimType() spec before all section specifications.");
  }  /* if */
    
  return (bErr);
}  /* GetIntegrate */



BOOL GetIntegrate (PINPUTBUF pibIn, PINTSPEC pis)
{
#define NINT_ARGS 6 	/* Six integrator Args */

static int vrgiIntArgTypes[NINT_ARGS] = {LX_IDENTIFIER, LX_INTEGER, LX_NUMBER,
				         LX_NUMBER, LX_NUMBER, LX_NUMBER};

  BOOL bErr=!GetFuncArgs (pibIn, NINT_ARGS, vrgiIntArgTypes, vrgszlexArgs[0]);

  if (!bErr) {
    pis->iMethod = ImFromLex (vrgszlexArgs[0]);
    pis->iMaxDeriv = atoi(vrgszlexArgs[1]);

    pis->dStep = atof(vrgszlexArgs[2]);
    pis->dStepMin = atof(vrgszlexArgs[3]);
    pis->dStepMax = atof(vrgszlexArgs[4]);
    pis->dErrorMax = atof(vrgszlexArgs[5]);
  }  /* if */
  else
    fprintf (stderr, "Syntax: %s ([Gear | Jacobian], iOrder, dStep, "
	     "dStepMin, dStepMax, dErrorMax)\n\n", GetKeyword(KM_INTEGRATE));
  return (bErr);
}  /* GetIntegrate */



/* OneDToArray
   
   Copies one double from the list to the newly formed array.
   Increments the info pointer which is the pointer into the array.
*/

int OneDToArray (PVOID pData, PVOID pInfo)
{
  PDOUBLE *ppdArrayVal = (PDOUBLE *) pInfo;

  *(*ppdArrayVal)++ = *(PDOUBLE) pData;
  return 0;
}  /* OneDToArray */


/* DListToArray
   
   Converts a list a doubles to an array of doubles.  *pcDouble is
   the count of doubles in the array, and *ppDouble is the array
   pointer. 
*/

void DListToArray (PLIST plist, PINT pcDouble, PDOUBLE *ppDouble)
{
  PDOUBLE pdTmp;		/* Temp pointer to get incremented */
  
  *pcDouble = ListLength(plist);
  pdTmp = *ppDouble = (PDOUBLE) malloc (*pcDouble * sizeof(double));
  ForAllList (plist, &OneDToArray, (PVOID) &pdTmp);

}  /* DListToArray */


/* GetListOfTimes
   
   Reads an arbitrary length list of times and closing parenthesis.
   Defines the count and array of times in the PRINTREC structure.
*/
   
BOOL GetListOfTimes (PINPUTBUF pibIn, PPRINTREC ppr, PSTR szLex)
{
  PLIST plistTimes = InitList();
  PDOUBLE pdTmp;
  int iNLI, i;
  BOOL bErr;
  
  while ((iNLI = NextListItem (pibIn, szLex, LX_NUMBER, 1, CH_RPAREN))
	 > 0) {
    pdTmp = (PDOUBLE) malloc (sizeof(double));
    *pdTmp = atof(szLex);
    QueueListItem (plistTimes, (PVOID) pdTmp);
  }  /* while */

  if (!iNLI)					/* List terminator */
    bErr = EGetPunct (pibIn, szLex, CH_RPAREN)
           || !ListLength(plistTimes);
  else {
    bErr = TRUE;
    ReportError (pibIn, RE_LEXEXPECTED, "number", szLex);
  }  /* else */
  
  if (!bErr)
    DListToArray (plistTimes, &ppr->cTimes, &ppr->pdTimes);

  for (i = 1; i < ppr->cTimes && !bErr; i++)	/* Verify Times */
    if (bErr = (*(ppr->pdTimes+i) <= *(ppr->pdTimes+i-1))) {
      ReportError (pibIn, RE_SPECERR, "Times out of order", NULL);
      free (ppr->pdTimes);
    }  /* if */

  FreeList (&plistTimes, NULL, TRUE);		/* Free list and cells */
  return (bErr);

}  /* GetListOfTimes */


/* GetPrint
   
   Gets the arguments to a Print() statement
*/

BOOL bGavePrintUsage = FALSE;		/* prevent multiple diagnostics */

BOOL GetPrint (PINPUTBUF pibIn, PSTR szLex, POUTSPEC pos)
{
  PPRINTREC pprintrec;
  BOOL bErr = FALSE;
  HVAR hvar;

  if (!(bErr = EGetPunct (pibIn, szLex, CH_LPAREN))) {
    if (!(bErr = ENextLex (pibIn, szLex, LX_IDENTIFIER))) {

      if (bErr = !(hvar = GetVarHandle (szLex)))
	ReportError (pibIn, RE_UNDEFINED, szLex, NULL);

      else {
	if (!pos->plistPrintRecs)
	  pos->plistPrintRecs = InitList();
	pprintrec = (PPRINTREC) malloc (sizeof(PRINTREC));
	pprintrec->szOutputName = (PSTR) malloc (_strlen(szLex)+1);
	_strcpy (pprintrec->szOutputName, szLex);
	assert(pprintrec);
	
	pprintrec->hvar = hvar;
	bErr = GetListOfTimes (pibIn, pprintrec, szLex);

	if (bErr) {
	  free (pprintrec->szOutputName);
	  free (pprintrec);
	}  /* if */
	else
	  QueueListItem (pos->plistPrintRecs, (PVOID) pprintrec);
      }  /* else */

    }  /* if */
  }  /* if */

  if (!bErr)
    bErr = GetTerminator (pibIn, szLex);
  else {
    if (!bGavePrintUsage) {
      fprintf (stderr, "Syntax: %s (identifier, Time1, Time2, ...)\n\n",
	       GetKeyword(KM_PRINT));
      bGavePrintUsage = TRUE;
    }  /* if */
  }  /* else */

  return (bErr);

}  /* GetPrint */


/* GetStringArg
   
   tries to read a string argument from pibIn and assign it to
   *pszArg.  If pszArg is NULL, the argument is read, but no
   assigment is made.  If pszArg is not NULL, space is allocated for
   argument read.  szLex is a workspace.  If bDelim is TRUE, a
   delimiter is skipped in the input buffer.
   
   The return value is TRUE for error.  Errors are reported.
*/

BOOL GetStringArg (PINPUTBUF pibIn, PSTR *pszArg, PSTR szLex, BOOL bDelim)
{
  BOOL bErr;
  
  assert (szLex);	/* Workspace must be given */
  
  if (bDelim)
    GetOptPunct (pibIn, szLex, ',');

  bErr = ENextLex (pibIn, szLex, LX_STRING);

  if (!bErr) {
    if (szLex[0]) {		/* Allocate and copy the string */
      *pszArg = (PSTR) malloc (_strlen(szLex) + 1);
      _strcpy (*pszArg, szLex);
    }  /* if */
    else
      *pszArg = NULL;		/* No string given */
  }  /* if */
  
  return (bErr);
    
}  /* GetStringArg */


/* GetOutputFile
   
   Use a name different from the default for the regular output
*/

BOOL GetOutputFile (PINPUTBUF pibIn, PSTR szLex, POUTSPEC pos)
{
  BOOL bErr = FALSE;

  bErr = EGetPunct (pibIn, szLex, CH_LPAREN)
	 || GetStringArg (pibIn, &pos->szOutfilename, szLex, FALSE);

  if (!bErr)
    bErr = EGetPunct (pibIn, szLex, CH_RPAREN);

  if (!bErr)
    bErr = GetTerminator (pibIn, szLex);
  else
    fprintf (stderr, "Syntax: %s (szOutputFilename)\n\n",
	     GetKeyword (KM_OUTPUTFILE));

  return (bErr);

}  /* GetOutputFile */



BOOL bGaveSimulateUsage = FALSE;	/* prevent multiple diagnostics */

BOOL GetSimulate (PINPUTBUF pibIn, PEXPERIMENT pexp)
{
#define NSIM_ARGS 2 	/* Six integrator Args */

static int vrgiSimArgTypes[NSIM_ARGS] = {LX_NUMBER, LX_NUMBER};

  BOOL bErr=!GetFuncArgs (pibIn, NSIM_ARGS, vrgiSimArgTypes, vrgszlexArgs[0]);

  if (!bErr) {
    pexp->dT0 = atof(vrgszlexArgs[0]);
    pexp->dTfinal = atof(vrgszlexArgs[1]);
  }  /* if */
  else {
    if (!bGaveSimulateUsage) {
      fprintf (stderr, "Syntax: %s (dInitialTime, dFinalTime)\n\n",
	     GetKeyword (KM_SIMULATE));
      bGaveSimulateUsage = TRUE;
    }  /* if */
  }  /* else */

  return (bErr);
}  /* GetSimulate */


/* GetGibbsSpec

   get the Gibbs specification.
*/

BOOL GetGibbsSpec (PINPUTBUF pibIn, PEXPERIMENT pexp)
{
#define NGIBBS_ARGS 8 	/* # Func args to gibbs spec */

static
  int vrgiGibbsArgTypes[NGIBBS_ARGS] = {
    LX_STRING, LX_STRING, LX_STRING, LX_STRING,
    LX_INTEGER, LX_INTEGER, LX_INTEGER, LX_NUMBER};

  PANALYSIS panal = (PANALYSIS) pibIn->pInfo;

  BOOL bErr= !GetFuncArgs(pibIn, NGIBBS_ARGS,
                          vrgiGibbsArgTypes,vrgszlexArgs[0]);

static char vszGibbsOutDefault[] = "Gibbs.Out.Default";
static char vszGibbsParmOutDefault[] = "Gibbs.ParmOut.Default";
static char vszGibbsDataDefault[] = "Gibbs.Data.Default";

/*.   BOOL bErr = GetPunct (pibIn, vrgszlexArgs[0], CH_LPAREN) */
/*. 	      && GetPunct (pibIn, vrgszlexArgs[0], CH_LPAREN); */

  if (!bErr) {
    if (*vrgszlexArgs[0]) {			/* Get Exter Data Filename */
      panal->gd.szGout = (PSTR)malloc(_strlen(vrgszlexArgs[0]) + 1);
      _strcpy (panal->gd.szGout, vrgszlexArgs[0]);
    }  /* if */
    else
      panal->gd.szGout = vszGibbsOutDefault;

    if (*vrgszlexArgs[1]) {			/* Get Parm output file */
      panal->gd.szGparmout = (PSTR)malloc(_strlen(vrgszlexArgs[1]) + 1);
      _strcpy (panal->gd.szGparmout, vrgszlexArgs[1]);
    }  /* if */
    else
      panal->gd.szGparmout = vszGibbsParmOutDefault;

    if (*vrgszlexArgs[2]) {			/* Get restart file */
      panal->gd.szGrestart = (PSTR)malloc(_strlen(vrgszlexArgs[2]) + 1);
      _strcpy (panal->gd.szGrestart, vrgszlexArgs[2]);
    }  /* if */
    /*-- If this file is NULL, we start with an initial guess from the data */

    if (*vrgszlexArgs[3]) {			/* Get Exter Data Filename */
      panal->gd.szGdata = (PSTR)malloc(_strlen(vrgszlexArgs[3]) + 1);
      _strcpy (panal->gd.szGdata, vrgszlexArgs[3]);
    }  /* if */
    else
      panal->gd.szGdata = vszGibbsDataDefault;

    panal->gd.nMaxIter = atoi(vrgszlexArgs[4]);
    panal->gd.nOutExp = atoi(vrgszlexArgs[5]);
    panal->gd.nPhis = atoi(vrgszlexArgs[6]);
    AnalysisSetSeed (panal, atof(vrgszlexArgs[7]));
  }  /* if */
  else
    fprintf (stderr, "Syntax: %s (szOut, szParm, szRestart, szDat,\n"
	             "              nMaxIters, nOutExps, nPhis, dSeed)\n\n",
	     GetKeyword (KM_GIBBS));
  
  if (!bErr && !panal->iType)
    panal->iType = AT_GIBBS;
  return (!bErr);
}  /* GetGibbsSpec */


/* GetMCVarySpec

*/

BOOL bGaveMCVaryUsage = FALSE;		/* prevent multiple diagnostics */

int GetMCVarySpec (PINPUTBUF pibIn, PANALYSIS panal, PSTR szLex)
{
  PMCVAR pMCVar = NULL;
  HVAR hvar;
  int iErr = 0;

  /*-- If another type is declared already which is not a Monte Carlo
       or a Gibbs type, then ignore this specification.

       NOTE:  This should not set the type since variations are used
              for multiple SimTypes.
   */
       
  if (panal->iType
      && !((panal->iType == AT_MONTECARLO)
	   || (panal->iType == AT_GIBBS))) {
    EatStatement (pibIn);	/*-- Ignore this MCVary() stmt */
    goto Exit_MCVarySpec;
  }  /* if */

  /*-- Get this foolishly designed MCVary() spec.  Check syntax at
       each element.  God, Yacc is going to make this so-o-o much
       nicer.  I wonder when I'm going to write it.
   */

  /*-- Get the parameter to be varied */

  if (iErr = (EGetPunct (pibIn, szLex, CH_LPAREN)
	      || ENextLex (pibIn, szLex, LX_IDENTIFIER)))
    goto Done_GetMCVary;
  
  if (iErr = (!(hvar = GetVarHandle (szLex)) /* Invalid variable name? */
	      || IsInput(hvar)
	      || IsOutput(hvar)))
  {
    ReportError (pibIn, RE_LEXEXPECTED, "state-or-parameter", szLex);
    goto Done_GetMCVary;
  }  /* if */
  pMCVar = (PMCVAR) malloc (sizeof(MCVAR));
  pMCVar->hvar = hvar;
  
    /*-- Get the distribution type */

  GetOptPunct (pibIn, szLex, ',');
  iErr |= ENextLex (pibIn, szLex, LX_IDENTIFIER);
  pMCVar->iType = McvFromLex (szLex);
  if (iErr |= pMCVar->iType < 0) {
    ReportError (pibIn, RE_LEXEXPECTED, "distribution-type", szLex);
    goto Done_GetMCVary;
  }  /* if */

    /*-- Get parameters of the distribution.  These vary by distribution
         type.
     */
  switch (pMCVar->iType) {
  case MCV_SINE:
  case MCV_CHI2:
    fprintf (stderr, "* TruncLogNormal, Sine and Chi2 distribution types are not implemented.\n");
    iErr = 1;
    break;

    /*-- Get the the mean and stddev, or a and b shape parms for Beta */

  case MCV_BETA:
  case MCV_NORMAL:
  case MCV_LOGNORMAL:
  case MCV_TRUNCNORMAL:
  case MCV_TRUNCLOGNORMAL:
    GetOptPunct (pibIn, szLex, ',');
    iErr |= ENextLex (pibIn, szLex, LX_NUMBER);
    pMCVar->dParm1 = atof(szLex);

    GetOptPunct (pibIn, szLex, ',');
    iErr |= ENextLex (pibIn, szLex, LX_NUMBER);
    pMCVar->dParm2 = atof(szLex);
    if (iErr)
      goto Done_GetMCVary;

    /*-- Set min-max range defaults */

    pMCVar->dMin = 0.0;		/*-- Standard range for beta */
    pMCVar->dMax = 1.0;
    if (pMCVar->iType == MCV_NORMAL) {
      pMCVar->dMin = -DBL_MAX;
      pMCVar->dMax = DBL_MAX;
    }  /* else */
    else if (pMCVar->iType == MCV_LOGNORMAL)
      pMCVar->dMax = DBL_MAX;

    /*-- Look if a min-max range is included.  For truncated types
         it is required.  Otherwise, modify the type.
     */
    SkipWhitespace (pibIn);
    if ((pMCVar->iType == MCV_BETA
	 || pMCVar->iType == MCV_NORMAL
	 || pMCVar->iType == MCV_LOGNORMAL
	)
	&& NextChar (pibIn) == CH_RPAREN)
      break;			/* The spec is finished */

    /*-- Ranges included for these type, change to truncated types. */

    if (pMCVar->iType == MCV_NORMAL)
      pMCVar->iType = MCV_TRUNCNORMAL;

    if (pMCVar->iType == MCV_LOGNORMAL)
      pMCVar->iType = MCV_TRUNCLOGNORMAL;

    /*** Fall through !! ***/

    /*-- Get the min and max */

  default:
    GetOptPunct (pibIn, szLex, ',');
    iErr |= ENextLex (pibIn, szLex, LX_NUMBER);
    pMCVar->dMin = atof(szLex);

    GetOptPunct (pibIn, szLex, ',');
    iErr |= ENextLex (pibIn, szLex, LX_NUMBER);
    pMCVar->dMax = atof(szLex);
    break;
  }  /* switch */

  EGetPunct (pibIn, szLex, CH_RPAREN);
  
  /*-- Check for a range error.  If there is a problem, correct it,
       but issue a warning in case this is wrong.
   */
  if (pMCVar->dMax < pMCVar->dMin) { 
    double dTmp = pMCVar->dMax;	/*-- Swap ranges */
    pMCVar->dMax = pMCVar->dMin;
    pMCVar->dMin = dTmp;
    ReportError (pibIn, RE_MAXMIN_RANGE | RE_WARNING, NULL, NULL);
  }  /* if */

    /*-- If there's no error at this point, queue the variation in
         the Monte Carlo record.  If a list hasn't been created yet,
	 initialize it.
     */
  if (!iErr) {
    if (!panal->mc.plistMCVars)
      panal->mc.plistMCVars = InitList();
    QueueListItem (panal->mc.plistMCVars, pMCVar);
  } /* if */
  
Done_GetMCVary:
  ;
  if (iErr) {
    if (pMCVar)
      free (pMCVar);
    if (!bGaveMCVaryUsage) {
      fprintf (stderr,
	       "Syntax: %s (id, distrib-type, [shape parms], dMin, dMax)\n\n"
	       "where  id  is an identifier that is a model parameter\n"
	       "       distrib-type  is one of:\n"
	       "       `Uniform', `LogUniform', `Normal', `LogNormal', or `Beta'\n"
	       "and the \"shape parms\" are mean and variance for Normals, or a and b for Beta.\n"
	       "For Normal types, dMin and dMax are optional, and if given, the normal\n"
	       "distribution is truncated.  For Log distributions, all parameters\n"
	       "are in the untransformed space.\n\n",
	       GetKeyword (KM_MCVARY));
      bGaveMCVaryUsage = TRUE;
    }  /* if */
    
  }  /* if */

Exit_MCVarySpec:
  ;
  return (iErr);
    
}  /* GetMCVarySpec */


/* GetSetPointsSpec
   
   Reads the SetPoints() arguments.  The modification list is kept
   in MCVAR variation records, although this is not really a Monte
   Carlo analysis.  This structure should eventually be changed to
   reflect a more general variation specification.  The optimize
   routines will need to use a similar thing.
*/

int GetSetPointsSpec (PINPUTBUF pibIn, PANALYSIS  panal, PSTR szLex)
{
  PMCVAR pMCVar;
  HVAR hvar;
  int iErr = 0;
  int iNLI;

  /*-- If there is an analysis type specified, don't bother to get this spec.
       Actually it is disasterous to do so in some cases so let's just not,
       so that we don't nuke info.
   */
  if (panal->iType && panal->iType != AT_SETPOINTS) {
    EatStatement (pibIn);
    goto Exit_GetSetPointsSpec;
  }  /* if */
  
  if (ListLength (panal->mc.plistMCVars) > 0) {
    ReportError (pibIn, RE_WARNING | RE_DEFOTHER,
		 "Monte Carlo variations", NULL);
    fprintf (stderr,
	     "** Oops.  If you have MCVary() specs before the SetPoints() spec"
	     "\n   move them all *after* the SetPoints() spec.  Otherwise \n"
	     "   tell Don Maszle @893-2982 to fix this foolish mistake\n");
    exit (-1);
/*  return TRUE;	*/			/* Error?? recoverable? */
  }  /* if */
  
	/*-- Try to get open paren and filenames */

  if (iErr = EGetPunct (pibIn, szLex, CH_LPAREN)
      || GetStringArg (pibIn, &panal->mc.szMCOutfilename, szLex, FALSE)
      || GetStringArg (pibIn, &panal->mc.szSetPointsFilename, szLex, TRUE)
      || GetStringArg (pibIn, &panal->mc.szExtDataFilename, szLex, TRUE))

    goto Exit_GetSetPointsSpec;

  if (!panal->mc.szSetPointsFilename)
    ReportError (pibIn, RE_SPECERR, "No set points file", NULL);

  if (panal->mc.szExtDataFilename)
    ReadExtData (&panal->mc);

	/*-- Try to get number of runs */

  GetOptPunct (pibIn, szLex, ',');
  if (iErr = ENextLex (pibIn, szLex, LX_INTEGER))
    goto Exit_GetSetPointsSpec;
  panal->mc.nRuns = atoi(szLex);

	/* Try to get identifier list */

  GetOptPunct (pibIn, szLex, ',');
  while ((iNLI = NextListItem (pibIn, szLex, LX_IDENTIFIER, 1, CH_RPAREN))
         > 0) {
    hvar = GetVarHandle(szLex);
    if (iErr = (!hvar || IsInput(hvar)))
      break;	 /* Is this reported ? */

    pMCVar = (PMCVAR) malloc (sizeof(MCVAR));
    SET_MCVAR (pMCVar, hvar, MCV_SETPOINTS, 0.0, 0.0);
    if (!panal->mc.plistMCVars)
      panal->mc.plistMCVars = InitList();
    QueueListItem (panal->mc.plistMCVars, pMCVar);
  }  /* while */

  if (!iNLI)					/* List terminator */
    iErr = EGetPunct (pibIn, szLex, CH_RPAREN)
           || ReadSetPointData (&panal->mc);
  else {
    iErr = TRUE;
    ReportError (pibIn, RE_LEXEXPECTED, "identifier", szLex);

  }  /* else */

Exit_GetSetPointsSpec:
  ;
  
  if (iErr)
    fprintf (stderr, "Syntax:\n"
             " %s (szOutputFile, szSetPtsFile, szExtDataFile,"
	     "nRuns, <id-list...>)\n\n", GetKeyword (KM_SETPOINTS));
  else if (!panal->iType)
    panal->iType = AT_SETPOINTS;	/* Flag SetPoints anal if not chosen */

  return (iErr);
}  /* GetSetPointsSpec */




int GetMonteCarloSpec (PINPUTBUF pibIn, PANALYSIS panal, PSTR szLex)
{
#define NMC_ARGS 5 	/* 5 MonteCarlo Args */

static int vrgiMCArgTypes[NMC_ARGS] = {LX_STRING, LX_STRING, LX_INTEGER,
				       LX_NUMBER, LX_INTEGER | LX_IDENTIFIER};

  int iErr = 0;

  /*-- If another type is declared already which is not a Monte Carlo
       type, then ignore this specification.

       This should check for duplicate specs! */
       
  if (panal->iType && panal->iType != AT_MONTECARLO) {
    EatStatement (pibIn);
    goto Exit_GetMonteCarloSpec;
  }  /* if */

  iErr = !GetFuncArgs (pibIn, NMC_ARGS, vrgiMCArgTypes, vrgszlexArgs[0]);

  if (!iErr) {
    if (*vrgszlexArgs[0]) {
      panal->mc.szMCOutfilename = (PSTR) malloc(_strlen(vrgszlexArgs[0]) + 1);
      _strcpy (panal->mc.szMCOutfilename, vrgszlexArgs[0]);
    }  /* if */
				/*-- Otherwise use default output file */

    if (*vrgszlexArgs[1]) {			/* Get Exter Data Filename */
      panal->mc.szExtDataFilename = (PSTR)malloc(_strlen(vrgszlexArgs[1]) + 1);
      _strcpy (panal->mc.szExtDataFilename, vrgszlexArgs[1]);
      ReadExtData (&panal->mc);			/* Read if specified */
    }  /* if */
    else
      panal->mc.szExtDataFilename = NULL;	/* Flag that no file given */

    panal->mc.nRuns = atoi(vrgszlexArgs[2]);
    AnalysisSetSeed (panal, atof(vrgszlexArgs[3]));
    panal->mc.bIndependent = YesNoFromLex (vrgszlexArgs[4]);
  }  /* if */
  else
    fprintf (stderr,
	     "Syntax: %s (szOutfilename, szExtDataFilename, nRuns,"
	     " dSeed, bIndependent [yes | no])\n\n", GetKeyword (KM_MONTECARLO));

  if (!iErr && !panal->iType)
    panal->iType = AT_MONTECARLO;	/* Flag as MC if none chosen yet */

Exit_GetMonteCarloSpec:
  ;
  return (iErr);
}  /* GetMonteCarloSpec */



BOOL GetParmMod (PINPUTBUF pibIn, PSTRLEX szLex, PSTREQN szeqn)
{
  HVAR hvar = GetVarHandle(szLex);
  PANALYSIS panal = (PANALYSIS) pibIn->pInfo;  
  PEXPERIMENT pexp = panal->pexpCurrent;

  PSTRLEX szPunct;
  int  iErr;
  PVARMOD pvarmod;	/* Pointer to the variable modification */
  
  if (iErr = !hvar)
    ReportError (pibIn, RE_LEXEXPECTED, "model-variable", szLex);
  
  else {
	/* Allocate space and initialize modifcation */

    pvarmod = (PVARMOD) malloc (sizeof(VARMODIFICATION));
    pvarmod->hvar = hvar;		/* The variable handle */
  

    if (!GetOptPunct (pibIn, szPunct, '=')) {           /* Try to get '=' */
      iErr = szPunct[1] = '=';
      ReportError (pibIn, RE_EXPECTED, szPunct, NULL);
    }  /* if */

    else if (IsInput (hvar)) {			/* Process INPUT */
      pvarmod->uvar.pifn = (PIFN) malloc (sizeof(IFN));
      iErr = !pvarmod->uvar.pifn
	     || !GetInputFn (pibIn, NULL, pvarmod->uvar.pifn);
      if (iErr) {			
	free (pvarmod->uvar.pifn);		/* Cleanup if error */
	pvarmod->uvar.pifn = NULL;
      }  /* if */	
    }  /* if */

    else {					/* PARM, STATE, etc */
      if (!(iErr = ENextLex(pibIn, szLex, LX_NUMBER)))
	pvarmod->uvar.dVal = atof(szLex);
    }  /* else */

    if (!iErr) {			/* No errors, add mod to list */
      QueueListItem (pexp->plistParmMods, pvarmod);
      iErr = GetTerminator (pibIn, szLex);
    }  /* if */
    else				/* Invalid mod, cleanup */
      free (pvarmod);

  }  /* else valid id */

  return ((BOOL) iErr);
}  /* GetParmMod */


/* NewExperiment
   
   creates a new experiment in the analysis and copies global defaults.
*/

void NewExperiment (PANALYSIS panal)
{
  panal->expGlobal.iExp++;	/* Increment number of experiment */

	/* Allocate new experiment and assign list and current pointers */
  
  panal->pexpCurrent = panal->rgpExps[panal->expGlobal.iExp - 1] =
      (PEXPERIMENT) malloc (sizeof(EXPERIMENT));
  if (!panal->pexpCurrent)
    ReportError (NULL, RE_OUTOFMEM | RE_FATAL, "NewExperiment()", NULL);

				/* Copy current global settings */
  memcpy (panal->pexpCurrent, &panal->expGlobal, sizeof(EXPERIMENT));

  panal->pexpCurrent->plistParmMods = InitList();	/* Local mods */
  panal->wContext = CN_EXPERIMENT;
  fprintf (stderr, "Reading experiment %d:\n", panal->expGlobal.iExp);

}  /* NewExperiment */


/* EndExperiment

   cleans up at the end of defining a new experiment section.
*/

BOOL EndExperiment (PINPUTBUF pibIn, PANALYSIS panal)
{
  BOOL bReturn;
  
  bReturn = !ErrorsReported (pibIn);
  
  if (!bReturn) {
    /*-- Experiment had errors.  Cleanup this space and continue.
     */
    ReportError (pibIn, RE_ERRORSINEXP | RE_FATAL,
		 (PSTR) &panal->pexpCurrent->iExp, NULL);
    ClearErrors (pibIn);
    panal->rgpExps[--panal->expGlobal.iExp] = NULL;
    free (panal->pexpCurrent);
  }  /* if */

  else {
    /*-- Create space for outputs
     */
    PrepareOutSpec (panal->pexpCurrent);    
  }  /* else */

  /*-- Reset current exp to global context. */
  
  panal->pexpCurrent = &panal->expGlobal;
  panal->wContext = CN_GLOBAL;

  return (bReturn);
}  /* EndExperiment */



/* ProcessWord
   
   processes the word szLex.

   This is the main loop of the interpreter.  It is a big switch that
   recognizes keywords that are specifications and takes the
   appropriate action.

   If the word szLex is not a keyword, ProcessWord() attempts to
   define a parameter specification.
*/

void ProcessWord (PINPUTBUF pibIn, PSTR szLex, PSTR szEqn)
{
  int iErr = 0;
  int iKWCode, fContext;
  PSTRLEX szPunct;
  PANALYSIS panal;
  
  if (!pibIn || !szLex || !szLex[0] || !szEqn)
    return;

  panal = (PANALYSIS) pibIn->pInfo;

  iKWCode = GetKeywordCode (szLex, &fContext);

assert(panal->wContext != CN_END);

  if (iErr =
        (iKWCode				   /* Is a keyword */
         && !(fContext & panal->wContext)))        /* In invalid context */
    ReportError (pibIn, RE_BADCONTEXT, szLex, NULL);

  else {
    switch (iKWCode) {

      /*-- If a keyword is not found, try to get a parmeter assignment */
      
    default:
      iErr = GetParmMod (pibIn, szLex, szEqn);
      break;

      /*-- Process the following keywords */
      
    case KM_END:
      panal->wContext = CN_END;
      break;
      
    case KM_EXPERIMENT:
      if (!(iErr = EGetPunct (pibIn, szPunct, CH_LBRACE)))
	NewExperiment (panal);
      break;

    case KM_GIBBS:
      iErr = GetGibbsSpec (pibIn, panal->pexpCurrent);
      break;

    case KM_INTEGRATE:
      iErr = GetIntegrate (pibIn, &panal->pexpCurrent->is);
      break;

    case KM_MCVARY:
      iErr = GetMCVarySpec (pibIn, panal, szLex);
      break;
      
    case KM_MONTECARLO:
      iErr = GetMonteCarloSpec (pibIn, panal, szLex);      
      break;

    case KM_OPTIMIZE:
      ReportError (pibIn, RE_FATAL | RE_BADCONTEXT, szLex,
		   "* Not yet implemented");
      iErr++;
      break;
  
    case KM_OUTPUTFILE:
      if (panal->pexpCurrent->os.szOutfilename) {
	ReportError (pibIn, RE_REDEF| RE_WARNING, "OutputFile", "* Ignoring");
	iErr++;
      }  /* if */
      else
	iErr = GetOutputFile (pibIn, szLex, &panal->pexpCurrent->os);
      break;

    case KM_PRINT:
      iErr = GetPrint (pibIn, szLex, &panal->pexpCurrent->os);
      break;

    case KM_SETPOINTS:
      iErr = GetSetPointsSpec (pibIn, panal, szLex);
      break;
      
    case KM_SIMULATE:
      iErr = GetSimulate (pibIn, panal->pexpCurrent);
      break;

    case KM_SIMTYPE:
      iErr = GetSimType (pibIn);
      break;
    }  /* switch */
  }  /* else */

  if (iErr)
    EatStatement (pibIn);

}  /* ProcessWord */





BOOL ReadAnalysis (PINPUTBUF pibIn)
{
  PSTRLEX  szLex;	/* Lex elem of MAX_LEX length */
  PSTREQN  szEqn;	/* Equation buffer of MAX_EQN length */
  int	   iLexType;

  BOOL	   bReturn = TRUE;
  PANALYSIS panal;
  
  if (!pibIn)
    return (FALSE);

  panal = (PANALYSIS) pibIn->pInfo;

  do {
					/* State machine for parsing syntax */
    NextLex (pibIn, szLex, &iLexType);
    switch (iLexType) {

      case LX_NULL:
	if (panal->wContext != CN_GLOBAL)
	  ReportError (pibIn, RE_WARNING, NULL, "Unexpected end of file");

	if (panal->wContext == CN_EXPERIMENT)
	  bReturn &= EndExperiment (pibIn, panal);
	panal->wContext = CN_END;
	break;

      case LX_IDENTIFIER:
	ProcessWord (pibIn, szLex, szEqn);
	break;
	
      case LX_PUNCT:
	if (szLex[0] == CH_STMTTERM)
	  break;

	else if (szLex[0] == CH_RBRACE && (panal->wContext & CN_EXPERIMENT)) {
	  bReturn &= EndExperiment (pibIn, panal);
	  break;
	}  /* if */

	else if (szLex[0] == CH_COMMENT) {
	  SkipComment (pibIn);
	  break;
	}  /* if */

		/* else -- fall through! */
	
      default:
	ReportError (pibIn, RE_UNEXPECTED, szLex, "* Ignoring");
	break;
	
      case LX_INTEGER:
      case LX_FLOAT:
	ReportError (pibIn, RE_UNEXPNUMBER, szLex, "* Ignoring");
	break;	
	
    }  /* switch */
    
  } while (panal->wContext != CN_END
           && (*pibIn->pbufCur || FillBuffer (pibIn) != EOF));

  return (bReturn);
}  /* ReadAnalysis */


