In SWI-Prolog I want to establish the list L from two lists L1 and L2 with the smallest count of elements under the condition, that 1 ∈ L1 and 1 ∈ L2.
If 1 ∉ L1 and 1 ∈ L2, then L = L1. If 1 ∈ L1 and 1 ∉ L2, then L = L2. If 1 ∉ L1 and 1 ∉ L2, then the predicate returns false.
I could evaluate this in Prolog with the following conditions:
minset_one(D1, D2, T) :- ((member(1, D1), not(member(1, D2))) -> T=D1).
minset_one(D1, D2, T) :- ((not(member(1, D1)), member(1, D2)) -> T=D2).
minset_one(D1, D2, T) :- (member(1, D1), member(1, D2), length(D1,L1), length(D2,L2), L1 >= L2) -> T=D2.
minset_one(D1, D2, T) :- (member(1, D1), member(1, D2), length(D1,L1), length(D2,L2), L2 > L1) -> T=D1.
My problem with that function is, the member function is called very often. Is their a way to reduce the complexity of that predicate in that way, the functions
member(1, D1)
member(1, D2)
length(D1, L1)
length(D2, L2)
are called only one time?
Both your code and the code in the answer of #TessellatingHacker lose logical-purity when the arguments of minset_one/3 are not sufficiently instantiated:
?- D1 = [X,Y,Z], D2 = [U,V], minset_one(D1,D2,T).
D1 = [1,Y,Z], D2 = [1,V], T = D2
; false. % no more solutions!
This is clearly incomplete. There are other solutions. We lost logical-purity.
So, what can we do about this?
Basically, we have two options:
check D1, D2 and T upfront and throw an instantiation_error when the instantiation is not sufficient.
use building blocks that are better suited for code that preserves logical-purity.
In this answer I want to show how to realise option number two.
The code is based on if_/3 which is the core of library(reif).
In short, we reify the truth values of relations and use Prolog indexing on these values.
Using SWI-Prolog 8.4.2:
?- use_module(library(reif)).
First, shorter_than_t(Xs,Ys,T)
reifies "list Xs is shorter than Ys" into T:
shorter_than_t([],Ys,T) :-
aux_nil_shorter_than(Ys,T).
shorter_than_t([_|Xs],Ys,T) :-
aux_cons_shorter_than_t(Ys,Xs,T).
aux_nil_shorter_than_t([],false).
aux_nil_shorter_than_t([_|_],true).
aux_cons_shorter_than_t([],_,false).
aux_cons_shorter_than_t([_|Ys],Xs,T) :-
shorter_than_t(Xs,Ys,T).
Based on shorter_than_t/3 we define minset_one/3:
minset_one(D1,D2,T) :-
if_(shorter_than_t(D1,D2),
if_(memberd_t(1,D1), D1=T, (memberd_t(1,D2,true),D2=T)),
if_(memberd_t(1,D2), D2=T, (memberd_t(1,D1,true),D1=T))).
Now let's run above query again:
?- D1 = [X,Y,Z], D2 = [U,V], minset_one(D1,D2,T).
D1 = [X,Y,Z], D2 = [1,V], T = D2
; D1 = [X,Y,Z], D2 = [U,1], T = D2, dif(U,1)
; D1 = [1,Y,Z], D2 = [U,V], T = D1, dif(U,1), dif(V,1)
; D1 = [X,1,Z], D2 = [U,V], T = D1, dif(U,1), dif(V,1), dif(X,1)
; D1 = [X,Y,1], D2 = [U,V], T = D1, dif(U,1), dif(V,1), dif(X,1), dif(Y,1)
; false.
At last, minset_one/3 has become complete!
I think you could do it with a wrapper / helper predicate which does those checks once, and then does a lookup of some fixed answers:
% minset_one(1 in D1, 1 in D2, D1, D2, D1Len, D2Len, T).
minset_one_(true, false, D1, _, _, _, D1).
minset_one_(false, true, _, D2, _, _, D2).
minset_one_(true, true, _, D2, D1Len, D2Len, D2) :- D1Len >= D2Len.
minset_one_(true, true, D1, _, D1Len, D2Len, D1) :- D1Len < D2Len.
minset_one(D1, D2, T) :-
(member(1, D1) -> D1check = true ; D1check = false),
(member(1, D2) -> D2check = true ; D2check = false),
length(D1, D1Len),
length(D2, D2Len),
minset_one_(D1check, D2check, D1, D2, D1Len, D2Len, T).
Related
I'm trying to write a predicate to find the depth of nesting in a prolog term.
for example : for an atom or variable the depth is zero.
for f(a,b,1,2) the depth is 1.
for f(a,b(7,a),1,2) the depth is 2, etc.
here is what I have so far.
% base cases.
get_depth(Term,0):-
non_compound(Term),!.
get_depth(Term,1):-
Term =.. [_|T],
all_basic(T),!. % no compound terms in list.
get_depth(Term,Depth):-
% this is where I need help.
% helper prdeicates
all_basic([T]):-
non_compound(T),!.
all_basic([H|T]):-
non_compound(H),
all_basic(T).
% term is non compound, either atomic or non instantiated variable.
non_compound(Term):-
atomic(Term),!;
var(Term).
max(X,Y,X):-
X >= Y,!.
max(_,Y,Y).
depth(Term, D) :-
Term =.. [_|Args],
( Args = []
-> D = 0
; maplist(depth, Args, Ds),
max_list(Ds, D1), D is D1 + 1
).
If you do not want maplist and max_list
depth(Term, D) :-
Term =.. [_|Args],
( Args = []
-> D = 0
; max_depth(Args, D1), D is D1 + 1
).
max_depth([Term], Max) :- depth(Term, Max).
max_depth([T1, T2| Rest], Max) :-
depth(T1, D1), max_depth([T2 | Rest], M1),
(D1 > M1 -> Max = D1; Max = M1).
I'm trying to print out all possible shuffled variants of two lists in one list while preserving the order.
I need to write a predicate shuffle(L1, L2, L3) which shuffles L1 and L2 and puts the result into L3 while preserving the inner order of L1 and L2.
For example :
?- shuffle([a,b],[1,2],L).
L = [a,b,1,2] ;
L = [a,1,b,2] ;
L = [a,1,2,b] ;
L = [1,a,b,2] ;
L = [1,a,2,b] ;
L = [1,2,a,b]
What I have so far :
shuffle([],[],[]).
shuffle([X|Xs],[Y|Ys],[X,Y|Tail]) :-
shuffle(Xs,Ys,Tail).
shuffle([X|Xs],[Y|Ys],[Y,X|Tail]) :-
shuffle(Xs,Ys,Tail).
This results in :
| ?- shuffle([a,b],[1,2],L).
L = [a,1,b,2] ? ;
L = [a,1,2,b] ? ;
L = [1,a,b,2] ? ;
L = [1,a,2,b]
So I'm missing the cases of "simple append" of L1+L2 and L2+L1...
What is my predicate missing?
We can use dcg for its ease of writing:
shuffle([A|B],[C|D]) --> [A] , shuffle(B,[C|D]).
shuffle([A|B],[C|D]) --> [C] , shuffle([A|B],D).
shuffle(A,[]) --> A.
shuffle([],C) --> C.
shuffle( A, B, C) :- phrase( shuffle(A,B), C).
We either take first card from one non-empty deck or the other, but if one of them is empty we must use all the remaining cards in the non-empty deck at once.
Unfortunately this leaves one extra choice point at the end:
5 ?- shuffle([a,b],[1,2],C).
C = [a, b, 1, 2] ;
C = [a, 1, b, 2] ;
C = [a, 1, 2, b] ;
C = [1, a, b, 2] ;
C = [1, a, 2, b] ;
C = [1, 2, a, b] ;
false.
As for your approach the problem with it was that you tried to take care of two cards at once, and it got complicated. Going by smallest steps can be the easiest.
Here's how you can shuffle two lists while preserving the relative item order.
shuffle([], Xs, Xs).
shuffle([X|Xs], Ys, Zs) :-
shuffle_(Ys, X, Xs, Zs). % use auxiliary predicate shuffle_/4
shuffle_([], X, Xs, [X|Xs]). % do indexing on both lists
shuffle_([Y|Ys], X, Xs, [X|Zs]) :-
shuffle_(Xs, Y, Ys, Zs).
shuffle_([Y|Ys], X, Xs, [Y|Zs]) :-
shuffle_(Ys, X, Xs, Zs).
Sample query using SWI-Prolog:
?- shuffle([a,b], [1,2], Xs).
Xs = [a,1,b,2]
; Xs = [a,1,2,b]
; Xs = [a,b,1,2]
; Xs = [1,a,2,b]
; Xs = [1,a,b,2]
; Xs = [1,2,a,b]. % no useless choice point at the end
#repeat's answer is more elegant and efficient, but, as an alternative:
The unwanted choice-point can be removed using a reusable empty_list_first predicate:
shuffle([A|B], [C|D]) --> [A],
shuffle(B, [C|D]).
shuffle([A|B], [C|D]) --> [C],
{ empty_list_first([A|B], D, A1, D1) },
shuffle(A1, D1).
% Rewritten to prevent needing https://www.swi-prolog.org/pldoc/man?section=basics
%shuffle([], C) --> remainder(C).
shuffle([], C, C, []).
shuffle(A, B, C) :-
empty_list_first(A, B, A1, B1),
phrase(shuffle(A1, B1), C).
empty_list_first([], L2, [], L2).
empty_list_first([H|T], L2, EL1, EL2) :-
empty_list_first_(L2, [H|T], EL1, EL2).
empty_list_first_([], L1, [], L1).
% If neither are empty, keep original order
empty_list_first_([H|T], L1, L1, [H|T]).
Result in swi-prolog:
?- shuffle([a,b], [1,2], C).
C = [a,b,1,2] ;
C = [a,1,b,2] ;
C = [a,1,2,b] ;
C = [1,a,b,2] ;
C = [1,a,2,b] ;
C = [1,2,a,b].
My answer is posted long time after original question but hoping this might prove useful to someone some day. I've taken a different approach to this, might be on the longer side but it works... :)
Since one of the requirements at the class I'm taking to not exceed material learned, some items such as delete and concatenate have been created here as well.
del(X,[X|Xs],Xs).
del(X,[Y|Ys],[Y|Zs]):-
del(X,Ys,Zs).
permutation([],[]).
permutation(Xs,[Z|Zs]):-
del(Z,Xs,Ys),
permutation(Ys,Zs).
conc([],L,L).
conc([X|L1],L2,[X|L3]):-
conc(L1,L2,L3).
is_in_order([],_).
is_in_order([_],_).
is_in_order(Sublist1, Sublist2, Superlist) :-
remove_elements(Superlist, Sublist1, SuperSubList),
list_equal(Sublist2, SuperSubList).
list_equal([], []).
list_equal([X|Xs],[X|Ys]) :-
list_equal(Xs, Ys).
% Remove L1 from L2 and return the resulting list
remove_elements(L, [H|T], R) :-
delete(L, H, R1),
remove_elements(R1, T, R).
remove_elements(L, [], L).
/*Shuffle first creates a concatenated list from both L1 & L2
* It then create permutation for all possible combinations of L1 & L2
* Once done, it scrubs the new lists to filter out the ones that do not
* maintain the original order of L1 & L2
* The result is only the permutations that fullfills the order condition
*/
shuffle(L1,L2,L):-
conc(L1,L2,L3),
permutation(L3, L),
is_in_order(L1, L2, L),
is_in_order(L2, L1, L).
I'm trying to implement Levenshtein distance in Prolog.
The implementation is pretty straightforward:
levenshtein(W1, W2, D) :-
atom_length(W1, L1),
atom_length(W2, L2),
lev(W1, W2, L1, L2, D),
!.
lev(_, _, L1, 0, D) :- D is L1, !.
lev(_, _, 0, L2, D) :- D is L2, !.
lev(W1, W2, L1, L2, D) :-
lev(W1, W2, L1 - 1, L2, D1),
lev(W1, W2, L1, L2 - 1, D2),
lev(W1, W2, L1 - 1, L2 - 1, D3),
charAt(W1, L1, C1),
charAt(W2, L2, C2),
( C1 = C2 -> T is 0; T is 1 ),
min(D1, D2, D3 + T, D).
% Returns the character at position N in the atom A
% The position is 1-based
% A: The atom
% N: The position at which to extract the character
% C: The character of A at position N
charAt(A, N, C) :- P is N - 1, sub_atom(A, P, 1, _, C).
% min(...): These rules compute the minimum of the given integer values
% I1, I2, I3: Integer values
% M: The minimum over the values
min(I1, I2, M) :- integer(I1), integer(I2), ( I1 =< I2 -> M is I1; M is I2).
min(I1, I2, I3, M) :- min(I1, I2, A), min(I2, I3, B), min(A, B, M).
However, this code failures with this error:
?- levenshtein("poka", "po", X).
ERROR: Out of local stack
I'm using SWIPL implementation on Mac OS X Sierra.
There is a good reason for which your program does not work: your recursive calls lead into an infinite loop.
This is caused by those lines:
lev(W1, W2, L1 - 1, L2, D1),
lev(W1, W2, L1, L2 - 1, D2),
lev(W1, W2, L1 - 1, L2 - 1, D3),
min(D1, D2, D3 + T, D)
In Prolog things like L1 - 1 are expressions that do not get evaluated to numbers. Therefore your code will recursively call lev with the third argument as L1 -1, then L1 - 1 - 1, etc. which does not match your terminating rules.
To fix this you need to use temporary variables where you evaluate the result of e.g. L1 - 1.
This fixes it:
lev(W1, W2, L1, L2, D) :-
L11 is L1 - 1,
L22 is L2 - 1,
lev(W1, W2, L11, L2, D1),
lev(W1, W2, L1, L22, D2),
lev(W1, W2, L11, L22, D3),
charAt(W1, L1, C1),
charAt(W2, L2, C2),
( C1 = C2 -> T is 0; T is 1 ),
D4 is D3 + T,
min(D1, D2, D4, D).
Now this does this:
?- levenshtein("poka","po",X).
X = 0.
Which is probably not the result you want, but at least it does not error. I will leave it to you to fix your predicate.
There are several problems with your program.
The loop
#Fatalize already gave you a reason, here is a general method how you can localize such problems, using a failure-slice by which some goals false are inserted into your program. If the remaining program loops, also the original version did:
?- levenshtein("poka","po",X), false.
levenshtein(W1, W2, D) :-
atom_length(W1, L1),
atom_length(W2, L2),
lev(W1, W2, L1, L2, D), false,
!.
lev(_, _, L1, 0, D) :- D is L1, !.
lev(_, _, 0, L2, D) :- D is L2, !.
lev(W1, W2, L1, L2, D) :-
lev(W1, W2, L1 - 1, L2, D1), false,
lev(W1, W2, L1, L2 - 1, D2),
lev(W1, W2, L1 - 1, L2 - 1, D3),
charAt(W1, L1, C1),
charAt(W2, L2, C2),
( C1 = C2 -> T is 0; T is 1 ),
min(D1, D2, D3 + T, D).
You have to modify something in the remaining, visible part. Otherwise, this problem will persist.
Use lists!
Instead of using atoms or strings, better use lists to represent words. The best is to add into your .swiplrc or .sicstusrc:
:- set_prolog_flag(double_quotes, chars).
In this manner, the following holds:
?- "abc" = [a,b,c].
Avoid cuts
Cuts somehow, sometimes work, but such programs are hard-to-debug. In particular for beginners. Therefore, avoid them at all costs
Use clean arithmetics
You are using the "olde" arithmetic of Prolog which is highly moded. Instead use_module(library(clpfd)) to get purer code.
So I am working on a practice problem, where I need to find the number of cells with opening right, up , down and left. I have a working solution but I want to change it into clauses. I don't want to to use -> to define if and else. how can I fix the code below without the affecting the solution.
Here is the code:
stats(U,D,L,R) :- maze(Size,_,_,_,_),
findall(R, genXY(Size,R), Out),
statsHelp(Out,U, L, R, D).
statsHelp([],0,0,0,0).
statsHelp([[X|[Y]]|Tl],U, L, R, D) :- cell(X,Y,Dirs,Wt),
(contains1(u,Dirs) -> U1 is 1; U1 is 0), % how do i remove -> and separate them into clauses?
(contains1(d,Dirs) -> D1 is 1; D1 is 0),
(contains1(l,Dirs) -> L1 is 1; L1 is 0),
(contains1(r,Dirs) -> R1 is 1; R1 is 0),
statsHelp(Tl,U2, L2, R2, D2),
U is U1 + U2,
D is D1 + D2,
R is R1 + R2,
L is L1 + L2.
contains1(V,[V|Tl]).
contains1(V,[Hd|Tl]):-
contains1(V,Tl).
Note that your contains1/2 predicate is just the standard member/2, which you could use instead.
As for a version that always succeeds and produces an extra 0 or 1, I think you have to use a cut or negation to achieve that. Here is one with negation:
member_reified(X, Xs, Result) :-
member(X, Xs),
Result = 1.
member_reified(X, Xs, Result) :-
\+ member(X, Xs),
Result = 0.
You could of course also just move your use of -> into your definition of member_reified/3. Different implementations can give different trade-offs on backtracking; this one may succeed several times:
?- member_reified(x, [a, b, c], Result).
Result = 0.
?- member_reified(a, [a, b, c], Result).
Result = 1 ;
false.
?- member_reified(a, [a, b, c, a], Result).
Result = 1 ;
Result = 1 ;
false.
I am trying to calculate cousin relationship in the format P'th cousin Qth removed. For example, In this picture below,
Thomas and Zack are cousins twice removed.
Thomas and Nikolay are second cousins once removed
Thomas and Saul are third cousins zero'th removed
So far I have a code like this that, finds the cousins:
ancestor(X,Z):-parent(X,Z).
ancestor(X,Z):-parent(X,Y), ancestor(Y,Z).
cousins(Child1, Child2) :-
ancestor(Y1,Child1),
ancestor(Y1,Child2),
Child1 \= Child2.
My logic is as long as Child1 and Child2 shares a common ancestor they are cousins.
The issue I am having is in trying to find out whether they are first cousins, or second cousins, or third cousins etc and whether they are once removed, twice removed, or thrice removed.
Any suggestion or hints on how I could solve this problem would be greatly helpful.
Thanks!
I think I got this right.
You will need the CLP(FD) library to make this work.
Simply write :- use_module(library(clpfd)). at the beginning of your program.
cousins_nth_removed/4
The first two arguments are atoms representing the persons' names. The third argument (in [1,sup)) represents the first/second/third/... cousins relationship, while the fourth argument (in [0,sup)) represents the zeroth/once/twice/... removed relationship
cousins_nth_removed(C1, C2, 1, 0) :- % First cousins, zeroth removed
dif(C1, C2),
dif(P1, P2), % They have different parents
parent_child(P1, C1),
parent_child(P2, C2),
parent_child(GP, P1), % Their parents have the same parent GP
parent_child(GP, P2).
cousins_nth_removed(C1, C2, N, 0) :- % Nth cousins, zeroth removed
N #> 1,
dif(C1, C2),
children_removed_ancestor(C1, C2, R, R), % They are both R generations away from
dif(P1, P2), % their oldest common ancestor
parent_child(P1, C1),
parent_child(P2, C2),
M #= N - 1, % Their parents are N-1th cousins
cousins_nth_removed(P1, P2, M, 0). % zeroth removed
cousins_nth_removed(C1, C2, N, R) :- % Nth cousins, Rth removed
R #> 0,
dif(C1, C2),
children_removed_ancestor(C1, C2, R1, R2), % R is the difference of the distances
R #= abs(R2 - R1), % between each cousin and their oldest
S #= R - 1, % common ancestor
( R1 #= R2, % R = 0 -> Zeroth removed, second rule
cousins_nth_removed(C1, C2, N, 0)
; R1 #> R2, % C1 is younger than C2
parent_child(P1, C1), % -> C2 is Nth cousin R-1th removed
cousins_nth_removed(P1, C2, N, S) % with the parent of C1
; R1 #< R2, % C2 is younger than C1
parent_child(P2, C2), % -> C1 is Nth cousin R-1th removed
cousins_nth_removed(C1, P2, N, S) % with the parent of C2
).
children_removed_ancestor/4
The name isn't ideal, but this predicate is basically used to retrieve the generation gaps of two persons to their oldest common ancestor.
children_removed_ancestor(C1, C2, R1, R2) :-
child_removed_oldest_ancestor(C1, R1, A),
child_removed_oldest_ancestor(C2, R2, A).
child_removed_oldest_ancestor/3
This predicate retrieves the generation gap between a person and their oldest ancestor.
child_removed_oldest_ancestor(C, 0, C) :- % The ancestor of all
\+ parent_child(_, C). % They have no parent
child_removed_oldest_ancestor(C, N, A) :-
N #> 0,
parent_child(P, C),
M #= N - 1,
child_removed_oldest_ancestor(P, M, A).
Some queries
?- cousins_nth_removed(thomas, zack, N, R). % Your example
N = 1,
R = 2 ;
false.
?- cousins_nth_removed(thomas, nikolay, N, R). % Your example
N = 2,
R = 1 ;
false.
?- cousins_nth_removed(thomas, saul, N, R). % Your example
N = 3,
R = 0 ;
false.
?- cousins_nth_removed(thomas, C, N, R). % All cousins of thomas
C = farah,
N = 1,
R = 0 ;
C = ping,
N = 2,
R = 0 ;
C = william,
N = 3,
R = 0 ;
C = saul,
N = 3,
R = 0 ;
C = sean,
N = R, R = 1 ;
C = steven,
N = R, R = 1 ;
C = zack,
N = 1,
R = 2 ;
C = kyle,
N = 2,
R = 1 ;
C = nikolay,
N = 2,
R = 1 ;
C = wei,
N = 2,
R = 1 ;
false.
?- cousins_nth_removed(C1, C2, 3, 0). % All third cousins zeroth removed
C1 = ping,
C2 = william ;
C1 = ping,
C2 = saul ;
C1 = farah,
C2 = william ;
C1 = farah,
C2 = saul ;
C1 = ignat,
C2 = william ;
C1 = ignat,
C2 = saul ;
C1 = thomas,
C2 = william ;
C1 = thomas,
C2 = saul ;
C1 = william,
C2 = ping ;
C1 = william,
C2 = farah ;
C1 = william,
C2 = ignat ;
C1 = william,
C2 = thomas ;
C1 = saul,
C2 = ping ;
C1 = saul,
C2 = farah ;
C1 = saul,
C2 = ignat ;
C1 = saul,
C2 = thomas ;
false.
Overall program
:- use_module(library(clpfd)).
parent_child(leila,min).
parent_child(leila,seema).
parent_child(min,ali).
parent_child(min,jesse).
parent_child(min,john).
parent_child(ali,sean).
parent_child(ali,steven).
parent_child(sean,ping).
parent_child(jesse,dallas).
parent_child(jesse,mustafa).
parent_child(dallas,farah).
parent_child(mustafa,ignat).
parent_child(mustafa,thomas).
parent_child(seema,zack).
parent_child(zack,kyle).
parent_child(zack,nikolay).
parent_child(zack,wei).
parent_child(kyle,william).
parent_child(nikolay,saul).
cousins_nth_removed(C1, C2, 1, 0) :-
dif(C1, C2),
dif(P1, P2),
parent_child(P1, C1),
parent_child(P2, C2),
parent_child(GP, P1),
parent_child(GP, P2).
cousins_nth_removed(C1, C2, N, 0) :-
N #> 1,
dif(C1, C2),
children_removed_ancestor(C1, C2, R, R),
dif(P1, P2),
parent_child(P1, C1),
parent_child(P2, C2),
M #= N - 1,
cousins_nth_removed(P1, P2, M, 0).
cousins_nth_removed(C1, C2, N, R) :-
R #> 0,
dif(C1, C2),
children_removed_ancestor(C1, C2, R1, R2),
R #= abs(R2 - R1),
S #= R - 1,
( R1 #= R2,
cousins_nth_removed(C1, C2, N, 0)
; R1 #> R2,
parent_child(P1, C1),
cousins_nth_removed(P1, C2, N, S)
; R1 #< R2,
parent_child(P2, C2),
cousins_nth_removed(C1, P2, N, S)
).
children_removed_ancestor(C1, C2, R1, R2) :-
child_removed_oldest_ancestor(C1, R1, A),
child_removed_oldest_ancestor(C2, R2, A).
child_removed_oldest_ancestor(C, 0, C) :-
\+ parent_child(_, C).
child_removed_oldest_ancestor(C, N, A) :-
N #> 0,
parent_child(P, C),
M #= N - 1,
child_removed_oldest_ancestor(P, M, A).
I now hate genealogical trees.