/*************************************************************************
*                                                                        *
*        TOOLS TO COMPILE AND EVALUATE USER DEFINED FUNCTIONS            *
*           (by their equation - Example "2*sin(x)/x -7*x")              *
*                                                                        *
*              By Alain Reverchon, 1989, France [BIBLI 14]               *
* ---------------------------------------------------------------------- *
*                                                                        *
*            English version adapted to Visual C++ by J-P Moreau, Paris, *
*                                                             june 1997. *
*                                                     (www.jpmoreau.fr)  *
*************************************************************************/
#include "armath.h"      // header to compile a function f(x) or f(t)
                         // with optional use of polymorphe type ar_nombre
                         // (integer, rational p/q or real).
#include <ctype.h> 
#include <malloc.h>


int   ar_glob_dim = 3;

static char  mem_f [2000];
static char  mem_g [2000];     

ar_fonction  ar_glob_f = {mem_f, 2000};
ar_fonction  ar_glob_g = {mem_g, 2000};

double ar_glob_x, ar_glob_y;
double  ar_glob_tab_y [10];


/************************************************************************
* 		          EVALUATE A PREANALYZED FUNCTION   	        *
* --------------------------------------------------------------------- *
* INPUTS : f		: Current pointer to formula to be analyzed     *
* 	    ar_val_var	: Function giving the value of a variable from  *
* 	        	  its number  			                *
* --------------------------------------------------------------------- *
* OUTPUTS : Valeur fn: Double corresponding to value of function.       *
* --------------------------------------------------------------------- *
* EXPLANATION:   The core of this analyze is the RECURSIVE function     *
*  evalue(), with void parameter, AND only two local variables.         *
*  The main variable used by this function is form_cur, current pointer *
*  to the formula to evaluate.      			                *
*  This pointer always goes from left to right in the formula,          *
*  it never goes backward, to improve rapidity.                	        *
*  This is made possible by the form of the analyzed function.          *
************************************************************************/

/****************************************************************
*      LOCAL VARIABLES (TO FUNCTION, BUT DECLARED STATIC)       *
****************************************************************/
double	(*ar_val_fn) (int); // Function value of the variable 
char	*ar_form_cur;       // Current pointer in formula to analyze

static int	i, j;
static double  s;

/*----------------------------------------------------------------------- 
 CAUTION:  The use of global variables in a recursive function allows to
   increase the recursivity deepness for a given stack size, but user must
   be very cautious: After each call to the function, one must not forget
   that every variable might have been modified. 
------------------------------------------------------------------------*/


/***************************************************************
*              MAIN RECURSIVE EVALUATION FUNCTION              *
***************************************************************/
double ar_evalue (void)
{
  double  r;	// these two variables (r and oper) MUST 
  char    oper; // be local ones. 

  switch (*(ar_form_cur++))  {
    //------------------------------------- Case constants
    case 'C' :
      r = * (double *) ar_form_cur;
      ar_form_cur += sizeof (double);
      return (r);

    //-------------------------------------- Case variables
    case 'V' :
      r = (* ar_val_fn) (* (int *) ar_form_cur);
      if (errno) return (0);
      ar_form_cur += sizeof (int);
      return (r);

    //---------------------------- Case binary operations
    case 'B' :
      oper = * (ar_form_cur ++);
      r = ar_evalue (); if (errno) return (0);
      switch (oper)  {
	case '+' : return (r + ar_evalue ());
	case '-' : return (r - ar_evalue ());
	case '*' : return (r * ar_evalue ());
	case '/' : s = ar_evalue ();
		   if (fabs (s) < 1e-20) errno = AR_OUI;
		   if (errno) return (0);
		   return (r / s);
	case '^' : s = ar_evalue (); if (errno) return (0);
		   return (pow (r, s));
	default  : errno = AR_OUI;	// Operation NOT valid
		   return (0);
      }

    //----------------------------- Case unary operations
    case 'U' :
      oper = * (ar_form_cur ++);
      r = ar_evalue (); if (errno) return (0);
      switch (oper)  {
        case FMOINS  : return (- r);
	case FPLUS   : return (r);
	case FABS    : return (fabs (r));
	case FINT    : return (floor (r));
	case FFRAC   : return (r - floor (r));
	case FSQRT   : return (sqrt (r));
	case FEXP    : return (exp (r));
	case FLOG    : return (log (r));
	case FSIN    : return (sin (r));
	case FCOS    : return (cos (r));
	case FTAN    : return (tan (r));
	case FSH     : return (sinh (r));
	case FCH     : return (cosh (r));
	case FTH     : return (tanh (r));
	case FARCSIN : return (asin (r));
	case FARCCOS : return (acos (r));
	case FARCTAN : return (atan (r));
	case FARGSH  : return (log (r + sqrt (1 + r * r)));
	case FARGCH  : return (log (r + sqrt (-1 + r * r)));
	case FARGTH  : return (log ((1 + r) / (1 - r)) / 2);
	case FFACT   : if (fabs (r) < 32)  {
			 for (s=1, i=1; i<=r; i++) s *= i;
	                 return (s);
		       }
        default      : errno = AR_OUI;	  // Operation NOT valid 
		       return (0);
      } /* switch oper */

    //-------------------------------------- Operation NOT valid
    case '\0' : return  (0);
    default   : errno = AR_OUI; return (0);

  } // switch
} // ar_evalue()


/****************************************************************
*		  EVALUATION  CALLING  FUNCTION                         *
****************************************************************/
double ar_evalue_fonction (ar_fonction *f,double (* val) (int))
{
  ar_form_cur = f->debut;
  ar_val_fn   = val;
  return (ar_evalue ());
}

double ar_val_var (int i)
{
  errno = 0;
  switch (i)  {
    case 1  : return (ar_glob_x);
    case 2  : return (ar_glob_y);
    default :
      errno = AR_OUI;
      return (0);
  }
}

double ar_eval_f (double x)
{
  ar_glob_x   = x;
  ar_form_cur = ar_glob_f.debut;
  ar_val_fn   = ar_val_var;
  return (ar_evalue ());
}

double ar_eval_g (double x)
{
  ar_glob_x   = x;
  ar_form_cur = ar_glob_g.debut;
  ar_val_fn   = ar_val_var;
  return (ar_evalue ());
}

double ar_eval_fxy (double x, double y)
{
  ar_glob_x   = x;
  ar_glob_y   = y;
  ar_form_cur = ar_glob_f.debut;
  ar_val_fn   = ar_val_var;
  return (ar_evalue ());
}

double ar_eval_gxy (double x, double y)
{
  ar_glob_x   = x;
  ar_glob_y   = y;
  ar_form_cur = ar_glob_g.debut;
  ar_val_fn   = ar_val_var;
  return (ar_evalue ());
}

double ar_val_tab (int i)
{
  errno = 0;
  if (i == 0) return (ar_glob_x);
  if (i <= ar_glob_dim) return (ar_glob_tab_y [i - 1]);
  else  {
    errno = AR_OUI;
    return (0);
  }
}

double ar_eval_fyi (double x, double *y)
{
  int  i;
  ar_glob_x   = x;
  for (i = 0; i < ar_glob_dim; i++) ar_glob_tab_y [i] = y [i];
  ar_form_cur = ar_glob_f.debut;
  ar_val_fn   = ar_val_tab;
  return (ar_evalue ());
}

/*****************************************************************
* RECURSIVELY PROGRESS TO THE VERY END OF THE FORMULA TO ANALYZE *
*****************************************************************/
static void progresse (void)
{
  switch (*(ar_form_cur++))  {
    case 'C' : ar_form_cur += sizeof (double);            break;
    case 'V' : ar_form_cur += sizeof (int);               break;
    case 'U' : ar_form_cur++; progresse ();               break;
    case 'B' : ar_form_cur++; progresse (); progresse (); break;
    default  : break;
  } /* switch */
} /* progresse () */


/****************************************************************
*	       CALCULATE THE LENGTH OF THE FORMULA	        *
****************************************************************/
unsigned int ar_fonclen (char *f)
{
  ar_form_cur = f;
  progresse ();
  return ((unsigned int) (ar_form_cur - f));
}


/************************************************************************
*	    ANALYZE A USER DEFINED FUNCTION ENTERED AS A STRING         *
* --------------------------------------------------------------------- *
* INPUTS:   *f		: Current pointer to function to be analyzed    *
* 	    lm	        : Maximum length of the formula to analyze      *
* 	    (*isvar) ()	: Function to know if a string is a valid       *
*                         variable                                      * 
* --------------------------------------------------------------------- *
* OUTPUTS: *form_ana: Pointer to the analyzed formula                   *
* 	        lr		: Real length of analyzed function      *
* 	        Value fn: 0 if there is a syntax error                  *
* --------------------------------------------------------------------- *
* EXPLANATION: The core of this analyze is the RECURSIVE function       *
* 	       analyse_chaine(), with only two parameters, a string ch  *
*              and its length lc. The other parameters are global to    *
*              avoid unnecessary use of stack storage.                  *
*	       The function analyse_fonction  does the following tasks: *
*	       - clean formula (spaces, lower case, etc.)               *
*	       - Initialize the global variables (see above)            *
*	       - Call recursive function with the full formula.         *
************************************************************************/

/****************************************************************
*      LOCAL VARIABLES (TO FUNCTION, BUT DECLARED GLOBAL)       *
****************************************************************/
static char	ar_nom_op_unaire [21] [7] =
     {"-", "+",
      "SIN","COS","TAN","ARCSIN","ARCCOS","ARCTAN",
      "SH", "CH", "TH", "ARGSH", "ARGCH", "ARGTH",
      "ABS","INT","FRAC", "FACT", "EXP","LOG","SQRT"};

static int (*isv) (char*, int);	// Function to check if a string is a valid variable 
static unsigned int	lmax;	    // Maximum length of the  formula to ANALYZE 
static char	*f_ana;		        // Analyzed formula (result) 
static unsigned int	ana_cur;    // Current index in ANALYZED formula 
static double r;
static int	  res;
static char   pourcte [30];

// CAUTION: GLOBAL VARIABLES IN A RECURSIVE FUNCTION
//	        SEE REMARK ABOVE 

/****************************************************************
*	         HEADERS OF LOCAL FUNCTIONS  	                *
****************************************************************/
static avance_parentheses (char*, int*);
static ins_unaire         (int);
static recherche          (char*, int, char, char);
static analyse_chaine     (char*, int);

/****************************************************************
*	            AVANCE_PARENTHESES		                *
* ------------------------------------------------------------- *
º   The pointer to the formula points to an opening parenthesis *
º   Move the pointer to the next closing parenthesis or the end *
*   of the string. len indicates in input the max. number of    *
*   chars to examine, in output the number of skipped chars.    *     
****************************************************************/
static avance_parentheses (char *f, int *len)
{
  int  i = 0, np = 0;

  do  {
    switch (*f++)  {
      case '(' : np++; break;
      case ')' : np--; break;
    }
    i++;
  }  while ((np) && (i < *len));

  f--;
  *len = i;
  return (! np);
}


/****************************************************************
*		        INS_UNAIRE                		*
* ------------------------------------------------------------- *
* Write to result formula the detected unary operation. The     *
* result indicates if there was enough room to do so.           *
****************************************************************/
static ins_unaire (int i)
{
  if (ana_cur + 2 >= lmax) return (0);
  f_ana [ana_cur++] = 'U';
  f_ana [ana_cur++] = (char) i;
  return (1);
}


/****************************************************************
*	                 RECHERCHE		                *
* ------------------------------------------------------------- *
* In output:  res indicates if the search was successful or not.*
*             The value <> 0 (yes) indicates that something has *
*   	      been made, so exit is required.                   *
****************************************************************/
static recherche (char *ch, int len, char c1, char c2)
{
  int np, i = len-1;

  do  {
    if (ch [i] == ')')  {
      np = 0;
      do switch (ch [i--])  {
	case '(' : np--; break;
	case ')' : np++; break;
      }	 while ((np) && (i >= 0));
      i++;
      if (np)  {
	res = 0;
	return (1);
      }
    }
    else
      if (((ch [i] == c1) || (ch [i] == c2)) && (i > 0) && (i < len-1))
	switch (ch [i-1])  {
	  case '(': case 'E': case '+': case '-':
	  case '*': case '/': case '^': break;
	  default :
	    if (ana_cur + 2 < lmax)  {
	      f_ana [ana_cur++] = 'B';
	      f_ana [ana_cur++] = ch [i];
	      if (analyse_chaine (&ch [0], i))
		res = analyse_chaine (&ch[i+1], len-i-1);
	      else
		res = 0;
	     }
	     else res = 0;
	     return (1);
	} /* switch ch[i-1] */
  } while (--i >= 0);
  return (0);
}


/****************************************************************
*	  MAIN RECURSIVE FUNCTION TO ANALYZE THE STRING         *
****************************************************************/
static analyse_chaine (char *ch, int lc)
{
  // CAUTION - NO LOCAL VARIABLES - See remarks above.

  //------------------------------------- 1 : Initializations
  if (lc == 0) return (1);

  //------------------------------ 2 : Seek binary operations
  if (recherche (ch, lc, '-', '+')) return (res);
  if (recherche (ch, lc, '/', '*')) return (res);

  //----------------------------------- 3 : Seek unary - and +
  if (ch [0] == '-')  {
    ins_unaire (FMOINS);
    return (analyse_chaine (&ch[1], lc-1));
  }
  if (ch [0] == '+')
    return (analyse_chaine (&ch[1], lc-1));

  //---------------------------------- 4 : Seek power function
  if (recherche (ch, lc, '^', '^')) return (res);

  //------------------------------------- 5 : Seek parentheses
  if (ch [0] == '(')  {
    i = lc;
  if ((avance_parentheses (ch, &i)) && (i == lc))
    return (analyse_chaine (&ch[1], lc-2));
  else
    return (0);
  }

  //---------------------------------------- 6 : Seek factorial
  if (ch [lc - 1] == '!')  {
    ins_unaire (FFACT);
    return (analyse_chaine (&ch[0], lc-1));
  }

  //---------------------------------- 7 : Seek unary functions
  for (i = (int) FSIN; i <= (int) FSQRT; i++)  {
    j = strlen (ar_nom_op_unaire [i]);
    if (strncmp(ar_nom_op_unaire [i], ch, j) == 0)  {
      res = 0;
      if (ch [j] == '(')
	if (ins_unaire (i))
	  res = analyse_chaine (&ch[j], lc-j);
      return (res);
    }
  }

  //------------------------------------------ 8 : Seek unknowns
  i = (*isv)(ch, lc);
  if (i >= 0)  {
    if (ana_cur + 1 + sizeof (int) >= lmax) return (0);
    f_ana [ana_cur++] = 'V';
    memcpy (&f_ana [ana_cur], (char *) &i, sizeof (int));
    ana_cur += sizeof(int);
    return (1);
  }

  //------------------------------------------ 9 : Seek constants
  if (ana_cur + sizeof (double) + 1 >= lmax) return (0);
  i = AR_NON;
  strncpy (pourcte, ch, lc);
  pourcte [lc] = 0;
  if ((i = (strcmp (pourcte, "0") == 0)) == AR_OUI)
    r = 0;
  if (i == AR_NON)
    i = ((r = atof (pourcte)) != 0);
  if (i == AR_NON)
    if ((i = (strcmp (pourcte, "PI") == 0)) == AR_OUI)
      r = AR_PI;
  if (i)  {
    f_ana [ana_cur++] = 'C';
    memcpy (&f_ana [ana_cur], (char *) &r, sizeof (double));
    ana_cur += sizeof (double);
    return (1);
  }

  return (0);	// unknown sign or operator: analyze failed ! ... 

}


/***************************************************************
*	      ANALYZE A FUNCTION: CALLING FUNCTION     	       *
***************************************************************/
int  ar_analyse_fonction (char *f, int lm, int (*isvar)(char *,int), char *form_ana, int *lr)
{
   unsigned int	i, j;
   char *fb;

   //******************* Initialize static global variables 
   isv		= isvar;
   lmax		= lm;
   f_ana	= form_ana;
   ana_cur	= 0;

   //******************* clean formula 
   fb = (char *) malloc (strlen (f));
   if (fb == 0) return (0);
   for (i = 0, j = 0; i < strlen(f); i++)
      if (f[i] != ' ')
         fb [j++] = toupper (f[i]);

   //******************* call recursive function 
   i = analyse_chaine (fb, j);
   *lr = ana_cur;
   free (fb);
   return (i);
}

static int num_var (char *ch, int lc)
{
  if (lc != 1) return (-1);
  switch (ch [0])  {
    case 'X':
    case 'T': return (1);
    case 'Y': return (2);
  }
  return (-1);
}

int ar_anal_fonction (char *cc, ar_fonction *fon)
{
  int lr;
  return (ar_analyse_fonction (cc, fon->maxlen, num_var, fon->debut, &lr));
}

static int num_var_xyi (char *ch, int lc)
{
  int  i;

  if (strncmp (ch, "X", lc) == 0) return (0);
  if (strncmp (ch, "Y", 1) != 0) return (-1);
  if (lc == 1) return (1);
  if ((lc == 2) && (ch [1] > '0') && (ch [1] <= '9'))
    return (ch [1] - '0');
  for (i = 1; i < lc; i++)
    if (ch [i] != '\'') return (-1);
  return (lc);
}

int ar_anal_fonc_xyi (char *cc, ar_fonction *fon)
{
  int lr;
  return (ar_analyse_fonction (cc, fon->maxlen,
	  num_var_xyi, fon->debut, &lr));
}
 

/*************************************************
*          "UNCOMPILE" A FUNCTION                *
* ---------------------------------------------- *
* Input : pointer to an analyzed function        *
* Output: string storing the decompiled function *
*         (with possibility to display it).      *
*************************************************/
static char ar_nom_op [] [7] = {"-", "+",
     "SIN","COS","TAN","ARCSIN","ARCCOS","ARCTAN",
     "SH", "CH", "TH", "ARGSH", "ARGCH", "ARGTH",
     "ABS","INT","FRAC", "FACT", "EXP","LN","SQRT"};

void ar_decompile_fonction (char *f, char *ch)
{
  char  ch1 [255], ch2 [255], *pv;

  switch (f [0])  {
    case 'C' :
      sprintf (ch2, "%30.15lf", * (double *) & f[1]);
      pv = ch2; while (*(pv++) == ' ');  /* Elimine les espaces */
      strcpy (ch, pv - 1);
      pv = ch + strlen (ch);
      while (*(--pv) == '0') *pv = 0;
      if (*pv == '.') *pv = 0;
      break;

    case 'V' :
      strcpy (ch, "X"); break;

    case 'U' :
      ar_decompile_fonction (&f [2], ch1);
      if (strlen (ch1) > 245) return;
      switch (f [1])  {
	case FMOINS :
	  strcpy (ch, "- "); strcat (ch, ch1); break;
	case FPLUS  :
	  strcpy (ch, ch1); break;
	default     :
	  strcpy (ch, ar_nom_op [f [1]]);
	  if (ch1 [0] == '(')  {
	    strcat (ch, " "); strcat (ch, ch1);
	  }
	  else  {
	    strcat (ch, " ("); strcat (ch, ch1);
	    strcat (ch, ")");
	  }
	  break;
     }
     break;

    case 'B' :
      pv = &f [2 + ar_fonclen (&f [2])];
      ar_decompile_fonction (&f [2], ch1);
      ar_decompile_fonction (pv, ch2);
      if (strlen (ch1) + strlen (ch2) > 245) return;
      strcpy (ch, ch1);
      switch (f [1])  {
	    case '+' : strcat (ch, " + "); strcat (ch, ch2); break;
	    case '-' : strcat (ch, " - "); strcat (ch, ch2); break;
	    case '*' : strcat (ch, " * "); strcat (ch, ch2); break;
	    case '/' : strcat (ch, " / "); strcat (ch, ch2); break;
	    case '^' : strcat (ch, " ^ "); strcat (ch, ch2); break;
      }
      strcpy (ch2, "("); strcat (ch2, ch);
      strcat (ch2, ")"); strcpy (ch, ch2);
      break;
  }
}

// end of file fonction.cpp