VOL1 francis 1HDR1ADVICE.HLP 00010001000100 85045 99364 000000Unix V7 File: Advice.Hlp Author: R.A.O'Keefe Updated: 21 August 1984 #source. The source code for the Prolog advice package is UTIL:ADVICE.PL. This help file is UTIL:ADVICE.HLP. #needs. To get help, HELPER.PL must be compiled. To print out the advice using pa/1, PP.PL must be compiled. To turn the advice package on, you need flag/3 from FLAGRO.PL. #purpose. The advice package is a debugging tool. It gives you a way of inserting verification and printing code at any or all of the four ports of an INTERPRETED predicate without actually modifying the code yourself. The idea is that you say "whenever you are at the X port of a goal matching Y do action Z". Advice cannot be used to bind variables as it is failed back over. Advice at the call port can switch tracing on, and advice at the exit or fail ports can switch it off. #commands. advise(Head, Port, Action) -- see advise. advised(Head) -- see advised. unadvise(Head), unadvise(Head,Port) -- see unadvise. pa, pa Pattern -- see pa. #data,database. The advice package uses the data base in three ways. First, it uses the flag "advice" (see advice). Second, it records a term advice(Port,Goal,Action) under the key Goal for each (Goal,Port,Action) combination. If you want to remove one piece of advice from a single predicate this is where you look. Finally, it renames the clauses for the original predicate. It is to be hoped that this will not happen in other Prologs, but the other two uses of the data base are likely to be permanent. #advice. Advice is what is recorded, the verb you use to give advice is advise with an S. The only advice you can actually give is "execute such and such a Prolog form at such a Port of such a Goal". This should include spying and mode/type checking, but it currently DOESN'T. As an efficiency measure, advice will NOT be checked for unless the 'advice' flag is on. Use flag(advice, _, on) -- to turn advice checking on flag(advice, _, off) -- to turn it off flag(advice, on, on) -- to check if it is on flag(advice, Old, Old) -- to find out what it is. THIS FLAG IS NOT ON INITIALLY. YOU HAVE TO TURN IT ON YOURSELF. That is because Dec-10 compiled code cannot have actions in it. In other Prologs the flag should be on to start with. #advise,advise(Goal,Port,Action). :- advise(Goal, Port, Action) where Goal is a compound term such as prove(X,Y) and NOT a pattern such as prove/2, Port is one of call/exit/redo/fail, and Action is a Prolog form tucks the advice away in the recorded data base and renames the clauses. As a typical example, :- advise(prove(X,Y), call, writef('call %t\n', [prove(X,Y)]). says to obey the writef form whenever control reaches the call port of a prove/2 goal. #advised,advised(Goal). advised(Goal) recognises or enumerates Goals which have been advised. You have to give a compound term such as current_predicate/2 or system/1 wants, not a pattern F/N such as spy or pp wants. #pa. pa -- print all advice pa help -- display list of topics pa Pattern -- print advice for selected predicates This reminds you what advice you have given. A distinction is made between predicates which have never been advised and predicates which don't happen to have any advice at the moment. #unadvise,unadvise(Goal),unadvise(Goal,Port). unadvise(Goal, Port) -- remove some advice for Goal unadvise(Goal) -- remove all advice for Goal unadvise(Goal, Port) removes all the advice pertaining to one particular Port (call/exit/redo/fail) of the *predicate* specified by Goal. It will remove advice for heads that do not match the Goal pattern exactly; only the principal functor matters. unadvise(Goal) removes all the advice for the predicate specified by Goal, and renames its clauses back to their original state. Removing all the advice for each of the four ports will not rename the clauses back. #end_of_file. EOF1ADVICE.HLP 00010001000100 85045 99364 000009Unix V7 HDR1ADVICE.PL 00010002000100 85045 99364 000000Unix V7 % File : ADVICE.PL % Author : R.A.O'Keefe % Updated: 20 August 1984 % Purpose: Interlisp-like advice package. % Needs : concat/3 and flag/3 from UTIL, isCurrent from PP.PL. :- public advise/3, advised/1, (pa)/0, (pa)/1, unadvise/1, unadvise/2. :- mode 'a$abolish'(+, +), 'a$call'(+, +), 'a$fail'(+), advise(+, +), advise(+, +, +), advised(+), advised(+, -, -), (pa), pa(+), pa_explicit(+), unadvise(+), unadvise(+, +). :- op(900, fx, pa). % This module defines three commands and a predicate: % advise(Predicate, Port, Action) % unadvise(Predicate) % unadvise(Predicate, Port) % advised(Prediate) % which cause the Action to be performed at that Port (advise), % cause no action to be performed at that Port (unadvise), or % test whether a predicate is advised. % The Predicate argument must be a Prolog term. a/2 will be taken % as referring to the predicate (/)/2, which is probably not what % you want. Write a(_,_). This is the same convention as that % used by current_predicate. For advise/3 the arguments will be % retained and may be used as a further condition; the other two % predicates ignore the arguments except to note how many they are. % The Port argument may be call, exit, redo, or fail. % This corresponds exactly to the ports shown by the debugger. % Note that the "neck" port of some debuggers cannot be handled in % this indirect fashion. Advice should be integrated with the % debugger so that spy-points are handled this way, perhaps as % advise(Goal, call, spy) or some such. % Advice is only heeded when the 'advice' flag is on, use the % utility flag/3 to switch it on and off % flag(advice, Val, Val) -- returns the current setting % flag(advice, _, on) -- turns it on % flag(advice, _, off) -- turns it off % Unlike the InterLISP facility on which this is based, it is % not possible to advise built-in predicates. Also, advice is % only heeded in interpreted calls, public compiled predicates % may be advised, but calls to them from within compiled code % will not see the advice. This is due to implementation facts % beyond my power to change, and may perhaps be different in % NIP if/when that gets off the ground. %----------------------------------------------------------------------------% %...advised(Goal) % is true when Goal is a Prolog goal whose predicate is under advice. % The Goal may have some of its arguments filled in, that doesn't % matter. This predicate may be used to enumerate the predicates % being advised, in the spirit of current_predicate. advised(Goal) :- current_predicate(_, Goal), clause(Goal, 'a$call'(Goal,_)). %...advised(Goal, Skel, Call) % is a version of advised/1 which returns the general skeleton for % goal, and if the goal is ill-formed or not being advised, prints % an error message. It may NOT be used to enumerate goals, but as % you are not supposed to know about it, that is acceptable. As a % result of picking up the mapped call from the clause, only advise % needs to know how the new name is generated. advised(Goal, Skel, Call) :- functor(Goal, Functor, Arity), functor(Skel, Functor, Arity), clause(Skel, 'a$call'(Skel,Call)), !. advised(Goal, _, _) :- display('! You are not advising '), display(Goal), ttynl, fail. %----------------------------------------------------------------------------% %...advise(Goal, Port, Action) % makes sure that the Goal is being advised, and then adds an % entry to its advice table. On the Dec-10 and in C-Prolog, we % are able to put the advice "on the Goal's property list" by % using recorda/z. advise(Goal, Port, Action) :- 'a$fail'(Port), functor(Goal, Functor, Arity), functor(Skel, Functor, Arity), advise(Goal, Skel), recordz(Skel, advice(Port,Goal,Action), _). %...a$fail(Port) % checks that the Port is a valid port name. 'a$fail'(Var) :- var(Var), !, display('! Variable as port name in advise/unadvise'), ttynl, fail. 'a$fail'(call) :- !. 'a$fail'(exit) :- !. 'a$fail'(redo) :- !. 'a$fail'(fail) :- !. 'a$fail'(Port) :- display('! unknown port name '), display(Port), ttynl. %...advise(Goal) % takes a skeletal Goal, e.g. f(A,B,C), and makes sure that calls % to that goal will be routed to e.g. a$f(A,B,C) via a$call. If % the goal is advised already, nothing is done. If there are no % clauses for this goal, an error is announced (as this usually % indicates a typing mistake or a system predicate. Otherwise % all the current clauses are renamed, and a new clause % f(A, B, C) :- a$call(f(A,B,C), a$f(A,B,C)). % is added. BEWARE: this will not work if you change the predicate % using assert/retract. It would have to be built in to the system % at a much lower level for that to work. advise(_, Skel) :- % already advised? clause(Skel, 'a$call'(Skel,_)), !. advise(_, Skel) :- % has clauses? current_predicate(Functor, Skel), !, concat('a$', Functor, Afunctor), Skel =.. [Functor |Args], Call =.. [Afunctor|Args], ( clause(Skel, Body, Ref), assertz((Call :- Body)), erase(Ref), fail ; true ), !, assert((Skel :- 'a$call'(Skel,Call))). advise(Goal, _) :- display('! You have no clauses for '), display(Goal), ttynl, fail. %----------------------------------------------------------------------------% %...unadvise(Goal) % wipes out all of the advice for the Goal. unadvise(Goal) :- advised(Goal, Skel, Call), retract((Skel :- 'a$call'(Skel,Call))), ( clause(Call, Body, Ref), assertz((Skel :- Body)), erase(Ref), fail ; true ), !, 'a$abolish'(Skel, _). %...unadvise(Goal, Port) % wipes out all the advice for Goal saying what to do at this Port. unadvise(Goal, Port) :- 'a$fail'(Port), % check that the Port is valid. advised(Goal, Skel, Call), % validate the Goal. 'a$abolish'(Skel, Port). %...a$abolish(Goal, Port) % wipes out all the advice for this port of the goal, given % that the goal and port have been validated. 'a$abolish'(Goal, Port) :- recorded(Goal, advice(Port,_,_), Ref), erase(Ref), fail. 'a$abolish'(_, _). %...a$call(SourceGoal, MappedGoal) % routes a call on SourceGoal to call MappedGoal instead, but obeys % any advice that may be lying around. 'a$call'(Goal, Call) :- flag(advice, off, off), !, call(Call). 'a$call'(Goal, Call) :- ( recorded(Goal, advice(call,Goal,Action), _), call(Action), fail ; call(Call) ; recorded(Goal, advice(fail,Goal,Action), _), call(Action), fail ), ( recorded(Goal, advice(exit,Goal,Action), _), call(Action), fail ; true ; recorded(Goal, advice(redo,Goal,Action), _), call(Action), fail ). /*----------------------------------------------------------------------+ | | | pa prints all advice | | pa help prints help about the advice package | | pa Preds prints the advice for Preds, where Preds | | is the same sort of specification pp takes. | | To use these commands you must have PP.PL loaded. | | | +----------------------------------------------------------------------*/ pa :- flag(advice, Old, Old), write('% The advice flag is '), write(Old), nl, advised(Pred), functor(Pred, F, N), pa_explicit(F/N), fail ; true. pa(help) :- !, give_help('advice.hlp'). pa(Pattern) :- setof(Predicate, isCurrent(Pattern, pp, Predicate), Predicates), pa_explicit(Predicates). pa_explicit([Head|Tail]) :- pa_explicit(Head), pa_explicit(Tail). pa_explicit([]). pa_explicit(Functor/Arity) :- functor(Head, Functor, Arity), write('% '), write(Functor/Arity), ( clause(Head, 'a$call'(Head,_)), !, nl, ( recorded(Head, advice(Port,Head,Action), _), write(:-(advise(Head,Port,Action))), put(46), nl, fail ; true ) ; write(' is not advised'), nl ). EOF1ADVICE.PL 00010002000100 85045 99364 000016Unix V7 HDR1ANDOR.PL 00010003000100 85045 99364 000000Unix V7 % File : andor_debug % Author : Dave Bowen (documented by Paul Wilk) % Updated: 27 February 1984 % Purpose: Meta-circular interpreter maintaining extended AND/OR tree % Needs : findall/3 from UTIL:SETOF.PL. /* MAIN DATA STRUCTURES A1 =:= A term instantiated to the current argument of the current goal being unified. A2 =:= A term instantiated to the current argument of the current choice being unified. F =:= The name of the principal functor of the current goal or current procedure. N =:= The arity of the current goal. T1 =:= A term instantiated to current goal being unified. T2 =:= A term instantiated to the current choice being unified. [AndNodes] =:= This is a list of "and" goals for the parent goal. When AndNodes instantiates to a list, the current goal can then be thought of as the parent goal. [AndNode] =:= This is a list of one "and" goal and is used to catch a parent goal with only one goal in its Body. [And | RestA] =:= When the parent goal has more than one goal in the Body, And instantiates to the first goal in the Body and RestA to to the tail. And will be used to construct an "or" node and RestA will be saved in Choice =:= Choice instantiates to the head of the list of or_goals. RestC =:= RestC instantiates to the tail of the list of or_goals; the choicepoints.. [Clauses] =:= The unordered set of all instances of the goal-term (Head:-Body); a list. Cont =:= Cont instantiates to the continuation list of the parent goal for the current goal. Note that this is a list the head of which is the term cont/3 the tail is the rest of the continuation list. % [bp(RestC,RestA,Goal,Substs,Cont,ParentFail)|Fail] Fail =:= Holds a list of records, where each record contains backtrack information relating to a current goal, i.e. [bp/9 | Fail]. Each record bp(RestC,RestA,Goal,Substs,Cont,ParentFail) Goals =:= Goals consists of a linked list of the goals to be satisfied Head =:= OrNodes =:= OrNodes is a pointer to a pointer tuple, Or and Rest0. Or =:= Or points to "or" nodes. "or" nodes consist of a list called Clauses and a list AndNodes. % cont(RestG, RestO, Parentfail) RestG =:= continuation list for the parent goal; for when all descendant goals have been resolved. RestO =:= list of choice points still to be resolved against the current goal; in case the current or_goal choice fails. ParentFail =:= Contains the backtracking information for the current goal's parent goal; in case the parent goal fails. Substs =:= A list of the bindings made during the unification of the current goal. MidSubsts =:= MidSubsts is used as a local variable in the nested call to unify/5 for nested terms. NewSubsts =:= Note that NewSubsts will contain any new substitutions made locally in the call to unify/5. Rest =:= The rest of the substitution list. Tree =:= contains the current state of the search tree. The search tree consists of nodes represented as terms. There are "and" nodes and "or" nodes An "and" term consists of two pointers Goals and OrNodes. Value =:= The value of a unified term; be it an atom integer, variable or non-real variable. % MAIN PROCEDURES %debug/1 Initialise_Question The call to numbervars/3 unifies the variables in the initial question with the special term known as $Var; by convention. These variables are now referred to as non-real variables. Associated with each non-real variable is a unique number. This number is used to in the substitution list, to associate a variable with a value. Note that Tree is a shared variable occuring as the second and seventh argument of and_node. The contents of Tree, the current state of the search tree, are built up until a solution is found for the initial question, or the question fails. In either case fail/3 will call ask/1 to see if the user wishes to display the search tree. %and_node/8. Exit_Parent If the body of the current goal is empty then the second argument of and_node, which will usually contain a list of and_goals, will be empty. Therefore the parent goalf is proven true; so call continue/5. Reduce_Goal If the body of the current goal is NOT empty (i.e. their ARE continuation points) then solve the next goal. %do_and/8. Create_AndNode_with_ChoicePoints Create an and_node using the current goal, passing forward continuation information in the term cont/3: copy the continuation list for the parent goal; copy the list of choice points which may still satisfy the current goal. Go and look for continuation Create_AndNode_without_ChoicePoints Prune at this and_node after satisfying the current goal; this is the last continuation for the parent goal. %do_goal/8. Cut The current goal is a cut therefore commit to the choices made since the parent goal was invoked and discard any choices left prior to the cut; go to continue to determine if the parent goal has any remaining continuation points. Test_ChoicePoints Invariably the choice points will have been collected together and Or will be instantiated to this collection. Find_ChoicePoints Initially, apart from a cut or system predicate goal, when a new current goal is chosen, the choice points, in the form of Clauses will not yet have been collected together, and Or will be uninstantiated. Note that Cont instantiates to the continuation list of the parent goal for the current goal. Also note the head of the list is a is the term cont/3; the tail is the rest of the continuation list. So, clause(Head, Body) searches the program for a clause whose head matches Head. Body instantiates to the body of this clause. findall repeats this for all the instances of the term Head. Clauses is a non-empty, unordered list, containing all clause instances (Head:-Body) such that clause(Head, Body) is true. Note that for the last goal in a parent goal: Clauses == [(Head1:-Body1), (Head2:-Body2),...] But more generally: Clauses == [[(Head1:-Body1), (Head1:-Body2),...] | [(Head2:-Body1), (Head2:-Body2),...]]. where each element of the outer list represents a goal to be satisfied; collectively they form the current list of and_goals still to be satisfied. Each element of the inner lists represents an or_goal that will match the head of the corresponding and_goal. Note that N, the arity of the term is determined here. It is used later as a controlling variabl for the unification of terms. %or_node/8. Fail_to_MatchClause No principal functor of a procedure matched the current goal, i.e. the list Clauses is empty, so fail back. Succeed_to_MatchClause A principal functor of a procedure matched the current goal. %do_or/9. Last_Choice There is only one and_goal still to be satisfied in the scope of the current goal. We are looking to get a current goal from the list of or_goals contained in Clauses. Not_Last_Choice More than one choice left, so Choice instantiates to the current head of the list of or_goals and RestC instantiates to the tail. We will pass forward all the information relating to choice points using the term bp/9 which will instantiate FAIL. This information is necessary should the current or_goal choice fail, because we wont have to backtrack and look for the next or_goal choice as it can be taken from the head of RestC. If we backtracked we would loose all the current or_goal choice bindings which defeats the purpose of this debugger. When the match for and_node is made in do_choice/9 AndNode will instantiate to the body of the current or_goal choice. %do_choice/9. Unify_Choice Now take the chosen or goal apart again. If unification against the head of the current_choice is successful then this or-goal choice is suitable as an and_goal therefore commit to it. We won't backtrack looking for any more or_goal choices because we collect ALL of them once the first one succeeds. Pass forward the body of the or-goal chosen. This will be used to form the next and_node and become the new current goal. Consequently, this call to and_node/8 will instantiate And to a term pointer which has as its value the head of the and_goals for the current or_goal. The current or_goal passed forward should now be thought of as the new parent goal. Unify_Failed The or_choice used as the current goal failed to unify so pass forward the list of or_goal choices held by Fail (this was instantiated in do_or) and the current state of the proof tree held by Tree, to fail/3. Note that Fail could hold an empty list containing no or_goal choicepoints. %continue/5 Proven_Question If continue/5 is called and the list of continuation points is empty then a solution has been found. Go and write the solution to the question. Ask the user if they require a display of the proof tree. Note that if another solution is required we fail back here and call fail/3. Find_Continuation Usually when continue/5 is called there will be a list containing continuation points. The head of the first argument will match with cont/3, and the tail, which will be an empty list or contain continuation points, will instantiate Cont to be the current continuation list. Cont is passed forward to do_and/8. %fail/3. Fail There were no choice points left for the current and_goal therefore Fail consists of an empty list. Ask the user if they want to print the proof tree. Get_ChoicePoint We have not exhausted the choicepoints for the current and_goal therefore get the head of Fail which contains all the information about the next choice point. Note that the information describing the unresolved, unordered set of choicepoints is contained in the term list bp/6. So, this is passed forward to or_goal. Also, note that the tail of the list bp becomes the new choice-point list, passed forward in Fail. %unify/4 Test_for_Dereferencing The terms to be unified might not be integers or atoms so they may need dereferencing. Pass the values to unify_drf/3 for unification. %deref/3 Found_VariableTerm Dereference the non-real varible term; this will be the current goal term and the head of the current choice on subsequent calls. Note that. Found_Atom The term is an atom or an integer, so simply return its value; no dereferencing is required. %unify_drf/4 Current_Goal_is_RealVariable The current goal unifying with the current choice is a real variable as yet uninstantiated. So, bind the real variable to the variable-number of the non-real variable. Unification of the particular term is true. If there are no more terms to be unified in the current goal then go to the next and_node. Add this binding to the head of the substitution list. Current_Choice_is_RealVariable The current choice made for unifying with the current goal is a real variable as yet uninstantiated. So, bind the real variable to the number of the non-real variable. Unification of the particular term is true. If there are no more terms to be unified in the current goal then go to the next and_node. Add this binding to the head of the substitution list Current_Patterns_both_NonVariableTerms Both the current goal and current choice or non-variable terms. functor/3 returns the arity and name of the principal functor of each of the terms. Unification will fail when functor/3 is called for the second time if the names of the principal functors instantiating the second argument F, are not the same. Or, if they are the same, they do not have the same arity. If the terms have the same principal functor and arity then we need to call unify/5 to see if the terms are compound structures, atoms or integers. Note that we carry forward the substition list. %unify/5 Unify_Atom The arity of the term is 0 therefore the term is an integer or an atom. Or, this the terminal case of a compound structure as we are using the arity returned by functor as a counter for determining which current argument we are matching. Note that nothing is added to the substitution list if this clause succeeds. Unify_Structure The structures have the same principal functor and arity so match the arguments in turn. Note that the arity I returned by functor/3 can be used to iterate up the argument lists from right to left. arg/3 is used to take the Ith argument from the current goal and the current choice. Note that we are still carrying the substitution list. Also note that to keep the substitutions in the correct order in dealing with the further nested structures MidSubsts is used as a local variable to this nested call to unify/4. Note that on successful return from unify/4, MidSubsts is passed forward. New substitutions may or may not have been added. Subsequently, Unify/5 is called attempting to match the I-1th argument. Note that NewSubsts will contain any new substitutions made, local to the unify/5 call. %derefvar/4 Dereference_Head_of_SubstitutionList N is the number of the variable. Unify this with the number of the numbered-variable in the head of the substitution list. If they unify then we have to find the value of the numbered-variable in the head of the substituion list. We call deref/3 to see if the binding is to a value or to yet another non-real variable. Dereference_Tail_of_SubstitutionList If the numbered variable in the head of the substitution list fails to unify with the number of the current non-real variable then the tail of the substitution list is passed to derefvar, referenced by Rest. Note that the third argument is used to maintain the completeness of the substitution list while searching for the value of the non-real variable. Found_RealVariable We have emptied the substitution list therefore the variable is unstantiated. So we pass back the value of the last non-real variable in the chain as the value to which to bind the current variable term to. */ :- public (debug)/1. :- op(1050,fy,(debug)). debug Goals :- numbervars(Goals,0,N), and_node(Goals,Tree,[],[],[],[],Tree,N). and_node(true,true,Substs,Cont,Fail,ParentFail,Tree,N) :- !, continue(Cont,Substs,Fail,Tree,N). and_node(Goals,and(Goals,OrNodes),Substs,Cont,Fail,ParentFail,Tree,N) :- do_and(Goals,OrNodes,Substs,Cont,Fail,ParentFail,Tree,N). do_and((Goal,RestG),(Or,RestO),Substs,Cont,Fail,ParentFail,Tree,N) :- !, do_goal(Goal,Or,Substs,[cont(RestG,RestO,ParentFail)|Cont], Fail,ParentFail,Tree,N). do_and(Goal,Or,Substs,Cont,Fail,ParentFail,Tree,N) :- do_goal(Goal,Or,Substs,Cont,Fail,ParentFail,Tree,N). do_goal(!,true,Substs,Cont,Fail,ParentFail,Tree,N) :- !, % handle cut continue(Cont,Substs,ParentFail,Tree,N). do_goal(Goal,Or,Substs,Cont,Fail,ParentFail,Tree,N) :- nonvar(Or), !, % clauses exist or_node(Clauses,Or,Goal,Substs,Cont,Fail,Tree,N). do_goal(Goal,Or,Substs,Cont,Fail,ParentFail,Tree,N0) :- functor(Goal,F,N), % get clauses functor(Head,F,N), findall( (Head:-Body), clause(Head,Body), Clauses), numbervars(Clauses,N0,N1), or_node(Clauses,Or,Goal,Substs,Cont,Fail,Tree,N1). or_node([],fail,Goal,Substs,Cont,Fail,Tree,N) :- !, % no clauses nl, write('Warning: there are no clauses for '), write(Goal), nl, fail(Fail,Tree,N). or_node(Clauses,or(Clauses,AndNodes),Goal,Substs,Cont,Fail,Tree,N) :- do_or(Clauses,AndNodes,Goal,Substs,Cont,Fail,Fail,Tree,N). do_or([Choice],[AndNode],Goal,Substs,Cont,Fail,ParentFail,Tree,N) :- !, % last clause do_choice(Choice,AndNode,Goal,Substs,Cont,Fail,ParentFail,Tree,N). do_or([Choice|RestC],[And|RestA],Goal,Substs,Cont,Fail,ParentFail,Tree,N) :- do_choice(Choice,And,Goal,Substs,Cont, [bp(RestC,RestA,Goal,Substs,Cont,ParentFail)|Fail], ParentFail,Tree,N). do_choice((Head:-Body),And,Goal,Substs,Cont,Fail,ParentFail,Tree,N) :- unify(Goal,Head,Substs,NewSubsts), !, and_node(Body,And,NewSubsts,Cont,Fail,ParentFail,Tree,N). do_choice(Choice,And,Goal,Substs,Cont,Fail,ParentFail,Tree,N) :- fail(Fail,Tree,N). continue([],Substs,Fail,Tree,N) :- !, ( nl, write_substs(Substs,Tree), ask('More'), !, nl, write(yes), nl ; fail(Fail,Tree,N) ). continue([cont(Goals,OrNodes,ParentFail)|Cont],Substs,Fail,Tree,N) :- do_and(Goals,OrNodes,Substs,Cont,Fail,ParentFail,Tree,N). fail([],Tree,N) :- !, nl, write(no), nl, ( ask('Print tree'), ! ; printm(0,[],Tree) ). fail([bp(RestC,RestA,Goal,Substs,Cont,ParentFail)|Fail],Tree,N) :- do_or(RestC,RestA,Goal,Substs,Cont,Fail,ParentFail,Tree,N). unify(T1,T2,Substs,NewSubsts) :- deref(T1,Substs,DT1), deref(T2,Substs,DT2), unify_drf(DT1,DT2,Substs,NewSubsts). unify_drf(T,'$VAR'(N),Substs,[N=T|Substs]) :- !. unify_drf('$VAR'(N),T,Substs,[N=T|Substs]) :- !. unify_drf(T1,T2,Substs,NewSubsts) :- functor(T1,F,N), functor(T2,F,N), unify(N,T1,T2,Substs,NewSubsts). unify(0,T1,T2,Substs,Substs) :- !. unify(I,T1,T2,Substs,NewSubsts) :- arg(I,T1,A1), arg(I,T2,A2), unify(A1,A2,Substs,MidSubsts), J is I-1, unify(J,T1,T2,MidSubsts,NewSubsts). deref('$VAR'(N),Substs,Value) :- !, derefvar(N,Substs,Substs,Value). deref(X,S,X). derefvar(N,[N=V1|Rest],Substs,V2) :- !, deref(V1,Substs,V2). derefvar(N,[_|Rest],Substs,V) :- !, derefvar(N,Rest,Substs,V). derefvar(N,[],_,'$VAR'(N)). /* Outputting routines */ write_substs(Substs,and(Goals,T)) :- write('Proved:'), nl, printm(0,Substs,Goals), ( ask('Print tree'), ! ; printm(0,Substs,and(Goals,T)) ). printm(M,_,V) :- var(V), !, write(V). printm(M,Substs,or(C,A)) :- !, N is M+1, write('or('), printm_nl(N,Substs,C), put(0',), printm_nl(N,Substs,A), put(0')). printm(M,Substs,and(G,O)) :- !, N is M+1, write('and('), printm_nl(N,Substs,G), put(0',), printm_nl(N,Substs,O), put(0')). printm(M,Substs,[X|L]) :- !, N is M+1, write('[ '), printm(N,Substs,X), printml(N,Substs,L), write(' ]'). printm(M,Substs,(X,Y)) :- !, N is M+1, write('( '), printm(N,Substs,X), put(0',), printm_nl(N,Substs,Y), write(' )'). printm(M,Substs,X) :- dosubsts(X,Substs,V), print(V). printm_nl(M,S,X) :- nl, tab(M*2), printm(M,S,X). printml(_,_,V) :- var(V), !, write(' |'), write(V), put(0']). printml(_,_,[]) :- !. printml(M,Substs,[X|L]) :- put(0',), printm_nl(M,Substs,X), printml(M,Substs,L). dosubsts(Var,S,Var) :- var(Var), !. % Leave real variable alone dosubsts('$VAR'(N),S,V) :- !, derefvar(N,S,S,T), dosubterms(T,S,V). dosubsts(T,S,V) :- functor(T,F,N), functor(V,F,N), dosubsts(N,T,S,V). dosubterms('$VAR'(N),_,'$VAR'(N)) :- !. % unbound variable dosubterms(T,S,V) :- % substitute values of vars in T dosubsts(T,S,V). dosubsts(0,T,S,V) :- !. dosubsts(I,T,S,V) :- arg(I,T,Ti), arg(I,V,Vi), dosubsts(Ti,S,Vi), J is I-1, dosubsts(J,T,S,V). /* Ask user question and fail if "y" typed */ ask(Question) :- nl, write(Question), write(' (y/n)? '), ttyflush, get0(C), skiptonl(C), C =\= "y". skiptonl(31) :- !. % DEC-10 skiptonl(10) :- !. % VAX skiptonl(_) :- get0(C), skiptonl(C). EOF1ANDOR.PL 00010003000100 85045 99364 000038Unix V7 HDR1APPLIC.HLP 00010004000100 85045 99364 000000Unix V7 % file. APPLIC.PL % author. Lawrence Byrd + Richard A. O'Keefe % updated. 4 August 1984 % purpose. Various "function" application routines based on apply/2. % needs. append/3 from ListUt.Pl %commands. apply(Pred, Args) is the key to this whole module. It is basically a variant of call/1 (see the Dec-10 Prolog V3.43 manual) where some of the arguments may be already in the Pred, and the rest are passed in the list of Args. Thus apply(foo, [X,Y]) is the same as call(foo(X,Y)), and apply(foo(X), [Y]) is also the same as call(foo(X,Y)). callable(Term) succeeds when Term is something that it would make sense to give to call/1 or apply/2, ie. an atom or a compound term. checkand(Pred, Conjunction) succeeds when Pred(Conjunct) succeeds for every Conjunct in the Conjunction. checklist(Pred, List) succeeds when Pred(Elem) succeeds for each Elem in the List. mapand(Rewrite, OldConj, NewConj) succeeds when Rewrite is able to rewrite each conjunct of OldConj, and combines the results into NewConj. maplist(Pred, OldList, NewList) succeeds when Pred(Old,New) succeeds for each corresponding Old in OldList, New in NewList. convlist(Rewrite, OldList, NewList) Each element of NewList is the image under Rewrite of some element of OldList. exclude(Pred, List, SubList) succeeds when SubList is the SubList of List containing all the elements for which Pred(Elem) is *false*. some(Pred, List) somechk(Pred, List) succeeds when Pred(Elem) succeeds for some Elem in List. sublist(Pred, List, SubList) succeeds when SubList is the sub-sequence of the List containing all the Elems of List for which Pred(Elem) succeeds. %end_of_help. EOF1APPLIC.HLP 00010004000100 85045 99364 000004Unix V7 HDR1APPLIC.PL 00010005000100 85045 99364 000000Unix V7 % File : APPLIC.PL % Author : Lawrence Byrd + Richard A. O'Keefe % Updated: 4 August 1984 % Purpose: Various "function" application routines based on apply/2. % Needs : append/3 from ListUt.Pl :- public apply/2, callable/1, checkand/2, checklist/2, convlist/3, exclude/3, mapand/3, maplist/3, some/2, somechk/2, sublist/3. :- mode apply(+, +), callable(?), checkand(+, +), checklist(+, +), convlist(+, +, ?), exclude(+, +, ?), mapand(+, ?, ?), maplist(+, ?, ?), some(+, ?), somechk(+, +), sublist(+, +, ?). % apply(Pred, Args) % is the key to this whole module. It is basically a variant of call/1 % (see the Dec-10 Prolog V3.43 manual) where some of the arguments may % be already in the Pred, and the rest are passed in the list of Args. % Thus apply(foo, [X,Y]) is the same as call(foo(X,Y)), % and apply(foo(X), [Y]) is also the same as call(foo(X,Y)). % BEWARE: any goal given to apply is handed off to call/1, which is the % Prolog *interpreter*, so if you want to apply compiled predicates you % MUST have :- public declarations for them. The ability to pass goals % around with some of their (initial) arguments already filled in is % what makes apply/2 so useful. Don't bother compiling anything that % uses apply heavily, the compiler won't be able to help much. LISP % has the same problem. Later Prolog systems may have a simpler link % between compiled and interpreted code, or may fuse compilation and % interpretation, so apply/2 may come back into its own. At the moment, % apply and the routines based on it are not well thought of. apply(Pred, Args) :- ( atom(Pred), Goal =.. [Pred|Args] ; %compound(Pred), Pred =.. OldList, append(OldList, Args, NewList), Goal =.. NewList ), !, call(Goal). % callable(Term) % succeeds when Term is something that it would make sense to give to % call/1 or apply/2. That is, Term must be an atom or a compound term; % variables and integers are out. callable(Term) :- nonvar(Term), functor(Term, FunctionSymbol, _), atom(FunctionSymbol). % checkand(Pred, Conjunction) % succeeds when Pred(Conjunct) succeeds for every Conjunct in the % Conjunction. All the *and predicates in this module assume that % a&b&c&d is parsed as a&(b&(c&d)), and that the "null" conjunction % is 'true'. It is possible for this predicate, and most of the % others, to backtrack and try alternative solutions. If you do not % want that to happen, copying one of these predicates and putting a % cut in the suggested place will produce a tail-recursive version. % The cuts in the *and predicates are there because "non-and" is % defined by exclusion; they cannot be assigned types. checkand(Pred, true) :- !. checkand(Pred, A&B) :- !, apply(Pred, [A]), checkand(Pred, B). checkand(Pred, A) :- apply(Pred, [A]). % checklist(Pred, List) % suceeds when Pred(Elem) succeeds for each Elem in the List. % In InterLisp, this is EVERY. It is also MAPC. checklist(Pred, []). checklist(Pred, [Head|Tail]) :- apply(Pred, [Head]), checklist(Pred, Tail). % mapand(Rewrite, OldConj, NewConj) % succeeds when Rewrite is able to rewrite each conjunct of OldConj, % and combines the results into NewConj. mapand(Pred, true, true) :- !. mapand(Pred, Old&Olds, New&News) :- !, apply(Pred, [Old,New]), mapand(Pred, Olds, News). mapand(Pred, Old, New) :- apply(Pred, [Old,New]). % maplist(Pred, OldList, NewList) % succeeds when Pred(Old,New) succeeds for each corresponding % Old in OldList, New in NewList. In InterLisp, this is MAPCAR. % It is also MAP2C. Isn't bidirectionality wonderful? maplist(Pred, [], []). maplist(Pred, [Old|Olds], [New|News]) :- apply(Pred, [Old,New]), maplist(Pred, Olds, News). % convlist(Rewrite, OldList, NewList) % is a sort of hybrid of maplist/3 and sublist/3. % Each element of NewList is the image under Rewrite of some % element of OldList, and order is preserved, but elements of % OldList on which Rewrite is undefined (fails) are not represented. % Thus if foo(X,Y) :- integer(X), Y is X+1. % then convlist(foo, [1,a,0,joe(99),101], [2,1,102]). convlist(Pred, [], []). convlist(Pred, [Old|Olds], NewList) :- apply(Pred, [Old,New]), !, NewList = [New|News], convlist(Pred, Olds, News). convlist(Pred, [_|Olds], News) :- convlist(Pred, Olds, News). % exclude(Pred, List, SubList) % succeeds when SubList is the SubList of List containing all the % elements for which Pred(Elem) is *false*. That is, it removes % all the elements satisfying Pred. Efficiency would be somewhat % improved if the List argument came first, but this argument order % was copied from the older sublist/3 predicate, and let's face it, % apply/2 isn't stupendously efficient itself. exclude(Pred, [], []). exclude(Pred, [Head|List], SubList) :- apply(Pred, [Head]), !, exclude(Pred, List, SubList). exclude(Pred, [Head|List], [Head|SubList]) :- exclude(Pred, List, SubList). % some(Pred, List) % succeeds when Pred(Elem) succeeds for some Elem in List. It will % try all ways of proving Pred for each Elem, and will try each Elem % in the List. somechk/2 is to some/2 as memberchk/2 is to member/2; % you are more likely to want somechk with its single solution. % In InterLisp this is SOME. some(Pred, [Head|_]) :- apply(Pred, [Head]). some(Pred, [_|Tail]) :- some(Pred, Tail). somechk(Pred, [Head|_]) :- apply(Pred, [Head]), !. somechk(Pred, [_|Tail]) :- somechk(Pred, Tail). % sublist(Pred, List, SubList) % succeeds when SubList is the sub-sequence of the List containing all % the Elems of List for which Pred(Elem) succeeds. sublist(Pred, [], []). sublist(Pred, [Head|List], SubList) :- apply(Pred, [Head]), !, SubList = [Head|Rest], sublist(Pred, List, Rest). sublist(Pred, [_|List], SubList) :- sublist(Pred, List, SubList). EOF1APPLIC.PL 00010005000100 85045 99364 000012Unix V7 HDR1ARC3.PL 00010006000100 85045 99364 000000Unix V7 % File : ARC3.PL % Author : R.A.O'Keefe % Updated: 9 February 1984 % Purpose: Implement Mackworth's AC-3 algorithm. % Needs : Util:Assoc.Pl, Util:ListUt.Pl /* It is often stated that blind backtracking is highly inefficient, and it is thereby implied that Prolog must be highly inefficient. In his article "Consistency in Networks of Relations" (AIJ 8 (1977) 99-118) Mackworth presents a series of algorithms of increasing complexity to "remedy the thrashing behaviour that nearly always accompanies back- tracking", which applies to problems involving unary and binary constraints for a fixed number of variables with modest discrete domains. Of course it can readily be extended to problems with higher degree relations, which become unary or binary when enough of their arguments are filled in. His algorithms do not constitute a complete problem-solving method, but can be used to plan a backtracking or other solution so that it will be more efficient. He considers three forms of "consistency". I have just implemented the first two in this file. The reason is that this level of planning can be handled using just sets of values, path consistency requires data structures for relations. (I know how to manipulate such data structures, but I'd like to keep this simple.) For an explanation of why the algorithms work, read Mackworth's paper. We are given a set of Nodes a set of Arcs, represented as (From->To) pairs a fixed "node admissibility" relation admissible_node(Node, Value) a fixed "arc admissibility" relation admissible_arc(FromNode, ToNode, FromValue, ToValue) We compute a set of (Node=PossibleValues) associations which is node consistent and arc consistent, but may well not be path consistent. */ :- public arc_consistency_3/3. :- mode arc_consistency_3(+, +, -), make_nodes(+, -, -), make_graph(+, +, -, -), revise_each_arc(+, +, +, -), node_consistent_bindings(+, -), normalise_arcs(+, -), group_arcs_with_same_to_node(+, +, -), group_arcs_with_same_to_node(+, +, -, -), revise_arc(+, +, +, +, -), queue_arcs(+, +, +, -). arc_consistency_3(Nodes, Arcs, ArcConsistentBindings) :- make_nodes(Nodes, NodeSet, InitialBindings), make_graph(NodeSet, Arcs, ArcSet, Graph), revise_each_arc(ArcSet, Graph, InitialBindings, FinalBindings), assoc_to_list(FinalBindings, ArcConsistentBindings). /* make_nodes(NodeList, NodeSet, Bindings) is given a representation of the set of nodes as an unordered list possibly with duplicates and returns a representation as an ordered list without duplicates (make_graph will need this). It also returns an initial set of node-consistent bindings for the nodes. Now we will want to fetch and update random elements of this map, and the simplest thing to do is to use the existing ASSOC.PL utilities. The fact that setof fails if the set would be empty is *exactly* what we want here. */ make_nodes(NodeList, NodeSet, Bindings) :- sort(NodeList, NodeSet), node_consistent_bindings(NodeSet, NodeValList), list_to_assoc(NodeValList, Bindings). node_consistent_bindings([], []). node_consistent_bindings([Node|Nodes], [Node-Possible|Bindings]) :- setof(Value, admissible_node(Node, Value), Possible), !, node_consistent_bindings(Nodes, Bindings). /* We shall want to look up all the arcs leading TO a given node. We would like that to be fast. We would also like to eliminate self-loops (X->X). I think it is safe to assume that the arc list does not mention any nodes not in the node list, but we may have nodes that no arc leads to. So what we are going to build as a representation of the graph is a binary tree mapping nodes to the list of arcs leading to that node. In other contexts we would make that the list of node with arcs leading to the node, but here we want the arcs so we can push them back onto the stack. We also want a list of arcs. Just in case an arc appears more than once in the list, we use sort rather than keysort. The code for building the list into a tree is taken from ASSOC.PL, avoiding the extra keysort. */ make_graph(NodeSet, ArcList, ArcSet, GraphTree) :- normalise_arcs(ArcList, PairList), sort(PairList, ArcSet), group_arcs_with_same_to_node(NodeSet, ArcSet, FinalPairs), length(FinalPairs, N), list_to_assoc(N, FinalPairs, GraphTree, []). /* normalise_arcs maps a list of (From->To) pairs to a list of (To-From) pairs, omitting any (X->X) pairs it may find. */ normalise_arcs([], []) :- !. normalise_arcs([(X->X)|ArcList], PairList) :- !, normalise_arcs(ArcList, PairList). normalise_arcs([(From->To)|ArcList], [To-From|PairList]) :- normalise_arcs(ArcList, PairList). /* group_arcs_with_same_to_node(NodeSet, ArcSet, NodeToArcMap) takes a list of Nodes, and for each node puts a (Node-Arcs) pair in the NodeToArcMap, where Arcs is the subset of the ArcSet that has Node as the To-node. It exploits the fact that the NodeSet and ArcSet are both sorted, and the NodeToArcMap will also be sorted on the Node key, ready for building into a tree. */ group_arcs_with_same_to_node([], [], []). group_arcs_with_same_to_node([Node|Nodes], ArcSet, [Node-Arcs|NodeToArcMap]) :- group_arcs_with_same_to_node(ArcSet, Node, Arcs, RestArcSet), group_arcs_with_same_to_node(Nodes, RestArcSet, NodeToArcMap). group_arcs_with_same_to_node([Node-To|ArcSet], Node, [Node-To|Arcs], Rest) :- !, group_arcs_with_same_to_node(ArcSet, Node, Arcs, Rest). group_arcs_with_same_to_node(Rest, _, [], Rest). /* revise_each_binding implements the heart of Mackworth's AC-3: Q <- {(i,j) | (i,j) in arcs(G), i =/= j} while Q not empty do begin select and delete any arc (k,m) from Q; if REVISE((k,m)) then Q <- Q U {(i,k) | (i,k) in arcs(G),i/=k,i/=m} end; the Bindings variables play the role of his D-subscript-i, and the ArcSet variables play the role of Q. We exploit Prolog's success-failure: if revise_arc fails we just pop the arc from Q, if it succeeds it returns the new binding for node k. Note that arc (i,j) in Mackworth's notation corresponds to J-I in our notation. */ revise_each_arc([], _, Bindings, Bindings) :- !. revise_each_arc([M-K|Arcs], Graph, OldBindings, NewBindings) :- get_assoc(M, OldBindings, OldM), get_assoc(K, OldBindings, OldK), revise_arc(OldK, K, OldM, M, NewK), NewK \== OldK, !, % There was at least one deletion put_assoc(K, OldBindings, NewK, MidBindings), get_assoc(K, Graph, ArcsToK), queue_arcs(ArcsToK, M, Arcs, MidArcs), revise_each_arc(MidArcs, Graph, MidBindings, NewBindings). revise_each_arc([_|Arcs], Graph, OldBindings, NewBindings) :- revise_each_arc(Arcs, Graph, OldBindings, NewBindings). /* revise_arc(OldK, K, OldM, M, NewK) checks each value in OldK to see whether there is at least one value in OldM which admissible_arc will accept. If there is, it includes that value from OldK in NewK, otherwise it skips it. So NewK is the subset of bindings for K which is compatible with the current bindings for M. */ revise_arc([], _, _, _, []). revise_arc([Kval|OldK], K, OldM, M, [Kval|NewK]) :- member(Mval, OldM), admissible_arc(K, M, Kval, Mval), !, % at least one combination works revise_arc(OldK, K, OldM, M, NewK). revise_arc([_|OldK], K, OldM, M, NewK) :- revise_arc(OldK, K, OldM, M, NewK). % nothing worked /* queue_arcs(Arcs, Exclude, OldQueue, NewQueue) adds each (To-From) arc from Arcs whose From is not Exclude to OldQueue, forming at last a NewQueue. On reflection, it wasn't necessary to store complete arcs in the Graph after all, and I should go back and change it. However, storing complete arcs wins in a structure copying system. */ queue_arcs([], _, Queue, Queue). queue_arcs([_-Exclude|Arcs], Exclude, OldQueue, NewQueue) :- !, queue_arcs(Arcs, Exclude, OldQueue, NewQueue). queue_arcs([Arc|Arcs], Exclude, OldQueue, NewQueue) :- queue_arcs(Arcs, Exclude, [Arc|OldQueue], NewQueue). EOF1ARC3.PL 00010006000100 85045 99364 000016Unix V7 HDR1ARITH.OPS 00010007000100 85045 99364 000000Unix V7 /* ARITH.OPS : Operator declarations for arithmetic expressions Now present in UTIL, used by PRESS and others UTILITY Lawrence Updated: 2 August 81 */ :- op(500,yfx,[++,--]). :- op(400,yfx,[div,mod]). :- op(300,xfy,[:,^]). EOF1ARITH.OPS 00010007000100 85045 99364 000001Unix V7 HDR1ARITH.PL 00010008000100 85045 99364 000000Unix V7 % File : ARITH.PL % Author : R.A.O'Keefe % Updated: 12 June 1984 % Purpose: Define the 'plus' family of arithmetic predicates. :- public divide/4, ge/2, gt/2, le/2, lt/2, plus/3, succ/2, times/3. :- mode instantiation_fault_(+), ge(?, ?), gt(?, ?), le(?, ?), lt(?, ?), succ(?, ?), plus(?, ?, ?), times(?, ?, ?), times(+, +, ?, ?, ?), divide(?, ?, ?, ?). /* :- pred ge(integer, integer), gt(integer, integer), le(integer, integer), lt(integer, integer), succ(integer, integer), plus(integer, integer, integer), times(integer, integer, integer), times(integer, integer, integer, integer, integer), divide(integer, integer, integer, integer). */ /* These predicates are now primitives in C Prolog. My original reason for adding them to C-Prolog was efficiency, as the "is" expression interpreter (which has to handle floating point as well as integers) is quite complicated. succ(X, Y) is 1.2ms faster than Y is X+1 on a VAX 11-750. However, I found that using succ and plus were clearer, and because of the (limited) reversibility of these operations, lived up to Prolog's claim to have some relation to logic a little better than programs written using the strictly one-way "is". When I started using Prolog I was very taken with "is" and held my nose up at IC- Prolog for lacking it. I now think this was a mistake. Of course there are occasions when you want more than the four algorithms of antiquity, such as when you want to do bit-wise operations, or when you want to use floating-point. And it is undeniable that a single arithmetic expression involving 3 or 4 operators is a lot clearer than 3 or 4 predicate calls whose data flow needs careful tracing. The style rule I have adopted (in addition to using 'is' when these predicates simply can't express what I mean) is to use 'is' whenever I can't express what I want with a *single* call on one of these predicates. Thus to calculate 3X I might use times(3,X,Ans), but to obtain 3X+2 I would use Ans is 3*X+2. A further style rule is that if a predicate uses 'is', all similar calculations in that predicate also use 'is' so you can see what is going on. Thus if I want 3X+2 in one clause and 3X in another, I would use 'is' in both so that the reader can easily perceive the similarities and differences. Reversibility is not then an issue. This Prolog code looks bulky. It is bulky. But don't dismiss these operations for such a reason. The C code which implements them in C Prolog is much shorter, and it is much more efficient than using "is", as it knows that there is no question of walking down trees. When writing a Prolog compiler, you should consider these operations: the compiler can benefit from knowing more about the arguments, and if it keeps track of the instantiation state of source variables it may be able to generate special- purpose code. (E.g. calling plus(X,Y,Z) when Z is known to be unbound should generate "int_chk_push(X), int_chk_push(Y), add, bind_new_var(Z)" or something like that.) */ % The general idea is that if there is enough information in a goal % to detect that it must fail (e.g. succ(X,a)) we fail, if there is % enough information to determine a unique solution, we yield that % solution, and otherwise (this can generally only happen when too % few arguments are instantiated) we report an instantiation fault. % We report a fault even when the non-determinism is bounded, e.g. % in times(X, X, 4) there are only two possible solutions. This is % because these operations are primitives, that would be coded in % assembler or micro-code, and we don't want to oblige a compiler % to generate full frames for them. instantiation_fault_(Goal) :- nl, write('! instantiation fault in '), print(Goal), nl, break, abort. % {ge|gt|le|lt}(X,Y) <-> integer(X) & integer(Y) & X {>=|>|=<|<} Y % Note that there is no eq or ne, = and \= will do fine. ge(X, Y) :- integer(X), integer(Y), !, X @>= Y. ge(X, Y) :- ( var(X) ; integer(X) ), ( var(Y) ; integer(Y) ), !, instantiation_fault_(ge(X,Y)). gt(X, Y) :- integer(X), integer(Y), !, X @> Y. gt(X, Y) :- ( var(X) ; integer(X) ), ( var(Y) ; integer(Y) ), !, instantiation_fault_(gt(X,Y)). le(X, Y) :- integer(X), integer(Y), !, X @=< Y. le(X, Y) :- ( var(X) ; integer(X) ), ( var(Y) ; integer(Y) ), !, instantiation_fault_(le(X,Y)). lt(X, Y) :- integer(X), integer(Y), !, X @< Y. lt(X, Y) :- ( var(X) ; integer(X) ), ( var(Y) ; integer(Y) ), !, instantiation_fault_(lt(X,Y)). % succ(P, S) <-> integer(P) & integer(S) & P >= 0 & S = P+1 % given either of P or S we can solve for the other. % If either is neither an integer nor a variable the relation % must be false. But succ(P, S) with both arguments unbound % has infinitely many solutions. (You can generate a bounded % range of integers using between/3.) succ(Pred, Succ) :- integer(Pred), !, Pred >= 0, Succ is Pred+1. succ(Pred, Succ) :- integer(Succ), !, Succ > 0, Pred is Succ-1. succ(Pred, Succ) :- var(Pred), var(Succ), instantiation_fault_(succ(Pred,Succ)). % plus(A, B, S) <-> integer(A) & integer(B) & integer(S) & S = A+B. % given any two of the arguments, we can solve for the third. % If any argument is neither an integer nor a variable, the relation % must be false. If two are variables and the other is variable or % integer, there are infinitely many solutions. plus(A, B, S) :- integer(A), integer(B), !, S is A+B. plus(A, B, S) :- integer(A), integer(S), !, B is S-A. plus(A, B, S) :- integer(B), integer(S), !, A is S-B. plus(A, B, S) :- ( var(A) ; integer(A) ), ( var(B) ; integer(B) ), ( var(S) ; integer(S) ), !, % at most one of A,B,S is integer, the others are vars instantiation_fault_(plus(A,B,S)). % times(A, B, P) <-> integer(A) & integer(B) & integer(P) & P = A*B. % This is trickier than plus. Given A and B there is a unique solution % for P. Given A(B) and P there is at most one solution for B(A) % except in the case when P and A(B) are both 0, in which case there % are infinitely many solutions. Given just A or B there are infinitely % many solutions. Given P there is always a finite number of solutions, % but this number always exceeds 1 (even times(X,Y,1) has X,Y=1,1 or -1,-1). % So we report an instantiation error in that case two. Of course if any % argument is instantiated to a non-integer the relation must be false. times(A, B, P) :- integer(A), integer(B), !, P is A*B. times(A, B, P) :- integer(A), integer(P), !, times(P, A, B, A, B). times(A, B, P) :- integer(B), integer(P), !, times(P, B, A, A, B). times(A, B, P) :- ( var(A) ; integer(A) ), ( var(B) ; integer(B) ), ( var(P) ; integer(P) ), !, % at most one of P,A,B is integer, the others are vars instantiation_fault_(times(A,B,P)). times(P, A, B, X, Y) :- A \== 0, !, 0 is P mod A, B is P / A. times(0, 0, B, X, Y) :- instantiation_fault_(times(X,Y,0)). /* divide(A, B, Q, R) means A, B, Q, and R are all integers, A = B*Q + R, A*R >= 0, (A and R have the same sign, so Q is truncated towards 0) 0 <= |R/B| < 1 (so B is non-zero) This piece of Prolog is to be taken as a specification of the predicate, an implementation may proceed differently. I assume "is", and that overflow need not be checked for, and that X / Y and X / Y are well defined for X >= 0, Y >= 1. Cases: any one of A, B, Q, R is bound to a non-integer => FAIL B is bound to 0 => FAIL {These two failures should have associated error messages} A and B bound => calculate Q', R' unify Q=Q' R=R' A, Q, and R bound => if A*R < 0 then FAIL if Q = 0 then instantiation FAULT unless |Q| divides A-R then FAIL calculate B from divide(A-R,Q,B,0) B, Q, and R bound => check conditions calculate A = B*Q+R check remaining conditions otherwise, instantiation FAULT */ divide(A, B, Q, R) :- ( nonvar(A), \+ integer(A) ; nonvar(B), \+ integer(B) ; nonvar(Q), \+ integer(Q) ; nonvar(R), \+ integer(R) ), !, % bound to fail fail. divide(A, B, Q, R) :- nonvar(A), nonvar(B), !, ( B > 0, A >= 0, Q1 is A/B ; B > 0, A < 0, Q1 is -((-A)/B) ; B < 0, A >= 0, Q1 is -(A/(-B)) ; B < 0, A < 0, Q1 is (-A)/(-B) ), !, Q = Q1, R is A-Q1*B. divide(A, B, Q, R) :- nonvar(A), nonvar(Q), nonvar(R), !, ( A >= 0, R >= 0 ; A =< 0, R =< 0 ), ( Q = 0, !, instantiation_fault_(divide(A,B,Q,R)) ; true ), !, 0 is (A-R) mod Q, B is (A-R) / Q. divide(A, B, Q, R) :- nonvar(B), nonvar(Q), nonvar(R), !, B \== 0, A is B*Q+R, ( R >= 0, A >= 0, (B > R ; -B > R) ; R =< 0, A =< 0, (B < R ; -B < R) ), !. divide(A, B, Q, R) :- instantiation_fault_(divide(A,B,Q,R)). EOF1ARITH.PL 00010008000100 85045 99364 000018Unix V7 HDR1ARRAYS.PL 00010009000100 85045 99364 000000Unix V7 % File : ARRAYS.PL % Author : R.A.O'Keefe % Updated: 8 November 1983 % Purpose: Updatable arrays in Prolog. /* These operations are fully described in "Updatable Arrays in Prolog", R.A.O'Keefe, DAI Working Paper 150. Note that store(Index, Old, Elem, New) sometimes side-effects Old and sometimes doesn't; you cannot rely on Old remaining unchanged. This is NOT an example of logic programming. For a logic programming solution (with cost O(lgN) rather O(1)) see Trees.Pl. */ :- public array_length/1, array_to_list/2, fetch/3, list_to_array/2, store/4. :- mode array_length(+, -), array_to_list(+, -), un_wrap(+, ?), fetch(+, +, ?), get_last(+, ?), list_to_array(+, -), wrap_up(+, -), store(+, +, +, -), store(+, +, -, +, -). array_length(Array+Updates, Length) :- functor(Array, array, Length). array_to_list(Array+Updates, List) :- Array =.. [array|Wrapped], un_wrap(Wrapped, List). un_wrap([History|Histories], [Element|Elements]) :- get_last(History, Element), !, un_wrap(Histories, Elements). un_wrap([], []). fetch(Index, Array+Updates, Element) :- arg(Index, Array, History), get_last(History, Element). get_last([Head|Tail], Element) :- var(Tail), !, Element = Head. get_last([_|Tail], Element) :- get_last(Tail, Element). list_to_array(List, Array+0) :- wrap_up(List, Wrapped), Array =.. [array|Wrapped]. wrap_up([Element|Elements], [[Element|_]|Wrapped]) :- !, wrap_up(Elements, Wrapped). wrap_up([], []). store(Index, Array+Updates, Element, NewArray+NewUpdates) :- functor(Array, array, Length), arg(Index, Array, History), put_last(History, Element), K is Updates+1, !, store(Length, K, NewUpdates, Array, NewArray). store(N, N, 0, Old, New) :- !, Old =.. [array|OldList], un_wrap(OldList, MidList), !, wrap_up(MidList, NewList), New =.. [array|NewList]. store(_, U, U, Array, Array). put_last(History, Element) :- var(History), !, History = [Element|_]. put_last([_|History], Element) :- put_last(History, Element). EOF1ARRAYS.PL 00010009000100 85045 99364 000005Unix V7 HDR1ASK.PL 00010010000100 85045 99364 000000Unix V7 % File : ASK.PL % Author : R.A.O'Keefe % Updated: 25 November 1983 % Purpose: ask questions that have a one-character answer. % Conversion note: end of line is 10 in C-Prolog, 31 in Dec-10 Prolog. % Note: the public predicates with two underscores in their names are % public just so that call/1 can see them. They are not meant to be % called by your programs. The other public predicates are meant to % be so called. :- public ask/2, ask__1/2, ask/3, ask__2/3, ask_default_character/2, talk_to_user_while/1, yesno/1, yesno__1/1, yesno/2, yesno__2/2. :- mode ask(+, ?), ask__1(+, ?), ask__1(+, +, ?), ask(+, +, ?), ask__2(+, +, ?), ask__2(+, +, +, ?), ask_default_character(+, -), talk_to_user_while(+), yesno(+), yesno__1(+), yesno__1(+, +), yesno(+, +), yesno__2(+, +), yesno__2(+, +, +). % The method of redirecting input-output in Dec-10 Prolog, C-Prolog, % PDP-11 Prolog, and PopLog is rather clumsy. The following % version of "call" manages to ensure that input and output are % redirected to 'user' while Goal is running, and restored to their % original values while it is not, even if Goal should backtrack or % fail. This is no mean achievement, I can tell you. To avoid the % need for this nonsense, Dec-10 Prolog has a number of commands % ttyX that do X to 'user'. There isn't any ttywrite, but display % comes close. However, this file has to run under C-Prolog as well, % where display writes on the current output stream, and the ttyX % predicates are not primitives, but have to do their own switching. talk_to_user_while(Goal) :- seeing(Seeing), telling(Telling), ( see(user), tell(user) % CALL port ; see(Seeing), tell(Telling), fail % FAIL port ), call(Goal), ( see(Seeing), tell(Telling) % EXIT port ; see(user), tell(user), fail % REDO port ). % ask_default_character(Spec, Char) % lets the programmer specify the default character in whatever way % s/he finds convenient, either as an integer, as a string, or as a % Prolog atom. The case of the character is preserved. ask_default_character(Spec, Spec) :- integer(Spec), !. ask_default_character([Spec|_], Spec) :- !. ask_default_character(Spec, Char) :- atom(Spec), name(Spec, [Char|_]). % ask(Question, Answer) % displays the Question on the terminal and reads a one-character % answer from the terminal. But because you normally have to type "X % " to get the computer to attend to you, it skips to the end of % the line. All the juggling with see and tell is to make sure that % i/o is done to the terminal even if your program is doing something % else. The character returned will have Ascii code in the range % 33..126 (that is, it won't be a space or a control character). ask(Question, Answer) :- talk_to_user_while(ask__1(Question, Answer)). ask__1(Question, Answer) :- write(Question), write('? '), ttyflush, get0(Char), ask__1(Char, Question, Answer). ask__1(Char, _, Answer) :- Char > 32, Char < 127, !, skip(31), Answer = Char. ask__1(31, Question, Answer) :- !, ask__1(Question, Answer). ask__1(_, Question, Answer) :- skip(31), ask__1(Question, Answer). % ask(Question, Default, Answer) % is like ask(Question, Answer) except thast if the user types a newline % the Default will be taken as the Answer. ask(Question, Default, Answer) :- ask_default_character(Default, DefChar), talk_to_user_while(ask__2(Question, DefChar, Answer)). ask__2(Question, Default, Answer) :- write(Question), write(' ['), put(Default), write(']? '), ttyflush, get0(Char), ask__2(Char, Question, Default, Answer). ask__2(Char, _, _, Answer) :- Char > 32, Char < 127, !, skip(31), Answer = Char. ask__2(31, _, Default, Answer) :- !, Answer = Default. ask__2(_, Question, Default, Answer) :- skip(31), ask__2(Question, Default, Answer). % yesno(Question) % asks the question, and succeeds if the answer is y or Y, fails if % the answer is n or N, and repeats the question if it is anything else. yesno(Question) :- talk_to_user_while(yesno__1(Question)). yesno__1(Question) :- write(Question), write('? '), ttyflush, get0(Char), Answer is Char\/32, % force lower case ( Char = 31 % end of line ; skip(31) % skip if it isn't ), !, yesno__1(Answer, Question). yesno__1(121/*y*/, _) :- !. yesno__1(110/*n*/, _) :- !, fail. yesno__1(_, Question) :- write('Please answer Yes or No.'), nl, yesno__1(Question). % yesno(Question, Default) % is like yesno(Question), except that if the user types a newline % without a Y or N the default will be used. It should of course % be y or n itself. yesno(Question, Default) :- ask_default_character(Default, DefChar), talk_to_user_while(yesno__2(Question, DefChar)). yesno__2(Question, Default) :- write(Question), write(' ['), put(Default), write(']? '), ttyflush, get0(Char), ( Char = 31, Answer = Default % end of line ; skip(31), Answer is Char\/32 % skip to eol ), !, yesno__2(Answer, Question, Default). yesno__2(121/*y*/, _, _) :- !. yesno__2(110/*n*/, _, _) :- !, fail. yesno__2(_, Question, Default) :- write('Please answer Yes or No.'), nl, yesno__2(Question, Default). EOF1ASK.PL 00010010000100 85045 99364 000011Unix V7 HDR1ASSOC.PL 00010011000100 85045 99364 000000Unix V7 % File : ASSOC.PL % Author : R.A.O'Keefe % Updated: 9 November 1983 % Purpose: Binary tree implementation of "association lists". % Note : the keys should be ground, the associated values need not be. :- public assoc_to_list/2, gen_assoc/3, get_assoc/3, list_to_assoc/2, map_assoc/3, put_assoc/4. :- mode assoc_to_list(+, -), assoc_to_list(+, -, +), gen_assoc(+, ?, ?), get_assoc(+, +, ?), get_assoc(+, +, +, +, +, ?), list_to_assoc(+, -), list_to_assoc(+, +, -, +), map_assoc(+, +, -), put_assoc(+, +, +, -), put_assoc(+, +, +,+,+,+, +, -). assoc_to_list(Assoc, List) :- assoc_to_list(Assoc, List, []). assoc_to_list(t(Key,Val,L,R), List, Rest) :- assoc_to_list(L, List, [Key-Val|More]), assoc_to_list(R, More, Rest). assoc_to_list(t, List, List). gen_assoc(t(_,_,L,_), Key, Val) :- gen_assoc(L, Key, Val). gen_assoc(t(Key,Val,_,_), Key, Val). gen_assoc(t(_,_,_,R), Key, Val) :- gen_assoc(R, Key, Val). get_assoc(Key, t(K,V,L,R), Val) :- compare(Rel, Key, K), get_assoc(Rel, Key, V, L, R, Val). get_assoc(=, _, Val, _, _, Val). get_assoc(<, Key, _, Tree, _, Val) :- get_assoc(Key, Tree, Val). get_assoc(>, Key, _, _, Tree, Val) :- get_assoc(Key, Tree, Val). list_to_assoc(List, Assoc) :- keysort(List, Keys), length(Keys, N), list_to_assoc(N, Keys, Assoc, []). list_to_assoc(0, List, t, List). list_to_assoc(N, List, t(Key,Val,L,R), Rest) :- A is (N-1)/2, Z is (N-1)-A, list_to_assoc(A, List, L, [Key-Val|More]), list_to_assoc(Z, More, R, Rest). map_assoc(Pred, t(Key,Val,L0,R0), t(Key,Ans,L1,R1)) :- !, map_assoc(Pred, L0, L1), apply(Pred, [Val,Ans]), map_assoc(Pred, R0, R1). map_assoc(_, t, t). put_assoc(Key, t(K,V,L,R), Val, New) :- compare(Rel, Key, K), put_assoc(Rel, Key, K, V, L, R, Val, New). put_assoc(Key, t, Val, t(Key,Val,t,t)). put_assoc(=, Key, _, _, L, R, Val, t(Key,Val,L,R)). put_assoc(<, Key, K, V, L, R, Val, t(K,V,Tree,R)) :- put_assoc(Key, L, Val, Tree). put_assoc(>, Key, K, V, L, R, Val, t(K,V,L,Tree)) :- put_assoc(Key, R, Val, Tree). EOF1ASSOC.PL 00010011000100 85045 99364 000005Unix V7 HDR1BACKUP.PL 00010012000100 85045 99364 000000Unix V7 % File : BACKUP.PL % Author : R.A.O'Keefe % Updated: 19 February 1984 % Purpose: Rename a file according to common "back up" convention. % Beware : this is Tops-10-specific. % This file MUST be compiled with TrySee.Pl, since it uses the routines % parse_file(-Device, -Name, -Extension, +String, +[]) % pack_file_title(+Device, +Name, +Extension, -String) % normalise_file_component(+String, +Length, -Truncated) % which are defined in that file. Herein is defined one predicate: % backup(FileName, BackUpExtn) % which checks whether a file named by FileName exists, and if so % tries to back it up. The BackUpExtn is the extension to be merged % with the extension of the file name, e.g. if it is "Q" and the file % was "Foo.Pl" the backup will be "Foo.Ql". Spaces at the end are % significant. For convenience, backup/1 is also defined. Note that % both these routines will succeed even if the file didn't exist. :- public backup/1, % backup(F) -> F.BAK backup/2. % backup(F,Ext) for e.g. Q convention :- mode backup(+), backup(+, +), backup_name(+, +, -), merge_extensions(+, +, -). backup(FileName) :- backup(FileName, "BAK"). backup(FileName, BackUpExtn) :- atom(BackUpExtn), name(BackUpExtn, BackUpString), !, backup(FileName, BackUpString). backup(FileName, BackUpExtn) :- \+ atom(FileName), !, ttynl, display('**error: '), display(backup(FileName,'_')), ttynl, fail. backup(FileName, BackUpExtn) :- seeing(OldFile), nofileerrors, see(FileName), !, fileerrors, seeing(NewFile), backup_name(NewFile, BackUpExtn, BackFile), rename(NewFile, BackFile), see(OldFile). backup(FileName, BackUpExtn) :- fileerrors. backup_name(OldFile, BackExtn, NewFile) :- name(OldFile, OldName), parse_file(Device, Name, Extension, OldName, []), normalise_file_component(BackExtn, 3, BackupExtension), merge_extensions(Extension, BackupExtension, NewExtension), pack_file_title(Device, Name, NewExtension, NewName), name(NewFile, NewName). merge_extensions([_|OldT], [NewH|NewT], [NewH|AnsT]) :- !, merge_extensions(OldT, NewT, AnsT). merge_extensions([], New, New). EOF1BACKUP.PL 00010012000100 85045 99364 000005Unix V7 HDR1BAGUTL.HLP 00010013000100 85045 99364 000000Unix V7 SRC Interactive Computing Facility Prolog Program LibrarySRC Interactive Computing Facility Prolog Program LibrarySRC Interactive Computing Facility Prolog Program Library SIG Artificial Intelligence BAGUTLSIG Artificial Intelligence BAGUTLSIG Artificial Intelligence BAGUTL Department of Artificial Intelligence Department of Artificial Intelligence Department of Artificial Intelligence University of Edinburgh University of Edinburgh University of Edinburgh BAG MANIPULATION UTILITY ROUTINES BAG MANIPULATION UTILITY ROUTINES BAG MANIPULATION UTILITY ROUTINES Source: R. A. O'Keefe Program Issued: 23 September 81 Documentation: 25 September 1981 1. Description1. Description1. Description Bags are a generalisation of sets, in which a given element may be present several times. Just as a set may be represented by its characteristic function (a mapping from some class to truth values), so may a bag be represented by its characteristic function, whose range is the non-negative integers. These routines manipulate Prolog data-structures encoding bags as tabular characteristic functions. X is an encoded bag if - it is the term 'bag', representing the empty bag. - it is the term bag(Element, Count, RestOfBag) where RestOfBag is a term representing a bag, Count is a (strictly) positive integer, and Element is any Prolog term. To make these representations canonical, Element must precede all the other elements of the bag, in the sense of '@<'. For example, the bag {a,b,c,d,c,a,d,c,a,e,d,c} would be represented by the Prolog term bag(a,3,bag(b,1,bag(c,4,bag(d,3,bag(e,1,bag))))). 2. How to Use the Program2. How to Use the Program2. How to Use the Program This library may already be loaded into UTIL. To see if it is, type 'listing(is_bag)' to UTIL. If it shows you any clauses, all these predicates should be available at once. Otherwise, you may either compile or consult the file 'Util:BagUtl.Pl'. The following predicates are then available. bag_inter(+Bag1, +Bag2, -Inter) takes the intersection of two bags. The count of an element in the result is the minimum of its count in Bag1 and its count in Bag2. bag_to_list(+Bag, -List) converts a Bag to a List. Each element of the Bag will appear in the List as many times as it occurs in {the abstract value of} the Bag. E.g. [% a:2, b:3, c:1 %] => [a,a, b,b,b, c]. BAGUTL - 2 - bag_to_set(+Bag, -SetList) converts a Bag to a Set, i.e. to a List in which each element of the Bag occurs exactly once. bag_union(+Bag1, +Bag2, -Union) takes the union of two bags. The count of an element in the result is the sum of its count in Bag1 and its count in Bag2. bagmax(+Bag, ?Elem) unifies Elem with that element of Bag which has the greatest not not count. NB: this is not an ordering on the elements themselves, but the ordinary arithmetic ordering on their frequencies. Predicates to select the alphabetically (@<) least and greatest elements could be supplied if anyone wanted them. bagmax returns the commonest one. bagmin(+Bag, ?Elem) unifies Elem with that element of Bag which has the least count. In other words, with the rarest object actually in the Bag. checkbag(+Pred, +Bag) is an analogue of checklist for bags. It succeeds if Pred(Elem,Count) is true for every element of the Bag and its associated Count. is_bag(+Bag) succeeds if Bag is a well-formed bag representation. Not all terms which resemble bags are bags: bag(1,a,bag) is not {'a' is not a positive integer} and bag(b,1,bag(a,1,bag)) is not {'b' is not alphabetically less than 'a}. length(+Bag, -Total, -Distinct) unifies Distinct with the number of distinct elements in the Bag and Total with the sum of their counts. Hence Total >= Distinct. This name was chosen to agree with the notation for lists (sets). list_to_bag(+List, -Bag) converts a List to a Bag. The elements of the list do not need to be in any special order. make_sub_bag(+Bag, -SubBag) A sub_bag predicate would have two uses: testing whether one already existing bag is a sub-bag of another, and generating ____ the sub-bags of a given bag. Since bags have so many sub-bags, this second use is likely to be rare, and has been split out as make_sub_bag. Given a Bag, make_sub_bag will backtrack through all its SubBags. mapbag(+Pred, +BagIn, -BagOut) is analogous to maplist. It applies Pred(Element,Transformed) to each element of the Bag, generating a transformed bag. The counts are not given to Pred, but are preserved. If several elements are mapped to the same transformed element, their counts will be added, so the result will always be a proper bag. For the same reason, the order of results in the answer - 3 - BAGUTL will be alphabetic, rather than the order of the elements in the input bag. member(?Elem, -Count, +Bag) can be used to backtrack through all the members of a bag or to test whether some specific object is in a bag. In either case Count is set to the element's count. NB if Elem is not an not not element of the bag, member will not unify Count with 0, it will fail fail fail. portray_bag(+Bag) These predicates assume that people will never want to type bags, but will always create them using bag utilities. Hence the internal representation is meant for efficiency rather than readability. If you add the clause portray(Bag) :- portray_bag(Bag). to your program you will get a prettier 'print'ed form (but not a 'write'n form, alas). A bag is printed between '[%' and '%]', with elements followed by a colon and their count, and separated by commas. For example, ?- list_to_bag([a,c,d,e,f,a,f,d,c,d,e,f,s], B). B = [% a:2, c:2, d:3, e:2, f:3, s:1 %] test_sub_bag(+SubBag, +Bag) tests whether SubBag is a sub bag of Bag. This is redundant, as test_sub_bag_2(Sb, Bg) :- bag_inter(Sb, Bg, In), In = Sb. It is cheaper and clearer to use test_sub_bag. 3. Program Requirements3. Program Requirements3. Program Requirements checkbag and mapbag require the utility apply/2. No other utilities are used, but BagUtl cannot be used with versions of Prolog prior to Version 3. The database is not affected. The compiled code occupies about 2k. EOF1BAGUTL.HLP 00010013000100 85045 99364 000017Unix V7 HDR1BAGUTL.PL 00010014000100 85045 99364 000000Unix V7 % File : BAGUTL.PL % Author : R.A.O'Keefe % Updated: 18 February 1984 % Purpose: Bag Utilities /* A bag B is a function from a set dom(B) to the non-negative integers. For the purposes of this module, a bag is constructed from two functions: bag - creates an empty bag bag(E, M, B) - extends the bag B with a new (NB!) element E which occurs with multiplicity M, and which precedes all elements of B in Prolog's order. A bag is represented by a Prolog term mirroring its construction. There is one snag with this: what are we to make of bag(f(a,Y), 1, bag(f(X,b), 1, bag)) ? As a term it has two distinct elements, but f(a,b) will be reported as occurring in it twice. But according to the definition above, bag(f(a,b), 1, bag(f(a,b), 1, bag)) is not the representation of any bag, that bag is represented by bag(f(a,b), 2, bag) alone. We are apparently stuck with a scheme which is only guaranteed to work for "sufficiently instantiated" terms, but then, that's true of a lot of Prolog code. The reason for insisting on the order is to make union and intersection linear in the sizes of their arguments. */ :- public bag_inter/3, bag_to_list/2, bag_to_set/2, bag_union/3, bagmax/2, bagmin/2, checkbag/2, is_bag/1, length/3, list_to_bag/2, make_sub_bag/2, mapbag/3, member/3, member/3, portray_bag/1, test_sub_bag/2. :- mode addkeys(+, -), bag_inter(+, +, -), bag_inter(+, +, +, +, +, +, +, -), bag_scan(+, +, +, -, +), bag_to_list(+, -), bag_to_list(+, +, -, -), bag_to_set(+, -), bag_union(+, +, -), bag_union(+, +, +, +, +, +, +, -), bagform(+, -), bagform(?, +, -, +, -), bagmax(+, -), bagmin(+, -), checkbag(+, +), countdown(+, -), is_bag(+), is_bag(+, +), length(+, -, -), length(+, +, -, +, -), list_to_bag(+, -), make_sub_bag(+, -), mapbag(+, +, -), mapbaglist(+, +, -), member(?, ?, +), memberchk(+, ?, +), portray_bag(+), portray_bag(+, +, +), portray_bag(+, +), test_sub_bag(+, +), test_sub_bag(+, +, +, +, +, +, +). is_bag(bag). is_bag(bag(E,M,B)) :- integer(M), M > 0, is_bag(B, E). is_bag(bag, _). is_bag(bag(E,M,B), P) :- E @> P, integer(M), M > 0, is_bag(B, E). portray_bag(bag(E,M,B)) :- write('[% '), portray_bag(E, M, B), write(' %]'). portray_bag(bag) :- write('[% '), write(' %]'). portray_bag(E, M, B) :- var(B), !, portray_bag(E, M), write(' | '), write(B). portray_bag(E, M, bag(F,N,B)) :- !, portray_bag(E, M), write(', '), portray_bag(F, N, B). portray_bag(E, M, bag) :- !, portray_bag(E, M). portray_bag(E, M, B) :- portray_bag(E, M), write(' | '), write(B). portray_bag(E, M) :- print(E), write(':'), write(M). % If bags are to be as useful as lists, we should provide mapping % predicates similar to those for lists. Hence % checkbag(Pred, Bag) - applies Pred(Element, Count) % mapbag(Pred, BagIn, BagOut) - applies Pred(Element, Answer) % Note that mapbag does NOT give the Count to Pred, but preserves it. % It wouldn't be hard to apply Pred to four arguments if it wants them. checkbag(Pred, bag). checkbag(Pred, bag(E,M,B)) :- apply(Pred, [E, M]), checkbag(Pred, B). mapbag(Pred, BagIn, BagOut) :- mapbaglist(Pred, BagIn, Listed), keysort(Listed, Sorted), bagform(Sorted, BagOut). mapbaglist(Pred, bag, []). mapbaglist(Pred, bag(E,M,B), [R-M|L]) :- apply(Pred, [E, R]), mapbaglist(Pred, B, L). bag_to_list(bag, []). bag_to_list(bag(E,M,B), R) :- bag_to_list(M, E, L, R), bag_to_list(B, L). bag_to_list(0, _, L, L) :- !. bag_to_list(M, E, L, [E|R]) :- N is M-1, bag_to_list(N, E, L, R). list_to_bag(L, B) :- addkeys(L, K), keysort(K, S), bagform(S, B). addkeys([], []). addkeys([Head|Tail], [Head-1|Rest]) :- addkeys(Tail, Rest). bagform([], bag) :- !. bagform(List, bag(E,M,B)) :- bagform(E, List, Rest, 0, M), !, bagform(Rest, B). bagform(Head, [Head-N|Tail], Rest, K, M) :-!, L is K+N, bagform(Head, Tail, Rest, L, M). bagform(Head, Rest, Rest, M, M). bag_to_set(bag, []). bag_to_set(bag(E,_,B), [E|S]) :- bag_to_set(B, S). /* There are two versions of the routines member, bagmax, and bagmin. The slow versions, which are commented out, try to allow for the possibility that distinct elements in the bag might unify, while the faster routines assume that all elements are ground terms. member(E, M, bag(E,K,B)) :- member(B, E, K, M). member(E, M, bag(_,_,B)) :- member(E, M, B). member(bag(E,L,B), E, K, M) :- !, N is K+L, member(B, E, N, M). member(bag(_,_,B), E, K, M) :- member(B, E, K, M). member(bag, E, M, M). % These routines are correct, but Oh, so costly! bagmax(B, E) :- member(E, M, B), \+ (member(F, N, B), N > M). bagmin(B, E) :- member(E, M, B), \+ (member(F, N, B), N < M). *//* The faster versions follow */ member(Element, Multiplicity, bag(Element,Multiplicity,_)). member(Element, Multiplicity, bag(_,_,Bag)) :- member(Element, Multiplicity, Bag). memberchk(Element, Multiplicity, bag(Element,Multiplicity,_)) :- !. memberchk(Element, Multiplicity, bag(_,_,Bag)) :- memberchk(Element, Multiplicity, Bag). bagmax(bag(E,M,B), Emax) :- bag_scan(B, E, M, Emax, >). bagmin(bag(E,M,B), Emin) :- bag_scan(B, E, M, Emin, <). bag_scan(bag(Eb,Mb,B), Ei, Mi, Eo, C) :- compare(C, Mb, Mi), !, bag_scan(B, Eb, Mb, Eo, C). bag_scan(bag(Eb,Mb,B), Ei, Mi, Eo, C) :- bag_scan(B, Ei, Mi, Eo, C). /* bag_scan(bag(Eb,Mb,B), Ei, Mi, Eo, C) :- bag_scan(B, Eb, Mb, Eo, C). % for all extrema */ bag_scan(bag, Ei, Mi, Ei, C). length(B, BL, SL) :- length(B, 0, BL, 0, SL). length(bag, BL, BL, SL, SL). length(bag(_,M,B), BA, BL, SA, SL) :- BB is BA+M, SB is SA+1, length(B, BB, BL, SB, SL). % sub_bag, if it existed, could be used two ways: to test whether one bag % is a sub_bag of another, or to generate all the sub_bags. The two uses % need different implementations. make_sub_bag(bag, bag). make_sub_bag(bag(E,M,B), bag(E,N,C)) :- countdown(M, N), make_sub_bag(B, C). make_sub_bag(bag(_,_,B), C) :- make_sub_bag(B, C). countdown(M, M). countdown(M, N) :- M > 1, K is M-1, countdown(K, N). test_sub_bag(bag, _). test_sub_bag(bag(E1,M1,B1), bag(E2,M2,B2)) :- compare(C, E1, E2), test_sub_bag(C, E1, M1, B1, E2, M2, B2). test_sub_bag(>, E1, M1, B1, E2, M2, B2) :- test_sub_bag(bag(E1, M1, B1), B2). test_sub_bag(=, E1, M1, B1, E1, M2, B2) :- M1 =< M2, test_sub_bag(B1, B2). bag_union(bag(E1,M1,B1), bag(E2,M2,B2), B3) :- compare(C, E1, E2), !, bag_union(C, E1, M1, B1, E2, M2, B2, B3). bag_union(bag, Bag, Bag) :- !. bag_union(Bag, bag, Bag). bag_union(<, E1, M1, B1, E2, M2, B2, bag(E1,M1,B3)) :- bag_union(B1, bag(E2, M2, B2), B3). bag_union(>, E1, M1, B1, E2, M2, B2, bag(E2,M2,B3)) :- bag_union(bag(E1, M1, B1), B2, B3). bag_union(=, E1, M1, B1, E1, M2, B2, bag(E1,M3,B3)) :- M3 is M1+M2, bag_union(B1, B2, B3). bag_inter(bag(E1,M1,B1), bag(E2,M2,B2), B3) :- compare(C, E1, E2), !, bag_inter(C, E1, M1, B1, E2, M2, B2, B3). bag_inter(_, _, bag). bag_inter(<, E1, M1, B1, E2, M2, B2, B3) :- bag_inter(B1, bag(E2,M2,B2), B3). bag_inter(>, E1, M1, B1, E2, M2, B2, B3) :- bag_inter(bag(E1,M1,B1), B2, B3). bag_inter(=, E1, M1, B1, E1, M2, B2, bag(E1, M3, B3)) :- ( M1 < M2, M3 = M1 ; M3 = M2 ), !, bag_inter(B1, B2, B3). EOF1BAGUTL.PL 00010014000100 85045 99364 000015Unix V7 HDR1BETWEE.PL 00010015000100 85045 99364 000000Unix V7 % File : BETWEEN.PL % Author : R.A.O'Keefe % Updated: 4 October 1984 % Purpose: Generate integers. :- public between/3, gen_arg/3, gen_int/1, gen_nat/1, repeat/1. :- mode between(+, +, ?), between1(+, +, -), gen_arg(?, +, ?), gen_int(?), gen_nat(?), gen_nat(+, -), repeat(+). between(L, U, N) :- nonvar(N), !, integer(L), integer(U), integer(N), L =< N, N =< U. between(L, U, N) :- integer(L), integer(U), L =< U, between1(L, U, N). between1(L, _, L). between1(L, U, N) :- L < U, M is L+1, between1(M, U, N). % gen_arg(N, Term, Arg) % is exactly like arg(N, Term, Arg), except that it will generate % solutions for N by backtracking (will work when N is a variable). gen_arg(N, Term, Arg) :- functor(Term, _, Arity), between(1, Arity, N), arg(N, Term, Arg). gen_nat(N) :- % gen-erate nat-ural nonvar(N), % if we aren't to generate it !, % demand that it is an integer integer(N), N >= 0. % and non-negative. gen_nat(N) :- % otherwise, generate an gen_nat(0, N). % integer >= 0 gen_nat(L, L). gen_nat(L, N) :- % generate natural > L M is L+1, gen_nat(M, N). % generate natural >= M gen_int(I) :- % gen-erate int-eger nonvar(I), % if we aren't to generate it !, % demand that it is an integer. integer(I). gen_int(0). % generate 0 gen_int(I) :- % generate +/- N for N > 0 gen_nat(1, N), ( I = N ; I is -N ). repeat(N) :- telling(Old), tell(user), write('It is pointlessly stupid to use repeat/1.'), nl, write('Why don''t you use between/3 instead, fathead?'), nl, tell(Old), between(1, N, _). EOF1BETWEE.PL 00010015000100 85045 99364 000004Unix V7 HDR1BUNDLE.PL 00010016000100 85045 99364 000000Unix V7 % File : BUNDLE.PL % Author : R.A.O'Keefe % Updated: 22 September 1984 % Purpose: Bundle and Unbundle files. % Needs : append/3 and reverse/2 from LISTUT.PL (lib(lists)). /* This file defines two commands: bundle [ = , ..., = ]. unbundle . The former writes, for each of the files in turn, %?BEGIN -- {contents of file } %?ENDOF -- There is no special mark at the beginning or end of the file. The latter reads the , and writes every %?BEGIN..%?ENDOF section to a file whose name is the given label. If you omit a