emathfun.c

NASA 开发使用的一个专家系统

   if (SingleNumberCheck("sech",&num) == CLIPS_FALSE) return(0.0);
   return(1.0 / cosh(num));
  }

/**************************************/
/* CschFunction: CLIPS access routine */
/*   for the csch function.           */
/**************************************/
globle double CschFunction()
  {
   double num;

   if (SingleNumberCheck("csch",&num) == CLIPS_FALSE) return(0.0);
   if (num == 0.0)
     {
      SingularityErrorMessage("csch");
      return(0.0);
     }
   else if (TestProximity(num,1e-25) == CLIPS_TRUE)
     {
      ArgumentOverflowErrorMessage("csch");
      return(0.0);
     }
   return(1.0 / sinh(num));
  }

/**************************************/
/* CothFunction: CLIPS access routine */
/*   for the coth function.           */
/**************************************/
globle double CothFunction()
  {
   double num;

   if (SingleNumberCheck("coth",&num) == CLIPS_FALSE) return(0.0);
   if (num == 0.0)
     {
      SingularityErrorMessage("coth");
      return(0.0);
     }
   else if (TestProximity(num,1e-25) == CLIPS_TRUE)
     {
      ArgumentOverflowErrorMessage("coth");
      return(0.0);
     }
   return(1.0 / tanh(num));
  }

/***************************************/
/* AcoshFunction: CLIPS access routine */
/*   for the acosh function.           */
/***************************************/
globle double AcoshFunction()
  {
   double num;

   if (SingleNumberCheck("acosh",&num) == CLIPS_FALSE) return(0.0);
   if (num < 1.0)
     {
      DomainErrorMessage("acosh");
      return(0.0);
     }
   return(genacosh(num));
  }

/***************************************/
/* AsinhFunction: CLIPS access routine */
/*   for the asinh function.           */
/***************************************/
globle double AsinhFunction()
  {
   double num;

   if (SingleNumberCheck("asinh",&num) == CLIPS_FALSE) return(0.0);
   return(genasinh(num));
  }

/***************************************/
/* AtanhFunction: CLIPS access routine */
/*   for the atanh function.           */
/***************************************/
globle double AtanhFunction()
  {
   double num;

   if (SingleNumberCheck("atanh",&num) == CLIPS_FALSE) return(0.0);
   if ((num >= 1.0) || (num <= -1.0))
     {
      DomainErrorMessage("atanh");
      return(0.0);
     }
   return(genatanh(num));
  }

/***************************************/
/* AsechFunction: CLIPS access routine */
/*   for the asech function.           */
/***************************************/
globle double AsechFunction()
  {
   double num;

   if (SingleNumberCheck("asech",&num) == CLIPS_FALSE) return(0.0);
   if ((num > 1.0) || (num <= 0.0))
     {
      DomainErrorMessage("asech");
      return(0.0);
     }
   return(genasech(num));
  }

/***************************************/
/* AcschFunction: CLIPS access routine */
/*   for the acsch function.           */
/***************************************/
globle double AcschFunction()
  {
   double num;

   if (SingleNumberCheck("acsch",&num) == CLIPS_FALSE) return(0.0);
   if (num == 0.0)
     {
      DomainErrorMessage("acsch");
      return(0.0);
     }
   return(genacsch(num));
  }

/***************************************/
/* AcothFunction: CLIPS access routine */
/*   for the acoth function.           */
/***************************************/
globle double AcothFunction()
  {
   double num;

   if (SingleNumberCheck("acoth",&num) == CLIPS_FALSE) return(0.0);
   if ((num <= 1.0) && (num >= -1.0))
     {
      DomainErrorMessage("acoth");
      return(0.0);
     }
   return(genacoth(num));
  }

/*************************************/
/* ExpFunction: CLIPS access routine */
/*   for the exp function.           */
/*************************************/
globle double ExpFunction()
  {
   double num;

   if (SingleNumberCheck("exp",&num) == CLIPS_FALSE) return(0.0);
   return(exp(num));
  }

/*************************************/
/* LogFunction: CLIPS access routine */
/*   for the log function.           */
/*************************************/
globle double LogFunction()
  {
   double num;

   if (SingleNumberCheck("log",&num) == CLIPS_FALSE) return(0.0);
   if (num < 0.0)
     {
      DomainErrorMessage("log");
      return(0.0);
     }
   else if (num == 0.0)
     {
      ArgumentOverflowErrorMessage("log");
      return(0.0);
     }

   return(log(num));
  }

/***************************************/
/* Log10Function: CLIPS access routine */
/*   for the log10 function.           */
/***************************************/
globle double Log10Function()
  {
   double num;

   if (SingleNumberCheck("log10",&num) == CLIPS_FALSE) return(0.0);
   if (num < 0.0)
     {
      DomainErrorMessage("log10");
      return(0.0);
     }
   else if (num == 0.0)
     {
      ArgumentOverflowErrorMessage("log10");
      return(0.0);
     }

    return(log10(num));
   }

/**************************************/
/* SqrtFunction: CLIPS access routine */
/*   for the sqrt function.           */
/**************************************/
globle double SqrtFunction()
  {
   double num;

   if (SingleNumberCheck("sqrt",&num) == CLIPS_FALSE) return(0.0);
   if (num < 0.00000)
     {
      DomainErrorMessage("sqrt");
      return(0.0);
     }
   return(sqrt(num));
  }

/*************************************/
/* PowFunction: CLIPS access routine */
/*   for the pow function.           */
/*************************************/
globle double PowFunction()
  {
   DATA_OBJECT value1, value2;

   if (ArgCountCheck("**",EXACTLY,2) == -1) return(0.0);

   if (ArgTypeCheck("**",1,FLOAT,&value1) == CLIPS_FALSE) return(0.0);
   if (ArgTypeCheck("**",2,FLOAT,&value2) == CLIPS_FALSE) return(0.0);

    if (((DOToDouble(value1) == 0.0) &&
        (DOToDouble(value2) <= 0.0)) ||
       ((DOToDouble(value1) < 0.0) &&
        (dtrunc((double) DOToDouble(value2)) != DOToDouble(value2))))
     {
      DomainErrorMessage("**");
      SetHaltExecution(CLIPS_TRUE);
      SetEvaluationError(CLIPS_TRUE);
      return(0.0);
     }

   return (pow(DOToDouble(value1),DOToDouble(value2)));
  }

/*************************************/
/* ModFunction: CLIPS access routine */
/*   for the mod function.           */
/*************************************/
globle VOID ModFunction(result)
  DATA_OBJECT_PTR result;
  {
   DATA_OBJECT item1, item2;
   double fnum1, fnum2;
   long lnum1, lnum2;

   if (ArgCountCheck("mod",EXACTLY,2) == -1)
     {
      result->type = INTEGER;
      result->value = (VOID *) AddLong(0L);
      return;
     }

   if (ArgTypeCheck("mod",1,INTEGER_OR_FLOAT,&item1) == CLIPS_FALSE)
     {
      result->type = INTEGER;
      result->value = (VOID *) AddLong(0L);
      return;
     }

   if (ArgTypeCheck("mod",2,INTEGER_OR_FLOAT,&item2) == CLIPS_FALSE)
     {
      result->type = INTEGER;
      result->value = (VOID *) AddLong(0L);
      return;
     }

   if (((item2.type == INTEGER) ? (ValueToLong(item2.value) == 0L) : CLIPS_FALSE) ||
       ((item2.type == FLOAT) ? ValueToDouble(item2.value) == 0.0 : CLIPS_FALSE))
     {
      DivideByZeroErrorMessage("mod");
      SetEvaluationError(CLIPS_TRUE);
      result->type = INTEGER;
      result->value = (VOID *) AddLong(0L);
      return;
     }

   if ((item1.type == FLOAT) || (item2.type == FLOAT))
     {
      fnum1 = CoerceToDouble(item1.type,item1.value);
      fnum2 = CoerceToDouble(item2.type,item2.value);
      result->type = FLOAT;
      result->value = (VOID *) AddDouble(fnum1 - (dtrunc(fnum1 / fnum2) * fnum2));
     }
   else
     {
      lnum1 = DOToLong(item1);
      lnum2 = DOToLong(item2);
      result->type = INTEGER;
      result->value = (VOID *) AddLong(lnum1 - (lnum1 / lnum2) * lnum2);
     }
  }

/************************************/
/* PiFunction: CLIPS access routine */
/*   for the pi function.           */
/************************************/
globle double PiFunction()
  {
   if (ArgCountCheck("pi",EXACTLY,0) == -1) return(acos(-1.0));
   return(acos(-1.0));
  }

/****************************************/
/* DegRadFunction: CLIPS access routine */
/*   for the deg-rad function.          */
/****************************************/
globle double DegRadFunction()
  {
   double num;

   if (SingleNumberCheck("deg-rad",&num) == CLIPS_FALSE) return(0.0);
   return(num * PI / 180.0);
  }

/****************************************/
/* RadDegFunction: CLIPS access routine */
/*   for the rad-deg function.          */
/****************************************/
globle double RadDegFunction()
  {
   double num;

   if (SingleNumberCheck("rad-deg",&num) == CLIPS_FALSE) return(0.0);
   return(num * 180.0 / PI);
  }

/*****************************************/
/* DegGradFunction: CLIPS access routine */
/*   for the deg-grad function.          */
/*****************************************/
globle double DegGradFunction()
  {
   double num;

   if (SingleNumberCheck("deg-grad",&num) == CLIPS_FALSE) return(0.0);
   return(num / 0.9);
  }

/*****************************************/
/* GradDegFunction: CLIPS access routine */
/*   for the grad-deg function.          */
/*****************************************/
globle double GradDegFunction()
  {
   double num;

   if (SingleNumberCheck("grad-deg",&num) == CLIPS_FALSE) return(0.0);
   return(num * 0.9);
  }

/***************************************/
/* RoundFunction: CLIPS access routine */
/*   for the round function.           */
/***************************************/
globle long int RoundFunction()
  {
   DATA_OBJECT result;

   if (ArgCountCheck("round",EXACTLY,1) == -1)
     { return(0L); }

   if (ArgTypeCheck("round",1,INTEGER_OR_FLOAT,&result) == CLIPS_FALSE)
     { return(0L); }

   if (result.type == INTEGER)
     { return(ValueToLong(result.value)); }
   else
     { return((long) ceil(ValueToDouble(result.value) - 0.5)); }
  }

/*******************************************/
/* genacsch: Generic routine for computing */
/*   the hyperbolic arccosine.             */
/*******************************************/
static double genacosh(num)
  double num;
  {
   return(log(num + sqrt(num * num - 1.0)));
  }

/*******************************************/
/* genacsch: Generic routine for computing */
/*   the hyperbolic arcsine.               */
/*******************************************/
static double genasinh(num)
  double num;
  {
   return(log(num + sqrt(num * num + 1.0)));
  }

/*******************************************/
/* genatanh: Generic routine for computing */
/*   the hyperbolic arctangent.            */
/*******************************************/
static double genatanh(num)
  double num;
  {
   return((0.5) * log((1.0 + num) / (1.0 - num)));
  }

/*******************************************/
/* genacsch: Generic routine for computing */
/*   the hyperbolic arcsecant.             */
/*******************************************/
static double genasech(num)
  double num;
  {
   return(log(1.0 / num + sqrt(1.0 / (num * num) - 1.0)));
  }

/*******************************************/
/* genacsch: Generic routine for computing */
/*   the hyperbolic arccosecant.           */
/*******************************************/
static double genacsch(num)
  double num;
  {
   return(log(1.0 / num + sqrt(1.0 / (num * num) + 1.0)));
  }

/*******************************************/
/* genacoth: Generic routine for computing */
/*   the hyperbolic arccotangent.          */
/*******************************************/
static double genacoth(num)
  double num;
  {
   return((0.5) * log((num + 1.0) / (num - 1.0)));
  }

#endif