multifun.c

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

  
/***************************************/
/* FirstFunction: CLIPS access routine */
/*   for the first$ function.          */
/***************************************/
globle VOID FirstFunction(returnValue)
  DATA_OBJECT_PTR returnValue;
  {
   DATA_OBJECT theValue;
   struct multifield *theList;

   /*===================================*/
   /* Get the segment to be subdivided. */
   /*===================================*/
   
   if (ArgTypeCheck("first$",1,MULTIFIELD,&theValue) == CLIPS_FALSE)
     {
      SetMultifieldErrorValue(returnValue);
      return;
     }
     
   theList = (struct multifield *) DOToPointer(theValue);

   /*=========================*/
   /* Return the new segment. */
   /*=========================*/

   SetpType(returnValue,MULTIFIELD);
   SetpValue(returnValue,theList);
   if (GetDOEnd(theValue) >= GetDOBegin(theValue))
     { SetpDOEnd(returnValue,GetDOBegin(theValue)); }
   else
     { SetpDOEnd(returnValue,GetDOEnd(theValue)); }
   SetpDOBegin(returnValue,GetDOBegin(theValue));
  }
  
/**************************************/
/* RestFunction: CLIPS access routine */
/*   for the rest$ function.          */
/**************************************/
globle VOID RestFunction(returnValue)
  DATA_OBJECT_PTR returnValue;
  {
   DATA_OBJECT theValue;
   struct multifield *theList;

   /*===================================*/
   /* Get the segment to be subdivided. */
   /*===================================*/
   
   if (ArgTypeCheck("rest$",1,MULTIFIELD,&theValue) == CLIPS_FALSE)
     {
      SetMultifieldErrorValue(returnValue);
      return;
     }
     
   theList = (struct multifield *) DOToPointer(theValue);

   /*=========================*/
   /* Return the new segment. */
   /*=========================*/

   SetpType(returnValue,MULTIFIELD);
   SetpValue(returnValue,theList);
   if (GetDOBegin(theValue) > GetDOEnd(theValue))
     { SetpDOBegin(returnValue,GetDOBegin(theValue)); }
   else
     { SetpDOBegin(returnValue,GetDOBegin(theValue) + 1); }
   SetpDOEnd(returnValue,GetDOEnd(theValue));
  }
  
/*************************************/
/* NthFunction: CLIPS access routine */
/*   for the nth$ function.          */
/*************************************/
globle VOID NthFunction(nth_value)
  DATA_OBJECT_PTR nth_value;
  {
   DATA_OBJECT value1, value2;
   struct multifield *elm_ptr;
   long n; /* 6.04 Bug Fix */

   if (ArgCountCheck("nth$",EXACTLY,2) == -1)
     {
      SetpType(nth_value,SYMBOL);
      SetpValue(nth_value,(VOID *) AddSymbol("nil"));
      return;
     }

   if ((ArgTypeCheck("nth$",1,INTEGER,&value1) == CLIPS_FALSE) ||
       (ArgTypeCheck("nth$",2,MULTIFIELD,&value2) == CLIPS_FALSE))
     {
      SetpType(nth_value,SYMBOL);
      SetpValue(nth_value,(VOID *) AddSymbol("nil"));
      return;
     }

   n = DOToLong(value1); /* 6.04 Bug Fix */
   if ((n > GetDOLength(value2)) || (n < 1))
     {
      SetpType(nth_value,SYMBOL);
      SetpValue(nth_value,(VOID *) AddSymbol("nil"));
      return;
     }

   elm_ptr = (struct multifield *) GetValue(value2);
   SetpType(nth_value,GetMFType(elm_ptr,n + GetDOBegin(value2) - 1));
   SetpValue(nth_value,GetMFValue(elm_ptr,n + GetDOBegin(value2) - 1));
  }

/* ------------------------------------------------------------------
 *    SubsetFunction:
 *               This function compares two multi-field variables
 *               to see if the first is a subset of the second. It
 *               does not consider order.
 *
 *    INPUTS:    Two arguments via CLIPS stack. First is the sublist
 *               multi-field variable, the second is the list to be
 *               compared to. Both should be of type MULTIFIELD.
 *
 *    OUTPUTS:   TRUE if the first list is a subset of the 
 *               second, else FALSE
 *
 *    NOTES:     This function is called from CLIPS with the subset
 *               command. Repeated values in the sublist must also
 *               be repeated in the main list.
 * ------------------------------------------------------------------
 */

globle BOOLEAN SubsetpFunction()
  {
   DATA_OBJECT item1, item2, tmpItem;
   long i,j,k; /* 6.04 Bug Fix */
   /*
   int fiSize;
   long * foundIndices;
   int l,usedficnt;
   */
   if (ArgCountCheck("subsetp",EXACTLY,2) == -1)
     return(CLIPS_FALSE);

   if (ArgTypeCheck("subsetp",1,MULTIFIELD,&item1) == CLIPS_FALSE)
     return(CLIPS_FALSE);

   if (ArgTypeCheck("subsetp",2,MULTIFIELD,&item2) == CLIPS_FALSE)
     return(CLIPS_FALSE);

   if (GetDOLength(item1) == 0) return(CLIPS_TRUE);
   if (GetDOLength(item2) == 0) return(CLIPS_FALSE);
   
   for (i = GetDOBegin(item1) ; i <= GetDOEnd(item1) ; i++)
     {
      SetType(tmpItem,GetMFType((struct multifield *) GetValue(item1),i));
      SetValue(tmpItem,GetMFValue((struct multifield *) GetValue(item1),i));
      if (! FindDOsInSegment(&tmpItem,1,&item2,&j,&k,NULL,0))
        { return(FALSE); }

      /*
      if (FindItemInSegment(GetMFType((struct multifield *) GetValue(item1),i),
                            GetMFValue((struct multifield *) GetValue(item1),i),&item2) == 0)
        { return(FALSE); }
      */
     }
   
   /* Brian's subsetp fix. */
   /*
   fiSize = (int) (sizeof(long) * GetDOLength(item2) * 2);
   foundIndices = (long *) gm2(fiSize);
   for (i = 0 ; i < GetDOLength(item2) * 2 ; i++)
     foundIndices[i] = 0L;
   usedficnt = 0;
   for (i = GetDOBegin(item1) ; i <= GetDOEnd(item1) ; i++)
     {
      SetType(tmpItem,GetMFType((struct multifield *) GetValue(item1),i));
      SetValue(tmpItem,GetMFValue((struct multifield *) GetValue(item1),i));
      if (!FindDOsInSegment(&tmpItem,1,&item2,&j,&k,usedficnt ? foundIndices : NULL,usedficnt))
        {
         rm((VOID *) foundIndices,fiSize);
         return(CLIPS_FALSE);
        }
      for (l = 0 ; l < usedficnt ; l++)
        if ((foundIndices[l*2] == j) &&
            (foundIndices[l*2+1] == k))
          break;
      if (l >= usedficnt)
        {
         foundIndices[l*2] = j;
         foundIndices[l*2+1] = k;
         usedficnt++;
        }
     }
   rm((VOID *) foundIndices,fiSize);
   */
   
   return(CLIPS_TRUE);
  }

/****************************************/
/* MemberFunction: CLIPS access routine */
/*   for the member$ function.          */
/****************************************/
globle VOID MemberFunction(result)
  DATA_OBJECT_PTR result;
  {
   DATA_OBJECT item1, item2;
   long j,k;

   result->type = SYMBOL;
   result->value = CLIPSFalseSymbol;

   if (ArgCountCheck("member$",EXACTLY,2) == -1) return;

   RtnUnknown(1,&item1);

   if (ArgTypeCheck("member$",2,MULTIFIELD,&item2) == CLIPS_FALSE) return;

   if (FindDOsInSegment(&item1,1,&item2,&j,&k,NULL,0))
     {
      if (j == k)
        {
         result->type = INTEGER;
         result->value = (VOID *) AddLong(j);
        }
      else
        {
         result->type = MULTIFIELD;
         result->value = CreateMultifield(2);
         SetMFType(result->value,1,INTEGER);
         SetMFValue(result->value,1,AddLong(j));
         SetMFType(result->value,2,INTEGER);
         SetMFValue(result->value,2,AddLong(k));
         SetpDOBegin(result,1);
         SetpDOEnd(result,2);
        }
     }
  }

/***************************************/
/* FindDOsInSegment:                  */
/***************************************/
/* 6.05 Bug Fix */
static BOOLEAN FindDOsInSegment(searchDOs,scnt,value,si,ei,excludes,epaircnt)
  DATA_OBJECT_PTR searchDOs;
  int scnt;
  DATA_OBJECT_PTR value;
  long  *si,*ei,*excludes;
  int epaircnt;
  {
   long mul_length,slen,i,k; /* 6.04 Bug Fix */
   int j;
   
   mul_length = GetpDOLength(value);
   for (i = 0 ; i < mul_length ; i++)
     {
      for (j = 0 ; j < scnt ; j++)
        {
         if (GetType(searchDOs[j]) == MULTIFIELD)
           {            
            slen = GetDOLength(searchDOs[j]);
            if (MVRangeCheck(i+1L,i+slen,excludes,epaircnt))
              {
               for (k = 0L ; (k < slen) && ((k + i) < mul_length) ; k++)
                 if ((GetMFType(GetValue(searchDOs[j]),k+1L) !=
                      GetMFType(GetpValue(value),k+i+1L)) ||
                     (GetMFValue(GetValue(searchDOs[j]),k+1L) !=
                      GetMFValue(GetpValue(value),k+i+1L)))
                   break;
               if (k >= slen)
                 {
                  *si = i + 1L;
                  *ei = i + slen;
                  return(CLIPS_TRUE);
                 }
              }
           }
         else if ((GetValue(searchDOs[j]) == GetMFValue(GetpValue(value),i + GetpDOBegin(value))) &&
                  (GetType(searchDOs[j]) == GetMFType(GetpValue(value),i + GetpDOBegin(value))) &&
                  MVRangeCheck(i+1L,i+1L,excludes,epaircnt))
           {
            *si = *ei = i+1L;
            return(CLIPS_TRUE);
           }
        }
     }

   return(CLIPS_FALSE);
  }

/******************************************************/
/* MVRangeCheck:  */
/******************************************************/
static BOOLEAN MVRangeCheck(si,ei,elist,epaircnt)
  long si,ei;
  long * elist;
  int epaircnt;
{
  int i;

  if (!elist || !epaircnt)
    return(CLIPS_TRUE);
  for (i = 0 ; i < epaircnt ; i++)
    if (((si >= elist[i*2]) && (si <= elist[i*2+1])) ||
        ((ei >= elist[i*2]) && (ei <= elist[i*2+1])))
    return(CLIPS_FALSE);

  return(CLIPS_TRUE);
}

#if (! BLOAD_ONLY) && (! RUN_TIME)

/******************************************************/
/* MultifieldPrognParser: Parses the progn$ function. */
/******************************************************/
static struct expr *MultifieldPrognParser(top,infile)
  struct expr *top;
  char *infile;
  {
   struct BindInfo *oldBindList,*newBindList,*prev;
   struct token tkn;
   struct expr *tmp;
   SYMBOL_HN *fieldVar = NULL;
   
   SavePPBuffer(" ");
   GetToken(infile,&tkn);
   
   /* ================================
      Simple form: progn$ <mf-exp> ...
      ================================ */
   if (tkn.type != LPAREN)
     {
      top->argList = ParseAtomOrExpression(infile,&tkn);
      if (top->argList == NULL)
        {
         ReturnExpression(top);
         return(NULL);
        }
     }
   else
     {
      GetToken(infile,&tkn);
      if (tkn.type != SF_VARIABLE)
        {
         if (tkn.type != SYMBOL)
           goto MvPrognParseError;
         top->argList = Function2Parse(infile,ValueToString(tkn.value));
         if (top->argList == NULL)
           {
            ReturnExpression(top);
            return(NULL);
           }
        }

      /* =========================================
         Complex form: progn$ (<var> <mf-exp>) ...
         ========================================= */
      else
        {
         fieldVar = (SYMBOL_HN *) tkn.value;
         SavePPBuffer(" ");
         top->argList = ParseAtomOrExpression(infile,NULL);
         if (top->argList == NULL)
           {
            ReturnExpression(top);
            return(NULL);
           }
         GetToken(infile,&tkn);
         if (tkn.type != RPAREN)
           goto MvPrognParseError;
         PPBackup();
         /* PPBackup(); */
         SavePPBuffer(tkn.printForm);
         SavePPBuffer(" ");
        }
     }

   if (CheckArgumentAgainstRestriction(top->argList,(int) 'm'))
     goto MvPrognParseError;
   oldBindList = GetParsedBindNames();
   SetParsedBindNames(NULL);
   IncrementIndentDepth(3);
   BreakContext = CLIPS_TRUE;
   ReturnContext = svContexts->rtn;
   PPCRAndIndent();
   top->argList->nextArg = GroupActions(infile,&tkn,CLIPS_TRUE,NULL);
   DecrementIndentDepth(3);
   PPBackup();
   PPBackup();
   SavePPBuffer(tkn.printForm);
   if (top->argList->nextArg == NULL)
     {
      SetParsedBindNames(oldBindList);
      ReturnExpression(top);
      return(NULL);
     }
   tmp = top->argList->nextArg;
   top->argList->nextArg = tmp->argList;
   tmp->argList = NULL;
   ReturnExpression(tmp);
   newBindList = GetParsedBindNames();
   prev = NULL;
   while (newBindList != NULL)
     {
      if ((fieldVar == NULL) ? CLIPS_FALSE :
          (strcmp(ValueToString(newBindList->name),ValueToString(fieldVar)) == 0))
        {
         ClearParsedBindNames();
         SetParsedBindNames(oldBindList);
         PrintErrorID("MULTIFUN",2,CLIPS_FALSE);
         PrintCLIPS(WERROR,"Cannot rebind field variable in function progn$.\n");
         ReturnExpression(top);
         return(NULL);
        }
      prev = newBindList;
      newBindList = newBindList->next;
     }
   if (prev == NULL)
     SetParsedBindNames(oldBindList);
   else
     prev->next = oldBindList;
   if (fieldVar != NULL)
     ReplaceMvPrognFieldVars(fieldVar,top->argList->nextArg,0);
   return(top);
   
MvPrognParseError:
   SyntaxErrorMessage("progn$");