home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / X_PROLOG.LZH / X_PROLOG / SOURCES / BIDATABA.C < prev    next >
C/C++ Source or Header  |  1990-08-13  |  10KB  |  454 lines
  1. /*
  2.  *        X PROLOG  Vers. 2.0
  3.  *
  4.  *
  5.  *    Written by :     Andreas Toenne
  6.  *            CS Dept. , IRB
  7.  *            University of Dortmund, W-Germany
  8.  *            <at@unido.uucp>
  9.  *            <....!seismo!unido!at>
  10.  *            <at@unido.bitnet>
  11.  *
  12.  *    Copyright :    This software is copyrighted by Andreas Toenne.
  13.  *            Permission is granted hereby to copy the entire
  14.  *            package including this copyright notice without fee.
  15.  *
  16.  */
  17.  
  18. #include <stdio.h>
  19. #include "prolog.h"
  20. #include "error.h"
  21. #include "extern.h"
  22.  
  23. extern term *term_proto();        /* terms */
  24. extern term *term_copy();        /* terms */
  25. extern term *int_proto();        /* terms */
  26. extern term *int_copy();        /* terms */
  27. extern term *var_proto();        /* terms */
  28. extern term *argument();        /* terms */
  29. extern term *deref();            /* terms */
  30. extern short term_unify();        /* terms */
  31. extern clause *make_clause();        /* memory */
  32. extern void remove_clause();        /* memory */
  33. extern void push_env();            /* memory */
  34. extern void push_frame();        /* memory */
  35. extern functor *get_functor();        /* functor */
  36. extern short bicut();            /* bimeta */
  37.  
  38. term    *prototype();            /* forward */
  39.  
  40. short    nvars;                /* variables count */
  41.  
  42. /*    Primitive for asserting clauses. */
  43. /*    Given the head and body of the clause, make a unique prototype */
  44. /*    of them and insert them in the right clause list either at */
  45. /*    the first or last position. */
  46.  
  47. short    assert(head, body, first)
  48. term *head;
  49. term *body;
  50. short first;
  51. {
  52.     register clause *c,*d;
  53.     term *h,*b;
  54.     
  55.     if (FUNC(head)->cp && (ISBUILTIN((clause *)FUNC(head)->cp) ||
  56.         ISPROTECTED(FUNC(head))))
  57.         return(FALSE);
  58.  
  59.     /* test, if we reconsult this clause */
  60.     if (lastconsult && FUNC(head)->cp && (long)FUNC(head)!=lastconsult)
  61.     {
  62.         lastconsult = (long)FUNC(head);/* don't reconsult next time */
  63.         c = (clause *)FUNC(head)->cp;
  64.         FUNC(head)->cp = NULL;
  65.         while(c)
  66.         {
  67.             d = c;
  68.             c = c->next;
  69.             remove_clause(d);
  70.         }
  71.     }
  72.     
  73.     nvars = 0;            /* no vars in lookup table */
  74.     h = prototype(head);
  75.     b = (body ? prototype(body) : term_proto(TRUEFUNCTOR));
  76.     if (c_errno)            /* error in prototype */
  77.         return(FALSE);
  78.     c = make_clause(0, h, b, nvars);
  79.     if (!FUNC(h)->cp || first)    /* insert as first */
  80.     {
  81.         c->next = (clause *)FUNC(h)->cp;
  82.         FUNC(h)->cp = (char *)c;
  83.     }
  84.     else
  85.     {
  86.         d = (clause *)FUNC(h)->cp;
  87.         while (d->next)
  88.             d = d->next;
  89.             
  90.         c->next = d->next;
  91.         d->next = c;
  92.     }
  93.     return(TRUE);
  94. }
  95.  
  96. /*    Primitive for building unique term prototypes */
  97. /*    Uses the global variables l_table und nvars for manageing */
  98. /*    variables. */
  99.  
  100. term *prototype(t)
  101. term *t;
  102. {
  103.     register short i;
  104.     register term *p;
  105.  
  106.     if (ISANONYMOUS(t))
  107.     {
  108.         p = var_proto(0);
  109.         p->flags |= ANOPROTO;        /* special !! */
  110.         return(p);
  111.     }
  112.     
  113.     if (ISINT(t))                /* int's are easy */
  114.         return(int_proto(VALUE(t)));
  115.  
  116.     if (ISVAR(t))                /* more tricky */
  117.     {
  118.         for (i=0; i<nvars; i++)
  119.             if (l_table[i].t == t)    /* var found */
  120.                 return(var_proto(i));
  121.                 
  122.         if (++nvars == MAXVARS)        /* to much vars */
  123.             BIERROR(ETOOMANY);
  124.         l_table[i].t = t;        /* enter variable */
  125.         return(var_proto(i));
  126.     }
  127.     
  128.     if (ISSTRUCT(t))            /* compound term */
  129.     {
  130.         p = term_proto(FUNC(t));    /* make term */
  131.         for (i=1; i<=ARITY(t); i++)/* and make arguments */
  132.             ARG(p,i) = prototype(argument(t,Topenv,i));
  133.         return(p);
  134.     }
  135.     /* what's this ? */
  136.     return(NILATOM);
  137. }
  138.  
  139. /*    ASSERTA ( term )    */
  140.  
  141. short biasserta(args)
  142. term *args[];
  143. {
  144.     term *head, *body;
  145.     
  146.     if (FUNC(args[0]) == IFFUNCTOR)
  147.     {
  148.         head = argument(args[0],Topenv, 1);
  149.         body = argument(args[0],Topenv, 2);
  150.         if (!ISSTRUCT(head))
  151.             BIERROR(EBAD);
  152.             
  153.         return(assert(head, body, TRUE));
  154.     }
  155.     if (!ISSTRUCT(args[0]))
  156.         BIERROR(EBAD);
  157.         
  158.     return(assert(args[0], NULL, TRUE));
  159. }
  160.  
  161. /*    ASSERTZ ( term )    */
  162.  
  163. short biassertz(args)
  164. term *args[];
  165. {
  166.     term *head, *body;
  167.     
  168.     if (FUNC(args[0]) == IFFUNCTOR)
  169.     {
  170.         head = argument(args[0],Topenv, 1);
  171.         body = argument(args[0],Topenv, 2);
  172.         if (!ISSTRUCT(head))
  173.             BIERROR(EBAD);
  174.             
  175.         return(assert(head, body, FALSE));
  176.     }
  177.     if (!ISSTRUCT(args[0]))
  178.         BIERROR(EBAD);
  179.         
  180.     return(assert(args[0], NULL, FALSE));
  181. }
  182.  
  183. /*    Primitive builtin for finding a matching clause */
  184.  
  185. short bidollarclause(args)
  186. term *args[];
  187. {
  188.     term *head, *body, *help;
  189.     long ttemp;            /* temp trail space */
  190.     term *oldtop, *oldnext;        /* old copystack values */
  191.     char *oldstack;
  192.     env *oldenv;
  193.     register clause *c;        /* try */
  194.     
  195.     head = args[0];
  196.     body = args[1];
  197.     help = args[2];
  198.     
  199.     if (FUNC(head)->cp && (ISBUILTIN((clause *)FUNC(head)->cp)
  200.                ||  ISHIDDEN(FUNC(head))))
  201.     {
  202.         bicut();
  203.         return(FALSE);
  204.     }
  205.     
  206.     if (ISVAR(help))        /* first try */
  207.     {
  208.         if (!FUNC(head)->cp)    /* head has no clauses */
  209.         {
  210.             bicut();    /* cut off backtrack log */
  211.             return(FALSE);  /* this is !,fail. */
  212.         }
  213.         help->flags &= ~VAR;
  214.         help->flags |= INT;    /* make a frame integer :-) */
  215.         REF(help) = (term *)FUNC(head)->cp;
  216.     }
  217.     c = (clause *)REF(help);
  218.  
  219.     /* Build a temporary enviroment to unify head and body with a clause */
  220.     oldstack = stacktop;
  221.     oldenv = Topenv;
  222.     push_env(Topenv, 0L);
  223.     push_frame(Topenv, MAXVARS);
  224.  
  225.     while (c)            /* while more possibilities */
  226.     {
  227.         ttemp = trailtop;
  228.         oldnext = copynext;
  229.         oldtop = copytop;    /* save stacks for undoing effects */
  230.  
  231.         /* Note ! c->body is possibly only a variable */
  232.         if (term_unify(head, Preenv, c->head, Topenv) &&
  233.             term_unify(body,Preenv,deref(c->body,Topenv),Topenv))
  234.         {
  235.             Topenv = oldenv;
  236.             Preenv = Topenv->pre;
  237.             stacktop = oldstack;
  238.             REF(help) = (term *)c->next;
  239.             return(TRUE);    /* return this one */
  240.         }
  241.         pop_trails(ttemp);
  242.         copynext = oldnext;
  243.         copytop = oldtop;    /* undo effects of unify */
  244.         c = c->next;        /* try next clause */
  245.     }
  246.  
  247.     /* no more clauses found */
  248.     Topenv = oldenv;
  249.     Preenv = Topenv->pre;
  250.     stacktop = oldstack;
  251.     help->flags &= ~INT;
  252.     help->flags |= VAR;
  253.     REF(help) = FREEVAR;
  254.     bicut();
  255.     return(FALSE);
  256. }
  257.  
  258. /*    Primitive built in for finding all functors    */
  259.  
  260. short bidollarfunctor(args)
  261. term *args[];
  262. {
  263.     term *name, *arity;
  264.     register term *help;
  265.     register functor *f;
  266.     long ttemp;
  267.     term *oldnext, *oldtop;
  268.     
  269.     name = args[0];
  270.     arity = args[1];
  271.     help = args[2];
  272.  
  273.     if (!ISVAR(name) && !ISATOM(name))
  274.         BIERROR(EBAD);
  275.     if (!ISVAR(arity) && !ISINT(arity))
  276.         BIERROR(EBAD);
  277.  
  278.     if (ISVAR(help))        /* first try */
  279.     {
  280.         help->flags &= ~VAR;
  281.         help->flags |= INT;
  282.         REF(help) = (term *)0;
  283.     }
  284.     f = (functor *)VALUE(help);    /* next functor for try */
  285.     if (!f)                /* first try */
  286.         f = (functor *)functorsp;
  287.  
  288.     ttemp = trailtop;
  289.     oldnext = copynext;
  290.     oldtop = copytop;        /* save stack values on entry */
  291.         
  292.     while (f < functornext)        /* until last functor */
  293.     {
  294.         /* don't show hidden functors */
  295.         if (ISHIDDEN(f))
  296.             goto fail;
  297.             
  298.         /* hand coded unify for speed */
  299.         if (ISVAR(name))
  300.         {
  301.             BIND_VAR(name, term_copy(get_functor(f->name,0)));
  302.         }
  303.         else
  304.             if (strcmp(NAME(name), f->name))
  305.                 goto fail;
  306.         if (ISVAR(arity))
  307.         {
  308.             BIND_VAR(arity, int_copy((long)f->arity));
  309.         }
  310.         else
  311.             if (VALUE(arity) != f->arity)
  312.                 goto fail;
  313.         /* success */
  314.         VALUE(help) = (long)((long)f+sizeof(functor)+strlen(f->name));
  315.         if (VALUE(help) & 0x1)
  316.             VALUE(help)++;
  317.         return(TRUE);
  318.     fail:
  319.         pop_trails(ttemp);
  320.         copytop = oldtop;
  321.         copynext = oldnext;
  322.         f = (functor *)((long)f+sizeof(functor)+strlen(f->name));
  323.         if ((long)f & 0x1)
  324.             f = (functor *)((long)f + 1);
  325.     }
  326.  
  327.     /* no more functors */
  328.     bicut();
  329.     help->flags &= ~INT;
  330.     help->flags |= VAR;
  331.     REF(help) = FREEVAR;        /* clear help */
  332.     return(FALSE);
  333. }
  334.  
  335. /*    retract( clause ) */
  336.  
  337. short biretract(args)
  338. term *args[];
  339. {
  340.     term *head, *body;
  341.     long ttemp;            /* temp trail space */
  342.     term *oldtop, *oldnext;        /* old copystack values */
  343.     char *oldstack;
  344.     env *oldenv;
  345.     register clause *c;        /* try */
  346.     clause *x;
  347.     
  348.     if (! ISSTRUCT(args[0]))
  349.         BIERROR(EBAD);
  350.  
  351.     if (FUNC(args[0]) == IFFUNCTOR)    /* head :- body */
  352.     {
  353.         head = argument(args[0], Topenv, 1);
  354.         body = argument(args[0], Topenv, 2);
  355.     }
  356.     else
  357.     {
  358.         head = deref(args[0], Topenv);
  359.         body = NULL;
  360.     }
  361.         
  362.     if (FUNC(head)->cp && (ISBUILTIN((clause *)FUNC(head)->cp)
  363.                ||  ISPROTECTED(FUNC(head))))
  364.         return(FALSE);
  365.  
  366.     if ((c = (clause *)FUNC(head)->cp) == NULL)    /* no clause  ? */
  367.         return(FALSE);
  368.  
  369.     /* Build a temporary enviroment to unify head and body with a clause */
  370.     oldstack = stacktop;
  371.     oldenv = Topenv;
  372.     push_env(Topenv, 0L);
  373.     push_frame(Topenv, MAXVARS);
  374.  
  375.     x = c;
  376.     while (c)            /* while more possibilities */
  377.     {
  378.         ttemp = trailtop;
  379.         oldnext = copynext;
  380.         oldtop = copytop;    /* save stacks for undoing effects */
  381.  
  382.         if ((body && term_unify(head, Preenv, c->head, Topenv) &&
  383.             term_unify(body,Preenv, c->body, Topenv)) ||
  384.                 term_unify(head, Preenv, c->head, Topenv))
  385.         {
  386.             stacktop = oldstack;
  387.             Topenv = oldenv;
  388.             Preenv = Topenv->pre;
  389.             if (c == (clause *)FUNC(head)->cp)
  390.             {
  391.                 FUNC(head)->cp = (char *)c->next;
  392.                 remove_clause(c);
  393.             }
  394.             else
  395.             {
  396.                 x->next = c->next;
  397.                 remove_clause(c);
  398.             }
  399.             return(TRUE);
  400.         }
  401.         pop_trails(ttemp);
  402.         copynext = oldnext;
  403.         copytop = oldtop;    /* undo effects of unify */
  404.         x = c;
  405.         c = c->next;        /* try next clause */
  406.     }
  407.  
  408.     /* no more clauses found */
  409.     stacktop = oldstack;
  410.     Topenv = oldenv;
  411.     Preenv = Topenv->pre;
  412.     return(FALSE);
  413. }
  414.  
  415. /*    ABOLISH ( name, arity )    */
  416.  
  417. short biabolish(args)
  418. term *args[];
  419. {
  420.     functor *f;
  421.     clause *c1,*c2;
  422.  
  423.     if (!ISATOM(args[0]) || !ISINT(args[1]))
  424.         BIERROR(EBAD);
  425.         
  426.     f = get_functor(NAME(args[0]), (short)VALUE(args[1]));
  427.     if (!f->cp)
  428.         return(FALSE);
  429.     if (ISPROTECTED(f))
  430.         return(FALSE);
  431.         
  432.     c1 = (clause *)f->cp;
  433.     f->cp = NULL;
  434.     while (c1)
  435.     {
  436.         c2 = c1;
  437.         c1 = c1->next;
  438.         remove_clause(c2);
  439.     }
  440.     return(TRUE);
  441. }
  442.  
  443. /*    $RECONSULTING( true/false ) */
  444.  
  445. short bireconsulting(args)
  446. term *args[];
  447. {
  448.     if (!ISINT(args[0]))
  449.         BIERROR(EBAD);
  450.         
  451.     lastconsult = VALUE(args[0]);
  452.     return(TRUE);
  453. }
  454.