Faster implementation of verbal arithmetic in Prolog

Question

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.

Amputee

Answer 1

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.

Spectroheliograph

Answer 2

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.

Treenware

your omit/3 is SWI-Prolog's select/3. Variously known as del/3, delete/3 etc. Using it allows for direct manipulation of finite domains (or "pools"). The selectM/3 predicate from my answer packs multiple invocations of select/3 into one, for easier and much shorter coding. Also, your code employs a lot of human reasoning. – Kendo

@WillNess: It's true that SWI-Prolog has that (equivalent) predicate as a built-in. I was trying to illustrate the benefit of left-to-right evaluation, which thanks to your right-to-left version, we can compare. – Treenware

So I tried your version and it took 533(676) inferences/0.00 sec, vs. 27,653(38,601) inferences/0.02 sec that my version takes. :) That's not surprising considering the amount of human reasoning that goes into your code, which is much harder to formalize in comparison (which is what the original Q is about, after all). The WP article e.g. arrives at full solution without any code, carrying that human reasoning a bit further. – Kendo

you're too much!! :) :) Your new code certainly looks generic. When tested, it shows taking 833 inferences to arrive at the solution, and 1477 infs to fully explore the search space. – Kendo

@WillNess: Thanks for your kind remarks and generous award! I appreciate the "hallway code review". – Treenware

Answer 3

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!

Maximomaximum

Very nice reasoning, +1! This is exactly what the CLP(FD) version does for you behind the scenes. For example, when I query: ?- puzzle([S,E,N,D] + [M,O,R,E] = [M,O,N,E,Y])., then I get as variable bindings: M = 1, O = 0, S = 9, so 3 variables are readily fixed to concrete integers already by just posting the CLP(FD) constraints that describe the puzzle. The domains of the remaining variables are reduced too, as we see from the residual goals: N in 5..8, E in 4..7, R in 2..8, Y in 2..8. A final search step finds the unique solution as concrete integer bindings for all CLP(FD) variables. – Spectroheliograph

Answer 4

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.

Kendo

Answer 5

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.

Waterresistant

Answer 6

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.

Alisun