Solution to Smullyan's numerical machines

Question

Here I propose to find a solution to Smullyan's numerical machines as defined here.

Problem statement

They're machines that take a list of digits as input, and transform it to another list of digits following some rules based on the pattern of the input. Here are the rules of the machine given in the link above, expressed a bit more formally. Let say M is the machine, and M(X) is the transformation of X. We define a few rules like this:

M(2X) = X
M(3X) = M(X)2M(X)
M(4X) = reverse(M(X)) // reverse the order of the list.
M(5X) = M(X)M(X)

And anything that does not match any rule is rejected. Here are a few examples:

• M(245) = 45
• M(3245) = M(245)2M(245) = 45245
• M(43245) = reverse(M(3245)) = reverse(45245) = 54254
• M(543245) = M(43245)M(43245) = 5425454254

And the questions are, find X such that:

• M(X) = 2
• M(X) = X
• M(X) = X2X
• M(X) = reverse(X)
• M(X) = reverse(X2X)reverse(X2X)

Here is a second example a bit more complex with the exhaustive search (especially if I want the first 10 or 100 solutions).

M(1X2) = X
M(3X) = M(X)M(X)
M(4X) = reverse(M(X))
M(5X) = truncate(M(X)) // remove the first element of the list truncate(1234) = 234. Only valid if M(X) has at least 2 elements.
M(6X) = 1M(X)
M(7X) = 2M(X)

Questions:

• M(X) = XX
• M(X) = X
• M(X) = reverse(X)

(Non-)Solutions

Writing a solver in Prolog is pretty straightforward. Except that it's just exhaustive exploration (a.k.a brute force) and may take some time for some set of rules.

I tried but couldn't express this problem in terms of logic constraints with CLP(FD), so I tried CHR (Constraint Handling Rules) to express this in terms of constraints on lists (especially append constraints), but no matter how I express it, it always boils down to an exhaustive search.

Question

Any idea what approach I could take to resolve any problem of this kind in a reasonable amount of time? Ideally I would like to be able to generate all the solutions shorter than some bound.

Answer 1

Let's look at your "a bit more complex" problem. Exhaustive search works excellently!

Here is a comparison with Серге́й's solution which can be improved significantly by factoring the common goals:

m([1|A], X) :-
    A = [_|_],
    append(X, [2], A).
m([E | X], Z) :-
    m(X, Y),
    (  E = 3,
       append(Y, Y, Z)
    ;  E = 4,
       reverse(Y, Z)
    ;  E = 5,
       Y = [_ | Z]
    ;  E = 6,
       Z = [1 | Y]
    ;  E = 7,
       Z = [2 | Y]
    ).

For query time(findall(_, (question3(X), write(X), nl), _)). I get with B 8.1, SICStus 4.3b8:

Серге́й B tabled   104.542s
Серге́й B          678.394s
false  B           16.013s
false  B tabled    53.007s
Серге́й SICStus    439.210s
false  SICStus      7.990s
Серге́й SWI       1383.678s, 5,363,110,835 inferences
false  SWI         44.743s,   185,136,302 inferences

The additional questions are not that difficult to answer. Only SICStus with above m/2 and call_nth/2:

| ?- time(call_nth( (
        length(Xs0,N),append(Xs0,Xs0,Ys),m(Xs0,Ys),
          writeq(Ys),nl ), 10)).
[4,3,7,4,3,1,4,3,7,4,3,1,2,4,3,7,4,3,1,4,3,7,4,3,1,2]
[3,4,7,4,3,1,3,4,7,4,3,1,2,3,4,7,4,3,1,3,4,7,4,3,1,2]
[4,3,7,3,4,1,4,3,7,3,4,1,2,4,3,7,3,4,1,4,3,7,3,4,1,2]
[3,4,7,3,4,1,3,4,7,3,4,1,2,3,4,7,3,4,1,3,4,7,3,4,1,2]
[3,5,4,5,3,1,2,2,1,3,5,4,5,3,1,2,3,5,4,5,3,1,2,2,1,3,5,4,5,3,1,2]
[3,5,5,3,4,1,2,1,4,3,5,5,3,4,1,2,3,5,5,3,4,1,2,1,4,3,5,5,3,4,1,2]
[5,4,7,4,3,3,1,2,5,4,7,4,3,3,1,2,5,4,7,4,3,3,1,2,5,4,7,4,3,3,1,2]
[4,7,4,5,3,3,1,2,4,7,4,5,3,3,1,2,4,7,4,5,3,3,1,2,4,7,4,5,3,3,1,2]
[5,4,7,3,4,3,1,2,5,4,7,3,4,3,1,2,5,4,7,3,4,3,1,2,5,4,7,3,4,3,1,2]
[3,5,4,7,4,3,1,_2735,3,5,4,7,4,3,1,2,3,5,4,7,4,3,1,_2735,3,5,4,7,4,3,1,2]
196660ms

| ?- time(call_nth( (
        length(Xs0,N),m(Xs0,Xs0),
          writeq(Xs0),nl ), 10)).
[4,7,4,3,1,4,7,4,3,1,2]
[4,7,3,4,1,4,7,3,4,1,2]
[5,4,7,4,3,1,_2371,5,4,7,4,3,1,2]
[4,7,4,5,3,1,_2371,4,7,4,5,3,1,2]
[5,4,7,3,4,1,_2371,5,4,7,3,4,1,2]
[3,5,4,7,4,1,2,3,5,4,7,4,1,2]
[4,3,7,4,5,1,2,4,3,7,4,5,1,2]
[3,4,7,4,5,1,2,3,4,7,4,5,1,2]
[4,7,5,3,6,4,1,4,7,5,3,6,4,2]
[5,4,7,4,3,6,1,5,4,7,4,3,6,2]
6550ms

| ?- time(call_nth( (
        length(Xs0,N),reverse(Xs0,Ys),m(Xs0,Ys),
          writeq(Ys),nl ), 10)).
[2,1,3,4,7,1,3,4,7]
[2,1,4,3,7,1,4,3,7]
[2,1,3,5,4,7,_2633,1,3,5,4,7]
[2,1,5,4,7,3,2,1,5,4,7,3]
[2,4,6,3,5,7,1,4,6,3,5,7]
[2,6,3,5,4,7,1,6,3,5,4,7]
[2,_2633,1,5,3,4,7,_2633,1,5,3,4,7]
[2,_2633,1,5,4,3,7,_2633,1,5,4,3,7]
[2,1,3,4,4,4,7,1,3,4,4,4,7]
[2,1,3,4,5,6,7,1,3,4,5,6,7]
1500ms

Answer 2

(I assume that this is about a list of digits, as you suggest. Contrary to the link you gave, which talks about numbers. There might be differences with leading zeros. I did not take the time to think that through)

First of all, Prolog is an excellent language to search brute force. For, even in that case, Prolog is able to mitigate combinatorial explosion. Thanks to the logic variable.

Your problem statements are essentially existential statements: Does there exist an X such that such and such is true. That's where Prolog is best at. The point is the way how you are asking the question. Instead of asking with concrete values like [1] and so on, simply ask for:

?- length(Xs, N), m(Xs,Xs).
   Xs = [3,2,3], N = 3
;  ... .

And similarly for the other queries. Note that there is no need to settle for concrete values! This makes the search certainly more expensive!

?- length(Xs, N), maplist(between(0,9),Xs), m(Xs,Xs).
   Xs = [3,2,3], N = 3
;  ... .

In this manner it is quite efficiently possible to find concrete solutions, should they exist. Alas, we cannot decide that a solution does not exist.

Just to illustrate the point, here is the answer for the "most complex" puzzle:

?- length(Xs0,N),
      append(Xs0,[2|Xs0],Xs1),reverse(Xs1,Xs2),append(Xs2,Xs2,Xs3), m(Xs0,Xs3).
   Xs0 = [4, 5, 3, 3, 2, 4, 5, 3, 3], N = 9, ...

; ... .

It comes up in no time. However, the query:

?- length(Xs0,N), maplist(between(0,9),Xs0),
   append(Xs0,[2|Xs0],Xs1),reverse(Xs1,Xs2),append(Xs2,Xs2,Xs3), m(Xs0,Xs3).

is still running!

The m/2 I used:

m([2|Xs], Xs).
m([3|Xs0], Xs) :-
   m(Xs0,Xs1),
   append(Xs1,[2|Xs1], Xs).
m([4|Xs0], Xs) :-
   m(Xs0, Xs1),
   reverse(Xs1,Xs).
m([5|Xs0],Xs) :-
   m(Xs0,Xs1),
   append(Xs1,Xs1,Xs).

The reason why this is more effective is simply that a naive enumeration of all n digits has 10ⁿ different candidates, whereas Prolog will only search for 3ⁿ given by the 3 recursive rules.

Here is yet another optimization: All 3 rules have the very same recursive goal. So why do this thrice, when once is more than enough:

m([2|Xs], Xs).
m([X|Xs0], Xs) :-
   m(Xs0,Xs1),
   ( X = 3,
     append(Xs1,[2|Xs1], Xs)
   ; X = 4,
     reverse(Xs1,Xs)
   ; X = 5,
     append(Xs1,Xs1,Xs)
   ).

For the last query, this reduces from 410,014 inferences, 0.094s CPU down to 57,611 inferences, 0.015s CPU.

Edit: In a further optimization the two append/3 goals can be merged:

m([2|Xs], Xs).
m([X|Xs0], Xs) :-
   m(Xs0,Xs1),
   ( X = 4,
     reverse(Xs1,Xs)
   ; append(Xs1, Xs2, Xs),
     ( X = 3, Xs2 = [2|Xs1]
     ; X = 5, Xs2 = Xs1
     )
   ).

... which further reduces execution to 39,096 inferences and runtime by 1ms.

What else can be done? The length is bounded by the length of the "input". If n is the length of the input, then 2^(n-1)-1 is the longest output. Is this helping somehow? Probably not.

Answer 3

I propose here another solution which is basically exhaustive exploration. Given the questions, if the length of the first argument of m/2 is known, the length of the second is known as well. If the length of the second argument is always known, this can be used to cut down the search earlier by propagating some constraints down to the recursive calls. However, this is not compatible with the optimization proposed by false.

appendh([], [], Xs, Xs).
appendh([_, _ | Ws], [X | Xs], Ys, [X | Zs]) :-
    appendh(Ws, Xs, Ys, Zs).

m([1 | A], X) :-
    append(X, [2], A).
m([3 | A], X) :-
    appendh(X, B, B, X),
    m(A, B).
m([4 | A], X) :-
    reverse(X, B),
    m(A, B).
m([5 | A], X) :-
    B = [_, _ | _],
    B = [_ | X],
    m(A, B).
m([H1 | A], [H2 | B]) :-
    m(A, B),
    (  H1 = 6, H2 = 1
    ;  H1 = 7, H2 = 2
    ).

answer3(X) :-
    between(1, 13, N),
    length(X, N),
    reverse(X, A),
    m(X, A).

Here is the time taken respectively by: this code, this code when swapping recursive calls with the constraints of each case (similar to solution of Sergey Dymchenko), and the solution of false which factor the recursive calls. The test is run on SWI and search for all the solution whose length is less or equal to 13.

% 36,380,535 inferences, 12.281 CPU in 12.315 seconds (100% CPU, 2962336 Lips)
% 2,359,464,826 inferences, 984.253 CPU in 991.474 seconds (99% CPU, 2397214 Lips)
% 155,403,076 inferences, 47.799 CPU in 48.231 seconds (99% CPU, 3251186 Lips)

All measures are performed with the call:

?- time(findall(X, (answer3(X), writeln(X)), _)).

Answer 4

Here is another improvement to @Celelibi's improved version (cele_n). Roughly, it gets a factor of two by constraining the length of the first argument, and another factor of two by pretesting the two versions.

cele_n SICStus  2.630s
cele_n SWI     12.258s 39,546,768 inferences
cele_2 SICStus  0.490s
cele_2 SWI      2.665s  9,074,970 inferences

---

appendh([], [], Xs, Xs).
appendh([_, _ | Ws], [X | Xs], Ys, [X | Zs]) :-
   appendh(Ws, Xs, Ys, Zs).

m([H|A], X) :-
   A = [_|_],                 % New
   m(H, X, A).

m(1, X, A) :-
   append(X, [2], A).
m(3, X, A) :-
   appendh(X, B, B, X),
   m(A, B).
m(4, X, A) :-
   reverse(X, B),
   m(A, B).
m(5, X, A) :-
   X = [_| _],
   m(A, [_|X]).
m(H1, [H2 | B], A) :-
   \+ \+ ( H2 = 1 ; H2 = 2 ),  % New
   m(A, B),
   (  H1 = 6, H2 = 1
   ;  H1 = 7, H2 = 2
   ).

answer3(X) :-
   between(1, 13, N),
   length(X, N),
   reverse(X, A),
   m(X, A).

run :-
   time(findall(X, (answer3(X), write(X), nl), _)).

Answer 5

Tabling (memoization) can help with harder variants of the problem.

Here is my implementation for the third question of second example in B-Prolog (returns all solutions of length 13 or less):

:- table m/2.

m(A, X) :-
    append([1 | X], [2], A).
m([3 | X], Z) :-
    m(X, Y),
    append(Y, Y, Z).
m([4 | X], Z) :-
    m(X, Y),
    reverse(Y, Z).
m([5 | X], Z) :-
    m(X, Y),
    Y = [_ | Z].
m([6 | X], Z) :-
    m(X, Y),
    Z = [1 | Y].
m([7 | X], Z) :-
    m(X, Y),
    Z = [2 | Y].

question3(X) :-
    between(1, 13, N),
    length(X, N), 
    reverse(X, Z), m(X, Z).

Run:

B-Prolog Version 8.1, All rights reserved, (C) Afany Software 1994-2014.
| ?- cl(smullyan2).
cl(smullyan2).
Compiling::smullyan2.pl
compiled in 2 milliseconds
loading...

yes
| ?- time(findall(_, (question3(X), writeln(X)), _)).
time(findall(_, (question3(X), writeln(X)), _)).
[7,3,4,1,7,3,4,1,2]
[7,4,3,1,7,4,3,1,2]
[3,7,4,5,1,2,3,7,4,5,1,2]
[7,4,5,3,1,_678,7,4,5,3,1,2]
[7,4,5,3,6,1,7,4,5,3,6,2]
[7,5,3,6,4,1,7,5,3,6,4,2]
[4,4,7,3,4,1,4,4,7,3,4,1,2]
[4,4,7,4,3,1,4,4,7,4,3,1,2]
[5,6,7,3,4,1,5,6,7,3,4,1,2]
[5,6,7,4,3,1,5,6,7,4,3,1,2]
[5,7,7,3,4,1,5,7,7,3,4,1,2]
[5,7,7,4,3,1,5,7,7,4,3,1,2]
[7,3,4,4,4,1,7,3,4,4,4,1,2]
[7,3,4,5,1,_698,7,3,4,5,1,_698,2]
[7,3,4,5,6,1,7,3,4,5,6,1,2]
[7,3,4,5,7,1,7,3,4,5,7,1,2]
[7,3,5,6,4,1,7,3,5,6,4,1,2]
[7,3,5,7,4,1,7,3,5,7,4,1,2]
[7,3,6,5,4,1,7,3,6,5,4,1,2]
[7,4,3,4,4,1,7,4,3,4,4,1,2]
[7,4,3,5,1,_698,7,4,3,5,1,_698,2]
[7,4,3,5,6,1,7,4,3,5,6,1,2]
[7,4,3,5,7,1,7,4,3,5,7,1,2]
[7,4,4,3,4,1,7,4,4,3,4,1,2]
[7,4,4,4,3,1,7,4,4,4,3,1,2]
[7,4,5,6,3,1,7,4,5,6,3,1,2]
[7,4,5,7,3,1,7,4,5,7,3,1,2]
[7,5,6,3,4,1,7,5,6,3,4,1,2]
[7,5,6,4,3,1,7,5,6,4,3,1,2]
[7,5,7,3,4,1,7,5,7,3,4,1,2]
[7,5,7,4,3,1,7,5,7,4,3,1,2]
[7,6,5,3,4,1,7,6,5,3,4,1,2]
[7,6,5,4,3,1,7,6,5,4,3,1,2]

CPU time 25.392 seconds.
yes

So it's less than a minute for this particular problem.

I don't think constraint programming will be of any help with this type of problem, especially with "find 20 first solutions" variant.

Update: running times of the same program on my computer on different systems:

B-Prolog 8.1 with tabling: 26 sec
B-Prolog 8.1 without tabling: 128 sec
ECLiPSe 6.1 #187: 122 sec
SWI-Prolog 6.2.6: 330 sec