17 June 2012

Solving Professor Popalop's puzzles in Prolog

This puzzle was in my daughter's Dandy:

and I thought it would give me an opportunity to experiment with Prolog, which I'd been meaning to do for a while. I used SWI-Prolog.

Structure of the puzzle

We'll represent a block of nine boxes as a list. A box is the expression X/Y/C, meaning that creature type C occupies location X/Y, where the top-left box is 1/1. We'll have a fragment similar to

Bs = [1/1/_, 1/2/_, 1/3/_,
      2/1/_, 2/2/_, 2/3/_,
      3/1/_, 3/2/_, 3/3/_]

Our goal is to find which creature can go in each box.

The different types of creature

Every box must have a creature in it.

box_has_creature(_/_/p).
box_has_creature(_/_/h).
box_has_creature(_/_/b).

We'll use the variable name 'Bs' throughout to mean 'boxes'. We now bring together the fixed creature (who always goes in the top-left box) and the fact that all boxes must have creatures in them.

challenge(C) :- Bs = [1/1/C, 1/2/_, 1/3/_,
                      2/1/_, 2/2/_, 2/3/_,
                      3/1/_, 3/2/_, 3/3/_],
                maplist(box_has_creature, Bs),
                to be continued....

Rules for each creature type

The conditions that we must satisfy for the various creature types:


talk about the occupants of neighbouring boxes, so we need a way to find what sorts of creatures are adjacent to a given box.

Meaning of 'adjacent'

The instructions give a handy hint:

which we can translate as

one_away(X, Y) :- Y is X + 1.
one_away(X, Y) :- X is Y + 1.

adjacent(X1/Y1, X2/Y2) :- X1 = X2, one_away(Y1, Y2).
adjacent(X1/Y1, X2/Y2) :- Y1 = Y2, one_away(X1, X2).

We now start by finding all creatures which occupy boxes adjacent to a given box. This will be a list of between two (for corner boxes) and four (for the central box) creature types, possibly including duplicates.

adj_creatures([], _X/_Y, []).

adj_creatures([X1/Y1/C | Bs], X/Y, [C | Cs])
    :- adjacent(X1/Y1, X/Y),
       adj_creatures(Bs, X/Y, Cs).

adj_creatures([X1/Y1/_C | Bs], X/Y, Cs)
    :- \+ adjacent(X1/Y1, X/Y),
       adj_creatures(Bs, X/Y, Cs).

Then we want to remove any duplicates, to get a list of just the different types of creature which are adjacent to a given box.

adj_creature_types(Bs, X/Y, Cs)
    :- adj_creatures(Bs, X/Y, AllCs),
       sort(AllCs, Cs).

We are now ready to translate the conditions on each creature type.

Popops

We don't need to worry about these creatures.

Hopples

The 'hopple rule' is satisfied for a given box in one of two ways. Either the creature in that box is not a hopple, or it is a hopple and there is another hopple in some adjacent box.

hopple_ok(_X/_Y/C, _Bs) :- C \= h.
hopple_ok(X/Y/h, Bs) :- adj_creature_types(Bs, X/Y, Cs),
                        member(h, Cs).

Bungos

We approach the bungos in a similar way to the hopples. We obey the 'bungo rule' for a given box if its occupant is not a bungo, or if it is a bungo, and among its neighbours there is a popop and there is not a hopple.

bungo_ok(_X/_Y/C, _Bs) :- C \= b.
bungo_ok(X/Y/b, Bs) :- adj_creature_types(Bs, X/Y, Cs),
                       member(p, Cs),
                       \+ member(h, Cs).

Rules apply to all boxes

We recurse our way through the list of boxes, checking that we obey the hopple rule and the bungo rule for each one:

all_creatures_ok([], _AllBs).
all_creatures_ok([X1/Y1/C | Bs], AllBs)
    :- hopple_ok(X1/Y1/C, AllBs),
       bungo_ok(X1/Y1/C, AllBs),
       all_creatures_ok(Bs, AllBs).

Counting bungos

We create a predicate which is only satisfied for bungos, then find the list of all boxes which satisfy it, and see how long that list is.

box_has_bungo(_/_/b).
count_bungos(Bs, N) :- include(box_has_bungo, Bs, BungoBs),
                       length(BungoBs, N).

Output presentation

To make it easier to look at the results, extract from each box description X/Y/C just the occupying creature type (not the X/Y location at the start), collecting them into a list.

box_occupants([], []).
box_occupants([_X/_Y/C | Bs], [C | Cs]) :- box_occupants(Bs, Cs).

Find valid sleeping arrangements

Look for a valid sleeping arrangement where the top-left box is a C, and there are N bungos altogether, and the list of occupants is Cs.

challenge(C, N, Cs) :- Bs = [1/1/C, 1/2/_, 1/3/_,
                             2/1/_, 2/2/_, 2/3/_,
                             3/1/_, 3/2/_, 3/3/_],
                       maplist(box_has_creature, Bs),
                       count_bungos(Bs, N),
                       all_creatures_ok(Bs, Bs),
                       box_occupants(Bs, Cs).

Find maximal bungos

I'm not so happy with the way I did this, but: we can just try out the possible alternatives in turn for the number of bungos, starting with the case that we can put bungos in all the boxes, and finishing with the case that no boxes contain bungos.

possible_n_bungos(N) :- member(N, [9, 8, 7, 6, 5, 4, 3, 2, 1, 0]).

We then try each possibility in turn, and when it finds the first working one (which will be the biggest), generate all solutions:

challenge_best_solns(C, N, Cs) :- possible_n_bungos(N),
                                  challenge(C, N, _)
                                  ->
                                  challenge(C, N, Cs).

Solving the challenges

Now can try it out:

Challenge 1

?- challenge_best_solns(h, N, Cs).
N = 3, Cs = [h, p, b, h, p, p, p, b, b] ;
N = 3, Cs = [h, p, b, h, p, b, p, p, b] ;
N = 3, Cs = [h, p, b, h, p, b, p, b, p] ;
N = 3, Cs = [h, p, b, h, p, b, h, p, b] ;
N = 3, Cs = [h, h, p, p, p, p, b, b, b] ;
N = 3, Cs = [h, h, p, p, p, b, b, p, b] ;
N = 3, Cs = [h, h, p, p, p, b, b, b, p] ;
N = 3, Cs = [h, h, h, p, p, p, b, b, b] ;
false.

Challenge 2

?- challenge_best_solns(b, N, Cs).
N = 6, Cs = [b, p, b, p, b, b, b, b, p] ;
N = 6, Cs = [b, p, b, b, p, b, b, p, b] ;
N = 6, Cs = [b, p, b, b, b, p, p, b, b] ;
N = 6, Cs = [b, p, b, b, b, b, p, b, p] ;
N = 6, Cs = [b, b, p, p, b, b, b, p, b] ;
N = 6, Cs = [b, b, p, p, b, b, b, b, p] ;
N = 6, Cs = [b, b, b, p, p, p, b, b, b] ;
false.

Challenge 3

?- challenge_best_solns(p, N, Cs).
N = 6, Cs = [p, b, p, b, b, b, b, p, b] ;
N = 6, Cs = [p, b, b, b, b, p, p, b, b] ;
N = 6, Cs = [p, b, b, b, b, p, b, p, b] ;
false.

Prolog is cool

No doubt people who actually know Prolog could find better ways of doing this, and would have avoided the several dead-ends I went down while exploring. All the same, I found this puzzle to be a good way of getting a taste of Prolog. It is very pleasing how you can specify the constraints in a fairly natural way, and then as if by magic it produces the solutions.

Comments are closed.