home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / plbin.zip / pl / src / pl-bag.c < prev    next >
C/C++ Source or Header  |  1992-05-26  |  3KB  |  127 lines
  1. /*  pl-bag.c,v 1.1.1.1 1992/05/26 11:52:15 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: Support predicates for bagof
  8. */
  9.  
  10. #include "pl-incl.h"
  11.  
  12. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  13. This module defines support  predicates  for  the  Prolog  all-solutions
  14. predicates findall/3, bagof/3 and setof/3.  These predicates are:
  15.  
  16.     $record_bag(Key, Value)        Record a value under a key.
  17.         $collect_bag(Bindings, Values)    Retract all Solutions matching
  18.                     Bindings.
  19.  
  20. The (toplevel) remainder of the all-solutions predicates is  written  in
  21. Prolog.
  22. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  23.  
  24. typedef struct assoc * Assoc;
  25.  
  26. struct assoc
  27. { Record    key;            /* key binding */
  28.   Record    value;            /* generator binding */
  29.   Assoc        next;            /* next in chain */
  30. };
  31.  
  32. Assoc bags = (Assoc) NULL;        /* chain of value pairs */
  33.  
  34. forwards word appendBag P((word, word));
  35. forwards void freeAssoc P((Assoc, Assoc));
  36.  
  37. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  38. $record_bag(Key, Value)
  39.  
  40. Record a solution of bagof.  Key is a term  v(V0,  ...Vn),  holding  the
  41. variable biding for solution `Gen'.  Key is ATOM_mark for the mark.
  42. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  43.  
  44. word
  45. pl_record_bag(key, value)
  46. register Word key, value;
  47. { register Assoc a = (Assoc) allocHeap(sizeof(struct assoc));
  48.  
  49.   a->next  = bags;
  50.   bags = a;
  51.   a->key   = copyTermToHeap(key);
  52.   a->value = copyTermToHeap(value);
  53.  
  54.   succeed;
  55. }
  56.  
  57. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  58. This predicate will fail if no more records are left before the mark.
  59. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  60.  
  61. word
  62. pl_collect_bag(bindings, bag)
  63. Word bindings, bag;
  64. { word var_term;            /* v() term on global stack */
  65.   word list = (word) ATOM_nil;        /* result list */
  66.   register Assoc a, next;
  67.   Assoc prev = (Assoc) NULL;
  68.   
  69.   if ( (a = bags) == (Assoc) NULL )
  70.     fail;
  71.   if ( !a || a->key->term == (word) ATOM_mark )
  72.   { freeAssoc(prev, a);
  73.     fail;                /* trapped the mark */
  74.   }
  75.  
  76.   var_term = copyTermToGlobal(a->key);    /* get variable term on global stack */
  77.   list = appendBag(list, copyTermToGlobal(a->value));
  78.  
  79.   next = a->next;
  80.   freeAssoc(prev, a);  
  81.  
  82.   if ( next != (Assoc) NULL )
  83.   { for( a = next, next = a->next; next; a = next, next = a->next )
  84.     { if ( a->key->term == (word) ATOM_mark )
  85.     break;
  86.       if ( pl_structural_equal(&var_term, &a->key->term) == FALSE )
  87.       { prev = a;
  88.     continue;
  89.       }
  90.  
  91.       list = appendBag(list, copyTermToGlobal(a->value));
  92.       freeAssoc(prev, a);
  93.     }
  94.   }
  95.  
  96.   TRY( pl_unify(bindings, &var_term) );
  97.  
  98.   return pl_unify(bag, &list);
  99. }
  100.  
  101.  
  102. static
  103. void
  104. freeAssoc(prev, a)
  105. Assoc prev, a;
  106. { if ( prev == NULL )
  107.     bags = a->next;
  108.   else
  109.     prev->next = a->next;
  110.   freeRecord(a->key);
  111.   freeRecord(a->value);
  112.   freeHeap(a, sizeof(struct assoc));
  113. }
  114.  
  115.  
  116. static word
  117. appendBag(bag, term)
  118. register word bag;
  119. register word term;
  120. { register word result = globalFunctor(FUNCTOR_dot2);
  121.  
  122.   argTerm(result, 0) = term;
  123.   argTerm(result, 1) = bag;
  124.  
  125.   return result;
  126. }
  127.