Prolog - Latin Square solution - prolog

I am trying to write a program in Prolog to find a Latin Square of size N.
I have this right now:
delete(X, [X|T], T).
delete(X, [H|T], [H|S]) :-
delete(X, T, S).
permutation([], []).
permutation([H|T], R) :-
permutation(T, X),
delete(H, R, X).
latinSqaure([_]).
latinSquare([A,B|T], N) :-
permutation(A,B),
isSafe(A,B),
latinSquare([B|T]).
isSafe([], []).
isSafe([H1|T1], [H2|T2]) :-
H1 =\= H2,
isSafe(T1, T2).

using SWI-Prolog library:
:- module(latin_square, [latin_square/2]).
:- use_module(library(clpfd), [transpose/2]).
latin_square(N, S) :-
numlist(1, N, Row),
length(Rows, N),
maplist(copy_term(Row), Rows),
maplist(permutation, Rows, S),
transpose(S, T),
maplist(valid, T).
valid([X|T]) :-
memberchk(X, T), !, fail.
valid([_|T]) :- valid(T).
valid([_]).
test:
?- aggregate(count,S^latin_square(4,S),C).
C = 576.
edit your code, once corrected removing typos, it's a verifier, not a generator, but (as noted by ssBarBee in a deleted comment), it's flawed by missing test on not adjacent rows.
Here the corrected code
delete(X, [X|T], T).
delete(X, [H|T], [H|S]) :-
delete(X, T, S).
permutation([], []).
permutation([H|T], R):-
permutation(T, X),
delete(H, R, X).
latinSquare([_]).
latinSquare([A,B|T]) :-
permutation(A,B),
isSafe(A,B),
latinSquare([B|T]).
isSafe([], []).
isSafe([H1|T1], [H2|T2]) :-
H1 =\= H2,
isSafe(T1, T2).
and some test
?- latinSquare([[1,2,3],[2,3,1],[3,2,1]]).
false.
?- latinSquare([[1,2,3],[2,3,1],[3,1,2]]).
true .
?- latinSquare([[1,2,3],[2,3,1],[1,2,3]]).
true .
note the last test it's wrong, should give false instead.

Like #CapelliC, I recommend using CLP(FD) constraints for this, which are available in all serious Prolog systems.
In fact, consider using constraints more pervasively, to benefit from constraint propagation.
For example:
:- use_module(library(clpfd)).
latin_square(N, Rows, Vs) :-
length(Rows, N),
maplist(same_length(Rows), Rows),
maplist(all_distinct, Rows),
transpose(Rows, Cols),
maplist(all_distinct, Cols),
append(Rows, Vs),
Vs ins 1..N.
Example, counting all solutions for N = 4:
?- findall(., (latin_square(4,_,Vs),labeling([ff],Vs)), Ls), length(Ls, L).
L = 576,
Ls = [...].
The CLP(FD) version is much faster than the other version.
Notice that it is good practice to separate the core relation from the actual search with labeling/2. This lets you quickly see that the core relation terminates also for larger N:
?- latin_square(20, _, _), false.
false.
Thus, we directly see that this terminates, hence this plus any subsequent search with labeling/2 is guaranteed to find all solutions.

I have better solution, #CapelliC code takes very long time for squares with N length higher than 5.
:- use_module(library(clpfd)).
make_square(0,_,[]) :- !.
make_square(I,N,[Row|Rest]) :-
length(Row,N),
I1 is I - 1,
make_square(I1,N,Rest).
all_different_in_row([]) :- !.
all_different_in_row([Row|Rest]) :-
all_different(Row),
all_different_in_row(Rest).
all_different_in_column(Square) :-
transpose(Square,TSquare),
all_different_in_row(TSquare).
all_different_in_column1([[]|_]) :- !.
all_different_in_column1(Square) :-
maplist(column,Square,Column,Rest),
all_different(Column),
all_different_in_column1(Rest).
latin_square(N,Square) :-
make_square(N,N,Square),
append(Square,AllVars),
AllVars ins 1..N,
all_different_in_row(Square),
all_different_in_column(Square),
labeling([ff],AllVars).

Related

How add finitely failed branches to a Prolog visualizer?

Assume we want to visualize this Prolog execution. No goals from the fidschi islands, or something else exotic assumed, only good old SLDNF
with the default selection rule:
p(a).
p(b).
?- \+ p(c).
Yes
But we have only a Prolog visualizer that can show derivations
without negation as failure, like here. How can we boost
the Prolog visualizer to also show negation as failure?
The good thing about negation as failure, writing a meta interpreter for negation as failure is much easier, than writing a meta interpreter for cut (!). So basically the vanilla interpreter for SLDNF can be derived from the vanilla interpreter for SLD by inserting one additional rule:
solve(true) :- !.
solve((A,B)) :- !, solve(A), solve(B).
solve((\+ A)) :- !, \+ solve(A). /* new */
solve(H) :- functor(H, F, A), sys_rule(F/A, H, B), solve(B).
We can now go on and extend solve/3 from here in the same vain. But we do something more, we also write out failure branches in the search tree, similar like Prolog visualizer does by strikethrough of a clause. So the amended solve/3 is as follows:
% solve(+Goal, +Assoc, +Integer, -Assoc)
solve(true, L, _, L) :- !.
solve((A, B), L, P, R) :- !, solve(A, L, P, H), solve(B, H, P, R).
solve((\+ A), L, P, L) :- !, \+ solve(A, L, P, _). /* new */
solve(H, L, P, R) :- functor(H, F, A), sys_rule(F/A, J, B),
callable_property(J, sys_variable_names(N)),
number_codes(P, U), atom_codes(V, [0'_|U]), shift(N, V, W),
append(L, W, M),
(H = J -> true; offset(P), write(fail), nl, fail), /* new */
reverse(M, Z), triage(M, Z, I, K),
offset(P), write_term(I, [variable_names(Z)]), nl,
O is P+1, solve(B, K, O, R).
Here is an example run:
?- ?- \+ p(c).
fail
fail
Yes
See also:
AI Algorithms, Data Structures and Idioms
CH6: Three Meta-Interpreters
Georg F. Luger - Addison-Wesley 2009
https://www.cs.unm.edu/~luger/

How to calculate all the possible divisions in a list?

I found this predicate for the calculation of all possible sums.
subset_sum(0,[],[]).
subset_sum(N,[_|Xs],L) :-
subset_sum(N,Xs,L).
subset_sum(N,[X|Xs],[X|Rest]) :-
R is N-X,
subset_sum(R,Xs,Rest).
Knowing that the division does not have the commutative property, how do I get the same result for the division?
This predicate only works for the division between the two elements and in order.
subset_div(1,[],[]).
subset_div(N,[_|Xs],L) :-
subset_div(N,Xs,L).
subset_div(N,[X|Xs],[X|Rest]) :-
R is X/N,
subset_div(R,Xs,Rest).
how you can get this result?
?-subset_div(20,[10,100,90,3,5],L).
L=[100,5].
?-subset_div(5,[10,4,59,200,12],L).
L=[200,10,4].
5= (200/10)/4 or 5 = (200/4)/10 but 5 \= (4/200)/10 or 5\= (10/4)/200
Thanks.
You can do it in terms of a product if you only care about left-associative solutions. Solutions when you can do, say [20 / (10 / 2) / 5] are harder, and would require a more complicated output format.
subset_prod(1, [], []).
subset_prod(N, [_|Xs], L) :-
subset_prod(N, Xs, L).
subset_prod(N, [X|Xs], [X|Rest]) :-
R is N/X,
subset_prod(R, Xs, Rest).
subset_div1(N, [X|Xs], [X|L]) :-
X1 is X / N,
integer(X1),
subset_prod(X1, Xs, L).
subset_div1(N, [_|Xs], L) :-
subset_div(N, Xs, L).
subset_div(N, L, M) :-
sort(L, L1),
reverse(L1, L2),
subset_div1(N, L2, M).

Change goal execution order in Prolog Interpreter

I'm attempting to write a Prolog meta-interpreter to choose the order of goal execution, for example executing first all goals with the minimum number of parameters.
I started from the vanilla meta-interpreter:
solve2(true).
solve2(A) :- builtin(A), !, A.
solve2((A,B)) :- solve2(A), solve2(B).
solve2(A) :- clause(A,B), solve2(B).
Then i went to something like
solve2(true).
solve2(A) :- builtin(A), !, A.
solve2((A,B)) :- count(A,Args), count(B,Args2), Args<Args2, solve2(A), solve2(B).
solve2((A,B)) :- count(A,Args), count(B,Args2), Args>Args2, solve2(B), solve2(A).
solve2(A) :- clause(A,B), solve2(B).
But if the 4th line is executed then the whole block B is executed before A which is wrong.
Ex. A=a(x,y), B=(b(x,y,z), c(x)) I'd like to execute c, then a, then b. - while in this method i'd get c, b and then a.
I'm thinking about transforming the goals in a list but i'm not too sure.
Any ideas?
Here is an (untested) vanilla meta interpreter, with conjunction order changed. I would be glad if you could try with your data.
solve2(true).
solve2(A) :- builtin(A), !, A.
solve2((A,B)) :- ordering(A,B, C,D), ! /* needed */, solve2(C), solve2(D).
solve2(A) :- clause(A,B), solve2(B).
ordering(A,B, C,D) :-
minargs(A, NA),
minargs(B, NB),
( NA =< NB -> C/D=A/B ; C/D=B/A ).
minargs((A,B), N) :-
minargs(A, NA),
minargs(B, NB),
!, ( NA =< NB -> N=NA ; N=NB ).
minargs(T, N) :-
functor(T, _, N).
edit I tested with this setting:
builtin(writeln(_)).
a(1):-writeln(1).
b(1,2):-writeln(2).
c(1,2,3):-writeln(3).
test :-
solve2((c(A,B,_),a(A),b(A,B))).
and got the expected output:
?- test.
1
2
3
true .
edit I had to resort to a list representation, but then it make sense to preprocess the clauses and get the right order before, then stick to plain vanilla interpreter:
test :-
sortjoin((b(A,B),a(A),c(A,B,_)), X),
solve2(X).
sortjoin(J, R) :-
findall(C-P, (pred(J, P), functor(P,_,C)), L),
sort(L, T),
pairs_values(T, V),
join(V, R).
join([C], C).
join([H|T], (H,R)) :- join(T, R).
pred((A, _), C) :-
pred(A, C).
pred((_, B), C) :-
!, pred(B, C).
pred(C, C).
where solve2((A,B)) :- ... it's the original solve2(A),solve2(B)

Prolog finding and removing predicate

I my have code:
locdiff([A|T], [A|_], T).
locdiff([H|T], L2, [H|T2]) :-
locdiff(T, L2, T2).
and when i test it with locdiff([(a,1), (b,2), (b,3), (c,3), (c,4)], [(b,_)], L3), it only finds and removes one of the [(b,_)] which is (b,2). I need it to find and remove both (b,2) and (b,3) or what ever the [(b,_)] contains. can anyone help me with what i have missed?
there is a technical complication that's worth to note if you follow larsman' hint, that I would implement straight in this way
locdiff([], _, []).
locdiff([A|T], [A|_], R) :-
!, locdiff(T, [A|_], R).
locdiff([H|T], L2, [H|T2]) :-
locdiff(T, L2, T2).
with this
?- locdiff([(a,1), (b,2), (b,3), (c,3), (c,4)], [(b,_)], L3).
L3 = [ (a, 1), (b, 3), (c, 3), (c, 4)].
you can see that the first instance is removed, and the last. That's because the first match binds the anonymous variable, and then forbids following matchings, except the last (b,_)
Then a completed procedure would read
locdiff([], _, []).
locdiff([H|T], [A|_], R) :-
\+ \+ H = A, % double negation allows matching without binding
!, locdiff(T, [A|_], R).
locdiff([H|T], L2, [H|T2]) :-
locdiff(T, L2, T2).
now the outcome is what you are requiring.
Alternatively, you need to be more precise in pattern matching, avoiding undue binding
locdiff([], _, []).
locdiff([(A,_)|T], [(A,_)|_], R) :-
!, locdiff(T, [(A,_)|_], R).
locdiff([H|T], L2, [H|T2]) :-
locdiff(T, L2, T2).
?- locdiff([(a,1), (b,2), (b,3), (c,3), (c,4)], [(b,_)], L3).
L3 = [ (a, 1), (c, 3), (c, 4)].
Please note that some library has specific functionality, like exclude/3 in SWI-Prolog, but still you need attention to avoid bindings:
eq([(E,_)|_], (E,_)).
locdiff(L, E, R) :-
exclude(eq(E), L, R).
May be you need something loke that :
locdiff([], _, []).
locdiff([(b,_)|T], [(b,_)], T1) :-
!, locdiff(T, [(b,_)], T1).
locdiff([H|T], L2, [H|T2]) :-
locdiff(T, L2, T2).
But why do you write [A| _] if there is only one element in the list ?
[EDIT] I forgot the ! in the second rule

Prolog: converting atom to new atom

I have a problem with predicate which works in that way that it takes list of atoms:
nopolfont([to,jest,tekśćik,'!'],L).
and in result
L = [to,jest,tekscik,'!'].
I have problem with make_swap and swap predicates. So far I have:
k(ś,s).
k(ą,a).
% etc.
swap(X,W) :- name(X,P), k(P,Y), !, name(Y,W).
swap(X,X).
make_swap(A,W)
:- atom(A),!,
name(A,L),
swap(L,NL),
name(W,NL).
nopolfont([],[]).
nopolfont([H|T],[NH|S]) :- make_swap(H,NH), nopolfont(T,S).
Is there any elegant way to do this?
This is also quite elegant:
polish_char_replacer(X, Y) :-
k(X, Y),
!.
polish_char_replacer(X, X).
nopolfont(Atoms1, Atoms2) :-
maplist(replace(polish_char_replacer), Atoms1, Atoms2).
replace(Goal, Atom1, Atom2) :-
atom_chars(Atom1, Chars1),
maplist(Goal, Chars1, Chars2),
atom_chars(Atom2, Chars2).
Probably as elegant as it can get:
k(ś,s).
k(ą,a).
swap(X,W) :- name(P,[X]), k(P,Y), !, name(Y,[W]).
swap(X,X).
list_swap([], []).
list_swap([H|T], [W|S]) :-
swap(H, W),
list_swap(T, S).
atom_swap(A,W) :-
atom(A), !,
name(A, L),
list_swap(L,S),
name(W, S).
nopolfont([],[]).
nopolfont([H|T],[NH|S]) :-
atom_swap(H,NH),
nopolfont(T,S).
Also, obviously define this, to get the expected result, but I assume this is in the % etc
k(ć, c).

Resources