Lock Challenge in Prolog

Question

I just started learning prolog and I'm stuck trying to solve this puzzle :

I tried to add some rules like this example http://swish.swi-prolog.org/example/houses_puzzle.pl but I couldn't come up with a solution.

What I tried so far:

% Render the houses term as a nice table.
:- use_rendering(table,
         [header(h('N1', 'N2', 'N3'))]).
numbers(Hs) :-
    length(Hs, 1),
    member(h(6,8,2), Hs),
    member(h(6,1,4), Hs),
    member(h(2,0,6), Hs),
    member(h(7,3,8), Hs),
    member(h(7,8,0), Hs),
    correct_and_placed(6, 8, 2, Hs).

correct_and_place(A, B, C, R).

But I don't even know how to write a rule that can check if a number is correct and on the right place.

Answer 1

Another method, more succinct than my previous:

padlock(S) :-
    length(S, 3),
    present([6,8,2], S, 1, 0),
    present([6,1,4], S, 0, 1),
    present([2,0,6], S, 0, 2),
    present([7,3,8], S, 0, 0),
    present([7,8,0], S, 0, 1).

present(L, S, R, W) :-
    % Keep copy of full S
    present_(L, S, S, R, W).

present_([], [], _, 0, 0).
present_([H|T], [H|S], F, R, W) :-
    % Present and in right place
    present_(T, S, F, R0, W),
    R is R0 + 1.
present_([H|T], [HS|S], F, R, W) :-
    % Present but in wrong place
    dif(H, HS),
    member(H, F),
    present_(T, S, F, R, W0),
    W is W0 + 1.
present_([H|T], [_|S], F, R, W) :-
    % H is not present at all
    maplist(dif(H), F),
    present_(T, S, F, R, W).

Result in swi-prolog:

?- time(setof(L, padlock(L), Ls)).
% 7,519 inferences, 0.001 CPU in 0.001 seconds (100% CPU, 11695261 Lips)
Ls = [[0, 4, 2]].

Answer 2

As a generic solver, without using clpfd:

digits_length(3).

% Digits present, digits in right place
digit_clue([6,8,2], 1, 1).
digit_clue([6,1,4], 1, 0).
digit_clue([2,0,6], 2, 0).
% The last 2 clues are not needed
%digit_clue([7,3,8], 0, 0).
%digit_clue([7,8,0], 1, 0).

go(Sol) :-
    digits_length(Len),
    length(Sol, Len),
    findall(clue(Digits, PR, RP), digit_clue(Digits, PR, RP), Clues),
    add_digit_clues(Clues, Sol),
    maplist(between(0, 9), Sol).

add_digit_clues([], _).
add_digit_clues([clue(Digits, PR, RP)|T], Sol) :-
    add_digit_clue(Digits, Digits, PR, RP, Sol),
    add_digit_clues(T, Sol).

add_digit_clue([], _, 0, 0, _).
add_digit_clue([H|T], DigitsOrig, PR, RP, Sol) :-
    compare(Comp, PR, 0),
    add_clue(Comp, [H|T], DigitsOrig, PR, RP, RP0, Digits0, PR0, Sol),
    add_digit_clue(Digits0, DigitsOrig, PR0, RP0, Sol).

add_clue('=', Digits, _DigitsOrig, 0, 0, 0, [], 0, Sol) :-
    % None in Digits are in Sol
    list_elems_not_in_list(Digits, Sol).

add_clue('>', Digits, DigitsOrig, PR, RP, RP0, Digits0, PR0, Sol) :-
    succ(PR0, PR),
    compare(Comp, PR, RP),
    add_clue_rp(Comp, Digits, DigitsOrig, RP, RP0, Digits0, Sol).

add_clue_rp(Comp, Digits, DigitsOrig, RP, RP0, Digits0, Sol) :-
    (   Comp = '>',
        present_wrong_place(Digits, DigitsOrig, RP, RP0, Digits0, Sol)
    ;   present_right_place(Digits, DigitsOrig, RP, RP0, Digits0, Sol)
    ).

present_right_place(Digits, DigitsOrig, RP, RP0, Digits0, Sol) :-
    succ(RP0, RP),
    select(Digit, Digits, Digits0),
    nth0(Pos, DigitsOrig, Digit),
    nth0(Pos, Sol, Digit).

present_wrong_place(Digits, DigitsOrig, RP, RP, Digits0, Sol) :-
    select(Digit, Digits, Digits0),
    nth0(Pos, DigitsOrig, Digit),
    nth0(Pos, Sol, DigitSol),
    % The digit is in a different position, in Sol
    dif(Digit, DigitSol),
    member(Digit, Sol).

list_elems_not_in_list([], _).
list_elems_not_in_list([H|T], Lst) :-
    maplist(dif(H), Lst),
    list_elems_not_in_list(T, Lst).

Result in swi-prolog:

?- time(setof(S, go(S), Ss)).
% 3,848 inferences, 0.001 CPU in 0.001 seconds (97% CPU, 6941839 Lips)
Ss = [[0,4,2]].

Answer 3

To the existing answers, I would like to add a version using CLP(FD) constraints.

The two building blocks I shall use are num_correct/3 and num_well_placed/3.

First, num_correct/3, relating two lists of integers to the number of common elements:

num_correct(Vs, Ns, Num) :-
        foldl(num_correct_(Vs), Ns, 0, Num).

num_correct_(Vs, Num, N0, N) :-
        foldl(eq_disjunction(Num), Vs, 0, Disjunction),
        Disjunction #<==> T,
        N #= N0 + T.

eq_disjunction(N, V, D0, D0 #\/ (N #= V)).

Sample query:

?- num_correct([1,2,3], [3,5], Num).
Num = 1.

As is characteristic for pure relations, this also works for much more general queries, for example:

?- num_correct([A], [B], Num).
B#=A#<==>Num,
Num in 0..1.

Second, I use num_well_placed/3, which relates two lists of integers to the number of indices where corresponding elements are equal:

num_well_placed(Vs, Ns, Num) :-
        maplist(num_well_placed_, Vs, Ns, Bs),
        sum(Bs, #=, Num).

num_well_placed_(V, N, B) :- (V #= N) #<==> B.

Again, a sample query and answer:

?- num_well_placed([8,3,4], [0,3,4], Num).
Num = 2.

The following predicate simply combines these two:

num_correct_placed(Vs, Hs, C, P) :-
        num_correct(Vs, Hs, C),
        num_well_placed(Vs, Hs, P).

Thus, the whole puzzle can be formulated as follows:

lock(Vs) :-
        Vs = [_,_,_],
        Vs ins 0..9,
        num_correct_placed(Vs, [6,8,2], 1, 1),
        num_correct_placed(Vs, [6,1,4], 1, 0),
        num_correct_placed(Vs, [2,0,6], 2, 0),
        num_correct_placed(Vs, [7,3,8], 0, 0),
        num_correct_placed(Vs, [7,8,0], 1, 0).

No search at all is required in this case:

?- lock(Vs).
Vs = [0, 4, 2].

Moreover, if I generalize away the last hint, i.e., if I write:

lock(Vs) :-
        Vs = [_,_,_],
        Vs ins 0..9,
        num_correct_placed(Vs, [6,8,2], 1, 1),
        num_correct_placed(Vs, [6,1,4], 1, 0),
        num_correct_placed(Vs, [2,0,6], 2, 0),
        num_correct_placed(Vs, [7,3,8], 0, 0),
        * num_correct_placed(Vs, [7,8,0], 1, 0).

then the unique solution can still be determined without search:

?- lock(Vs).
Vs = [0, 4, 2].

In fact, I can even also take away the penultimate hint:

lock(Vs) :-
        Vs = [_,_,_],
        Vs ins 0..9,
        num_correct_placed(Vs, [6,8,2], 1, 1),
        num_correct_placed(Vs, [6,1,4], 1, 0),
        num_correct_placed(Vs, [2,0,6], 2, 0),
        * num_correct_placed(Vs, [7,3,8], 0, 0),
        * num_correct_placed(Vs, [7,8,0], 1, 0).

and still the solution is unique, although I now have to use label/1 to find it:

?- lock(Vs), label(Vs).
Vs = [0, 4, 2] ;
false.

Answer 4

So, as with all problems in this vein, I tend to be tempted to write a generic solver as opposed to a specific solver. Borrowing from a mastermind implementation I wrote a while ago (spawned by a question on here) I present the following:

compare(List,Reference,RightPlace,WrongPlace) takes two lists, and unifies RightPlace with the number of elements of the first list that appear at the same point in the second list, and WrongPlace with the number of elements that appear at a different point in the second list (where a duplicate element is only counted if it is duplicated in both lists). It does this using...

right_place(List,Reference,RightPlace) which wraps an accumulator and consumes elements from the head of each list, incrementing where they match, and...

any_match(List,Reference,Matches) which wraps an accumulator that consumes the head of the List list, and selects it from the Reference list where possible, incrementing where this occurs.

WrongPlace is then the number of RightPlace elements subtracted from the number of Matches.

Finally, find_solutions(Soln) creates a list of elements in the domain (0-9) using clpfd, then maps indomain to create the combinations. Each combination is then compared with each hint using forall, to ensure that all hint constraints are satisfied. Put it all together with the hints, and you get:

:- use_module(library(clpfd)).

compare(List,Reference,RightPlace,WrongPlace) :-
    right_place(List,Reference,RightPlace),
    any_match(List,Reference,Matches),
    WrongPlace #= Matches - RightPlace.

right_place(List,Reference,RightPlace) :-
    right_place(List,Reference,0,RightPlace).

right_place([],[],RightPlace,RightPlace).
right_place([Match|List],[Match|Reference],Accumulator,RightPlace) :-
    NewAccumulator is Accumulator + 1,
    right_place(List,Reference,NewAccumulator,RightPlace).
right_place([A|List],[B|Reference],Accumulator,RightPlace) :-
    A \= B,
    right_place(List,Reference,Accumulator,RightPlace).

any_match(List,Reference,Matches) :-
    any_match(List,Reference,0,Matches).

any_match([],_,Matches,Matches).
any_match([Match|List],Reference,Accumulator,Matches) :-
    select(Match,Reference,NewReference),
    NewAccumulator is Accumulator + 1,
    any_match(List,NewReference,NewAccumulator,Matches).
any_match([Match|List],Reference,Accumulator,Matches) :-
    \+member(Match,Reference),
    any_match(List,Reference,Accumulator,Matches).

find_solutions(Soln) :-
    length(Soln,3),
    Soln ins 0..9,
    maplist(indomain,Soln),
    forall(hint(X,Y,Z),compare(Soln,X,Y,Z)).

hint([6,8,2],1,0).
hint([6,1,4],0,1).
hint([2,0,6],0,2).
hint([7,3,8],0,0).
hint([7,8,0],0,1).

Answer 5

I hope there are better ways but...

You can implement "one number is correct and well placed" as follows

oneRightPlace(X, Y, Z, X, S2, S3) :-
  \+ member(Y, [S2, S3]),
  \+ member(Z, [S2, S3]).

oneRightPlace(X, Y, Z, S1, Y, S3) :-
  \+ member(X, [S1, S3]),
  \+ member(Z, [S1, S3]).

oneRightPlace(X, Y, Z, S1, S2, Z) :-
  \+ member(X, [S1, S2]),
  \+ member(Y, [S1, S2]).

For "one number is correct but wrong placed, you can use

oneWrongPlace(X, Y, Z, S1, S2, S3) :-
  member(X, [S2, S3]),
  \+ member(Y, [S1, S2, S3]),
  \+ member(Z, [S1, S2, S3]).

oneWrongPlace(X, Y, Z, S1, S2, S3) :-
  member(Y, [S1, S3]),
  \+ member(X, [S1, S2, S3]),
  \+ member(Z, [S1, S2, S3]).

oneWrongPlace(X, Y, Z, S1, S2, S3) :-
  member(Z, [S1, S2]),
  \+ member(X, [S1, S2, S3]),
  \+ member(Y, [S1, S2, S3]).

For "two number are correct but wrong placed", you can write

twoWrongPlace(X, Y, Z, S1, S2, S3) :-
  member(X, [S2, S3]),
  member(Y, [S1, S3]),
  \+ member(Z, [S1, S2, S3]).

twoWrongPlace(X, Y, Z, S1, S2, S3) :-
  member(X, [S2, S3]),
  member(Z, [S1, S2]),
  \+ member(Y, [S1, S2, S3]).

twoWrongPlace(X, Y, Z, S1, S2, S3) :-
  member(Y, [S1, S3]),
  member(Z, [S1, S2]),
  \+ member(X, [S1, S2, S3]).

And, for "nothing is correct", become simply

zeroPlace(X, Y, Z, S1, S2, S3) :-
  \+ member(X, [S1, S2, S3]),
  \+ member(Y, [S1, S2, S3]),
  \+ member(Z, [S1, S2, S3]).

Now you can put all togheter and write

  member(S1, [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]),
  member(S2, [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]),
  member(S3, [0, 1, 2, 3, 4, 5, 6, 7, 8, 9]),
  oneRightPlace(6, 8, 2, S1, S2, S3),
  oneWrongPlace(6, 1, 4, S1, S2, S3),
  twoWrongPlace(2, 0, 6, S1, S2, S3),
  zeroPlace(7, 3, 8, S1, S2, S3),
  oneWrongPlace(7, 8, 0, S1, S2, S3).

obtaining (in S1, S2 and S3) the right solution.

The preceding examples are written without the use of clp(fd), that I don't know well but that (I suppose) can semplify a lot.

Answer 6

Not sure I need to explain this much. You generate all possibilities, and then you code the constraints.

code(A,B,C) :-
  member(A,[0,1,2,3,4,5,6,7,8,9]),
  member(B,[0,1,2,3,4,5,6,7,8,9]),
  member(C,[0,1,2,3,4,5,6,7,8,9]),
  ( A = 6 ; B = 8 ; C = 2 ),
  ( A = 1, \+ member(B,[6,4]), \+ member(C,[6,4])
  ; A = 4, \+ member(B,[6,1]), \+ member(C,[6,1])
  ; B = 6, \+ member(A,[1,4]), \+ member(C,[1,4])
  ; B = 4, \+ member(A,[6,1]), \+ member(C,[6,1])
  ; C = 6, \+ member(B,[1,4]), \+ member(A,[1,4])
  ; C = 1, \+ member(B,[6,4]), \+ member(A,[6,4]) ),
  ( A = 0, B = 2, C \= 6
  ; A = 0, B = 6, C \= 2
  ; A = 6, B = 2, C \= 0
  ; B = 2, C = 0, A \= 6
  ; B = 6, C = 2, A \= 0
  ; B = 6, C = 0, A \= 2
  ; C = 2, A = 0, B \= 6
  ; C = 2, A = 6, B \= 0
  ; C = 0, A = 6, B \= 2 ),
  \+ member(A,[7,3,8]), \+ member(B,[7,3,8]), \+ member(C,[7,3,8]),
  ( A = 8, \+ member(B,[7,0]), \+ member(C,[7,0])
  ; A = 0, \+ member(B,[7,8]), \+ member(C,[7,8])
  ; B = 7, \+ member(A,[8,0]), \+ member(C,[8,0])
  ; B = 0, \+ member(A,[7,8]), \+ member(C,[7,8])
  ; C = 7, \+ member(B,[8,0]), \+ member(A,[8,0])
  ; C = 8, \+ member(B,[7,0]), \+ member(A,[7,0]) ).

Here is the result:

| ?- code(A,B,C).
A = 0,
B = 4,
C = 2 ? ;
no