requires CE for CLIPS

requires.diff

commit 41434dc598adef1b1275966c70eb85a0e9caa5f6
Author: Yurii Rashkovskii <yrashk@gmail.com>
Date:   Sat Jun 17 18:10:44 2023 -0700

    Problem: forward chaining in CLIPS
    
    This makes creating systems that drive for an outcome much more
    difficult as forward chaining is inherently reactive and doesn't tell
    the engine which facts would drive the rules to expected completion.
    
    Solution: prototype `requires` CE that assert `need-FACT` templates
    
    This is far from perfect but allows some initial prototyping to be done.
    The bindings in CEs are replaced with `nil` to allow broad matching.
    
    A potentially much better approach has been suggested here
    https://groups.google.com/g/clipsesg/c/lzyjvZe1EyQ/m/NlTuV-AkBAAJ
    
    But at least for the time being, this helps starting somewhere.

diff --git a/clips/reorder.c b/clips/reorder.c
index d6f70f7..bf1dd00 100644
--- a/clips/reorder.c
+++ b/clips/reorder.c
@@ -142,6 +142,7 @@ struct lhsParseNode *ReorderPatterns(
    newLHS = GetLHSParseNode(theEnv);
    newLHS->pnType = AND_CE_NODE;
    newLHS->right = theLHS;
+   newLHS->requires = theLHS->requires;
 
    /*==============================================================*/
    /* Mark the nodes to indicate which CE they're associated with. */
@@ -491,6 +492,7 @@ static struct lhsParseNode *PerformReorder1(
                tempArg->exists = false;
                tempArg->existsNand = false;
                tempArg->logical = false;
+               tempArg->requires = false;
                tempArg->value = NULL;
                tempArg->expression = NULL;
                tempArg->secondaryExpression = NULL;
@@ -511,6 +513,7 @@ static struct lhsParseNode *PerformReorder1(
                   ((theLHS->pnType == AND_CE_NODE) && (argPtr->pnType == AND_CE_NODE)))
            {
             if (argPtr->logical) theLHS->logical = true;
+            if (argPtr->requires) theLHS->requires = true;
 
             change = true;
             *newChange = true;
@@ -692,6 +695,7 @@ static struct lhsParseNode *PerformReorder2(
             theLHS->existsNand = argPtr->existsNand;
             theLHS->value = argPtr->value;
             theLHS->logical = argPtr->logical;
+            theLHS->requires = argPtr->requires;
             theLHS->right = argPtr->right;
             argPtr->right = NULL;
             argPtr->bottom = NULL;
@@ -872,6 +876,7 @@ static struct lhsParseNode *CompressCEs(
              ((theLHS->pnType == AND_CE_NODE) && (argPtr->pnType == AND_CE_NODE)))
            {
             if (argPtr->logical) theLHS->logical = true;
+            if (argPtr->requires) theLHS->requires = true;
 
             change = true;
             *newChange = true;
@@ -1124,6 +1129,7 @@ void CopyLHSParseNode(
    dest->singleFieldsBefore = src->singleFieldsBefore;
    dest->singleFieldsAfter = src->singleFieldsAfter;
    dest->logical = src->logical;
+   dest->requires = src->requires;
    dest->userCE = src->userCE;
    //dest->marked = src->marked;
    dest->whichCE = src->whichCE;
@@ -1210,6 +1216,7 @@ struct lhsParseNode *GetLHSParseNode(
    newNode->singleFieldsBefore = 0;
    newNode->singleFieldsAfter = 0;
    newNode->logical = false;
+   newNode->requires = false;
    newNode->derivedConstraints = false;
    newNode->userCE = true;
    //newNode->marked = false;
@@ -1581,6 +1588,7 @@ static struct lhsParseNode *AddRemainingInitialPatterns(
          thePattern->beginNandDepth = theLHS->beginNandDepth;
          thePattern->endNandDepth = theLHS->beginNandDepth;
          thePattern->logical = theLHS->logical;
+         thePattern->requires = theLHS->requires;
          thePattern->existsNand = theLHS->existsNand;
          theLHS->existsNand = false;
 
diff --git a/clips/reorder.h b/clips/reorder.h
index 181f20a..c9fc098 100644
--- a/clips/reorder.h
+++ b/clips/reorder.h
@@ -112,6 +112,7 @@ struct lhsParseNode
    unsigned int exists : 1;
    unsigned int existsNand : 1;
    unsigned int logical : 1;
+   unsigned int requires : 1;
    unsigned int multifieldSlot : 1;
    unsigned int bindingVariable : 1;
    unsigned int derivedConstraints : 1;
diff --git a/clips/rulelhs.c b/clips/rulelhs.c
index cb4625b..fb7b3f1 100644
--- a/clips/rulelhs.c
+++ b/clips/rulelhs.c
@@ -74,6 +74,8 @@
    static struct lhsParseNode    *TestPattern(Environment *,const char *,bool *);
    static struct lhsParseNode    *AssignmentParse(Environment *,const char *,CLIPSLexeme *,bool *);
    static void                    TagLHSLogicalNodes(struct lhsParseNode *);
+   static void                    TagLHSRequiresNodes(struct lhsParseNode *);
+
    static struct lhsParseNode    *SimplePatternParse(Environment *,const char *,struct token *,bool *);
    static void                    ParseSalience(Environment *,const char *,const char *,bool *);
    static void                    ParseAutoFocus(Environment *,const char *,bool *);
@@ -555,17 +557,19 @@ static struct lhsParseNode *LHSPattern(
       else if (strcmp(theToken.lexemeValue->contents,"test") == 0)
         { theNode = TestPattern(theEnv,readSource,error); }
 
-      /*============================================*/
-      /* Otherwise check for an *and*, *or*, *not*, */
-      /* *logical*, *exists*, or *forall* CE.       */
-      /*============================================*/
+      /*=============================================*/
+      /* Otherwise check for an *and*, *or*, *not*,  */
+      /* *logical*, *exists*, *requires* or *forall* */
+      /* CE.                                         */
+      /*=============================================*/
 
       else if ((strcmp(theToken.lexemeValue->contents,"and") == 0) ||
                (strcmp(theToken.lexemeValue->contents,"logical") == 0) ||
                (strcmp(theToken.lexemeValue->contents,"not") == 0) ||
                (strcmp(theToken.lexemeValue->contents,"exists") == 0) ||
                (strcmp(theToken.lexemeValue->contents,"forall") == 0) ||
-               (strcmp(theToken.lexemeValue->contents,"or") == 0))
+               (strcmp(theToken.lexemeValue->contents,"or") == 0) ||
+               (strcmp(theToken.lexemeValue->contents,"requires") == 0))
         { theNode = ConnectedPatternParse(theEnv,readSource,&theToken,error); }
 
       /*=================================*/
@@ -655,6 +659,7 @@ static struct lhsParseNode *ConnectedPatternParse(
    struct lhsParseNode *theNode, *tempNode, *theGroup;
    const char *errorCE = NULL;
    bool logical = false;
+   bool requires = false;
    bool tempValue;
 
    /*==========================================================*/
@@ -699,6 +704,13 @@ static struct lhsParseNode *ConnectedPatternParse(
       logical = true;
       PPCRAndIndent(theEnv);
      }
+   else if (strcmp(theToken->lexemeValue->contents,"requires") == 0)
+     {
+      connectorValue = AND_CE_NODE;
+      errorCE = "the requires conditional element";
+      requires = true;
+      PPCRAndIndent(theEnv);
+     }
 
    /*=====================================================*/
    /* The logical CE cannot be contained within a not CE. */
@@ -712,6 +724,18 @@ static struct lhsParseNode *ConnectedPatternParse(
       return NULL;
      }
 
+   /*======================================================*/
+   /* The requires CE cannot be contained within a not CE. */
+   /*======================================================*/
+
+   if (PatternData(theEnv)->WithinNotCE && requires)
+     {
+      PrintErrorID(theEnv,"RULELHS",1,true);
+      WriteString(theEnv,STDERR,"The requires CE cannot be used within a not/exists/forall CE.\n");
+      *error = true;
+      return NULL;
+     }
+
    /*=====================================================*/
    /* Remember if we're currently within a *not* CE and   */
    /* then check to see if we're entering a new *not* CE. */
@@ -755,6 +779,13 @@ static struct lhsParseNode *ConnectedPatternParse(
 
    if (logical) TagLHSLogicalNodes(theGroup);
 
+   /*==========================================================*/
+   /* If we parsed a *requires* CE, then mark the requires flag */
+   /* for all of the CEs contained within the requires CE.      */
+   /*==========================================================*/
+
+   if (requires) TagLHSRequiresNodes(theGroup);
+
    /*=====================================================*/
    /* All the connected CEs must contain at least one CE. */
    /*=====================================================*/
@@ -798,6 +829,7 @@ static struct lhsParseNode *ConnectedPatternParse(
        (theGroup->bottom == NULL))
      {
       theGroup->logical = logical;
+      theGroup->requires = requires;
       return(theGroup);
      }
 
@@ -807,6 +839,7 @@ static struct lhsParseNode *ConnectedPatternParse(
 
    theNode = GetLHSParseNode(theEnv);
    theNode->logical = logical;
+   theNode->requires = requires;
 
    /*======================================================*/
    /* Attach and/or/not CEs directly to the top most node. */
@@ -831,12 +864,14 @@ static struct lhsParseNode *ConnectedPatternParse(
       theNode->right = GetLHSParseNode(theEnv);
       theNode->right->pnType = NOT_CE_NODE;
       theNode->right->logical = logical;
+      theNode->right->requires = requires;
 
       if (theGroup->bottom != NULL)
         {
          theNode->right->right = GetLHSParseNode(theEnv);
          theNode->right->right->pnType = AND_CE_NODE;
          theNode->right->right->logical = logical;
+         theNode->right->right->requires = requires;
          theNode->right->right->right = theGroup;
         }
       else
@@ -858,6 +893,7 @@ static struct lhsParseNode *ConnectedPatternParse(
       theNode->right = GetLHSParseNode(theEnv);
       theNode->right->pnType = AND_CE_NODE;
       theNode->right->logical = logical;
+      theNode->right->requires = requires;
       theNode->right->right = theGroup;
 
       theGroup = tempNode;
@@ -865,6 +901,7 @@ static struct lhsParseNode *ConnectedPatternParse(
       theNode->right->right->bottom = GetLHSParseNode(theEnv);
       theNode->right->right->bottom->pnType = NOT_CE_NODE;
       theNode->right->right->bottom->logical = logical;
+      theNode->right->right->bottom->requires = requires;
 
       tempNode = theNode->right->right->bottom;
 
@@ -875,6 +912,7 @@ static struct lhsParseNode *ConnectedPatternParse(
          tempNode->right = GetLHSParseNode(theEnv);
          tempNode->right->pnType = AND_CE_NODE;
          tempNode->right->logical = logical;
+         tempNode->right->requires = requires;
          tempNode->right->right = theGroup;
         }
      }
@@ -1113,6 +1151,26 @@ static void TagLHSLogicalNodes(
      }
   }
 
+/*************************************************************/
+/* TagLHSRequiresNodes: Marks all *and*, *or*, and *not* CEs */
+/*   contained within a requires CE as having the properties  */
+/*   associated with a requires CE.                          */
+/*****************(*******************************************/
+static void TagLHSRequiresNodes(
+  struct lhsParseNode *nodePtr)
+  {
+   while (nodePtr != NULL)
+     {
+      nodePtr->requires = true;
+      if ((nodePtr->pnType == AND_CE_NODE) ||
+          (nodePtr->pnType == OR_CE_NODE) ||
+          (nodePtr->pnType == NOT_CE_NODE))
+        { TagLHSRequiresNodes(nodePtr->right); }
+      nodePtr = nodePtr->bottom;
+     }
+  }
+
+
 /***********************************************************/
 /* SimplePatternParse: Parses a simple pattern (an opening */
 /*   parenthesis followed by one or more fields followed   */
diff --git a/clips/rulepsr.c b/clips/rulepsr.c
index 08b0f6b..e1b1e1e 100644
--- a/clips/rulepsr.c
+++ b/clips/rulepsr.c
@@ -97,6 +97,10 @@
 #endif
 
 #include "rulepsr.h"
+#include "tmpltpsr.h"
+#include "multifld.h"
+#include "tmpltutl.h"
+#include "cstrnutl.h"
 
 /***************************************/
 /* LOCAL INTERNAL FUNCTION DEFINITIONS */
@@ -290,6 +294,164 @@ bool ParseDefrule(
 
 #if (! RUN_TIME) && (! BLOAD_ONLY)
 
+static void ProcessRequires(Environment *theEnv, struct lhsParseNode *theLHS) {
+  struct lhsParseNode *node = theLHS;
+  if (!node) return;
+  if (node->pnType == PATTERN_CE_NODE && node->requires) {
+    struct lhsParseNode *tplNode = node->right->bottom;
+    const char *deftemplateName = tplNode->lexemeValue->contents;
+    unsigned int count;
+    Deftemplate *template = (Deftemplate *)
+        FindImportedConstruct(theEnv,"deftemplate",NULL,
+                              deftemplateName,&count,
+                              true,NULL);
+    size_t needLen=strlen(deftemplateName) + strlen("need-") +1;
+    char *needName = (char *) malloc(needLen);
+    strcpy(needName, "need-");
+    strlcat(needName, deftemplateName, needLen);
+    Deftemplate *newDeftemplate = FindDeftemplate(theEnv, needName) ;
+    if (newDeftemplate == NULL) {
+      newDeftemplate = get_struct(theEnv,deftemplate);
+      newDeftemplate->header.name = CreateSymbol(theEnv, needName);
+      newDeftemplate->header.ppForm = NULL;
+      newDeftemplate->header.usrData = NULL;
+      newDeftemplate->header.constructType = DEFTEMPLATE;
+      newDeftemplate->header.env = theEnv;
+      newDeftemplate->implied = template->implied;
+      newDeftemplate->numberOfSlots = template->numberOfSlots;
+      newDeftemplate->slotList = NULL;
+      newDeftemplate->inScope = template->inScope;
+      newDeftemplate->patternNetwork = NULL;
+      newDeftemplate->factList = NULL;
+      newDeftemplate->lastFact = NULL;
+      newDeftemplate->busyCount = 0;
+      newDeftemplate->watch = false;
+      newDeftemplate->header.next = NULL;
+
+      newDeftemplate->header.whichModule = template->header.whichModule;
+
+      /* Prepare slots without constraints */
+      struct templateSlot *slotPtr = template->slotList;
+      struct templateSlot *newSlot = NULL;
+      while (slotPtr != NULL)
+      {
+        struct templateSlot *allocatedSlot = get_struct(theEnv,templateSlot);
+        if (newSlot != NULL) {
+          newSlot->next = allocatedSlot;
+        }
+        newSlot = allocatedSlot;
+        newSlot->slotName = slotPtr->slotName;
+        newSlot->defaultList = slotPtr->defaultList;
+        newSlot->facetList = slotPtr->facetList;
+        newSlot->constraints = GetConstraintRecord(theEnv);
+        newSlot->multislot = slotPtr->multislot;
+        newSlot->noDefault = slotPtr->noDefault;
+        newSlot->defaultPresent = slotPtr->defaultPresent;
+        newSlot->defaultDynamic = slotPtr->defaultDynamic;
+        newSlot->next = NULL;
+
+        if (newDeftemplate->slotList == NULL) {
+          newDeftemplate->slotList = newSlot;
+        }
+        slotPtr = slotPtr->next;
+      }
+
+      /* Add the template */
+      AddConstructToModule(&newDeftemplate->header);
+      InstallDeftemplate(theEnv,newDeftemplate);
+    }
+
+    Fact *fact;
+    FactBuilder *factBuilder;
+    FunctionCallBuilder *fcb;
+    CLIPSValue slotNames;
+    if (newDeftemplate->implied) {
+      fact = CreateFact(newDeftemplate);
+      fcb = CreateFunctionCallBuilder(theEnv, 1);
+    } else {
+      factBuilder = CreateFactBuilder(theEnv, needName);
+      DeftemplateSlotNames(newDeftemplate, &slotNames);
+    }
+    free(needName);
+    /* Extract slots */
+    {
+      struct lhsParseNode *pattern = node->right->right;
+      struct lhsParseNode *multifieldHeader = NULL;
+
+      while (pattern != NULL)
+      {
+
+        if (pattern->pnType == MF_WILDCARD_NODE)
+        {
+          multifieldHeader = pattern;
+          pattern = pattern->bottom;
+        }
+
+        if (pattern != NULL)
+        {
+          if ((pattern->pnType == SF_VARIABLE_NODE) ||
+              (pattern->pnType == MF_VARIABLE_NODE) ||
+              ((pattern->pnType == PATTERN_CE_NODE) && (pattern->value != NULL)))
+          {
+            /* Variable */
+            CLIPSValue value = { .lexemeValue = CreateSymbol(theEnv,"nil") };
+            if (newDeftemplate->implied) {
+              FCBAppend(fcb, &value);
+            } else {
+              const char *slotName = GetNthSlot(newDeftemplate, pattern->slotNumber - 1)->slotName->contents;
+              FBPutSlot(factBuilder, slotName, &value);
+            }
+          }
+          else if (pattern->pnType == SF_WILDCARD_NODE)
+          {
+            /* Value */
+            struct lhsParseNode *slot = pattern->bottom;
+            CLIPSValue value = { .value = slot->value};
+            if (newDeftemplate->implied) {
+              FCBAppend(fcb, &value);
+            } else {
+              const char *slotName = GetNthSlot(newDeftemplate, slot->slotNumber - 1)->slotName->contents;
+              FBPutSlot(factBuilder, slotName, &value);
+            }
+          }
+        }
+
+        /*===============================================*/
+        /* Move on to the next field/slot in the pattern */
+        /* or to the next field in a multifield slot.    */
+        /*===============================================*/
+
+        if (pattern == NULL)
+        {
+          pattern = multifieldHeader;
+          multifieldHeader = NULL;
+        }
+        else if ((pattern->right == NULL) && (multifieldHeader != NULL))
+        {
+          pattern = multifieldHeader;
+          multifieldHeader = NULL;
+        }
+
+        pattern = pattern->right;
+      }
+
+
+    }
+    if (newDeftemplate->implied) {
+      CLIPSValue factMultifield;
+      FCBCall(fcb, "create$", &factMultifield);
+      PutFactSlot(fact, NULL, &factMultifield);
+      Assert(fact);
+    } else {
+      FBAssert(factBuilder);
+    }
+
+  } else {
+    ProcessRequires(theEnv, node->right);
+    ProcessRequires(theEnv, node->bottom);
+  }
+}
+
 /**************************************************************/
 /* ProcessRuleLHS: Processes each of the disjuncts of a rule. */
 /**************************************************************/
@@ -438,6 +600,10 @@ static Defrule *ProcessRuleLHS(
          continue;
         }
 
+      if (theLHS->requires) {
+         ProcessRequires(theEnv, theLHS);
+      }
+
       /*=================================*/
       /* Install the disjunct's actions. */
       /*=================================*/