home *** CD-ROM | disk | FTP | other *** search
/ GEMini Atari / GEMini_Atari_CD-ROM_Walnut_Creek_December_1993.iso / files / language / sbprolog / _et.p < prev    next >
Encoding:
Text File  |  1993-10-23  |  14.1 KB  |  431 lines
  1. /************************************************************************
  2. *                                    *
  3. * The SB-Prolog System                            *
  4. * Copyright SUNY at Stony Brook, 1986; University of Arizona, 1987    *
  5. *                                    *
  6. ************************************************************************/
  7.  
  8. /*-----------------------------------------------------------------
  9. SB-Prolog is distributed in the hope that it will be useful,
  10. but WITHOUT ANY WARRANTY.  No author or distributor
  11. accepts responsibility to anyone for the consequences of using it
  12. or for whether it serves any particular purpose or works at all,
  13. unless he says so in writing.  Refer to the SB-Prolog General Public
  14. License for full details.
  15.  
  16. Everyone is granted permission to copy, modify and redistribute
  17. SB-Prolog, but only under the conditions described in the
  18. SB-Prolog General Public License.   A copy of this license is
  19. supposed to have been given to you along with SB-Prolog so you
  20. can know your rights and responsibilities.  It should be in a
  21. file named COPYING.  Among other things, the copyright notice
  22. and this notice must be preserved on all copies. 
  23. ------------------------------------------------------------------ */
  24. /* $et.P */
  25.  
  26. $et_export([$et/1,$et_noet/1,$et_star/1,$et_points/1,
  27.         $et_remove/1,$et_answers/2,$et_calls/2]).
  28.  
  29. $et_use($glob,[$globalset/1,$gennum/1,$gensym/2]).
  30.  
  31. $et_use($call,[call/1,'_$interp'/2,'_$call'/1]).
  32.  
  33. $et_use($meta,[$functor/3,$univ/2,$length/2]).
  34.  
  35. $et_use($name,[$name/2,$name0/2]).
  36.  
  37. $et_use($bio,[$writename/1,$writeqname/1,$put/1,$nl/0,$tab/1,
  38.     $tell/1,$tell/2,$telling/1,$told/0,$get/1,$get0/1,$see/1,$seeing/1,
  39.     $seen/0]).
  40.  
  41. $et_use($io,[$write/1,$writeq/1,$display/1,$print/1]).
  42.  
  43. $et_use($assert,[$assert/1,$asserti/2,$assert_union/2,$assert_call_s/1,
  44.         $assert_get_prref/2,$assert_put_prref/2,$assert_abolish_i/1]).
  45.  
  46. $et_use($retr,[$retract/1,$abolish/1,_]).
  47.  
  48. $et_use($defint,[$defint_call/4]).
  49.  
  50. $et_use($buff,[$alloc_perm/2,$alloc_heap/2,$trimbuff/3,$buff_code/4,
  51.         $symtype/2,
  52.         $substring/6,$subnumber/6,$subdelim/6,$conlength/2,
  53.         $pred_undefined/1, $hashval/3]).
  54.  
  55. $et_use($bmeta,[$atom/1,$atomic/1,$integer/1,$number/1,$structure/1,
  56.     $functor0/2,$bldstr/3,$arg/3,$arity/2,$real/1,$floor/2]).
  57.  
  58. /***********************  ERROR CHECKING  *******************************/
  59.  
  60. /************************************************************************
  61.  *                    $et_check                    *
  62.  *  This is a general error testing routine for the et module.        *
  63.  *  The flag $et_error is initialized to 0 at the start of the error    *
  64.  *  checking. All elements of the input list are checked. The second    *
  65.  *  parameter Errorcheck is the name of a routine, that is supplied    *
  66.  *  to $et_check that must be satisfied in addition to the general     *
  67.  *  error checking. If an error is encountered the $et_error flag is 1     *
  68.  *  and $et_check will fail.                         *
  69.  ************************************************************************/
  70.  
  71. $et_check(Etlist,Errorcheck) :-
  72.     $globalset($et_error(0)),        /* Assume no error */
  73.     (not($et_unbound(Etlist)) ->
  74.         $et_checkit(Etlist,Errorcheck),!,
  75.         $et_error(0)).            /* Succeeds if no error */
  76.  
  77. /*   NOTE:     $et_checkit ASSUMES that it is never called with     *
  78.  *        an unbound variable as the first argument        */
  79.  
  80. $et_checkit(P/A,Errorcheck) :- 
  81.     ($et_invalid(P/A) ; not($et_check_then_fail(P/A,Errorcheck))),!.
  82. $et_checkit([Pred|More],Errorcheck) :- !,
  83.     ($et_unbound(Pred) ->
  84.         ($et_unbound(More) -> 
  85.         true
  86.         ;
  87.             $et_checkit(More,Errorcheck))
  88.         ;
  89.         $et_checkit(Pred,Errorcheck),
  90.         $et_checkit(More,Errorcheck)).
  91. $et_checkit([],_) :- !.
  92.  
  93. $et_check_then_fail(P/A,Errorcheck) :-
  94.     arg(1,Errorcheck,P/A),
  95.     call(Errorcheck),            
  96.     fail.                    /* Fail to unbind P/A */
  97.  
  98. /************************************************************************
  99.  *                $et_set_check                *
  100.  *  To set an et point, the predicate specified must be defined (either *
  101.  *  via a consult or load), and must not have an et point already.    *
  102.  ************************************************************************/
  103.  
  104. $et_set_check(P/A) :-
  105.     not($et_undefined(P/A)),
  106.     not($et_exists(P/A)).
  107.  
  108. /************************************************************************
  109.  *  The error checking predicates $et_unbound, $et_invalid, $et_exists    *
  110.  *  $et_undefined, $et_exists and $et_notexists succeed and display an     *
  111.  *  error message if the error condition being checked is true. The     *
  112.  *  global $et_error flag is set so that $et_check can determine if it     *
  113.  *  should fail.                            *
  114.  ************************************************************************/
  115.  
  116. $et_unbound(Arg) :-
  117.     var(Arg),
  118.     $globalset($et_error(1)),
  119.     $write('*et* unbound argument '),$write(Arg),$nl.
  120.  
  121. $et_invalid(P/A) :-
  122.     atomic(P),integer(A),!,fail.
  123. $et_invalid(Arg) :-
  124.     $globalset($et_error(1)),
  125.     $write('*et* invalid argument '),$write(Arg),$nl.
  126.  
  127. $et_undefined(P/A) :-
  128.     $functor(Pred,P,A),
  129.     $pred_undefined(Pred),
  130.     $globalset($et_error(1)),
  131.     $write('*et* Undefined predicate: '),
  132.     $write(P),$write('/'),$write(A),$nl.
  133.  
  134. $et_exists(P/A) :-
  135.     not($pred_undefined($et_preds(_))),     /* $et_preds defined */
  136.     $et_preds(P/A),
  137.     $globalset($et_error(1)),
  138.     $write('*et* already defined for: '),
  139.     $write(P),$write('/'),$write(A),$nl.
  140.  
  141. $et_notexists(P/A) :-
  142.     ($pred_undefined($et_preds(_)),!       /* $et_preds defined */
  143.     ;
  144.     not($et_preds(P/A))),
  145.     $globalset($et_error(1)),
  146.     $write('*et* no et point exists for: '),
  147.     $write(P),$write('/'),$write(A),$nl.
  148.  
  149. /**********************  END ERROR CHECKING  *************************/
  150.  
  151. $et(Etlist) :- 
  152.     $globalset('$et_flag'(0)),    /* required for general alg */
  153.     $globalset('_$nofile_msg'(0)),
  154.     $et_check(Etlist,$et_set_check(_)),
  155.     $et_setit(Etlist).
  156.  
  157. $et_setit(P/A) :-
  158.     $et_set(P/A),
  159.     $assert($et_preds(P/A)).
  160. $et_setit([Pred|More]) :-
  161.     $et_setit(Pred),
  162.     $et_setit(More).
  163. $et_setit([]).
  164.  
  165. $et_set(P/A) :- 
  166.     $name(P,Pnamelist),
  167.     $functor(Pred,P,A),
  168.     $name(Codepname,[99,111,100,101,36|Pnamelist]), /* code$p */
  169.     $functor(Code,Codepname,A),
  170.     $et_copfargs(Pred,Code,1,A),
  171.       /* make PRED and code$PRED have identical ep's */
  172.     $buff_code(Code,0,19 /* copy ep */ ,Pred),
  173.         /* define terms required for ET algorithm */
  174.     $functor(Pred1,P,A),
  175.         /* call$ */
  176.     $name(Callpred,[99,97,108,108,36|Pnamelist]),     
  177.     $functor(Call,Callpred,A),
  178.     $et_copfargs(Pred,Call,1,A),
  179.     $functor(Call1,Callpred,A),
  180.     $et_copfargs(Pred1,Call1,1,A),
  181.         /* et$ */
  182.     $name(Etpred,[101,116,36 | Pnamelist]),        
  183.     $functor(Et,Etpred,A),    
  184.     $et_copfargs(Pred,Et,1,A),
  185.     $functor(Et1,Etpred,A),    
  186.     $et_copfargs(Pred1,Et1,1,A),
  187. /*        Set up appropriate call to $et_tat          */
  188.     Etcall = $et_tat(Pred,Pred1,Call,Call1,Et,Et1,Code),
  189. /*  int$PRED(A1,...,An,B) stores arguments in Ai & Etroutine call in B. */
  190.     $name(Intname,[105,110,116,36 | Pnamelist]),    /* int$ */
  191.     A1 is A + 1,
  192.     $functor(Intterm,Intname,A1),
  193.     $et_copfargs(Pred,Intterm,1,A),
  194.     arg(A1,Intterm,Etcall),
  195.     $assert(Intterm),
  196. /*  define PRED(A1,..,An) :- $et_intercept(int$PRED(A1,...,An,B),B). */
  197.     $defint_call(Pred,A,Intterm,$et_intercept(_,_)). 
  198.  
  199. $et_points(List) :-
  200.     findall(P,$et_preds(P),List).
  201.  
  202. $et_noet(Etlist) :- 
  203.     $et_check(Etlist,$et_notexists(_)),
  204.     $et_unsetit(Etlist).
  205.  
  206. $et_unsetit(P/A) :-
  207.     $et_unset(P/A),
  208.     $retract($et_preds(P/A)).
  209. $et_unsetit([Pred|More]) :-
  210.     $et_unsetit(Pred),
  211.     $et_unsetit(More).
  212. $et_unsetit([]).
  213.  
  214. $et_unset(P/A) :-
  215.     $et_removeit(P/A),    /* Use of predicate that ASSUMES no errors */
  216.     $name(P,Pnamelist),
  217.     /* remove int$P fact for predicate  */
  218.     $name(Intname,[105,110,116,36 | Pnamelist]),    /* int$ */
  219.     A1 is A + 1,
  220.     $functor(Intterm,Intname,A1),
  221.     $retract(Intterm),
  222.     /* restore original definition of predicate */
  223.     $name(Codepname,[99,111,100,101,36|Pnamelist]), /* code$p */
  224.     $functor(Code,Codepname,A),
  225.     $functor(Pred,P,A),
  226.     $buff_code(Pred,0,19 /* copy ep */ ,Code).
  227.  
  228. $et_copfargs(Fact,Genclfact,K,Arity) :- 
  229.     K > Arity;
  230.     K =< Arity,
  231.      arg(K,Fact,A),arg(K,Genclfact,A),
  232.      K1 is K+1, $et_copfargs(Fact,Genclfact,K1,Arity).
  233.  
  234. /************************************************************************/
  235. /* et-intercept is the predicate that is called to intercept an et call.*/
  236. /* This is accomplished by the following transformation of the code    */
  237. /*  PRED(A1,..,An) :- $et_intercept(int$PRED(A1,...,An,B),B).        */
  238. /*  int$PRED(A1,...,An,B) stores arguments in Ai & $et_tat call in B.   */
  239. /************************************************************************/
  240.  
  241. $et_intercept(Intpred,Etinterp) :-
  242.     '_$call'(Intpred),
  243.     '_$call'(Etinterp).
  244.  
  245. $et_subsumes(X,Y) :- not(X=Y),!,fail.
  246. $et_subsumes(X,Y) :- $et_numbervars(Y,0,_),not(X=Y),!,fail.
  247. $et_subsumes(_,_).
  248.  
  249. $et_numbervars(Y,I,J) :- var(Y),!,Y='$var'(I),J is I+1.
  250. $et_numbervars(Y,I,J) :- $functor(Y,F,N),$et_numvargs(Y,I,J,0,N).
  251. $et_numvargs(Y,I,I,N,N) :- !.
  252. $et_numvargs(Y,I,J,C,N) :- C1 is C+1, arg(C1,Y,A),$et_numbervars(A,I,I1),
  253.     $et_numvargs(Y,I1,J,C1,N).
  254.  
  255. $et_changed :-
  256.     '$et_flag'(D),
  257.     (D =:= 1;
  258.      D \== 1,$globalset('$et_flag'(1))).
  259.  
  260. /*****************  Complete Extension Table Algorithm  ******************/
  261.  
  262. $et_star(Query) :-
  263.     $globalset('$et_flag'(0)),
  264.     $abolish(et$ANSWER(_)),
  265.     repeat,
  266.         ($et_points(L),        
  267.         $et_rem_calls(L),    /* Use of predicate that ASSUMES no errors */
  268.         call(Query),
  269.         not((not($pred_undefined(et$ANSWER(_))),
  270.          et$ANSWER(Answer),$et_subsumes(Answer,Query))),  
  271.         $assert(et$ANSWER(Query));    /* remove duplicate answers */
  272.         $et_nochange,!,fail).
  273.  
  274. $et_nochange :-
  275.     /* no need to check if '$et_flag' defined since it is 
  276.        always defined for the general algorithm        */
  277.     '$et_flag'(D),
  278.     (D =:= 0 ;
  279.      D \== 0, $globalset('$et_flag'(0)),fail).
  280.  
  281. $et_remove(Etlist) :-
  282.     $et_check(Etlist,$et_notexists(_)),
  283.     $et_removeit(Etlist).
  284.  
  285. $et_removeit(P/A) :-
  286.     /* remove calls and answers */
  287.     $name(P,Pname),
  288.     $name(C,[99,97,108,108,36 | Pname]),    /* call$ */
  289.     $functor(Callpred,C,A),
  290.     $abolish(Callpred),            /* undefine Callpred */
  291.     $name(E,[101,116,36 | Pname]),        /* et$ */
  292.     $functor(Etpred,E,A),
  293.     $abolish(Etpred).
  294. $et_removeit([Pred|More]) :-
  295.     $et_removeit(Pred),
  296.     $et_removeit(More).
  297. $et_removeit([]).
  298.  
  299. $et_remove_calls(Etlist) :-
  300.     $et_check(Etlist,$et_notexists(_)),
  301.     $et_rem_calls(Etlist).
  302.  
  303. $et_rem_calls(P/A) :-
  304.     $name(P,Pname),
  305.     $name(C,[99,97,108,108,36 | Pname]),    /* call$ */
  306.     $functor(Callpred,C,A),
  307.     $abolish(Callpred).
  308. $et_rem_calls([Pred|More]) :-
  309.     $et_rem_calls(Pred),
  310.     $et_rem_calls(More).
  311. $et_rem_calls([]).
  312.  
  313. $et_remove_answers(Etlist) :-
  314.     $et_check(Etlist,$et_notexists(_)),
  315.     $et_rem_answers(Etlist).
  316.  
  317. $et_rem_answers(P/A) :-
  318.     $name(P,Pname),
  319.     $name(E,[101,116,36 | Pname]),        /* et$ */
  320.     $functor(Etpred,E,A),
  321.     $abolish(Etpred).
  322. $et_rem_answers([Pred|More]) :-
  323.     $et_rem_answers(Pred),
  324.     $et_rem_answers(More).
  325. $et_rem_answers([]).
  326.  
  327. /*  Retrieves answers from the extension table for a predicate. */
  328. $et_answers(Arg,Pred) :-
  329.     not($et_unbound(Arg)),
  330.     not($et_invalid(Arg)),
  331.     not($et_notexists(Arg)),
  332.     Arg = P/A,
  333.     $name(P,Pname),
  334.     $functor(Pred,P,A),
  335.     Pred =.. [P | Args],
  336.     $name(E,[101,116,36 | Pname]),            /* et$ */
  337.     Etpred =.. [E | Args],
  338.     not($pred_undefined(Etpred)),
  339.     '_$call'(Etpred).
  340.  
  341. /*    Retrieves calls from the et for a predicate.         */
  342. $et_calls(Arg,Pred) :-
  343.     not($et_unbound(Arg)),
  344.     not($et_invalid(Arg)),
  345.     not($et_notexists(Arg)),
  346.     Arg = P/A,
  347.     $name(P,Pname),
  348.     $functor(Pred,P,A),
  349.     Pred =.. [P | Args],
  350.     $name(C,[99,97,108,108,36 | Pname]),        /* call$ */
  351.     Callpred =.. [C | Args],
  352.     not($pred_undefined(Callpred)),
  353.     '_$call'(Callpred).
  354.  
  355. /************************************************************************
  356.  *            ET tuple-at-a-time                *
  357.  *     for     Predterm = p(X,Y),                    *
  358.  *        Predterm1 = p(X1,Y1),                    *
  359.  *        Callterm = call$p(X,Y),                    *
  360.  *        Callterm1 = call$p(X1,Y1),                *
  361.  *        Etterm = et$p(X,Y),                    *
  362.  *        Etterm1 = et$p(X1,Y1),                    *
  363.  *           Codeterm = code$p(X,Y),                    *
  364.  *       generate code for:                        *
  365.  *        ( call$p(X1,Y1),                    *
  366.  *          subsumes(p(X1,Y1),p(X,Y)),!,                *
  367.  *          et$p(X,Y);                        *
  368.  *          assert(call$p(X,Y)),                     *
  369.  *           (et$p(X,Y);                        *
  370.  *          code$p(X,Y),                        *
  371.  *          not(et$p(X1,Y1),subsumes(p(X1,Y1),p(X,Y))),        *
  372.  *          et_changed,                        *
  373.  *          assert(et$p(X,Y)) ) ).                *
  374.  ************************************************************************/
  375.  
  376. $et_tat(Predterm,Predterm1,Callterm,Callterm1,Etterm,Etterm1,Codeterm) :-
  377.       ( '_$call'(Callterm1),$et_subsumes(Predterm1,Predterm),!,
  378.     $assert_call_s(Etterm);        
  379.     $assert(Callterm),
  380.     ($assert_call_s(Etterm);
  381.     call(Codeterm),
  382.     not(('_$call'(Etterm1),$et_subsumes(Predterm1,Predterm))),
  383.     $et_changed,            /* for use in ET* algorithm    */
  384.     $assert(Etterm) )).
  385.  
  386. /* ------------------------------ $et.P ------------------------------ */
  387.  
  388.  
  389. /*
  390. -----------------------------DISCLAIMER----------------------------------
  391. Beware:    
  392.     Using impure code with the ET algorithm can be dangerous to your health. 
  393.  
  394. Since the ET saves answers which are not instances of that already in the
  395. table and uses these answers if the current call is an instance of a call
  396. already made, then predicates such as var/1 and nonvar/1 should not be used.
  397.  
  398. Example:
  399.     if p(X,Y) is called before and the current call is p(X,b)
  400.     then the answers stored in the extension table are used to
  401.     answer the current call. However, these answers could be
  402.     incorrect if var/nonvar tests are used on the second argument
  403.     in the evaluation of p.
  404.  
  405. Another problem with using impure code is that if you cut over an ET predicate
  406. then the saved call implies that you computed all answers for that predicate
  407. but there are only partial results in the ET because of the cut.
  408. So on a subsequent call the incomplete extension table answers are used
  409. when all answers are expected.
  410.  
  411. Example:
  412.     r(X,Y) :- p(X,Y),q(Y,Z),!,fail.
  413.  
  414.     ?-  r(X,Y) ; p(X,Y).            
  415.  
  416.     Let p be an ET predicate whose evaluation yields many tuples.
  417.     In the evaluation of the query, r(X,Y) makes a call to p(X,Y).
  418.     Assuming that there is a tuple such that q(Y,Z) succeeds with the
  419.     first p tuple then the evaluation of p is cut over. The call to p(X,Y)
  420.     in the query uses the extension table because of the previous call
  421.     in the evaluation of r(X,Y). Only one answer is found, whereas the
  422.     relation p contains many tuples, so the computation is not complete.
  423.  
  424. Note that "cuts" used within the evaluation of an ET predicate are ok 
  425. (as long as they don't cut over the evaluation of another ET predicate). 
  426. The evaluation of the predicate that uses cuts does not cut over any et
  427. processing (such as storing or retrieving answers) so that the tuples that
  428. are computed are saved. In the following example, the ET is used to generate
  429. prime numbers where an ET point is put on prime/1.
  430. */
  431.