home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / X_PROLOG.LZH / X_PROLOG / SOURCES / BIDATABA.C < prev    next >
Encoding:
C/C++ Source or Header  |  1990-08-13  |  10.2 KB  |  454 lines
  1. /*
  2.  
  3.  *        X PROLOG  Vers. 2.0
  4.  
  5.  *
  6.  
  7.  *
  8.  
  9.  *    Written by :     Andreas Toenne
  10.  
  11.  *            CS Dept. , IRB
  12.  
  13.  *            University of Dortmund, W-Germany
  14.  
  15.  *            <at@unido.uucp>
  16.  
  17.  *            <....!seismo!unido!at>
  18.  
  19.  *            <at@unido.bitnet>
  20.  
  21.  *
  22.  
  23.  *    Copyright :    This software is copyrighted by Andreas Toenne.
  24.  
  25.  *            Permission is granted hereby to copy the entire
  26.  
  27.  *            package including this copyright notice without fee.
  28.  
  29.  *
  30.  
  31.  */
  32.  
  33.  
  34.  
  35. #include <stdio.h>
  36.  
  37. #include "prolog.h"
  38.  
  39. #include "error.h"
  40.  
  41. #include "extern.h"
  42.  
  43.  
  44.  
  45. extern term *term_proto();        /* terms */
  46.  
  47. extern term *term_copy();        /* terms */
  48.  
  49. extern term *int_proto();        /* terms */
  50.  
  51. extern term *int_copy();        /* terms */
  52.  
  53. extern term *var_proto();        /* terms */
  54.  
  55. extern term *argument();        /* terms */
  56.  
  57. extern term *deref();            /* terms */
  58.  
  59. extern short term_unify();        /* terms */
  60.  
  61. extern clause *make_clause();        /* memory */
  62.  
  63. extern void remove_clause();        /* memory */
  64.  
  65. extern void push_env();            /* memory */
  66.  
  67. extern void push_frame();        /* memory */
  68.  
  69. extern functor *get_functor();        /* functor */
  70.  
  71. extern short bicut();            /* bimeta */
  72.  
  73.  
  74.  
  75. term    *prototype();            /* forward */
  76.  
  77.  
  78.  
  79. short    nvars;                /* variables count */
  80.  
  81.  
  82.  
  83. /*    Primitive for asserting clauses. */
  84.  
  85. /*    Given the head and body of the clause, make a unique prototype */
  86.  
  87. /*    of them and insert them in the right clause list either at */
  88.  
  89. /*    the first or last position. */
  90.  
  91.  
  92.  
  93. short    assert(head, body, first)
  94.  
  95. term *head;
  96.  
  97. term *body;
  98.  
  99. short first;
  100.  
  101. {
  102.  
  103.     register clause *c,*d;
  104.  
  105.     term *h,*b;
  106.  
  107.     
  108.  
  109.     if (FUNC(head)->cp && (ISBUILTIN((clause *)FUNC(head)->cp) ||
  110.  
  111.         ISPROTECTED(FUNC(head))))
  112.  
  113.         return(FALSE);
  114.  
  115.  
  116.  
  117.     /* test, if we reconsult this clause */
  118.  
  119.     if (lastconsult && FUNC(head)->cp && (long)FUNC(head)!=lastconsult)
  120.  
  121.     {
  122.  
  123.         lastconsult = (long)FUNC(head);/* don't reconsult next time */
  124.  
  125.         c = (clause *)FUNC(head)->cp;
  126.  
  127.         FUNC(head)->cp = NULL;
  128.  
  129.         while(c)
  130.  
  131.         {
  132.  
  133.             d = c;
  134.  
  135.             c = c->next;
  136.  
  137.             remove_clause(d);
  138.  
  139.         }
  140.  
  141.     }
  142.  
  143.     
  144.  
  145.     nvars = 0;            /* no vars in lookup table */
  146.  
  147.     h = prototype(head);
  148.  
  149.     b = (body ? prototype(body) : term_proto(TRUEFUNCTOR));
  150.  
  151.     if (c_errno)            /* error in prototype */
  152.  
  153.         return(FALSE);
  154.  
  155.     c = make_clause(0, h, b, nvars);
  156.  
  157.     if (!FUNC(h)->cp || first)    /* insert as first */
  158.  
  159.     {
  160.  
  161.         c->next = (clause *)FUNC(h)->cp;
  162.  
  163.         FUNC(h)->cp = (char *)c;
  164.  
  165.     }
  166.  
  167.     else
  168.  
  169.     {
  170.  
  171.         d = (clause *)FUNC(h)->cp;
  172.  
  173.         while (d->next)
  174.  
  175.             d = d->next;
  176.  
  177.             
  178.  
  179.         c->next = d->next;
  180.  
  181.         d->next = c;
  182.  
  183.     }
  184.  
  185.     return(TRUE);
  186.  
  187. }
  188.  
  189.  
  190.  
  191. /*    Primitive for building unique term prototypes */
  192.  
  193. /*    Uses the global variables l_table und nvars for manageing */
  194.  
  195. /*    variables. */
  196.  
  197.  
  198.  
  199. term *prototype(t)
  200.  
  201. term *t;
  202.  
  203. {
  204.  
  205.     register short i;
  206.  
  207.     register term *p;
  208.  
  209.  
  210.  
  211.     if (ISANONYMOUS(t))
  212.  
  213.     {
  214.  
  215.         p = var_proto(0);
  216.  
  217.         p->flags |= ANOPROTO;        /* special !! */
  218.  
  219.         return(p);
  220.  
  221.     }
  222.  
  223.     
  224.  
  225.     if (ISINT(t))                /* int's are easy */
  226.  
  227.         return(int_proto(VALUE(t)));
  228.  
  229.  
  230.  
  231.     if (ISVAR(t))                /* more tricky */
  232.  
  233.     {
  234.  
  235.         for (i=0; i<nvars; i++)
  236.  
  237.             if (l_table[i].t == t)    /* var found */
  238.  
  239.                 return(var_proto(i));
  240.  
  241.                 
  242.  
  243.         if (++nvars == MAXVARS)        /* to much vars */
  244.  
  245.             BIERROR(ETOOMANY);
  246.  
  247.         l_table[i].t = t;        /* enter variable */
  248.  
  249.         return(var_proto(i));
  250.  
  251.     }
  252.  
  253.     
  254.  
  255.     if (ISSTRUCT(t))            /* compound term */
  256.  
  257.     {
  258.  
  259.         p = term_proto(FUNC(t));    /* make term */
  260.  
  261.         for (i=1; i<=ARITY(t); i++)/* and make arguments */
  262.  
  263.             ARG(p,i) = prototype(argument(t,Topenv,i));
  264.  
  265.         return(p);
  266.  
  267.     }
  268.  
  269.     /* what's this ? */
  270.  
  271.     return(NILATOM);
  272.  
  273. }
  274.  
  275.  
  276.  
  277. /*    ASSERTA ( term )    */
  278.  
  279.  
  280.  
  281. short biasserta(args)
  282.  
  283. term *args[];
  284.  
  285. {
  286.  
  287.     term *head, *body;
  288.  
  289.     
  290.  
  291.     if (FUNC(args[0]) == IFFUNCTOR)
  292.  
  293.     {
  294.  
  295.         head = argument(args[0],Topenv, 1);
  296.  
  297.         body = argument(args[0],Topenv, 2);
  298.  
  299.         if (!ISSTRUCT(head))
  300.  
  301.             BIERROR(EBAD);
  302.  
  303.             
  304.  
  305.         return(assert(head, body, TRUE));
  306.  
  307.     }
  308.  
  309.     if (!ISSTRUCT(args[0]))
  310.  
  311.         BIERROR(EBAD);
  312.  
  313.         
  314.  
  315.     return(assert(args[0], NULL, TRUE));
  316.  
  317. }
  318.  
  319.  
  320.  
  321. /*    ASSERTZ ( term )    */
  322.  
  323.  
  324.  
  325. short biassertz(args)
  326.  
  327. term *args[];
  328.  
  329. {
  330.  
  331.     term *head, *body;
  332.  
  333.     
  334.  
  335.     if (FUNC(args[0]) == IFFUNCTOR)
  336.  
  337.     {
  338.  
  339.         head = argument(args[0],Topenv, 1);
  340.  
  341.         body = argument(args[0],Topenv, 2);
  342.  
  343.         if (!ISSTRUCT(head))
  344.  
  345.             BIERROR(EBAD);
  346.  
  347.             
  348.  
  349.         return(assert(head, body, FALSE));
  350.  
  351.     }
  352.  
  353.     if (!ISSTRUCT(args[0]))
  354.  
  355.         BIERROR(EBAD);
  356.  
  357.         
  358.  
  359.     return(assert(args[0], NULL, FALSE));
  360.  
  361. }
  362.  
  363.  
  364.  
  365. /*    Primitive builtin for finding a matching clause */
  366.  
  367.  
  368.  
  369. short bidollarclause(args)
  370.  
  371. term *args[];
  372.  
  373. {
  374.  
  375.     term *head, *body, *help;
  376.  
  377.     long ttemp;            /* temp trail space */
  378.  
  379.     term *oldtop, *oldnext;        /* old copystack values */
  380.  
  381.     char *oldstack;
  382.  
  383.     env *oldenv;
  384.  
  385.     register clause *c;        /* try */
  386.  
  387.     
  388.  
  389.     head = args[0];
  390.  
  391.     body = args[1];
  392.  
  393.     help = args[2];
  394.  
  395.     
  396.  
  397.     if (FUNC(head)->cp && (ISBUILTIN((clause *)FUNC(head)->cp)
  398.  
  399.                ||  ISHIDDEN(FUNC(head))))
  400.  
  401.     {
  402.  
  403.         bicut();
  404.  
  405.         return(FALSE);
  406.  
  407.     }
  408.  
  409.     
  410.  
  411.     if (ISVAR(help))        /* first try */
  412.  
  413.     {
  414.  
  415.         if (!FUNC(head)->cp)    /* head has no clauses */
  416.  
  417.         {
  418.  
  419.             bicut();    /* cut off backtrack log */
  420.  
  421.             return(FALSE);  /* this is !,fail. */
  422.  
  423.         }
  424.  
  425.         help->flags &= ~VAR;
  426.  
  427.         help->flags |= INT;    /* make a frame integer :-) */
  428.  
  429.         REF(help) = (term *)FUNC(head)->cp;
  430.  
  431.     }
  432.  
  433.     c = (clause *)REF(help);
  434.  
  435.  
  436.  
  437.     /* Build a temporary enviroment to unify head and body with a clause */
  438.  
  439.     oldstack = stacktop;
  440.  
  441.     oldenv = Topenv;
  442.  
  443.     push_env(Topenv, 0L);
  444.  
  445.     push_frame(Topenv, MAXVARS);
  446.  
  447.  
  448.  
  449.     while (c)            /* while more possibilities */
  450.  
  451.     {
  452.  
  453.         ttemp = trailtop;
  454.  
  455.         oldnext = copynext;
  456.  
  457.         oldtop = copytop;    /* save stacks for undoing effects */
  458.  
  459.  
  460.  
  461.         /* Note ! c->body is possibly only a variable */
  462.  
  463.         if (term_unify(head, Preenv, c->head, Topenv) &&
  464.  
  465.             term_unify(body,Preenv,deref(c->body,Topenv),Topenv))
  466.  
  467.         {
  468.  
  469.             Topenv = oldenv;
  470.  
  471.             Preenv = Topenv->pre;
  472.  
  473.             stacktop = oldstack;
  474.  
  475.             REF(help) = (term *)c->next;
  476.  
  477.             return(TRUE);    /* return this one */
  478.  
  479.         }
  480.  
  481.         pop_trails(ttemp);
  482.  
  483.         copynext = oldnext;
  484.  
  485.         copytop = oldtop;    /* undo effects of unify */
  486.  
  487.         c = c->next;        /* try next clause */
  488.  
  489.     }
  490.  
  491.  
  492.  
  493.     /* no more clauses found */
  494.  
  495.     Topenv = oldenv;
  496.  
  497.     Preenv = Topenv->pre;
  498.  
  499.     stacktop = oldstack;
  500.  
  501.     help->flags &= ~INT;
  502.  
  503.     help->flags |= VAR;
  504.  
  505.     REF(help) = FREEVAR;
  506.  
  507.     bicut();
  508.  
  509.     return(FALSE);
  510.  
  511. }
  512.  
  513.  
  514.  
  515. /*    Primitive built in for finding all functors    */
  516.  
  517.  
  518.  
  519. short bidollarfunctor(args)
  520.  
  521. term *args[];
  522.  
  523. {
  524.  
  525.     term *name, *arity;
  526.  
  527.     register term *help;
  528.  
  529.     register functor *f;
  530.  
  531.     long ttemp;
  532.  
  533.     term *oldnext, *oldtop;
  534.  
  535.     
  536.  
  537.     name = args[0];
  538.  
  539.     arity = args[1];
  540.  
  541.     help = args[2];
  542.  
  543.  
  544.  
  545.     if (!ISVAR(name) && !ISATOM(name))
  546.  
  547.         BIERROR(EBAD);
  548.  
  549.     if (!ISVAR(arity) && !ISINT(arity))
  550.  
  551.         BIERROR(EBAD);
  552.  
  553.  
  554.  
  555.     if (ISVAR(help))        /* first try */
  556.  
  557.     {
  558.  
  559.         help->flags &= ~VAR;
  560.  
  561.         help->flags |= INT;
  562.  
  563.         REF(help) = (term *)0;
  564.  
  565.     }
  566.  
  567.     f = (functor *)VALUE(help);    /* next functor for try */
  568.  
  569.     if (!f)                /* first try */
  570.  
  571.         f = (functor *)functorsp;
  572.  
  573.  
  574.  
  575.     ttemp = trailtop;
  576.  
  577.     oldnext = copynext;
  578.  
  579.     oldtop = copytop;        /* save stack values on entry */
  580.  
  581.         
  582.  
  583.     while (f < functornext)        /* until last functor */
  584.  
  585.     {
  586.  
  587.         /* don't show hidden functors */
  588.  
  589.         if (ISHIDDEN(f))
  590.  
  591.             goto fail;
  592.  
  593.             
  594.  
  595.         /* hand coded unify for speed */
  596.  
  597.         if (ISVAR(name))
  598.  
  599.         {
  600.  
  601.             BIND_VAR(name, term_copy(get_functor(f->name,0)));
  602.  
  603.         }
  604.  
  605.         else
  606.  
  607.             if (strcmp(NAME(name), f->name))
  608.  
  609.                 goto fail;
  610.  
  611.         if (ISVAR(arity))
  612.  
  613.         {
  614.  
  615.             BIND_VAR(arity, int_copy((long)f->arity));
  616.  
  617.         }
  618.  
  619.         else
  620.  
  621.             if (VALUE(arity) != f->arity)
  622.  
  623.                 goto fail;
  624.  
  625.         /* success */
  626.  
  627.         VALUE(help) = (long)((long)f+sizeof(functor)+strlen(f->name));
  628.  
  629.         if (VALUE(help) & 0x1)
  630.  
  631.             VALUE(help)++;
  632.  
  633.         return(TRUE);
  634.  
  635.     fail:
  636.  
  637.         pop_trails(ttemp);
  638.  
  639.         copytop = oldtop;
  640.  
  641.         copynext = oldnext;
  642.  
  643.         f = (functor *)((long)f+sizeof(functor)+strlen(f->name));
  644.  
  645.         if ((long)f & 0x1)
  646.  
  647.             f = (functor *)((long)f + 1);
  648.  
  649.     }
  650.  
  651.  
  652.  
  653.     /* no more functors */
  654.  
  655.     bicut();
  656.  
  657.     help->flags &= ~INT;
  658.  
  659.     help->flags |= VAR;
  660.  
  661.     REF(help) = FREEVAR;        /* clear help */
  662.  
  663.     return(FALSE);
  664.  
  665. }
  666.  
  667.  
  668.  
  669. /*    retract( clause ) */
  670.  
  671.  
  672.  
  673. short biretract(args)
  674.  
  675. term *args[];
  676.  
  677. {
  678.  
  679.     term *head, *body;
  680.  
  681.     long ttemp;            /* temp trail space */
  682.  
  683.     term *oldtop, *oldnext;        /* old copystack values */
  684.  
  685.     char *oldstack;
  686.  
  687.     env *oldenv;
  688.  
  689.     register clause *c;        /* try */
  690.  
  691.     clause *x;
  692.  
  693.     
  694.  
  695.     if (! ISSTRUCT(args[0]))
  696.  
  697.         BIERROR(EBAD);
  698.  
  699.  
  700.  
  701.     if (FUNC(args[0]) == IFFUNCTOR)    /* head :- body */
  702.  
  703.     {
  704.  
  705.         head = argument(args[0], Topenv, 1);
  706.  
  707.         body = argument(args[0], Topenv, 2);
  708.  
  709.     }
  710.  
  711.     else
  712.  
  713.     {
  714.  
  715.         head = deref(args[0], Topenv);
  716.  
  717.         body = NULL;
  718.  
  719.     }
  720.  
  721.         
  722.  
  723.     if (FUNC(head)->cp && (ISBUILTIN((clause *)FUNC(head)->cp)
  724.  
  725.                ||  ISPROTECTED(FUNC(head))))
  726.  
  727.         return(FALSE);
  728.  
  729.  
  730.  
  731.     if ((c = (clause *)FUNC(head)->cp) == NULL)    /* no clause  ? */
  732.  
  733.         return(FALSE);
  734.  
  735.  
  736.  
  737.     /* Build a temporary enviroment to unify head and body with a clause */
  738.  
  739.     oldstack = stacktop;
  740.  
  741.     oldenv = Topenv;
  742.  
  743.     push_env(Topenv, 0L);
  744.  
  745.     push_frame(Topenv, MAXVARS);
  746.  
  747.  
  748.  
  749.     x = c;
  750.  
  751.     while (c)            /* while more possibilities */
  752.  
  753.     {
  754.  
  755.         ttemp = trailtop;
  756.  
  757.         oldnext = copynext;
  758.  
  759.         oldtop = copytop;    /* save stacks for undoing effects */
  760.  
  761.  
  762.  
  763.         if ((body && term_unify(head, Preenv, c->head, Topenv) &&
  764.  
  765.             term_unify(body,Preenv, c->body, Topenv)) ||
  766.  
  767.                 term_unify(head, Preenv, c->head, Topenv))
  768.  
  769.         {
  770.  
  771.             stacktop = oldstack;
  772.  
  773.             Topenv = oldenv;
  774.  
  775.             Preenv = Topenv->pre;
  776.  
  777.             if (c == (clause *)FUNC(head)->cp)
  778.  
  779.             {
  780.  
  781.                 FUNC(head)->cp = (char *)c->next;
  782.  
  783.                 remove_clause(c);
  784.  
  785.             }
  786.  
  787.             else
  788.  
  789.             {
  790.  
  791.                 x->next = c->next;
  792.  
  793.                 remove_clause(c);
  794.  
  795.             }
  796.  
  797.             return(TRUE);
  798.  
  799.         }
  800.  
  801.         pop_trails(ttemp);
  802.  
  803.         copynext = oldnext;
  804.  
  805.         copytop = oldtop;    /* undo effects of unify */
  806.  
  807.         x = c;
  808.  
  809.         c = c->next;        /* try next clause */
  810.  
  811.     }
  812.  
  813.  
  814.  
  815.     /* no more clauses found */
  816.  
  817.     stacktop = oldstack;
  818.  
  819.     Topenv = oldenv;
  820.  
  821.     Preenv = Topenv->pre;
  822.  
  823.     return(FALSE);
  824.  
  825. }
  826.  
  827.  
  828.  
  829. /*    ABOLISH ( name, arity )    */
  830.  
  831.  
  832.  
  833. short biabolish(args)
  834.  
  835. term *args[];
  836.  
  837. {
  838.  
  839.     functor *f;
  840.  
  841.     clause *c1,*c2;
  842.  
  843.  
  844.  
  845.     if (!ISATOM(args[0]) || !ISINT(args[1]))
  846.  
  847.         BIERROR(EBAD);
  848.  
  849.         
  850.  
  851.     f = get_functor(NAME(args[0]), (short)VALUE(args[1]));
  852.  
  853.     if (!f->cp)
  854.  
  855.         return(FALSE);
  856.  
  857.     if (ISPROTECTED(f))
  858.  
  859.         return(FALSE);
  860.  
  861.         
  862.  
  863.     c1 = (clause *)f->cp;
  864.  
  865.     f->cp = NULL;
  866.  
  867.     while (c1)
  868.  
  869.     {
  870.  
  871.         c2 = c1;
  872.  
  873.         c1 = c1->next;
  874.  
  875.         remove_clause(c2);
  876.  
  877.     }
  878.  
  879.     return(TRUE);
  880.  
  881. }
  882.  
  883.  
  884.  
  885. /*    $RECONSULTING( true/false ) */
  886.  
  887.  
  888.  
  889. short bireconsulting(args)
  890.  
  891. term *args[];
  892.  
  893. {
  894.  
  895.     if (!ISINT(args[0]))
  896.  
  897.         BIERROR(EBAD);
  898.  
  899.         
  900.  
  901.     lastconsult = VALUE(args[0]);
  902.  
  903.     return(TRUE);
  904.  
  905. }
  906.  
  907.