/* CUGINI.PL
Shelved on the 12th of December 1987.
Updated on the 30th of July, 1988, with a new copy from John Cugini.
*/
/*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% */
/* */
/* NBS/ICST Prolog Utility Library */
/* version date: December 8, 1987 */
/* */
/* developed by: */
/* */
/* John Cugini */
/* Institute for Computer Sciences and Technology */
/* National Bureau of Standards */
/* */
/* Product of US Government: not subject to copyright */
/* */
/* This file contains various utility predicates, some commonly used, */
/* some not. They deal with lists, structures, I/O, sets, numeric */
/* facilities, and some extensions of logic and control. This library */
/* is written in and for the C-Prolog dialect of Prolog. */
/* */
/* Many of these predicates expect certain of their arguments to be */
/* instantiated upon invocation. When such restrictions apply it is */
/* usually the leading arguments which are thought of as input (and */
/* hence instantiated), and the trailing arguments as output (and hence */
/* allowed to be uninstantiated). */
/* */
/* There is a coding convention: the user-callable version of the */
/* predicate has a plain name. If this predicate needs sub-predicates, */
/* based on whether certain arguments are instantiated or not, the names */
/* of the sub-predicates are formed by appending a string of c,v, or */
/* x's, where c indicates argument must be constant (instantiated), v */
/* that it must be a variable, and x that it may be either. */
/* */
/* Further, each main predicate is preceded by documentation lines, */
/* which describe the declarative meaning of the predicate, and which */
/* arguments must be instantiated. */
/* */
/* The overall organization of the library is: */
/* */
/* Basic predicates */
/* Lists */
/* Structures */
/* Input/Output */
/* Sets */
/* Numeric */
/* Control */
/* Extended Logic */
/* */
/* Each section is prefaced by a header with lots of asterisks */
/* */
/* [JNP...] */
/* I've replaced %% comments by star-slash ones. To undo the replacement */
/* globally edit out all star-slashes, and replace all slash-stars by */
/* percents. */
/* */
/* I've also replaced all ~ by ^ (they were used for exponentiation). */
/* That they were ~ may have been a character translation occurring in */
/* file transfer from John, since they were ^ anyway in the older version */
/* that Bert Shure sent me. */
/* */
/* And I've added to 'delete' a change that Bert Shure made to the older */
/* version. */
/* */
/* Some Prologs may lack the (X->Y;Z) construction which this library */
/* uses. You can define it by: */
/* (X -> Y); Z :- X, !, Y. */
/* (X -> Y); Z :- !, Z. */
/* */
/* Other problems you may have with portability: */
/* */
/* (1) 'float' assumes a predicate called number(T), which succeeds iff */
/* its argument is a number (integer or real). Its name may be different */
/* on other systems. */
/* */
/* (2) character codes 10 (end-of-line) and 26 (end-of-file) in */
/* 'readline'. */
/* */
/* (3) character codes in 'print_string'. */
/* */
/* (4) put(46) and the filename in 'ed'. */
/* */
/* (5) the filename in 'full_name'. */
/* */
/* [...JNP] */
/* */
/*%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%*/
/* ************ Basic Predicates ************* */
/* The following predicates test the type of the term passed */
/* to them, using the terminology of the C-Prolog manual. */
term(Term).
simple(Term) :- atomic(Term); var(Term).
compound(Term) :- not(simple(Term)).
literal(Term) :- nonvar(Term),
functor(Term, Name, _),
atom(Name).
float(Term) :- number(Term), not(integer(Term)).
rational(Term) :- integer(Term); ratio(Term).
ratio(Num/Den) :- integer(Num), integer(Den).
/* constant_term(Term) iff Term is currently instantiated and all */
/* of its arguments, sub-arguments, etc. are constant. */
constant_term(Term) :-
atomic(Term) -> true;
(nonvar(Term),
Term =.. [Functor | Args],
all(constant_term, Args)).
/* instantiation(Term, Type) iff Type describes the instantiation state */
/* of Term: constant (completely ground), partial, or var. */
instantiation(Term, Type) :-
var(Term) -> Type = var;
constant_term(Term) -> Type = constant;
Type = partial.
/* ************* Lists ************** */
/* islist(X) iff X is a list. (Really just checks for [] or that */
/* main functor is '.'). */
islist([]) :- !.
islist([_|_]).
/* is_real_list(X) iff X is a properly formed list. Does not allow */
/* "dotted" lists, a la [a|b], as does islist. */
is_real_list([]) :- !.
is_real_list([_ | Rest]) :- is_real_list(Rest).
/* non_null_list(List) iff List is a real list containing at least */
/* one element. */
non_null_list([_ | Rest]) :- is_real_list(Rest).
/* member(Elem, List) iff Elem is a member of List. */
member(Elem, [Elem | _]).
member(Elem, [_ | Rest_of_list]) :- member(Elem, Rest_of_list).
/* member_rest(Elem, List, Rest) iff Elem is a member of List and */
/* Rest is the rest of the list following Elem. */
member_rest(Elem, [Elem | Rest], Rest).
member_rest(Elem, [_ | Rest], Rest_rest) :-
member_rest(Elem, Rest, Rest_rest).
/* append(First_part, Second_part, List) iff List is the */
/* concatenation of the first two arguments. */
append([], List, List).
append([Elem | First_part], Second_part, [Elem | List]) :-
append(First_part, Second_part, List).
/* append_n(L1, L2) iff L1 is a list of lists, which, if concatenated, */
/* is L2. When L1 is var, no null lists are generated for it, even */
/* though logically they could appear anywhere. Thus, this isn't */
/* symmetric, in that L1=[[],[1]] will generate L2=[1], but not */
/* vice-versa. Note especially that L1=[[]] will generate L2=[], but */
/* not the reverse. L1 and L2 can be partially instantiated, and this */
/* usually works. NG if both args are var. */
/* avoid generating the null list in arg1. */
append_n([List1], List2) :-
not((var(List1), List2 == [])),
List1=List2.
append_n([SL1, SL2 | Rest], List) :-
(var(SL1) -> V=t; V=f),
append(SL1, Right_part, List),
not((V=t, SL1=[])),
append_n([SL2 | Rest], Right_part).
/* delete(Elem, Old_list, New_list) iff New_list equals Old_list except */
/* for the removal of all occurrences of Elem. NG if arg2 is var. */
/* The "true" in the else part of the "if-then" was added by Bert Shure on */
/* July 7, 87 - to avoid an error from the BIM_Prolog compiler */
delete(Elem, Old, New) :-
(var(Elem) -> (remove_dupl(Old, Smaller_old),
member(Elem, Smaller_old)
);
true /*Elem=X dummy statement to fill else-part */
),
delete_c(Elem, Old, New).
delete_c(_, [], []).
delete_c(Elem1, [Elem2 | Rest_of_old], New_list) :-
Elem1 = Elem2 -> (delete_c(Elem1, Rest_of_old, New_list)
);
(New_list = [Elem2 | Rest_of_new],
delete_c(Elem1, Rest_of_old, Rest_of_new)
).
/* delete_all(Del_list, Old_list, New_list) iff New_list equals Old_list */
/* except for the removal of any occurrences of any elements of Del_list. */
/* NG if arg1 or 2 is var. */
delete_all([], L, L).
delete_all([E | R_del], Old_list, New_list) :-
delete(E, Old_list, M),
delete_all(R_del, M, New_list).
/* remove_dupl(List, Shriven_list) iff Shriven_list equals List */
/* in same order, sans leading duplicate members. Ie, only the */
/* rightmost of duplicate members remain. NG if arg1 is var. */
remove_dupl([],[]).
remove_dupl([Elem | Rest_list], Rest_shriven) :-
member(Elem, Rest_list),
!,
remove_dupl(Rest_list, Rest_shriven).
remove_dupl([Elem | Rest_list], [Elem | Rest_shriven]) :-
remove_dupl(Rest_list, Rest_shriven).
/* no_dupls(List) iff List is a list with no duplicate elements. */
/* NG if arg1 is var. */
no_dupls([]).
no_dupls([Elem | Rest]) :-
not(member(Elem, Rest)),
no_dupls(Rest).
/* ordered(List) iff List is a list whose elements are in non- */
/* decreasing order. NG if List is var. */
ordered([]).
ordered([Elem]).
ordered([Elem1, Elem2 | Rest]) :-
Elem1 @=< Elem2,
!,
ordered([Elem2 | Rest]).
/* last(Elem, List) iff Elem is the last element in List. */
last(Elem, [Elem]).
last(Elem, [_ | Rest]) :- last(Elem, Rest).
/* next_to(X,Y,L) iff X and Y are adjacent in list L. */
next_to(X, Y, [X,Y | _]).
next_to(X, Y, [_ | Rest]) :- next_to(X, Y, Rest).
/* precedes(A,B,List) iff A and B are both members of List and A precedes B*/
/* within the List. NG if List is var. */
precedes(A,B,List) :-
member_rest(A,List,Rest),
member(B,Rest).
/* succeeds(A,B,List) iff A and B are both members of List and A follows B*/
/* within the List. NG if List is var. */
succeeds(A,B,List) :-
precedes(B,A,List).
/* naive_reverse(List1, List2) iff List1 is List2 in reverse order. */
/* naive_reverse takes n^2 + 3*n + 2 steps for a list of n elements. */
/* NG if arg1 is var. */
naive_reverse([], []) :- !.
naive_reverse([Head | Tail], List) :-
naive_reverse(Tail, Liat), append(Liat, [Head], List).
/* reverse(List1, List2) iff List1 is List2 in reverse order. */
/* reverse takes 2*n + 2 steps for a list of n elements. */
/* NG if both args are var. */
reverse(List1,List2) :- reverse_1(List1, [], List2).
reverse_1([], List2, List2) :- !.
reverse_1([Head | Tail], So_far, List2) :-
reverse_1(Tail, [Head | So_far], List2).
/* efface(Elem, Old_list, New_list) iff New_list = Old_list */
/* with first occurrence of Elem removed. NG if more than */
/* one arg is var. */
efface(Elem, [Elem | Rest], Rest) :- !.
efface(Elem, [Non_elem | Old_rest], [Non_elem | New_rest]) :-
not(Elem = Non_elem),
efface(Elem, Old_rest, New_rest).
/* insert(Elem, List, Bigger_list) iff Bigger_list = List plus */
/* Elem inserted somewhere. This can also be used to select */
/* non-deterministically Elem from Bigger_list and return Elem */
/* and the remaining List. NG if all args are var. */
insert(Elem, List, [Elem | List]).
insert(Elem, [Non_elem | List], [Non_elem | Bigger_list]) :-
insert(Elem, List, Bigger_list).
/* subst(Old_elem, Old_list, New_elem, New_list) iff New_list equals */
/* Old_list except for the substitution of New_elem for any */
/* occurrences of Old_elem. NG for arg1;2;3 var. */
subst(_, [], _, []).
subst(Old_elem, [Old_elem | Rest_of_old],
New_elem, [New_elem | Rest_of_new]) :-
!, subst(Old_elem, Rest_of_old, New_elem, Rest_of_new).
subst(Old_elem, [Non_elem | Rest_of_old],
New_elem, [Non_elem | Rest_of_new]) :-
subst(Old_elem, Rest_of_old, New_elem, Rest_of_new).
/* prefix(Part, Whole) iff Part is a leading substring of Whole. */
prefix([], _).
prefix([Elem | Rest_of_part], [Elem | Rest_of_whole]) :-
prefix(Rest_of_part, Rest_of_whole).
/* suffix(Part, Whole) iff Part is a trailing substring of Whole. */
suffix(List, List) :- islist(List).
suffix(Part, [Elem | Rest_of_whole]) :- suffix(Part, Rest_of_whole).
/* trim(List, Elem, Ans) iff Ans is List with all leading and */
/* trailing occurrences of Elem removed. NG if arg1 or arg2 */
/* is var. */
trim(List, Elem, Ans) :-
trim_left(List, Elem, Temp),
trim_right(Temp, Elem, Ans).
/* trim_left(List, Elem, Ans) iff Ans is List with all leading */
/* occurrences of Elem removed. NG if arg1 or arg2 is var. */
trim_left([Elem | Rest], Elem, Ans) :-
trim_left(Rest, Elem, Ans), !.
trim_left(List, _, List).
/* trim_right(List, Elem, Ans) iff Ans is List with all trailing */
/* occurrences of Elem removed. NG if arg1 or arg2 is var. */
trim_right([], _, []) :- !.
trim_right([Elem | Rest], Elem, []) :-
trim_right(Rest, Elem, []), !.
trim_right([Arb | Rest], Elem, [Arb | Rest_Trim]) :-
trim_right(Rest, Elem, Rest_Trim).
/* sublist(List, Start, End, Sublist) iff Sublist is a contiguous */
/* sub-list within List, starting at position Start, and ending at */
/* position End. Note that [] is a valid sublist, so for */
/* List = [1,2], valid solutions are: */
/* */
/* Start End Sublist */
/* 1 0 [] */
/* 1 1 [1] */
/* 1 2 [1,2] */
/* 2 1 [] */
/* 2 2 [2] */
/* 3 2 [] */
/* */
/* NG if arg1 is var. */
sublist(List, Start, End, Sublist) :-
prefix(Sublist, List),
Start = 1,
length(Sublist, End).
sublist([Elem | Rest], Start, End, Sublist) :-
sublist(Rest, Startx, Endx, Sublist),
Start is Startx + 1,
End is Endx + 1.
/* matchlist(List1, List2, Common, New1, New2) iff List1 and */
/* List2 are sorted instantiated lists (possibly with repetitions) */
/* and Common is a list of their matching elements, and New1 and New2 */
/* are List1 and List2 minus the matching elements in Common, eg: */
/* matchlist([1,2,3,3,3,4,5,5,6], [3,3,4,4,5,5], [3,3,4,5,5], */
/* [1,2,3,6], [4]) is true. NG if Arg1 or Arg2 */
/* is var or unsorted. */
matchlist([], List2, [], [], List2) :- !.
matchlist([Elem | Rest], [], [], [Elem | Rest], []) :- !.
matchlist([Elem | Rest1], [Elem | Rest2], [Elem | Com_Rest], New1, New2) :-
matchlist(Rest1, Rest2, Com_Rest, New1, New2), !.
matchlist([El1 | Rest1], [El2 | Rest2], Com, New1, New2) :-
(El1 @< El2 ->
(matchlist(Rest1, [El2 | Rest2], Com, New_Rest1, New2),
New1 = [El1 | New_Rest1]);
(matchlist([El1 | Rest1], Rest2, Com, New1, New_Rest2),
New2 = [El2 | New_Rest2])
),
!.
/* list_length(List, Number) iff List has Number elements. */
/* NG if arg1 is var. Note that, apparently, C-Prolog has an */
/* undocumented evaluable predicate, length(List, Number). */
list_length([], 0).
list_length([Elem | Rest], Number) :-
list_length(Rest, N_minus),
Number is N_minus + 1.
/* position(List, Elem, Number) iff Elem is in position Number */
/* in the List. NG if arg1 is var. */
position([Elem | Rest], Elem, 1).
position([_ | Rest], Elem, Number) :-
var(Number) -> (position(Rest, Elem, N_minus),
Number is N_minus + 1);
(N_minus is Number - 1,
position(Rest, Elem, N_minus),
!).
/* repeat_list(Elem, Number, List) iff List is a list of Elem */
/* repeated Number times. No var restrictions. */
repeat_list(Elem, Number, List) :-
(nonvar(Number), var(List)) ->
repeat_list_xcv(Elem, Number, List);
repeat_list_xxx(Elem, Number, List).
repeat_list_xcv(Elem, 0, []).
repeat_list_xcv(Elem, N, [Elem | Rest]) :-
N_minus is N - 1,
!,
N_minus > -1,
repeat_list_xcv(Elem, N_minus, Rest).
repeat_list_xxx(Elem, 0, []).
repeat_list_xxx(Elem, N, [Elem | Rest]) :-
repeat_list_xxx(Elem, N_minus, Rest),
N is N_minus + 1.
/* circular_list(List, Circle) iff Circle is a circular (infinite) list */
/* formed from List, eg. if List = [1,2,3], Circle = [1,2,3,1,2,3,1,2,...].*/
/* Exercise extreme caution - do not try to print Circle, nor rely on it */
/* to terminate recursion. NG if arg1 is var. */
circular_list(List,Circle) :-
de_tail(List, Circle, Tail),
Tail = Circle.
/* de_tail(List1, List2, Tail) iff List1 = List2, except for the */
/* terminating [] in List1, which is replaced by the uninstantiated */
/* variable Tail in List2. */
de_tail([Elem], [Elem | Tail], Tail) :- !.
de_tail([Elem | Rest], [Elem | Var_rest], Tail) :-
de_tail(Rest, Var_rest, Tail).
/* permute(List1, List2) iff List1 is a permutation of List2. */
/* NG if arg1 is var. */
permute(Whole, [Elem | Rest_of_part]) :-
insert(Elem, Reduced_whole, Whole),
permute(Reduced_whole, Rest_of_part).
permute([], []).
/* reduce_left(Bin_op, List, Ans) iff Ans is the result of applying */
/* Bin_op, left-associatively, to the elements of List. NG if */
/* arg1 or arg2 is var, or if List contains fewer than two */
/* elements. Bin_op must take three arguments and return its */
/* result in the third, based on the value of the first two. */
/* If ID is an identity element for Bin_op, and the List */
/* may contain only one element, invoke with: */
/* reduce_left(Bin_op, [ID | List], Ans). To allow a null list to */
/* return ID, invoke with: reduce_left(Bin_op, [ID, ID | List], Ans). */
reduce_left(Bin_op, [El1, El2 | Rest], Ans) :-
Callit =.. [Bin_op, El1, El2, Temp],
Callit,
(Rest = [] ->
Ans = Temp;
reduce_left(Bin_op, [Temp | Rest], Ans)
).
/* reduce_right(Bin_op, List, Ans) - just like reduce_left, except */
/* it's right-associative. */
reduce_right(Bin_op, [El1, El2], Ans) :-
Callit =.. [Bin_op, El1, El2, Ans],
Callit,
!.
reduce_right(Bin_op, [Elem | Rest], Ans) :-
reduce_right(Bin_op, Rest, Sub_ans),
Callit =.. [Bin_op, Elem, Sub_ans, Ans],
Callit.
/* maplist(Pred, Old, New) iff for each corresponding element in */
/* Old and New, Pred(Old, New) is true. NG if arg1 is var. */
maplist(_, [], []).
maplist(Pred, [Elem_old | Rest_of_old], [Elem_new | Rest_of_new]) :-
Pred_call =.. [Pred, Elem_old, Elem_new], /* constructs predicate */
Pred_call, /* invokes constructed predicate */
maplist(Pred, Rest_of_old, Rest_of_new).
/* maplist_2(Pred, L1, L2, L3) iff L1, L2, and L3 are lists of equal length*/
/* and for each element (E1, E2, E3) in corresponding positions in the */
/* lists, Pred(E1, E2, E3) is true. Thus, E3 should be a function of E1 */
/* and E2 - if there is more than one solution, only the first will be */
/* used. NG if arg1 is var. Whether arg2 or arg3 can be var depends on */
/* the nature of Pred. */
maplist_2(_, [], [], []).
maplist_2(Pred, [Elem1 | Rest1], [Elem2 | Rest2], [Elem3 | Rest3]) :-
Pred_call =.. [Pred, Elem1, Elem2, Elem3],
Pred_call,
!,
maplist_2(Pred, Rest1, Rest2, Rest3).
/* for_all(Op_list, Pre_list, Post_list) iff a predicate is */
/* successfully invoked for each member of Op_List. Each */
/* predicate is formed by pre-pending Pre_list to a member */
/* of Op_List, appending Post_list to it, and then forming */
/* the corresponding functor. */
/* */
/* Thus, for_all([a,b,c], [wiggle,x], [y]) will invoke: */
/* wiggle(x, a, y) */
/* wiggle(x, b, y) */
/* wiggle(x, c, y). */
/* */
/* and for_all([number, atomic], [], [A]) will invoke: */
/* number(A) */
/* atomic(A). */
for_all([], _, _).
for_all([Op | Rest_Ops], Pre_list, Post_list) :-
append(Pre_list, [Op | Post_list], Pred_list),
Pred =.. Pred_list,
!,
Pred,
for_all(Rest_Ops, Pre_list, Post_list).
/* maxlist(List, Max) iff Max is the highest value in a List of numbers. */
/* NG if arg1 is var. */
maxlist([Elem], Elem).
maxlist([Elem | Rest], Max) :-
maxlist(Rest, Rmax),
(Elem > Rmax -> Max = Elem; Max = Rmax).
/* minlist(List, Min) iff Min is the lowest value in a List of numbers. */
/* NG if arg1 is var. */
minlist([Elem], Elem).
minlist([Elem | Rest], Min) :-
minlist(Rest, Rmin),
(Elem < Rmin -> Min = Elem; Min = Rmin).
/* bestlist(List, Pred, Best) iff Best is the best value in a List, */
/* according to some binary predicate Pred(A,B), which succeeds iff */
/* A is better than B. NG if arg1 or arg2 is var. */
bestlist([Elem], _, Elem).
bestlist([Elem | Rest], Pred, Best) :-
bestlist(Rest, Pred, Rbest),
Call =.. [Pred, Elem, Rbest],
(Call -> Best = Elem; Best = Rbest).
/* all(Pred, List) iff Pred is a single-place predicate true of */
/* all members of the list. NG if either arg is var. */
all(Pred, []) :- atom(Pred).
all(Pred, [Elem | Rest]) :-
Callit =.. [Pred, Elem],
Callit,
all(Pred, Rest).
/* some(Pred, List) iff Pred is a single-place predicate true of */
/* at least one member of the list. NG if either arg is var. */
some(Pred, List) :- atom(Pred), some_cx(Pred, List).
some_cx(Pred, [Elem | Rest]) :-
(Callit =.. [Pred, Elem],
Callit);
some_cx(Pred, Rest).
/* notall(Pred, List) iff Pred is a single-place predicate false of */
/* at least one member of the list. NG if either arg is var. */
notall(Pred, List) :- atom(Pred), not(all(Pred,List)).
/* none(Pred, List) iff Pred is a single-place predicate true of */
/* none of the members of the list. NG if either arg is var. */
none(Pred, List) :- atom(Pred), not(some(Pred,List)).
/* all_same(List) iff all the elements of the list are identical, as */
/* tested by the '==' operator. */
all_same([]) :- !.
all_same([Elem]) :- !.
all_same([E1, E2 | Rest]) :-
E1 == E2,
all_same([E2 | Rest]).
/* all_diff(List) iff no two elements of the list are identical, as */
/* tested by the '==' operator. */
all_diff(List) :-
not(matching_pair(List, Matcher)).
/* matching_pair(List, Matcher) iff there is a matching pair of elements, */
/* E1 and E2 within List such that E1==E2==Matcher. */
matching_pair([Elem | Rest], Matcher) :-
(member(Matcher, Rest),
Elem == Matcher);
matching_pair(Rest, Matcher).
/* string_of(Alphabet, String) iff String is a list composed of */
/* elements of the non-redundant non-null Alphabet. */
/* NG if both args are var. */
string_of(Alphabet, String) :-
var(Alphabet) -> remove_dupl(String, Alphabet);
(Alphabet = [_|_], /* ie non-null */
no_dupls(Alphabet),
string_of_cv(Alphabet, String)
).
string_of_cv(Alphabet, []).
string_of_cv(Alphabet, [Elem | Rest]) :-
string_of_cv(Alphabet, Rest),
member(Elem, Alphabet).
/* sort_all(In_list, Out_list) iff Out_list is a sorting of In_list, */
/* saving duplicates. The Xing allows the use of keysort, which */
/* doesn't delete duplicates. */
sort_all(In, Out) :-
sort_all_xit(In, Xed_list),
keysort(Xed_list, Sorted_xed_list),
sort_all_xit(Out, Sorted_xed_list).
/* sort_all_xit(List, Xed_list) iff each element of list is matched */
/* by an xed element in Xed_list. */
sort_all_xit([],[]).
sort_all_xit([Elem | In_rest], [Elem-x | Out_rest]) :-
sort_all_xit(In_rest, Out_rest), !.
/* tot_sort(In_list, Out_list) iff Out_list is a total sorting */
/* of In_list. This means that not only are the elements of */
/* In_list sorted, but that any of those elements which are lists */
/* are also transformed by sorting, and so on. Thus: */
/* tot_sort([1,[a3,a2,a3,a1],2,1], [1,2,[a1,a2,a3]]). Recall that */
/* sort eliminates duplicates, and so Out_list might be shorter */
/* than In_list. Tot_sort can be thought of as providing a */
/* normalized form for multi-level sets. NG if arg1 is var. */
tot_sort(In, Out) :-
norm_elem(In, Normalized_list),
sort(Normalized_list, Out).
/* norm_elem(In, Out) iff Out is the same list as In, except that */
/* any elements of In which are themselves lists, are transformed */
/* by tot_sorting. NG if arg1 is var. */
norm_elem([],[]).
norm_elem([In_elem | In_rest], [Out_elem | Out_rest]) :-
(islist(In_elem) -> tot_sort(In_elem, Out_elem); In_elem = Out_elem),
norm_elem(In_rest, Out_rest),
!.
/* ordered_merge(List1, List2, List3) iff List3 is the ordered merging */
/* of List1 and List2. If more than one arg is var, returns only a */
/* single solution. To find all decompositions of a list into two */
/* lists, use merge. NG if all args are var. */
ordered_merge([], List, List) :-
islist(List),
!.
ordered_merge([Elem1 | Rest1], [], [Elem1 | Rest1]) :- !.
ordered_merge([Elem1 | Rest1], [Elem2 | Rest2], [Elem1 | Rest3]) :-
(var(Elem2) -> true; Elem1 @< Elem2),
!,
ordered_merge(Rest1, [Elem2 | Rest2], Rest3).
ordered_merge(List1, [Elem2 | Rest2], [Elem2 | Rest3]) :-
ordered_merge(List1, Rest2, Rest3).
/* merge(List1, List2, List3) iff List3 is a random merge of List1 and */
/* List2, ie, order is preserved within List1 and List2 but not between */
/* them. This is like a combination: pick 2 of 5. Eg, for */
/* List1=[1,2,3], and List2=[a,b], List3 can be [1,2,a,3,b], */
/* [a,1,2,b,3],... NG if List3 and (List1 or List2) are var. */
merge([], List, List) :- islist(List).
merge([Elem | Rest], [], [Elem | Rest]).
/* pick from List1 */
merge([Elem1 | Rest1], [Elem2 | Rest2], [Elem1 | Rest3]) :-
merge(Rest1, [Elem2 | Rest2], Rest3).
/* pick from List2 */
merge([Elem1 | Rest1], [Elem2 | Rest2], [Elem2 | Rest3]) :-
merge([Elem1 | Rest1], Rest2, Rest3).
/* ***************** Structures **************** */
/* atom_append(A,B,C) iff C is the deterministic concatenation */
/* of the atoms A and B. NG if arg1 or 2 is var. */
atom_append(A,B,C) :-
atom(A), atom(B),
name(A,AN), name(B,BN),
append(AN,BN,CN),
name(C,CN).
/* full_name(Term, Name) iff Name is the name of Term, which may be */
/* atomic or compound. NG if both args are var. */
full_name(Term, Name) :-
atomic(Term),
!,
name(Term, Name).
full_name(Term, Name) :-
var(Term),
telling(Cur_output),
tell('x.x'),
print_string(Name),
print_string("."),
told,
tell(Cur_output),
seeing(Cur_input),
see('x.x'),
read(Term),
seen,
!,
see(Cur_input).
full_name(Term, Name) :-
Term =.. [Functor, Arg1 | Arglist],
name(Functor, Func_name),
full_name(Arg1, Arg1_name),
full_name_list(Arglist, Arglist_name),
append_n([Func_name, "(", Arg1_name, Arglist_name, ")"], Name).
full_name_list([], []) :- !.
full_name_list([Arg1 | Arg_rest], Arglist_name) :-
full_name(Arg1, Arg1_name),
full_name_list(Arg_rest, Arg_rest_name),
append_n([",", Arg1_name, Arg_rest_name], Arglist_name).
/* tree_position(Term, Subterm, Location) iff Term is a */
/* non-variable containing Subterm, at the Location, which */
/* is a list of numbers corresponding to position, eg, for */
/* Term = a(b,c,d(e,f),g), the solutions are: */
/* */
/* Subterm Location */
/* ------- -------- */
/* a(b,c,d(e,f),b) [] */
/* b [1] */
/* c [2] */
/* d(e,f) [3] */
/* e [3,1] */
/* f [3,2] */
/* g [4] */
tree_position(Term, Sub, []) :-
nonvar(Term),
Term = Sub.
tree_position(Term, Sub, [Number | Sub_pos]) :-
Term =.. [Func | Args],
position(Args, Elem, Number),
tree_position(Elem, Sub, Sub_pos).
/* contains(Term, Sub) iff Term is a non-variable containing Sub, */
/* either immediately or indirectly. NG if arg1 is var. */
contains(Term, Sub) :-
nonvar(Term),
Term = Sub.
contains(Term, Sub) :-
Term =.. [Func | Args],
member(Elem, Args),
contains(Elem, Sub).
/* compound_contains(Term, Tester, Count) iff Count is the number of */
/* terms, compound or atomic, within Term for which Tester is true. */
/* Tester is either the name of a unary predicate, or a list of predicate */
/* name, followed by arguments. */
compound_contains(Term, Tester, Count) :-
(Tester = [Pred | Args] -> true;
(Pred = Tester, Args = [])),
Test =.. [Pred, Term | Args],
!,
(Test -> N=1; N=0),
(simple(Term) -> Count = N;
(Term =.. [Functor | Arglist],
compound_contains_list(Arglist, Pred, Args, Subcount),
Count is Subcount + N)).
compound_contains_list([], _, _, 0).
compound_contains_list([Elem | Rest], Pred, Args, Subcount) :-
compound_contains(Elem, [Pred | Args], Elemcount),
compound_contains_list(Rest, Pred, Args, Restcount),
Subcount is Elemcount + Restcount.
/* atomic_contains(Term, Tester, Count) iff Count is the number of */
/* atomic terms or vars within Term for which Tester is true. Tester is */
/* either the name of a unary predicate, or a list of predicate */
/* name, followed by arguments. */
atomic_contains(Term, Tester, Count) :-
(Tester = [Pred | Args] -> true;
(Pred = Tester, Args = [])),
!,
(simple(Term) -> (Test =.. [Pred, Term | Args],
(Test -> Count=1; Count=0)
);
(Term =.. Termlist,
atomic_contains_list(Termlist, Pred, Args, Count)
)).
atomic_contains_list([], _, _, 0).
atomic_contains_list([Elem | Rest], Pred, Args, Count) :-
atomic_contains(Elem, [Pred | Args], Elemcount),
atomic_contains_list(Rest, Pred, Args, Restcount),
Count is Elemcount + Restcount.
/* ************* Input and Output ************* */
/* copy_file(Input, Output) simply copies from Input to Output, as */
/* a sequence of characters (ie, it is character-oriented, not */
/* term-oriented. */
copy_file(Input, Output) :-
seeing(Old_input),
telling(Old_output),
see(Input),
tell(Output),
copy_file_1,
seen,
told,
see(Old_input),
tell(Old_output).
copy_file_1 :-
repeat,
get0(Char),
(Char = 26 -> true; (put(Char), fail)).
/* readline(List) iff List is the string of characters in */
/* the input stream from the current position up to, but */
/* not including the next end of line. If end of file is */
/* encountered, the tail of the List is end_of_file, rather */
/* than []. */
readline(List) :-
get0(Char),
(Char=10 -> List = [];
(Char=26 -> List = end_of_file;
(List = [Char | Rest], readline(Rest))
) ).
/* readword(Word) iff the next string of contiguous graphic */
/* characters in the input stream is Word. */
readword([Char | Rest]) :-
first_char(Char),
rest_word(Rest).
/* first_char(Char) iff the next graphic character in the input */
/* stream is Char. */
first_char(Char) :-
get0(N),
(graphic(N) -> Char=N; first_char(Char)).
/* rest_word(Rest) iff Rest is a contiguous string of graphic */
/* characters, starting at the current position in the */
/* input stream. */
rest_word(Rest) :-
get0(N),
(graphic(N) -> (Rest = [N | RestRest], rest_word(RestRest));
Rest = []).
/* graphic(N) iff N is a graphic, visible character. */
graphic(N) :- N > 32, N < 128.
/* user_pick(List, Selection) iff Selection is a member of the list */
/* chosen by the user. NG if arg1 is var. */
user_pick(List, Selection) :-
List = [E | R],
nl, print('Select one of the following: '),
user_pick_1(List, 1),
nl,
print('Enter the number of your preferred entry, '),
print('terminated by a period.'),
nl,
print('Anything besides a valid number will select none of the above.'),
nl,
read(Num),
!,
integer(Num),
position(List, Selection, Num).
user_pick_1([], _).
user_pick_1([Elem | Rest], N) :-
nl, print(' '),
(N < 10 -> print(' '); true),
print(N),
print(' - '),
print(Elem),
N1 is N+1,
user_pick_1(Rest, N1).
/* user_yes_no(Prompt) iff the user responds affirmatively to the Prompt. */
/* The Prompt should be a yes or no type question, suitable for printing, */
/* user_yes_no('Do you wish to continue?'). The current input stream */
/* is assumed to be set correctly. */
user_yes_no(Prompt) :-
nl, print(Prompt),
print(' (respond with "y." or "n.")'), nl,
read(Ans),
!,
(Ans = y -> true;
(Ans = n -> (!,fail);
(user_yes_no(Prompt)
) ) ).
/* print_string(S) succeeds if S is a list of printable integers, and */
/* it prints the string as a side-effect to the current output stream. */
print_string([]).
print_string(String) :-
name(N,String),
print(N).
/* tree_print(Term) prints term in tree-fashion, indented by two. */
tree_print(Term) :-
nl,
tree_print_sub(Term,0,' ').
tree_print_sub(Term, Depth, Prefix) :-
print_prefix(Depth, Prefix),
(var(Term) -> (Name = Term, Arglist = []);
Term =.. [Name | Arglist]),
print(Name), nl,
Depth_plus is Depth+1,
print_args(Arglist, Depth_plus, Prefix).
print_prefix(0,_).
print_prefix(Depth, Prefix) :-
Depth > 0,
print(Prefix),
Depth_minus is Depth-1,
print_prefix(Depth_minus, Prefix).
print_args([], Depth, _).
print_args([First | Rest], Depth, Prefix) :-
tree_print_sub(First, Depth, Prefix),
print_args(Rest, Depth, Prefix).
/* tree_list_print(Term) prints Term just like tree_print, except that */
/* it keeps lists flat (at the same level), rather than indenting. */
/* Further it uses '[' and ']' to delimit the lists instead of the */
/* true internal functor '.'. */
tree_list_print(Term) :-
nl,
tree_list_print_sub(Term,0,' ').
tree_list_print_sub(Term, Depth, Prefix) :-
print_prefix(Depth, Prefix),
(var(Term) -> (Name = Term, Arglist = []);
(non_null_list(Term) ->
(Name = '[', Term = Arglist);
Term =.. [Name | Arglist]
) ),
print(Name), nl,
D_plus is Depth+1,
list_print_args(Arglist, D_plus, Prefix),
(Name == '[' -> (print_prefix(Depth, Prefix), print(']'), nl); true).
list_print_args([], Depth, _).
list_print_args([First | Rest], Depth, Prefix) :-
tree_list_print_sub(First, Depth, Prefix),
list_print_args(Rest, Depth, Prefix).
/* *************** Sets **************** */
/* Following predicates treat lists as sets. Note that only */
/* outer brackets are interpreted as set-constructors. Any inner */
/* nested brackets are interpreted as ordered lists - thus these */
/* sets are "flat"; they do not contain other sets. Eg, the */
/* set: [a,b,[1,2,1]] has a list as its 3rd element and is */
/* distinct from: [a,b,[2,1]], but *not* from [b,b,[1,2,1],a,a], */
/* since duplication and order at the highest (set) level are */
/* insignificant. */
/* */
/* To treat lists as multi-level sets, perform tot_sort on them, eg */
/* both [a,b,[1,2,1]] and [a,b,[2,1]] map to: [a,b,[1,2]], which */
/* may be thought of as a normalized form for multi-level sets. */
/* */
/* Thus, the only easy choice is to treat all inner brackets as */
/* list-constructors (default) or as set-constructors (using */
/* tot_sort). To explicitly distinguish and therefore allow */
/* both kinds, a structure must be set up, something like: */
/* set(List) to be interpreted as a set. Then, eg: */
/* */
/* set([1,2,[d,d,c,a]]) : 3rd element is list */
/* */
/* set([1,2,set([d,d,c,a])]) : 3rd element is set */
/* */
/* [1,2,1] : (ordered) list of 3 integers */
/* */
/* set([1,2,1]) : (unordered) set of 2 integers (= set([1,2]))*/
/* */
/* Set structure would accept unordered/duplicate elements, but */
/* assume their insignificance. Conversion predicate might be: */
/* */
/* set_list(Set, List) :- Set =.. [set, List], is_real_list(List). */
/* subset(Part, Whole) iff Part is an subset of Whole. */
/* NG if both args are var. */
subset(Part, Whole) :-
var(Whole) -> (var(Part) -> fail;
subset_cv(Part, Whole)
);
(remove_dupl(Whole, Shorn_whole),
(var(Part) -> subset_vc(Part, Shorn_whole);
subset_cc(Part, Shorn_whole))
).
subset_vc([Elem | Rest_part], [Elem | Rest_whole]) :-
subset_vc(Rest_part, Rest_whole).
subset_vc( Rest_part, [Elem | Rest_whole]) :-
subset_vc(Rest_part, Rest_whole).
subset_vc([],[]).
subset_cv(Part, Whole) :- remove_dupl(Part, Whole).
subset_cc([], Whole) :- islist(Whole).
subset_cc([Elem | Rest_of_part], Whole) :-
member(Elem, Whole),
subset_cc(Rest_of_part, Whole).
/* intersection(S1, S2, Ans) iff Ans is the intersection of S1 and S2. */
/* NG if arg1;2 is var. */
intersection(S1, S2, Ans) :-
remove_dupl(S1, Better_S1),
(var(Ans) -> intersection_1(Better_S1, S2, Ans);
intersection_2(Better_S1, S2, Ans)
).
intersection_1([], S2, []).
intersection_1([E | R1], S2, Ans) :-
member(E, S2) -> (Ans = [E | RA],
intersection_1(R1, S2, RA)
);
intersection_1(R1, S2, Ans).
intersection_2(S1, S2, Ans) :-
intersection_1(S1, S2, X),
set_equal(X, Ans).
/* union(S1, S2, Ans) iff Ans is the union of S1 and S2. */
/* NG if arg1;2 is var. */
union(S1, S2, Ans) :-
var(Ans) -> union_1(S1, S2, Ans);
union_2(S1, S2, Ans).
union_1(S1, S2, Ans) :- append(S1, S2, X),
remove_dupl(X, Ans).
union_2(S1, S2, Ans) :- union_1(S1, S2, X),
set_equal(X, Ans).
/* set_diff(S1, S2, Ans) iff Ans is the set difference S1 - S2. */
/* NG if arg1;2 is var. */
set_diff(S1, S2, Ans) :-
remove_dupl(S1, Better_S1),
(var(Ans) -> set_diff_1(Better_S1, S2, Ans);
set_diff_2(Better_S1, S2, Ans)
).
set_diff_1(S1, S2, Ans) :- delete_all(S2, S1, Ans).
set_diff_2(S1, S2, Ans) :- set_diff_1(S1, S2, X),
set_equal(X, Ans).
/* set_equal(A,B) iff A and B contain the same elements (set equality). */
set_equal(A, B) :-
nonvar(A), nonvar(B), set_equal_cc(A, B);
var(A), var(B), A = B;
var(A), nonvar(B), remove_dupl(B, A);
nonvar(A), var(B), remove_dupl(A, B).
set_equal_cc(A, B) :- subset(A,B), subset(B,A).
/* disjoint(A,B) iff A and B have no common element. */
/* NG if arg1;2 is var. */
disjoint(A,B) :- not(joint(A,B)).
/* joint(A,B) iff A and B have at least one common element. */
/* NG if arg1;2 is var. */
joint(A,B) :- member(E,A), member(E,B).
/* set_plus(S1, S2, Both) iff S1 and S2 are disjoint, and their */
/* union equals Both. NG if Both and (S1 or S2) are var. */
set_plus(S1, S2, Both) :-
nonvar(S1) -> (nonvar(S2) -> set_plus_ccx(S1, S2, Both);
set_plus_vxc(S2, S1, Both)
);
set_plus_vxc(S1, S2, Both).
set_plus_ccx(S1, S2, Both) :- disjoint(S1, S2), union(S1, S2, Both).
set_plus_vxc(S1, S2, Both) :-
nonvar(Both),
subset(S2, Both),
set_diff(Both, S2, S1).
/* powerset(Set, Power) iff Power is the power set of Set, ie, a list */
/* of all subsets of Set. NG if arg1 is var. */
powerset(Set, Power) :-
remove_dupl(Set, Shrunk_set),
powerset_xx(Shrunk_set, Power).
powerset_xx([], [[]]).
powerset_xx([Elem | Rest], Power) :-
powerset_xx(Rest, Sub_Power),
double_list(Elem, Sub_Power, Power).
double_list(New_elem, [Single], [Single, [New_elem | Single]]) :- !.
double_list(New_elem, [Elem | Rest], [Elem, [New_elem | Elem] | List]) :-
double_list(New_elem, Rest, List).
/* Here's an alternative version of powerset, perhaps a bit less */
/* efficient, but easier to understand. It is deliberately */
/* commented out, so as not to conflict with the above. */
/* NG if arg1 is var. */
/* */
/* powerset(Set, Power) :- setof(Sub, subset(Sub, Set), Power). */
/* partition(S1, S2) iff S2 is a partition of S1, ie S2 is a set of */
/* non-null pairwise disjoint sets, whose union = S1. */
/* NG if both args are var. */
partition(S1, S2) :-
nonvar(S1), nonvar(S2), partition_cc(S1, S2);
var(S1), nonvar(S2), partition_vc(S1, S2);
nonvar(S1), var(S2),
remove_dupl(S1, Slim_S1), partition_cv(Slim_S1, S2).
partition_vc(S1, S2) :-
not(member([], S2)), /* partition members must be non-null */
append_n(S2, S1), /* take all elements of all members */
no_dupls(S1). /* ensure pairwise disjoint */
partition_cc(S1, S2) :-
partition_vc(Test, S2),
set_equal(Test, S1).
partition_cv([Elem], [[Elem]]).
partition_cv([Elem | Rest], S2) :-
partition_cv(Rest, Sub_S2), /* take a partition of set minus elem */
( S2 = [[Elem] | Sub_S2]; /* either add a new singleton member */
/* containing elem */
(insert(Sub_S2_Elem, Sub_S2_Less_1, Sub_S2),
/* or take one of the old members */
S2 = [[Elem | Sub_S2_Elem] | Sub_S2_Less_1]
) /* and add elem to it */
).
/* closure_n(List1, Pred/Arity, List2) iff List2 is the closure of */
/* List1 according to the predicate Pred/Arity, for which the *last* */
/* n-1 operands are the "old" elements and the *first* operand is */
/* the "new" or generated element. (n =< 10). NG if arg1 or arg2 is var.*/
closure_n(List1, Pred/Arity, List2) :-
integer(Arity),
Arity < 11,
Arity > 1,
sort(List1, SL1),
gen_varlist(Arity, VL),
VL = [Arg1 | Rest_args],
Test =.. [Pred | VL],
sub_closure(SL1, Test, VL, List2).
sub_closure(List1, Test, [Arg1 | Rest_args], List2) :-
build_test(Rest_args, Test, List1, Setof_test),
(setof(Arg1, Setof_test, New_list)
->
(append(List1, New_list, Combined_list),
sort(Combined_list, Sorted_combined_list),
(Sorted_combined_list = List1
-> List2 = Sorted_combined_list;
sub_closure(Sorted_combined_list, Test, [Arg1 | Rest_args],
List2)
));
List2 = List1
).
gen_varlist(0, []) :- !.
gen_varlist(Arity, [Var | Rest]) :-
A_minus is Arity-1,
gen_varlist(A_minus, Rest).
build_test(VL, Test, List1, Setof_test) :-
build_pred(VL, Test, List1, Pred),
build_quantifiers(VL, Pred, Setof_test).
build_pred([], Test, _, Test) :- !.
build_pred([V | Rest], Test, List, (member(V, List), Sub_pred)) :-
build_pred(Rest, Test, List, Sub_pred).
build_quantifiers([], P, P) :- !.
build_quantifiers([V | Rest], Pred, V^Sub_pred) :-
build_quantifiers(Rest, Pred, Sub_pred).
/* **************** Numeric **************** */
/* between(X,Lo,Hi) iff X is an integer between Lo and Hi. NG if */
/* Lo or Hi is var. */
between(X, Lo, Hi) :-
(integer(Lo) -> LL is Lo; LL is floor(Lo)+1),
HH is floor(Hi),
Lim is HH-LL,
!,
numvar(XX, Lim),
X is XX+LL.
/* numvar(X, Limit) iff X and Limit are non-negative integers, */
/* with X =< Limit. In generative mode, solutions are produced */
/* from zero to higher values. Either, both, or neither argument */
/* may be instantiated. NG if arg1 is fraction and arg2 var. */
numvar(X,Limit) :- var(Limit), natural(Limit), numvar(X, Limit).
numvar(X,Limit) :- nonvar(Limit), natural(X), ((X>Limit, !, fail); true).
/* natural(X) iff X is a non-negative integer. */
natural(X) :- nonvar(X), integer(X), X>=0;
var(X), gen_integer(X, 0).
/* gen_integer(X,Seed) generates integers, incrementing from Seed. */
/* NG if arg1 is nonvar or arg2 is var. */
gen_integer(X, Seed) :-
var(X),
integer(Seed),
gen_integer_vc(X, Seed).
gen_integer_vc(X, Seed) :-
X is Seed;
(New_seed is Seed+1,
gen_integer_vc(X, New_seed)).
/* random(Max, N) instantiates N to a random integer between */
/* 1 and Max. NG if arg1 is var. */
seed(13).
random(R,N) :-
retract(seed(S)),
N is (S mod R) +1,
NewSeed is (125*S+1) mod 4096,
asserta(seed(NewSeed)),!.
/* rationalize(Exprs, R_Exprs) iff Exprs is a numeric expression, */
/* and R_Exprs is a mostly evaluated form of the expression. */
/* Rational numbers are preserved and reduced to lowest terms, */
/* or integers if possible. If no floating-point numbers are in */
/* the expression, the results are exact, except for raising to a */
/* fractional power. NG if Exprs is not a fully instantiated */
/* numeric expression. Routines for handling exponentiation */
/* override some C-Prolog defaults. X^0 always equals 1, even for */
/* 0^0. A negative base is allowed with an integer power, so */
/* (-2)^4 = 16, and (-2)^5 = -32. Negative powers are handled */
/* correctly, eg, 2^(-3) = 1/8, (-2)^(-3) = -1/8, (2/3)^(-3) = */
/* 27/8. A negative base to a fractional power fails, as does zero */
/* to a negative power. */
rationalize(Exprs, Exprs) :- number(Exprs), !.
/* handle plus and minus unary ops */
rationalize(-(Exprs), R_Exprs) :- rationalize(Exprs*(-1), R_Exprs).
rationalize(+(Exprs), R_Exprs) :- rationalize(Exprs, R_Exprs).
/* all other unary ops to be handled by regular evaluation. */
rationalize(Exprs, R_Exprs) :-
Exprs =.. [Un_op, Opnd1],
Un_op \== '+',
Un_op \== '-',
rationalize(Opnd1, R_Opnd1),
Eval =.. [Un_op, R_Opnd1],
R_Exprs is Eval.
/* handle binary ops */
rationalize(Exprs, R_Exprs) :-
Exprs =.. [Bin_op, Opnd1, Opnd2],
rationalize(Opnd1, R_Opnd1),
rationalize(Opnd2, R_Opnd2),
(plain_eval(Bin_op, R_Opnd1, R_Opnd2)
-> (Eval =.. [Bin_op, R_Opnd1, R_Opnd2], R_Exprs is Eval, !);
(rationalize_1(Bin_op, R_Opnd1, R_Opnd2, R_Exprs), !)
).
/* plain_eval is true if the expression can be evaluated directly, */
/* either because: 1) the result will be exact (eg integer subtraction), */
/* or 2) the result is (probably) not rational anyway (eg, when */
/* a floating-point number is an operand, or raising to a fractional */
/* power). */
plain_eval(Bin_op, R_Opnd1, R_Opnd2) :-
not(member(Bin_op, [+,-,*,/,^])).
plain_eval(Bin_op, R_Opnd1, R_Opnd2) :-
Bin_op \== '^',
(float(R_Opnd1); float(R_Opnd2)).
plain_eval(Bin_op, R_Opnd1, R_Opnd2) :-
integer(R_Opnd1), integer(R_Opnd2),
member(Bin_op, [+,-,*]).
plain_eval(^, Base, Power) :-
Base > 0,
(not(integer(Power));
Power =:= 0;
float(Base);
(number(Base), Power > 0)
).
rationalize_1(^, 0, Power, _) :-
Power < 0,
nl, print('Error: raising zero to negative power.'), nl,
!, fail.
rationalize_1(^, 0, Power, 0) :-
Power > 0.
rationalize_1(^, _, 0, 1).
rationalize_1(^, Base, Power, R_Exprs) :-
Base < 0,
not(integer(Power)),
nl, print('Error: raising negative to fractional power.'), nl,
!, fail.
rationalize_1(^, Base, Power, R_Exprs) :-
Base < 0,
float(Base),
Mag is (-Base) ^ Power, !,
(Power mod 2 =:= 0 -> R_Exprs is Mag;
R_Exprs is -Mag).
rationalize_1(Bin_op, R_Opnd1, R_Opnd2, R_Exprs) :-
(integer(R_Opnd1) -> (Num1 = R_Opnd1, Den1 = 1);
Num1/Den1 = R_Opnd1),
(integer(R_Opnd2) -> (Num2 = R_Opnd2, Den2 = 1);
Num2/Den2 = R_Opnd2),
rationalize_2(Bin_op, Num1, Den1, Num2, Den2, Num, Den),
(Den =:= 0 -> (nl, print('Error: divide by zero'), nl,
!, fail
);
reduced(Num/Den, R_Exprs)
),
!.
rationalize_2(+, Num1, Den1, Num2, Den2, Num, Den) :-
Num is Num1*Den2 + Num2*Den1,
Den is Den1*Den2.
rationalize_2(-, Num1, Den1, Num2, Den2, Num, Den) :-
Num is Num1*Den2 - Num2*Den1,
Den is Den1*Den2.
rationalize_2(*, Num1, Den1, Num2, Den2, Num, Den) :-
Num is Num1*Num2,
Den is Den1*Den2.
rationalize_2(/, Num1, Den1, Num2, Den2, Num, Den) :-
Num is Num1*Den2,
Den is Den1*Num2.
rationalize_2(^, Num1, 1, Num2, 1, Num, Den) :-
abs(Num1, Base),
abs(Num2, Power),
Mag is Base^Power,
((Num1 >= 0; Power mod 2 =:= 0) -> Sign = 1; Sign = -1),
(Num2 < 0 -> (Num = Sign, Den = Mag);
(Num is Sign*Mag, Den = 1)).
rationalize_2(^, Num1, Den1, Num2, 1, Num, Den) :-
rationalize_2(^, Num1, 1, Num2, 1, NumNum, NumDen),
rationalize_2(^, Den1, 1, Num2, 1, DenNum, DenDen),
Num is NumNum*DenDen,
Den is NumDen*DenNum,
!.
/* reduced(Exprs, R_Exprs) iff R_Exprs is Exprs reduced to */
/* lowest terms. R_Exprs is an integer if the denominator */
/* would be 1. NG if arg1 is var. */
reduced(Exprs,Exprs) :- integer(Exprs), !.
reduced(Num/Den, Ans) :-
Num mod Den =:= 0,
Ans is Num/Den, !.
reduced(Num_In/Den_In, Num_Out/Den_Out) :-
gcd(Num_In, Den_In, GCD),
Num_Temp is Num_In/GCD,
Den_Temp is Den_In/GCD,
(Den_Temp < 0 -> (Num_Out is -Num_Temp, Den_Out is -Den_Temp);
(Num_Out is Num_Temp, Den_Out is Den_Temp)
),
!.
/* gcd(X, Y, Ans) iff Ans is the greatest common divisor of the */
/* integers X and Y. NG if arg1 or arg2 is var. */
gcd(X, 0, X) :- !.
gcd(0, X, X) :- !.
gcd(X, Y, Ans) :-
L is Y mod X,
gcd(L, X, Ans), !.
/* abs(X, Y) iff Y is the absolute value of X. Ng if arg1 is var. */
abs(X,Y) :-
X < 0 -> Y is -X; Y is X.
/* ***************** Control **************** */
/* loop(Pred) repeatedly invokes Pred until it fails. Loop always */
/* fails and so is executed only for side-effects. If Pred has */
/* several clauses, enclose in parens. A typical use might be: */
/* loop((pred(X,Y), write(X), write(' '), write(Y), nl)). */
/* to write out all solutions. */
loop(Pred) :-
repeat,
(Pred; (!, fail)), /* Pred succeeds, or kill loop */
fail. /* Force repetition. */
/* invoke(Pred_list) creates a predication from Pred_list and */
/* invokes it. Pred_list must be instantiated. The reason for */
/* the 2nd arg is that otherwise invoke will quit after first */
/* success with all nonvars. Even if all args are nonvar, */
/* users may wish to re-invoke by re-instantiating Pred_list. */
invoke(Pred_list, Pred_call) :- Pred_call=..Pred_list, Pred_call.
/* ************* Extended Logic ************** */
/* counter_eg(If, Then) iff there exists some instantiation of If */
/* and Then such that If is true and Then is false. If and Then */
/* must be predicates. Their arg-lists may contain vars, but the */
/* predicates themselves must be specified. Eg: */
/* counter_eg((gender(X,male), gender(Y,female)), taller(X,Y)). */
/* may be understood as "Are there any counter-examples to the rule */
/* that if X is male and Y is female, then X is taller than Y?" */
counter_eg(If, Then) :- If, not(Then).
/* implies(If, Then) iff If and Then form a true implication for */
/* this DB, ie there are no counter-examples. */
implies(If, Then) :- not(counter_eg(If, Then)).
/* The following stuff is meant to provide some capability for expressing */
/* disjunction and negation. The three predicates visible at the user */
/* level are: */
/* */
/* or(L) - to ask if this is a true disjunction; defined herein, but */
/* invoked by the user. */
/* */
/* ground_or(L) - to tell the system that this is a true disjunction, */
/* ie, at least one disjunct is true. Defined by the user */
/* as part of the DB. */
/* */
/* false(P) - says that P is definitely false (not just not provable, */
/* a la "not" in normal Prolog). Defined by the user as part */
/* of the DB. */
/* */
/* start_or. - the user has to invoke this to fire up the system, */
/* before he starts asking things. */
/* */
/* eg, if the user, in the DB, says: */
/* */
/* ground_or([e,f,g,h,i]). */
/* false(f). */
/* false(g). */
/* ground_or([a,b,c]) :- d. */
/* d. */
/* false(b). */
/* false(a) :- w; d. */
/* */
/* and then invokes start_or, the system will be able to conclude */
/* that the following succeed: */
/* */
/* c. (because (a or b or c) is true and a and b are */
/* both false) */
/* or([x1,d,x2]). (because d is a true disjunct) */
/* or([f,g,t,h,r,e,i]). (because it contains a true disjunct: [e,f,g,h,i]).*/
/* or([e,h,i]) (because its residue from [e,f,g,h,i] is [f,g] all*/
/* of which are false.) */
/* */
/* It's probably not wise for "ground_or" itself to depend on "or". */
/* or(L) iff L is a list of disjuncts, at least one of which is true. */
/* NG if L is var. */
or(L) :- nonvar(L), L = [_|_], (or_1(L); or_2(L); or_3(L)).
/* or_1 tries to find a true individual disjunct. */
/* or_2 tries to find a subset of L already known to be true. */
/* or_3 tries to find a superset of L already known to be true, */
/* and then show the rest are false. */
or_1([E | R]) :- E; or_1(R).
or_2(L1) :- ground_or(L2), subset(L2, L1).
or_3(L) :- ground_or(Ground_list),
set_plus(L, Residue, Ground_list),
false_list(Residue).
/* false_list(L) iff all members of L are provably false. */
false_list([]).
false_list([E1 | Rest]) :- false(E1), false_list(Rest).
/* start_or always fails, but in the meantime, it builds clauses */
/* for each disjunct of the ground_or's. */
start_or :-
clause(ground_or(Disjuncts), Antecedents),
set_plus([One_disjunct], Rest, Disjuncts),
assertz((One_disjunct :- Antecedents, false_list(Rest))),
fail.
/* Some meta-logical facilities coming up. */
/* kb_object(Type, Head, Tail) iff there is a clause "Head :- Tail." */
/* in the current program. If the Tail=true, and the Head is */
/* composed of all constants, Type = fact, otherwise Type = rule. */
kb_object(Type, Head, Tail) :-
current_predicate(_, Head),
clause(Head, Tail),
((Tail = true, constant_term(Head)) -> Type = fact;
Type = rule).
/* assert1(Term) iff there is exactly one matching instance of Term */
/* asserted in the DB. Term should be at least partially instantiated. */
assert1(Term) :-
repeat,
(retract(Term) -> fail;
assert(Term)
),
!.
/* ed allows for some very primitive run-time program modification. */
/* The user can enter terms, facts or rules, without the "extra" */
/* parentheses needed by assert, and ed then asserts and writes out */
/* the term for later editing into the permanent program. */
ed :-
nl, print('Enter fact or rule ([] to quit).'), nl,
read(T),
(T = [] -> true; (ed_1(T), !, ed)).
ed_1(T) :-
assert(T),
tell('x.tmp'),
nl, writeq(T), put(46), nl,
tell(user).
/* End of Prolog Utilities */