Solving a Dungeons and Dragons riddle using Prolog (opens in new tab)

While it's not quite the same, we can create a short makefile.

  vixen: rudolph prancer dasher cupid blitzen
   echo vixen

  dancer : vixen donder blitzen rudolph cupid dasher
   echo dancer

  comet: vixen cupid prancer rudolph
   echo comet

  donder: comet vixen dasher prancer cupid blitzen rudolph
   echo donder

  cupid: prancer
   echo cupid

  blitzen: cupid dasher
   echo blitzen

  rudolph: cupid prancer
   echo rudolph

  dasher: rudolph prancer
   echo dasher

  prancer: ;
   echo prancer

  order: vixen dancer comet donder cupid blitzen rudolph dasher prancer
   echo Get in Line

Then: make -n order

outputs:

  echo prancer
  echo cupid
  echo rudolph
  echo dasher
  echo blitzen
  echo vixen
  echo comet
  echo donder
  echo dancer
  echo Get in Line

Which, for me, is:

  real 0m0.015s
  user 0m0.003s
  sys 0m0.006s

Very nice!

This solution uses the library predicate list_to_set/2, relating a (known) list Ls0 of elements to a list Ls without duplicates, where the elements occur in the same order in which they first appear in Ls0. I think it is interesting to consider how such a relation can be described in Prolog, and also how efficient it can be.

An immediate solution suggests itself, considering the elements of Ls0 in the order they appear, and keeping track of the elements that have already been "seen". If an element is encountered that has already been seen, ignore it, otherwise it is part of the list Ls we want to describe. We can use a list to keep track of elements that have already been encountered:

    list_to_set(Ls0, Ls) :-
            phrase(firsts(Ls0, []), Ls).

    firsts([], _) --> [].
    firsts([L|Ls], Seen) -->
            (   { member(L, Seen) } ->
                []
            ;   [L]
            ),
            firsts(Ls, [L|Seen]).

This works correctly if the list is ground:

    ?- list_to_set("Corvus corax", Ls).
       Ls = "Corvus cax".

Yet, this solution has a very severe drawback: It is worst-case quadratic in the number of elements, and thus not usable for long lists:

    ?- length(_, E),
       E #> 10,
       N #= 2^E,
       numlist(1, N, Ls0),
       time(list_to_set(Ls0, Ls)).

yielding:

       % CPU time: 0.222s
       E = 11, N = 2048, Ls0 = [1,2,3,4,5,...], Ls = [1,2,3,4,5,...]
    ;  % CPU time: 0.880s
       E = 12, N = 4096, Ls0 = [1,2,3,4,5,...], Ls = [1,2,3,4,5,...]
    ;  % CPU time: 3.518s
       E = 13, N = 8192, Ls0 = [1,2,3,4,5,...], Ls = [1,2,3,4,5,...]
    ;  ... .

So, how to improve it? Well, it may be tempting to use for example a hash or an AVL tree to keep track of the "seen" elements, so that it can be more efficiently decided whether an element has already been encountered. And indeed, that is easy to do, and reduces the runtime considerably.

For example, using the commonly available library(assoc) for AVL trees, providing O(log(N)) lookup:

    list_to_set(Ls0, Ls) :-
            empty_assoc(A0),
            phrase(firsts(Ls0, A0), Ls).

    firsts([], _) --> [].
    firsts([L|Ls], A0) -->
            (   { get_assoc(L, A0, _) } ->
                []
            ;   [L]
            ),
            { put_assoc(L, A0, t, A) },
            firsts(Ls, A).

With this simple change, we get for the query above:

       % CPU time: 0.034s
       E = 11, N = 2048, Ls0 = [1,2,3,4,5,...], Ls = [1,2,3,4,5,...]
    ;  % CPU time: 0.070s
       E = 12, N = 4096, Ls0 = [1,2,3,4,5,...], Ls = [1,2,3,4,5,...]
    ;  % CPU time: 0.155s
       E = 13, N = 8192, Ls0 = [1,2,3,4,5,...], Ls = [1,2,3,4,5,...]
    ;  ... .

The most interesting part is that we can do significantly better, by leveraging Prolog's logic variables to propagate the information whether elements have already been encountered, yielding a very efficient solution where sorting the list Ls0 (or rather: the list of pairs LVs0, where we associate with each element of Ls0 a logic variable that can be used to propagate information by unifying it with other variables and more concrete terms) dominates the asymptotic complexity:

    list_to_set(Ls0, Ls) :-
            maplist(with_var, Ls0, LVs0),
            keysort(LVs0, LVs),
            same_elements(LVs),
            pick_firsts(LVs0, Ls).

    pick_firsts([], []).
    pick_firsts([E-V|EVs], Fs0) :-
            (   V == visited ->
                Fs0 = Fs
            ;   V = visited,
                Fs0 = [E|Fs]
            ),
            pick_firsts(EVs, Fs).

    with_var(E, E-_).

    same_elements([]).
    same_elements([EV|EVs]) :-
            foldl(unify_same, EVs, EV, _).

    unify_same(E-V, Prev-Var, E-V) :-
            (   Prev == E ->
                Var = V
            ;   true
            ).

We now get significantly improved performance:

       % CPU time: 0.003s
       E = 11, N = 2048, Ls0 = [1,2,3,4,5,...], Ls = [1,2,3,4,5,...]
    ;  % CPU time: 0.006s
       E = 12, N = 4096, Ls0 = [1,2,3,4,5,...], Ls = [1,2,3,4,5,...]
    ;  % CPU time: 0.013s
       E = 13, N = 8192, Ls0 = [1,2,3,4,5,...], Ls = [1,2,3,4,5,...]
    ;  ... .

And this is indeed how list_to_set/2 is implemented for example in Scryer Prolog's library(lists):

https://github.com/mthom/scryer-prolog/blob/fd19128530f68c46...

For an alternative solution, describe the directed graph by listing the nodes and using whitespace to represent the arcs:

  $ cat riddle
  Vixen Rudolph
  Vixen Prancer
  Vixen Dasher
  Dancer Vixen
  Comet Vixen
  ...
  Vixen Dasher

Then use tsort:

  $ tsort riddle
  Dancer
  Donder
  Comet
  Vixen
  Blitzen
  Dasher
  Rudolph
  Cupid
  Prancer

The raindeer in the riddle are in a total ordering, with each following one other, like a linked list. That means we can just... sort them.

We could do that by hand-rolling a sorting algorithm with a custom comparison. Or, if we want to leave time for breakfast, there's SWI-Prolog's predsort/3 that takes as an argument a custom ordering predicate, and then sorts a list of arbitrary Prolog terms according to that ordering.

For example, I define raindeer_order/2 as an ordering predicate, reusing follows/2 from the article above, like this:

  raindeer_order(>,R1,R2):-
          once(follows(R1,R2)).
  raindeer_order(<,R1,R2):-
          once(follows(R2,R1)).
  raindeer_order(=,R,R).

If you squint a bit you'll notice the polarity of "<" and ">" is inverted. That's because follows/2 is an inverse order.

Now we can find all the raindeer and sort them:

  ordered_raindeer(Rs_):-
          setof(R1
               ,R2^(   is_behind(R1,R2)
                   ;   is_behind(R2,R1)
                   )
               ,Rs)
          ,predsort(raindeer_order,Rs,Rs_).

And, at the command line:

  ?- ordered_raindeer(Rs).
  Rs = [prancer, cupid, rudolph, dasher, blitzen, vixen, comet, donder, dancer] ;
  false.

Runs in O(log(n)) :P

(Edit: I think it's n log n actually: follows/2 might have to run the length of the list to compare two reindeer.)

Very nice. I just solved it with GraphViz: https://gist.github.com/mLuby/d184c08c507fa03292c72acb38a146...

You can do this without the intermediate step of generating all permutations simply like so:

    order([]).
    order([_]).
    order([X,Y|L]) :-
        follows(Y, X), order([Y|L]).

    ?- length(L, 9), order(L).
    L = [prancer, cupid, rudolph, dasher, blitzen, vixen, comet, donder, dancer] .

This is likely more efficient as we're cutting short the generation of most permutations.

Or you can use CPL(FD) as suggested by @Avshalom below, though more heavyweight this is likely more efficient still.

The most efficient though is simply to use a topological sort algorithm, which will run in linear time, unlike any of these solutions (some of which are exponential). SWI Prolog has this built-in:

    ?- findall(X-Y, is_behind(Y, X), Edges), vertices_edges_to_ugraph([], Edges, UG), top_sort(UG, L).
    L = [prancer, cupid, rudolph, dasher, blitzen, vixen, comet, donder, dancer].

I got the solution with a straightforward set of assertions in Z3. It was a lot of typing, and I wonder if there's a more succinct way to do this than the following:

    (declare-const blitzen Int)
    (declare-const comet Int)
    ...
    (assert
      (and
        ; lower bound for readability (1 is front)
        (> blitzen 0)
        (> comet 0)
        ...
        ; upper bound for readability (9 is rear)
        (< blitzen 10)
        (< comet 10)
        ...
        ; clues from the puzzle
        (> vixen rudolph)
        ...
        (< dasher vixen)))

I'm curious how it would deal with the self-referential aptitude test (original text: https://faculty.uml.edu//jpropp/srat.html -- web version: http://www.drunkmenworkhere.org/170 )

> 1. The first question whose answer is B is question ...

From a more algorithmic point of view, this is exactly the task of topological sorting [1].

And it runs linearly in the number of edges!

I expect Prolog to be slower for large and hard inputs. But Makefiles solve exactly that!

[1]: https://en.m.wikipedia.org/wiki/Topological_sorting

Now I immediately turned to library(clpfd). Something along the lines of:

  Names = [rudolph, dancer...
  Vars = [Rudolph, Dancer...
  Vars ins 1..9,
  all_different(Vars),
  Rudolph #> Dancer,
  ...
  ...
  pairs_keys_values(P,Vars,Names),
  keysort(P,S),
  write(S).

Prolog was made to parse text, so shouldn't we derive the constraints from the text itself with a DCG ?

  :- set_prolog_flag(double_quotes, codes).
  
  text("Vixen should be behind Rudolph, Prancer and Dasher, whilst Vixen should be in front of Dancer and Comet. Dancer should be behind Donder, Blitzen and Rudolph. Comet should be behind Cupid, Prancer and Rudolph. Donder should be behind Comet, Vixen, Dasher, Prancer and Cupid. Cupid should be in front of Comet, Blitzen, Vixen, Dancer and Rudolph. Prancer should be in front of Blitzen, Donder and Cupid. Blitzen should be behind Cupid but in front of Dancer, Vixen and Donder. Rudolph should be behind Prancer but in front of Dasher, Dancer and Donder. Finally, Dasher should be behind Prancer but in front of Blitzen, Dancer and Vixen.").
  
  space -->
     " ".
  
  reindeer('Blitzen') -->
     "Blitzen".
  reindeer('Comet') -->
     "Comet".
  reindeer('Cupid') -->
     "Cupid".
  reindeer('Dancer') -->
     "Dancer".
  reindeer('Dasher') -->
     "Dasher".
  reindeer('Donder') -->
     "Donder".
  reindeer('Prancer') -->
     "Prancer".
  reindeer('Rudolph') -->
     "Rudolph".
  reindeer('Vixen') -->
     "Vixen".
  
  complement(S, P, [[S, P, Reindeer] | R], R) -->
     reindeer(Reindeer).
  
  sep -->
     ", ".
  sep -->
     " and ".
  
  list(Pred, Sep, S1, S3) -->
     call(Pred, S1, S2),
     list_next(Pred, Sep, S2, S3).
  list_next(Pred, Sep, S1, S3) -->
     Sep,
     call(Pred, S1, S2),
     list_next(Pred, Sep, S2, S3).
  list_next(_, _, S, S) -->
     [].
  
  position(>) -->
     "behind".
  position(<) -->
     "in front of".
  
  text(S) -->
     list(proposition, space, S, S2),
     space,
     last_sentence(S2, []).
  
  last_sentence(S1, S2) -->
     "Finally, ",
     proposition(S1, S2).
  
  proposition(S1, S3) -->
     proposition(R, S1, S2),
     inverse_proposition(R, S2, S3),
     ".".
  
  proposition(R, S1, S2) -->
     reindeer(R),
     " should be ",
     position_list(R, S1, S2).
  
  position_list(R, S1, S2) -->
     position(P),
     space,
     list(complement(R, P), sep, S1, S2).
  
  inverse_proposition(R, S1, S2) -->
     " but ",
     position_list(R, S1, S2).
  inverse_proposition(R, S1, S2) -->
     ", whilst ",
     proposition(R, S1, S2).
  inverse_proposition(_, S, S) -->
     [].
  
  :- table(follows/3).
  
  follows(R1, R2, Pairs) :-
     member([R1, >, R2], Pairs).
  follows(R1, R2, Pairs) :-
     member([R2, <, R1], Pairs).
  follows(R1, R3, Pairs) :-
     follows(R1, R2, Pairs),
     follows(R2, R3, Pairs).
  
  order([X | L], Pairs) :-
     order(L, X, Pairs).
  
  order([], _, _).
  order([Y | L], X, Pairs) :-
     follows(Y, X, Pairs),
     order(L, Y, Pairs).

And we can solve the riddle with:

  ?- text(T), phrase(text(Pairs), T), length(L, 9), order(L, Pairs).
  T = [86, 105, 120, 101, 110, 32, 115, 104, 111|...],
  Pairs = [['Vixen', >, 'Rudolph'], ['Vixen', >, 'Prancer'], ['Vixen', >, 'Dasher'], ['Vixen', <
  , 'Dancer'], ['Vixen', <, 'Comet'], ['Dancer', >, 'Donder'], ['Dancer', >|...], ['Dancer'|...]
  , [...|...]|...],
  L = ['Prancer', 'Cupid', 'Rudolph', 'Dasher', 'Blitzen', 'Vixen', 'Comet', 'Donder', 'Dancer']

One nice thing we can do with this grammar is that we can also generate the text from a list of constraints:

  ?- Pairs = [['Prancer', <, 'Cupid'], ['Cupid', <, 'Rudolph']], phrase(text(Pairs), T), string_codes(S, T).
  Pairs = [['Prancer', <, 'Cupid'], ['Cupid', <, 'Rudolph']],
  T = [80, 114, 97, 110, 99, 101, 114, 32, 115|...],
  S = "Prancer should be in front of Cupid. Finally, Cupid should be in front of Rudolph." .