Related
I'm trying to figure out if I have an infinite loop in my Prolog program, or if I just did a bad job of writing it, so its slow. I'm trying to solve the square sum chains problem from the dailyprogrammer subreddit. Given a number N, find an ordering of the numbers 1-N (inclusive) such that the sum of each pair of adjacent numbers in the ordering is a perfect square. The smallest N that this holds for is 15, with the ordering [8, 1, 15, 10, 6, 3, 13, 12, 4, 5, 11, 14, 2, 7, 9]. This is the code that I'm trying to use to solve the problem:
is_square(Num):- is_square_help(Num, 0).
is_square_help(Num, S):- Num =:= S * S.
is_square_help(Num, S):-
Num > S * S,
T is S+1,
is_square_help(Num, T).
is_square_help(Num, S):- Num < S * S, fail.
contains(_, []):- fail.
contains(Needle, [Needle|_]).
contains(Needle, [_|Tail]):- contains(Needle, Tail).
nums(0, []).
nums(Num, List) :- length(List, Num), nums_help(Num, List).
nums_help(0, _).
nums_help(Num, List) :-
contains(Num, List),
X is Num - 1,
nums_help(X, List).
square_sum(Num, List) :-
nums(Num, List),
square_sum_help(List).
square_sum_help([X, Y|T]) :-
Z is X + Y,
is_square(Z),
square_sum_help(T).
Currently, when I run square_sum(15, List)., the program does not terminate. I've left it alone for about 10 minutes, and it just keeps running. I know that there are problems that take a long time to solve, but others are reportedly generating answers in the order of milliseconds. What am I doing wrong here?
SWI-Prolog allows this compact implementation
square_sum(N,L) :-
numlist(1,N,T),
select(D,T,R),
adj_squares(R,[D],L).
adj_squares([],L,R) :- reverse(L,R).
adj_squares(T,[S|Ss],L) :-
select(D,T,R),
float_fractional_part(sqrt(S+D))=:=0,
adj_squares(R,[D,S|Ss],L).
that completes really fast for N=15
edit as suggested, building the list in order yields better code:
square_sum(N,L) :-
numlist(1,N,T),
select(D,T,R),
adj_squares(R,D,L).
adj_squares([],L,[L]).
adj_squares(T,S,[S|L]) :-
select(D,T,R),
float_fractional_part(sqrt(S+D))=:=0,
adj_squares(R,D,L).
edit
the code above becomes too slow when N grows. I've changed strategy, and attempt now to find an Hamiltonian path into the graph induced by the binary relation. For N=15 it looks like
(here is the code to generate the Graphviz script:
square_pairs(N,I,J) :-
between(1,N,I),
I1 is I+1,
between(I1,N,J),
float_fractional_part(sqrt(I+J))=:=0.
square_pairs_graph(N) :-
format('graph square_pairs_N_~d {~n', [N]),
forall(square_pairs(N,I,J), format(' ~d -- ~d;~n', [I,J])),
writeln('}').
)
and here the code for lookup a path
hamiltonian_path(N,P) :-
square_pairs_struct(N,G),
between(1,N,S),
extend_front(1,N,G,[S],P).
extend_front(N,N,_,P,P) :- !.
extend_front(Len,Tot,G,[Node|Ins],P) :-
arg(Node,G,Arcs),
member(T,Arcs),
\+memberchk(T,Ins),
Len1 is Len+1,
extend_front(Len1,Tot,G,[T,Node|Ins],P).
struct_N_of_E(N,E,S) :-
findall(E,between(1,N,_),As),
S=..[graph|As].
square_pairs_struct(N,G) :-
struct_N_of_E(N,[],G),
forall(square_pairs(N,I,J), (edge(G,I,J),edge(G,J,I))).
edge(G,I,J) :-
arg(I,G,A), B=[J|A], nb_setarg(I,G,B).
Here is a solution using Constraint Logic Programming:
squares_chain(N, Cs) :-
numlist(1, N, Ns),
phrase(nums_partners(Ns, []), NPs),
group_pairs_by_key(NPs, Pairs),
same_length(Ns, Pairs),
pairs_values(Pairs, Partners),
maplist(domain, Is0, Partners),
circuit([D|Is0]),
labeling([ff], Is0),
phrase(chain_(D, [_|Is0]), Cs).
chain_(1, _) --> [].
chain_(Pos0, Ls0) --> [Pos],
{ Pos0 #> 1, Pos #= Pos0 - 1,
element(Pos0, Ls0, E) },
chain_(E, Ls0).
plus_one(A, B) :- B #= A + 1.
domain(V, Ls0) :-
maplist(plus_one, Ls0, Ls),
foldl(union_, Ls, 1, Domain),
V in Domain.
union_(N, Dom0, Dom0\/N).
nums_partners([], _) --> [].
nums_partners([N|Rs], Ls) -->
partners(Ls, N), partners(Rs, N),
nums_partners(Rs, [N|Ls]).
partners([], _) --> [].
partners([L|Ls], N) -->
( { L + N #= _^2 } -> [N-L]
; []
),
partners(Ls, N).
Sample query and answers:
?- squares_chain(15, Cs).
Cs = [9, 7, 2, 14, 11, 5, 4, 12, 13|...] ;
Cs = [8, 1, 15, 10, 6, 3, 13, 12, 4|...] ;
false.
A longer sequence:
?- time(squares_chain(100, Cs)).
15,050,570 inferences, 1.576 CPU in 1.584 seconds (99% CPU, 9549812 Lips)
Cs = [82, 87, 57, 24, 97, 72, 28, 21, 60|...] .
What you are doing wrong is mainly that you generate the whole list before you start testing.
The two clauses that call fail are pointless. Removing them will not change the program. The only reason for doing that is if you do something side-effect-y, like printing output.
Your code for generating the list, and all permutations, seems to work, but it can be done much simpler by using select/3.
You don't seem to have a base case in square_sum_help/1, and you also seem to only check every other pair, which would have lead to problems in some years or whatever when your program had gotten around to checking the correct ordering.
So, by interleaving the generation and testing, like this
square_sum(Num,List) :-
upto(Num,[],List0),
select(X,List0,List1),
square_sum_helper(X,List1,[],List).
square_sum_helper(X1,Rest0,List0,List) :-
select(X2,Rest0,Rest),
Z is X1 + X2,
is_square(Z,0),
square_sum_helper(X2,Rest,[X1|List0],List).
square_sum_helper(_,[],List0,List) :- reverse(List0,List).
is_square(Num,S) :-
Sqr is S * S,
( Num =:= Sqr ->
true
; Num > Sqr,
T is S + 1,
is_square(Num,T) ).
upto(N,List0,List) :-
( N > 0 ->
M is N - 1,
upto(M,[N|List0],List)
; List = List0 ).
the correct result is produced in around 9 msec (SWI Prolog).
?- ( square_sum(15,List), write(List), nl, fail ; true ).
[8,1,15,10,6,3,13,12,4,5,11,14,2,7,9]
[9,7,2,14,11,5,4,12,13,3,6,10,15,1,8]
?- time(square_sum(15,_)).
% 37,449 inferences, 0.009 CPU in 0.009 seconds (100% CPU, 4276412 Lips)
Edit: fixed some typos.
contains/2:
clause contains(_, []):- fail. is buggy and redundant at best.
you should type in the body !, fail.
But it's not needed because that what is unprovable shouldn't be mentioned (closed world assumption).
btw contains/2 is in fact member/2 (built-in)
I'm new to prolog for constraint programming. I have an issue with CLPFD not reducing a domain as I expect it to. This is probably really simple.
[A,B] ins 1..5,A*B#=5.
I expect it to reduce the domain of A and B to
1\/5
But it just gives
A in 1..5,
A*B#=5,
B in 1..5.
Any suggestions would be appreciated.
While this answer is tailored to clpfd as implemented in swi-prolog, the idea/method is portable.
:- use_module(library(clpfd)).
Here's how we can reduce domain sizes before starting full enumeration:
shave_zs(Zs) :-
maplist(flag_zs_shave_z(F,Zs), Zs),
once((var(F) ; ground(Zs) ; shave_zs(Zs))).
flag_zs_shave_z(Flag, Zs, Z) :-
( fd_size(Z, sup)
-> true % never shave the infinite
; fd_dom(Z, Z_dom),
phrase(dom_integers_(Z_dom), Z_vals),
maplist(flag_zs_z_val(Flag,Zs,Z), Z_vals)
).
flag_zs_z_val(Flag, Zs, Z, Z_val) :-
( \+ call_with_inference_limit((Z #= Z_val,labeling([],Zs)), 1000, _)
-> Z #\= Z_val,
Flag = true
; true
).
We use grammar dom_integers_//1, as defined on the SWI-Prolog clpfd manual page:
dom_integers_(I) --> { integer(I) }, [I].
dom_integers_(L..U) --> { numlist(L, U, Is) }, Is.
dom_integers_(D1\/D2) --> dom_integers_(D1), dom_integers_(D2).
Sample queries:
?- [A,B] ins 1..5, A*B #= 5, (Shaved = false ; Shaved = true, shave_zs([A,B])).
Shaved = false, A*B #= 5, A in 1..5, B in 1..5 ;
Shaved = true, A*B #= 5, A in 1\/5, B in 1\/5.
?- [A,B] ins 1..10, A*B #= 10, (Shaved = false ; Shaved = true, shave_zs([A,B])).
Shaved = false, A*B #= 10, A in 1..10 , B in 1..10 ;
Shaved = true, A*B #= 10, A in 1..2\/5\/10, B in 1..2\/5\/10.
You are right that 1\/5 would be optimal pruning in this case.
However, for efficiency reasons, CLP(FD) systems typically maintain only so-called bounds consistency for arithmetic constraints, and in general do not remove interior elements from domains even when some of them cannot participate in solutions.
Bounds consistency, in the finite case, means that there are solutions where the variable assumes the lower and upper boundary of the domain. In this case, there are solutions for A=1 and A=5.
Notice that these are the only solutions in this concrete case, but in general, there are also solutions with interior points in analogous larger instances, for example:
?- [A,B] ins 1..10, A*B#=10, label([A,B]).
A = 1,
B = 10 ;
A = 2,
B = 5 ;
A = 5,
B = 2 ;
A = 10,
B = 1.
The good news though is that the number of such solutions only grows logarithmically in the size of the domain:
?- length(_, Exp), N #= 2^Exp, [A,B] ins 1..N,A*B#=N,
findall(., label([A,B]), Ls), length(Ls, L),
writeln(Exp-L), false.
0-1
1-2
2-3
3-4
4-5
5-6
6-7
7-8
etc.
This is in contrast to other cases, like X mod 2 #= 0, where the number of solutions grows linearly in the size of the domain of X (and thus exponentially in the length of its decimal representation), and it is thus not feasible to explicitly prune the domain.
Thus, as a feasible workaround, you can use label/1 to obtain concrete solutions, and then use in/2 constraints to restrict the operands to their concretely admissible domains:
:- use_module(library(clpfd)).
stricter_domains(Vs) :-
findall(Vs, label(Vs), Sols0),
transpose(Sols0, Sols),
maplist(list_to_domain, Sols, Ds),
maplist(in, Vs, Ds).
list_to_domain([L|Ls], Dom) :- foldl(dom_disj, Ls, L, Dom).
dom_disj(D0, I, D0\/I).
Your example:
?- [A,B] ins 1..5, A*B#=5, stricter_domains([A,B]).
A in 1\/5,
A*B#=5,
B in 1\/5.
How can I limit the repetition of a number in a list?
What is a suitable constraint in the following code example?
limit(X) :-
length(X,10),
domain(X,1,4),
% WANTED CONSTRAINT: maximum repetition of each number is 5 times.
labeling([],X).
Some sample queries and expected answers:
?- limit([1,1,1,1,1,1,1,1,1]).
false.
?- limit([1,1,1,1,1,2,2,2,2,2]).
true.
This works, L is the list of the number of repetitions of each number from 1 to 4.
:- use_module(library(clpfd)).
limit(X) :-
length(L, 4),
L ins 0..5,
sum(L, #=, 10),
label(L),
maplist(make_list, [1,2,3,4], L, LX),
flatten([LX],X).
make_list(Val, Nb, L) :-
length(L, Nb),
L ins Val .. Val.
The problem is that the numbers are group by values.
The code may be generalized to
limit(X, Min, Max, Len, Rep) :-
Nb is Max -Min + 1,
length(L, Nb),
L ins 0..Rep,
sum(L, #=, Len),
label(L),
numlist(Min, Max, Lst),
maplist(make_list, Lst, L, LX),
flatten([LX],X).
You try : limit(X, 1, 4, 10, 5).
In this answer we use two different clpfd "flavors": sicstus-prolog and gnu-prolog.
:- use_module(library(clpfd)).
limited_repetitions__SICStus(Zs) :-
length(Zs, 10),
domain(Zs, 1, 4),
domain([C1,C2,C3,C4], 0, 5),
global_cardinality(Zs, [1-C1,2-C2,3-C3,4-C4]),
labeling([], Zs).
limited_repetitions__gprolog(Zs) :-
length(Zs, 10),
fd_domain(Zs, 1, 4),
maplist(fd_atmost(5,Zs), [1,2,3,4]),
fd_labeling(Zs).
Simple sample query run with SICStus Prolog version 4.3.2 and GNU Prolog 1.4.4:
?- limited_repetitions__SICStus(Zs). % ?- limited_repetitions__gprolog(Zs).
Zs = [1,1,1,1,1,2,2,2,2,2] % Zs = [1,1,1,1,1,2,2,2,2,2]
; Zs = [1,1,1,1,1,2,2,2,2,3] % ; Zs = [1,1,1,1,1,2,2,2,2,3]
; Zs = [1,1,1,1,1,2,2,2,2,4] % ; Zs = [1,1,1,1,1,2,2,2,2,4]
; Zs = [1,1,1,1,1,2,2,2,3,2] % ; Zs = [1,1,1,1,1,2,2,2,3,2]
; Zs = [1,1,1,1,1,2,2,2,3,3] % ; Zs = [1,1,1,1,1,2,2,2,3,3]
; Zs = [1,1,1,1,1,2,2,2,3,4] % ; Zs = [1,1,1,1,1,2,2,2,3,4]
; Zs = [1,1,1,1,1,2,2,2,4,2] % ; Zs = [1,1,1,1,1,2,2,2,4,2]
... % ...
Let's measure the time required for counting the number of solutions!
call_succeeds_n_times(G_0, N) :-
findall(t, call(G_0), Ts),
length(Ts, N).
?- call_time(call_succeeds_n_times(limited_repetitions__SICStus(_), N), T_ms).
N = 965832, T_ms = 6550. % w/SICStus Prolog 4.3.2
?- call_time(call_succeeds_n_times(limited_repetitions__gprolog(_), N), T_ms).
N = 965832, T_ms = 276. % w/GNU Prolog 1.4.4
In this previous answer we utilized the SICStus Prolog clpfd predicate global_cardinality/2. As an non-constraint alternative, we could also use selectd/3 like this:
multi_selectd_rest([],Ds,Ds).
multi_selectd_rest([Z|Zs],Ds0,Ds) :-
selectd(Z,Ds0,Ds1),
multi_selectd_rest(Zs,Ds1,Ds).
Putting it to good use in limited_repetitions__selectd/3 we define:
limited_repetitions__selectd(Zs) :-
length(Zs, 10),
multi_selectd_rest(Zs,[1,1,1,1,1,2,2,2,2,2,3,3,3,3,3,4,4,4,4,4],_).
Again, let's measure the time required for counting the number of solutions!
?- call_time(call_succeeds_n_times(limited_repetitions__selectd(_),N), T_ms).
N = 965832, T_ms = 4600.
Here is a way, but not for sequences:
:- [library(clpfd)].
limit_repetition(Xs, Max) :-
maplist(vs_n_num(Xs, Max), Xs).
vs_n_num(Vs, Max, X) :-
maplist(eq_b(X), Vs, Bs),
% sum(Bs, #=, EqC),
% EqC #=< Max.
sum(Bs, #=<, Max).
eq_b(X, Y, B) :- X #= Y #<==> B.
vs_n_num/3 is an adapted version of what you can find in docs.
Here's a way to delimite sequences:
limit_repetition([X|Xs], Max) :-
limit_repetition(X, 1, Xs, Max).
limit_repetition(X, C, [Y|Xs], Max) :-
X #= Y #<==> B,
( B #/\ C + B #=< Max #/\ D #= C + B ) #\/ ( (#\ B) #/\ D #= 1 ),
limit_repetition(Y, D, Xs, Max).
limit_repetition(_X, _C, [], _Max).
yields
?- length(X,4), X ins 1..4, limit_repetition(X, 1) ,label(X).
X = [1, 2, 1, 2] ;
X = [1, 2, 1, 3] ;
...
Seems the former version is more related to your sample.
I'm trying to duplicate the behavior of the standard length/2 predicate. In particular, I want my predicate to work for bounded and unbounded arguments, like in the example below:
% Case 1
?- length(X, Y).
X = [],
Y = 0 ;
X = [_G4326],
Y = 1 ;
X = [_G4326, _G4329],
Y = 2 ;
X = [_G4326, _G4329, _G4332],
Y = 3 .
% Case 2
?- length([a,b,c], X).
X = 3.
% Case 3
?- length(X, 4).
X = [_G4314, _G4317, _G4320, _G4323].
% Case 4
?- length([a,b,c,d,e], 5).
true.
The plain&simple implementation:
my_length([], 0).
my_length([_|T], N) :- my_length(T, X), N is 1+X.
has some problems. In Case 3, after producing the correct answer, it goes into an infinite loop. Could this predicate be transformed into a deterministic one? Or non-deterministic that halts with false?
YES! But using red cut. See: https://stackoverflow.com/a/15123016/1545971
After some time, I've managed to code a set of predicates, that mimic the behavior of the build-in length/2. my_len_tail is deterministic and works correct in all Cases 1-4. Could it be done simpler?
my_len_tail(List, Len) :- var(Len)->my_len_tailv(List, 0, Len);
my_len_tailnv(List, 0, Len).
my_len_tailv([], Acc, Acc).
my_len_tailv([_|T], Acc, Len) :-
M is Acc+1,
my_len_tailv(T, M, Len).
my_len_tailnv([], Acc, Acc) :- !. % green!
my_len_tailnv([_|T], Acc, Len) :-
Acc<Len,
M is Acc+1,
my_len_tailnv(T, M, Len).
As #DanielLyons suggested in the comments, one can use clpfd to defer less than check. But it still leaves one problem: in Case 3 (my_len_clp(X, 3)) the predicate is nondeterministic. How it could be fixed?
:-use_module(library(clpfd)).
my_len_clp(List, Len) :- my_len_clp(List, 0, Len).
my_len_clp([], Acc, Acc).
my_len_clp([_|T], Acc, Len) :-
Acc#<Len,
M is Acc+1,
my_len_clp(T, M, Len).
It can be fixed using zcompare/3 from the CLP(FD) library. See: https://stackoverflow.com/a/15123146/1545971
In SWI-Prolog, the nondeterminism issue can be solved with CLP(FD)'s zcompare/3, which reifies the inequality to a term that can be used for indexing:
:- use_module(library(clpfd)).
my_length(Ls, L) :-
zcompare(C, 0, L),
my_length(Ls, C, 0, L).
my_length([], =, L, L).
my_length([_|Ls], <, L0, L) :-
L1 #= L0 + 1,
zcompare(C, L1, L),
my_length(Ls, C, L1, L).
Your example is now deterministic (since recent versions of SWI-Prolog perform just-in-time indexing):
?- my_length(Ls, 3).
Ls = [_G356, _G420, _G484].
All serious Prolog implementations ship with CLP(FD), and it makes perfect sense to use it here. Ask your vendor to also implement zcompare/3 or a better alternative if it is not already available.
For a set of test cases, please refer to this table and to the current definition in the prologue. There are many more odd cases to consider.
Defining length/2 with var/nonvar, is/2 and the like is not entirely trivial, because (is)/2 and arithmetic comparison is so limited. That is, they produce very frequently instantiation_errors instead of succeeding accordingly. Just to illustrate that point: It is trivial to define length_sx/2 using successor-arithmetics.
length_sx([], 0).
length_sx([_E|Es], s(X)) :-
length_sx(Es, X).
This definition is pretty perfect. It even fails for length_sx(L, L). Alas, successor arithmetics is not supported efficiently. That is, an integer i requires O(i) space and not O(log i) as one would expect.
The definition I would have preferred is:
length_fd([],0).
length_fd([_E|Es], L0) :-
L0 #> 0,
L1 #= L0-1,
length_fd(Es, L1).
Which is the most direct translation. It is quite efficient with a known length, but otherwise the overhead of constraints behind shows. Also, there is this asymmetry:
?- length_fd(L,0+0).
false.
?- length_fd(L,0+1).
L = [_A]
; false.
However, your definition using library(clpfd) is particularly elegant and efficient even for more elaborate cases.. It isn't as fast as the built-in length...
?- time(( length_fd(L,N),N=1000 )).
% 29,171,112 inferences, 4.110 CPU in 4.118 seconds (100% CPU, 7097691 Lips)
L = [_A,_B,_C,_D,_E,_F,_G,_H,_I|...], N = 1000
; ... .
?- time(( my_len_clp(L,N),N=10000 )).
% 1,289,977 inferences, 0.288 CPU in 0.288 seconds (100% CPU, 4484310 Lips)
L = [_A,_B,_C,_D,_E,_F,_G,_H,_I|...], N = 10000
; ... .
?- time(( length(L,N),N=10000 )).
% 30,003 inferences, 0.006 CPU in 0.006 seconds (100% CPU, 4685643 Lips)
L = [_A,_B,_C,_D,_E,_F,_G,_H,_I|...], N = 10000
; ... .
... but then it is able to handle constraints correctly:
?- N in 1..2, my_len_clp(L,N).
N = 1, L = [_A]
; N = 2, L = [_A, _B]
; false.
?- N in 1..2, length(L,N).
N = 1, L = [_A]
; N = 2, L = [_A, _B]
; loops.
I am not especially confident in this answer but my thinking is no, you have to do some extra work to make Prolog do the right thing for length/2, which is a real shame because it's such a great "tutorial" predicate in the simplest presentation.
I submit as proof, the source code to this function in SWI-Prolog and the source in GNU Prolog. Neither of these is a terse, cute trick, and it looks to me like they both work by testing the arguments and then deferring processing to different internal functions depending on which argument is instantiated.
I would love to be wrong about this though. I have often wondered why it is, for instance, so easy to write member/2 which does the right thing but so hard to write length/2 which does. Prolog isn't great at arithmetic, but is it really that bad? Here's hoping someone else comes along with a better answer.
(I've tried to edit #false's response, but it was rejected)
my_len_tail/2 is faster (in terms of both the number of inferences and actual time) than buldin length/2 when generating a list, but has problem with N in 1..2 constraint.
?- time(( my_len_tail(L,N),N=10000000 )).
% 20,000,002 inferences, 2.839 CPU in 3.093 seconds (92% CPU, 7044193 Lips)
L = [_G67, _G70, _G73, _G76, _G79, _G82, _G85, _G88, _G91|...],
N = 10000000 .
?- time(( length(L,N),N=10000000 )).
% 30,000,004 inferences, 3.557 CPU in 3.809 seconds (93% CPU, 8434495 Lips)
L = [_G67, _G70, _G73, _G76, _G79, _G82, _G85, _G88, _G91|...],
N = 10000000 .
This works for all your test cases (but it has red cut):
my_length([], 0).
my_length([_|T], N) :-
( integer(N) ->
!,
N > 0,
my_length(T, X), N is 1 + X, !
;
my_length(T, X), N is 1 + X
).
implementation
goal_expansion((_lhs_ =:= _rhs_),(when(ground(_rhs_),(_lhs_ is _rhs_)))) .
:- op(2'1,'yfx','list') .
_list_ list [size:_size_] :-
_list_ list [size:_size_,shrink:_shrink_] ,
_list_ list [size:_size_,shrink:_shrink_,size:_SIZE_] .
_list_ list [size:0,shrink:false] .
_list_ list [size:_size_,shrink:true] :-
when(ground(_size_),(_size_ > 0)) .
[] list [size:0,shrink:false,size:0] .
[_car_|_cdr_] list [size:_size_,shrink:true,size:_SIZE_] :-
(_SIZE_ =:= _size_ - 1) ,
(_size_ =:= _SIZE_ + 1) ,
_cdr_ list [size:_SIZE_] .
testing
/*
?- L list Z .
L = [],
Z = [size:0] ? ;
L = [_A],
Z = [size:1] ? ;
L = [_A,_B],
Z = [size:2] ? ;
L = [_A,_B,_C],
Z = [size:3] ?
yes
?- L list [size:0] .
L = [] ? ;
no
?- L list [size:1] .
L = [_A] ? ;
no
?- L list [size:2] .
L = [_A,_B] ? ;
no
?- [] list [size:S] .
S = 0 ? ;
no
?- [a] list [size:S] .
S = 1 ? ;
no
?- [a,b] list [size:S] .
S = 2 ? ;
no
?- [a,b,c] list [size:S] .
S = 3 ? ;
no
?-
*/
I already made a working generalized verbal arithmetic solver in Prolog but it's too slow. It takes 8 minutes just to run the simple expression S E N D + M O R E = M O N E Y. Can someone help me make it run faster?
/* verbalArithmetic(List,Word1,Word2,Word3) where List is the list of all
possible letters in the words. The SEND+MORE = MONEY expression would then
be represented as
verbalArithmetic([S,E,N,D,M,O,R,Y],[S,E,N,D],[M,O,R,E],[M,O,N,E,Y]). */
validDigit(X) :- member(X,[0,1,2,3,4,5,6,7,8,9]).
validStart(X) :- member(X,[1,2,3,4,5,6,7,8,9]).
assign([H|[]]) :- validDigit(H).
assign([H|Tail]) :- validDigit(H), assign(Tail), fd_all_different([H|Tail]).
findTail(List,H,T) :- append(H,[T],List).
convert([T],T) :- validDigit(T).
convert(List,Num) :- findTail(List,H,T), convert(H,HDigit), Num is (HDigit*10+T).
verbalArithmetic(WordList,[H1|Tail1],[H2|Tail2],Word3) :-
validStart(H1), validStart(H2), assign(WordList),
convert([H1|Tail1],Num1),convert([H2|Tail2],Num2), convert(Word3,Num3),
Sum is Num1+Num2, Num3 = Sum.
Consider using finite domain constraints, for example, in SWI-Prolog:
:- use_module(library(clpfd)).
puzzle([S,E,N,D] + [M,O,R,E] = [M,O,N,E,Y]) :-
Vars = [S,E,N,D,M,O,R,Y],
Vars ins 0..9,
all_different(Vars),
S*1000 + E*100 + N*10 + D +
M*1000 + O*100 + R*10 + E #=
M*10000 + O*1000 + N*100 + E*10 + Y,
M #\= 0, S #\= 0.
Example query:
?- time((puzzle(As+Bs=Cs), label(As))).
% 5,803 inferences, 0.002 CPU in 0.002 seconds (98% CPU, 3553582 Lips)
As = [9, 5, 6, 7],
Bs = [1, 0, 8, 5],
Cs = [1, 0, 6, 5, 2] ;
% 1,411 inferences, 0.001 CPU in 0.001 seconds (97% CPU, 2093472 Lips)
false.
Poor performance here is due to forming all possible letter assignments before checking if any are feasible.
My advice is "fail early, fail often". That is, push as many checks for failure as early as possible into the assignment steps, thus pruning the search tree.
Klas Lindbäck makes some good suggestions. As a generalization, when adding two numbers the carry is at most one in each place. So the assignment of distinct digits to letters from left to right can be checked with allowance for the possibility of an as-yet-undetermined carry in the rightmost places. (Of course in the final "units" place, there is no carry.)
It's a lot to think about, which is why constraint logic, as mat suggests (and which you've already broached with fd_all_different/1), is such a convenience.
Added: Here's a Prolog solution without constraint logic, using just one auxiliary predicate omit/3:
omit(H,[H|T],T).
omit(X,[H|T],[H|Y]) :- omit(X,T,Y).
which both selects an item from a list and produces the shortened list without that item.
Here then is the code for sendMoreMoney/3 that searches by evaluating the sum from left to right:
sendMoreMoney([S,E,N,D],[M,O,R,E],[M,O,N,E,Y]) :-
M = 1,
omit(S,[2,3,4,5,6,7,8,9],PoolO),
(CarryS = 0 ; CarryS = 1),
%% CarryS + S + M = M*10 + O
O is (CarryS + S + M) - (M*10),
omit(O,[0|PoolO],PoolE),
omit(E,PoolE,PoolN),
(CarryE = 0 ; CarryE = 1),
%% CarryE + E + O = CarryS*10 + N
N is (CarryE + E + O) - (CarryS*10),
omit(N,PoolN,PoolR),
(CarryN = 0 ; CarryN = 1),
%% CarryN + N + R = CarryE*10 + E
R is (CarryE*10 + E) - (CarryN + N),
omit(R,PoolR,PoolD),
omit(D,PoolD,PoolY),
%% D + E = CarryN*10 + Y
Y is (D + E) - (CarryN*10),
omit(Y,PoolY,_).
We get off to a quick start by observing that M must be the nonzero carry from the leftmost digits sum, hence 1, and that S must be some other nonzero digit. The comments show steps where additional letters may be deterministically assigned values based on choices already made.
Added(2): Here is a "general" cryptarithm solver for two summands, which need not have the same length/number of "places". Code for length/2 is omitted as a fairly common built-in predicate, and taking up the suggestion by Will Ness, calls to omit/3 are replaced by select/3 for convenience of SWI-Prolog users.
I've tested this with Amzi! and SWI-Prolog using those alphametics examples from Cryptarithms.com which involve two summands, each of which has a unique solution. I also made up an example with a dozen solutions, I + AM = BEN, to test proper backtracking.
solveCryptarithm([H1|T1],[H2|T2],Sum) :-
operandAlign([H1|T1],[H2|T2],Sum,AddTop,AddPad,Carry,TSum,Pool),
solveCryptarithmAux(H1,H2,AddTop,AddPad,Carry,TSum,Pool).
operandAlign(Add1,Add2,Sum,AddTop,AddPad,Carry,TSum,Pool) :-
operandSwapPad(Add1,Add2,Length,AddTop,AddPad),
length(Sum,Size),
( Size = Length
-> ( Carry = 0, Sum = TSum , Pool = [1|Peel] )
; ( Size is Length+1, Carry = 1, Sum = [Carry|TSum], Pool = Peel )
),
Peel = [2,3,4,5,6,7,8,9,0].
operandSwapPad(List1,List2,Length,Longer,Padded) :-
length(List1,Length1),
length(List2,Length2),
( Length1 >= Length2
-> ( Length = Length1, Longer = List1, Shorter = List2, Pad is Length1 - Length2 )
; ( Length = Length2, Longer = List2, Shorter = List1, Pad is Length2 - Length1 )
),
zeroPad(Shorter,Pad,Padded).
zeroPad(L,0,L).
zeroPad(L,K,P) :-
K > 0,
M is K-1,
zeroPad([0|L],M,P).
solveCryptarithmAux(_,_,[],[],0,[],_).
solveCryptarithmAux(NZ1,NZ2,[H1|T1],[H2|T2],CarryOut,[H3|T3],Pool) :-
( CarryIn = 0 ; CarryIn = 1 ), /* anticipatory carry */
( var(H1)
-> select(H1,Pool,P_ol)
; Pool = P_ol
),
( var(H2)
-> select(H2,P_ol,P__l)
; P_ol = P__l
),
( var(H3)
-> ( H3 is H1 + H2 + CarryIn - 10*CarryOut, select(H3,P__l,P___) )
; ( H3 is H1 + H2 + CarryIn - 10*CarryOut, P__l = P___ )
),
NZ1 \== 0,
NZ2 \== 0,
solveCryptarithmAux(NZ1,NZ2,T1,T2,CarryIn,T3,P___).
I think this illustrates that the advantages of left-to-right search/evaluation can be attained in a "generalized" solver, increasing the number of inferences by roughly a factor of two in comparison with the earlier "tailored" code.
Note: This answer discusses an algorithm for reducing the number of combinations that need to be tried. I don't know Prolog, so I can't provide any code snippets.
The trick to speed up a brute force solution is shortcuts. If you can identify a range of combinations that are invalid you can reduce the number of combinations substantially.
Take the example in hand. When a human solves it, she immediately notices that MONEY has 5 digits while SEND and MORE only have 4, so the M in MONEY must be the digit 1. 90% of the combinations gone!
When constructing an algorithm for a computer, we try to use shortcuts that apply to all possible input first. If they fail to give the required performance we start looking at shortcuts that only apply to specific combinations of input.
So we leave the M=1 shortcut for now.
Instead, I would focus on the last digits.
We know that (D+E) mod 10 = Y.
That's our 90% reduction in the number of combinations to try.
That step should bring exacution to just under a minute.
What can we do if that's not enough?
Next step:
Look at the second to last digit!
We know that (N+R+carry from D+E) mod 10 = E.
Since we are testing through all valid combinations of the last digit, for each test we will know whether the carry is 0 or 1.
A complication (for the code) that further reduces the number of combinations to be tested is that we will encounter duplicates (a letter gets mapped to a number that is already assigned to another letter). When we encounter a duplicate, we can advance to the next combination without going further down the chain.
Good luck with your assignment!
Here's my take on it. I use clpfd, dcg,
and meta-predicate mapfoldl/5:
:- meta_predicate mapfoldl(4,?,?,?,?).
mapfoldl(P_4,Xs,Zs, S0,S) :-
list_mapfoldl_(Xs,Zs, S0,S, P_4).
:- meta_predicate list_mapfoldl_(?,?,?,?,4).
list_mapfoldl_([],[], S,S, _).
list_mapfoldl_([X|Xs],[Y|Ys], S0,S, P_4) :-
call(P_4,X,Y,S0,S1),
list_mapfoldl_(Xs,Ys, S1,S, P_4).
Let's put mapfoldl/5 to good use and do some verbal arithmetic!
:- use_module(library(clpfd)).
:- use_module(library(lambda)).
digits_number(Ds,Z) :-
Ds = [D0|_],
Ds ins 0..9,
D0 #\= 0, % most-significant digit must not equal 0
reverse(Ds,Rs),
length(Ds,N),
numlist(1,N,Es), % exponents (+1)
maplist(\E1^V^(V is 10**(E1-1)),Es,Ps),
scalar_product(Ps,Rs,#=,Z).
list([]) --> [].
list([E|Es]) --> [E], list(Es).
cryptarithexpr_value([V|Vs],X) -->
{ digits_number([V|Vs],X) },
list([V|Vs]).
cryptarithexpr_value(T0,T) -->
{ functor(T0,F,A) },
{ dif(F-A,'.'-2) },
{ T0 =.. [F|Args0] },
mapfoldl(cryptarithexpr_value,Args0,Args),
{ T =.. [F|Args] }.
crypt_arith_(Expr,Zs) :-
phrase(cryptarithexpr_value(Expr,Goal),Zs0),
( member(Z,Zs0), \+var(Z)
-> throw(error(uninstantiation_error(Expr),crypt_arith_/2))
; true
),
sort(Zs0,Zs),
all_different(Zs),
call(Goal).
Quick and dirty hack to dump all solutions found:
solve_n_dump(Opts,Eq) :-
( crypt_arith_(Eq,Zs),
labeling(Opts,Zs),
format('Eq = (~q), Zs = ~q.~n',[Eq,Zs]),
false
; true
).
solve_n_dump(Eq) :- solve_n_dump([],Eq).
Let's try it!
?- solve_n_dump([S,E,N,D]+[M,O,R,E] #= [M,O,N,E,Y]).
Eq = ([9,5,6,7]+[1,0,8,5]#=[1,0,6,5,2]), Zs = [9,5,6,7,1,0,8,2].
true.
?- solve_n_dump([C,R,O,S,S]+[R,O,A,D,S] #= [D,A,N,G,E,R]).
Eq = ([9,6,2,3,3]+[6,2,5,1,3]#=[1,5,8,7,4,6]), Zs = [9,6,2,3,5,1,8,7,4].
true.
?- solve_n_dump([F,O,R,T,Y]+[T,E,N]+[T,E,N] #= [S,I,X,T,Y]).
Eq = ([2,9,7,8,6]+[8,5,0]+[8,5,0]#=[3,1,4,8,6]), Zs = [2,9,7,8,6,5,0,3,1,4].
true.
?- solve_n_dump([E,A,U]*[E,A,U] #= [O,C,E,A,N]).
Eq = ([2,0,3]*[2,0,3]#=[4,1,2,0,9]), Zs = [2,0,3,4,1,9].
true.
?- solve_n_dump([N,U,M,B,E,R] #= 3*[P,R,I,M,E]).
% same as: [N,U,M,B,E,R] #= [P,R,I,M,E]+[P,R,I,M,E]+[P,R,I,M,E]
Eq = (3*[5,4,3,2,8]#=[1,6,2,9,8,4]), Zs = [5,4,3,2,8,1,6,9].
true.
?- solve_n_dump(3*[C,O,F,F,E,E] #= [T,H,E,O,R,E,M]).
Eq = (3*[8,3,1,1,9,9]#=[2,4,9,3,5,9,7]), Zs = [8,3,1,9,2,4,5,7].
true.
Let's do some more and try some different labeling options:
?- time(solve_n_dump([],[D,O,N,A,L,D]+[G,E,R,A,L,D] #= [R,O,B,E,R,T])).
Eq = ([5,2,6,4,8,5]+[1,9,7,4,8,5]#=[7,2,3,9,7,0]), Zs = [5,2,6,4,8,1,9,7,3,0].
% 35,696,801 inferences, 3.929 CPU in 3.928 seconds (100% CPU, 9085480 Lips)
true.
?- time(solve_n_dump([ff],[D,O,N,A,L,D]+[G,E,R,A,L,D] #= [R,O,B,E,R,T])).
Eq = ([5,2,6,4,8,5]+[1,9,7,4,8,5]#=[7,2,3,9,7,0]), Zs = [5,2,6,4,8,1,9,7,3,0].
% 2,902,871 inferences, 0.340 CPU in 0.340 seconds (100% CPU, 8533271 Lips)
true.
Will Ness style, generalized (but assuming length(A) <= length(B)) solver:
money_puzzle(A, B, C) :-
maplist(reverse, [A,B,C], [X,Y,Z]),
numlist(0, 9, Dom),
swc(0, Dom, X,Y,Z),
A \= [0|_], B \= [0|_].
swc(C, D0, [X|Xs], [Y|Ys], [Z|Zs]) :-
peek(D0, X, D1),
peek(D1, Y, D2),
peek(D2, Z, D3),
S is X+Y+C,
( S > 9 -> Z is S - 10, C1 = 1 ; Z = S, C1 = 0 ),
swc(C1, D3, Xs, Ys, Zs).
swc(C, D0, [], [Y|Ys], [Z|Zs]) :-
peek(D0, Y, D1),
peek(D1, Z, D2),
S is Y+C,
( S > 9 -> Z is S - 10, C1 = 1 ; Z = S, C1 = 0 ),
swc(C1, D2, [], Ys, Zs).
swc(0, _, [], [], []).
swc(1, _, [], [], [1]).
peek(D, V, R) :- var(V) -> select(V, D, R) ; R = D.
performance:
?- time(money_puzzle([S,E,N,D],[M,O,R,E],[M,O,N,E,Y])).
% 38,710 inferences, 0.016 CPU in 0.016 seconds (100% CPU, 2356481 Lips)
S = 9,
E = 5,
N = 6,
D = 7,
M = 1,
O = 0,
R = 8,
Y = 2 ;
% 15,287 inferences, 0.009 CPU in 0.009 seconds (99% CPU, 1685686 Lips)
false.
?- time(money_puzzle([D,O,N,A,L,D],[G,E,R,A,L,D],[R,O,B,E,R,T])).
% 14,526 inferences, 0.008 CPU in 0.008 seconds (99% CPU, 1870213 Lips)
D = 5,
O = 2,
N = 6,
A = 4,
L = 8,
G = 1,
E = 9,
R = 7,
B = 3,
T = 0 ;
% 13,788 inferences, 0.009 CPU in 0.009 seconds (99% CPU, 1486159 Lips)
false.
You have
convert([A,B,C,D]) => convert([A,B,C])*10 + D
=> (convert([A,B])*10+C)*10+D => ...
=> ((A*10+B)*10+C)*10+D
So, you can express this with a simple linear recursion.
More importantly, when you pick one possible digit from your domain 0..9, you shouldn't use that digit anymore for subsequent choices:
selectM([A|As],S,Z):- select(A,S,S1),selectM(As,S1,Z).
selectM([],Z,Z).
select/3 is available in SWI Prolog. Armed with this tool, you can select your digits gradually from your thus narrowing domain:
money_puzzle( [[S,E,N,D],[M,O,R,E],[M,O,N,E,Y]]):-
Dom = [0,1,2,3,4,5,6,7,8,9],
selectM([D,E], Dom,Dom1), add(D,E,0, Y,C1), % D+E=Y
selectM([Y,N,R],Dom1,Dom2), add(N,R,C1,E,C2), % N+R=E
select( O, Dom2,Dom3), add(E,O,C2,N,C3), % E+O=N
selectM([S,M], Dom3,_), add(S,M,C3,O,M), % S+M=MO
S \== 0, M \== 0.
We can add two digits with a carry, add produce a resulting digit with new carry (say, 4+8 (0) = 2 (1) i.e. 12):
add(A,B,C1,D,C2):- N is A+B+C1, D is N mod 10, C2 is N // 10 .
Thus implemented, money_puzzle/1 runs instantaneously, thanks to the gradual nature in which the digits are picked and tested right away:
?- time( money_puzzle(X) ).
% 27,653 inferences, 0.02 CPU in 0.02 seconds (100% CPU, 1380662 Lips)
X = [[9, 5, 6, 7], [1, 0, 8, 5], [1, 0, 6, 5, 2]] ;
No
?- time( (money_puzzle(X),fail) ).
% 38,601 inferences, 0.02 CPU in 0.02 seconds (100% CPU, 1927275 Lips)
The challenge becomes now to make it generic.