Запрос Джесс миссис Розенкранц (загадка зебры), выраженный в прологе

Question

В книге " Jess в действии - основанные на правилах системы в Java" (написанной более 10 лет назад; я думаю, Drools - это система, которую нужно использовать сегодня?), Эрнест Фридман-Хилл решает проблему ограничений, приведенную ниже, используя Jess, стиль OPS5 прямая производственная система написана на Java. Я хочу решить это с помощью Пролога.

Вопрос: правильно ли я это решаю?

Эта проблема

Четверка игроков в гольф стоит у тройника, по линии слева направо. Каждый игрок в гольф носит брюки разного цвета; один одет в красные штаны. Игрок в гольф справа от ФРС одет в синие штаны. Джо второй в очереди. Боб одет в клетчатые штаны. Том не в положении один или четыре, и он не носит отвратительные оранжевые штаны.

В каком порядке будут играть четыре игрока в гольф, и какого цвета штаны каждого игрока в гольф?

Это экземпляр головоломки Zebra. Смотрите также эту презентацию, чтобы найти красиво иллюстрированное решение более сложного.

Используя Джесс, Эрнест Фридман-Хилл

Используя производственную систему Jess, код будет выглядеть следующим образом. Это из вышеупомянутой книги, переменные переименованы для ясности.

Рабочая память заполнена 32 ссылками от игроков в гольф на их возможные позиции и цвета брюк. find-solution правило срабатывает для набора ссылок, удовлетворяющего ограничениям.

Кажется, трудно об этом думать, потому что не проверяют "возможные миры" на предмет их соответствия ограничениям, а выбирают набор ссылок, которые удовлетворяют ограничениям. Не ясно, что это действительно то, что каждый ищет.

;; Templates for working memory, basically the links golfer<->pantscolor, 
;; and golfer<->position. 

(deftemplate pants-color (slot of) (slot is))
(deftemplate position (slot of) (slot is))

;; Generate all possible 'pants-color' and 'position' facts
;; 4 names, each with 4 pants-color: 16 entries
;; 4 names, each with 4 positions: 16 entries
;; This gives the 32 facts describing the links

(defrule generate-possibilities
    =>
    (foreach ?name (create$ Fred Joe Bob Tom)
        (foreach ?color (create$ red blue plaid orange)
            (assert (pants-color (of ?name) (is ?color))))
        (foreach ?position (create$ 1 2 3 4)
            (assert (position (of ?name) (is ?position))))))

;; The “find solution” rule forward-chains and prints out a solution

(defrule find-solution
   ;; There is a golfer named Fred, whose position is ?p_fred and
   ;; pants color is ?c_fred
   (position (of Fred) (is ?p_fred))
   (pants-color (of Fred) (is ?c_fred))
   ;; The golfer to Fred's immediate right (who is not Fred) is wearing
   ;; blue pants.
   (position (of ?n&~Fred) (is ?p&:(eq ?p (+ ?p_fred 1))))
   (pants-color (of ?n&~Fred) (is blue&~?c_fred))
   ;; Joe is in position #2
   (position (of Joe) (is ?p_joe&2&~?p_fred))
   (pants-color (of Joe) (is ?c_joe&~?c_fred))
   ;; Bob is wearing the plaid pants (so his position is not “n” either 
   ;; because “n” has blue pants)
   (position (of Bob) (is ?p_bob&~?p_fred&~?n&~?p_joe))
   (pants-color (of Bob&~?n) (is plaid&?c_bob&~?c_fred&~?c_joe))
   ;; Tom isn't in position 1 or 4 and isn't wearing orange (and not blue
   ;; either)
   (position (of Tom&~?n) (is ?p_tom&~1&~4&~?p_fred&~?p_joe&~?p_bob))
   (pants-color (of Tom) (is ?c_tom&~orange&~blue&~?c_fred&~?c_joe&~?c_bob))
   =>
   (printout t Fred " " ?p_fred " " ?c_fred crlf)
   (printout t Joe " " ?p_joe " " ?c_joe crlf)
   (printout t Bob " " ?p_bob " " ?c_bob crlf)
   (printout t Tom " " ?p_tom " " ?c_tom crlf crlf))

Мое первое решение в Прологе

Оказывается, это не элегантно и жестко (см. Другие ответы)

Давайте посмотрим на структуру данных, чтобы описать решение, следующее: Выберите список, в каждой позиции есть "игрок в гольф", имеющий "Имя" и "Цвет брюк": [golfer(N0,C0),golfer(N1,C1),golfer(N2,C2),golfer(N3,C3)], Каждый игрок в гольф также имеет начальную позицию в списке от 0 до 3; позиция не указана явно, как в golfer(Name,Color,Position),

solution(L) :-    
    % select possible pants colors which must be pairwise different; for 
    % fast fail, we check often
    is_pants_color(C0),
    is_pants_color(C1),are_pairwise_different([C0,C1]),
    is_pants_color(C2),are_pairwise_different([C0,C1,C2]),
    is_pants_color(C3),are_pairwise_different([C0,C1,C2,C3]),
    % select possible golfer names which must be pairwise different; for
    % fast fail, we check often
    is_name(N0),
    % we know that joe is second in line, so we can plonck that condition 
    % in here immediately
    N1 = joe,
    is_name(N1),are_pairwise_different([N0,N1]),
    is_name(N2),are_pairwise_different([N0,N1,N2]),
    is_name(N3),are_pairwise_different([N0,N1,N2,N3]),    
    % instantiate the solution in a unique order (we don't change the order
    % as we permute exhuastively permute colors and names)
    L = [golfer(N0,C0),golfer(N1,C1),golfer(N2,C2),golfer(N3,C3)],
    % tom is not in position one or four; express this clearly using
    % "searchWithPosition" instead of implicitly by unification with L
    search(tom,L,golfer(_,_,TomPosition)),
    TomPosition \== 0,
    TomPosition \== 3,
    % check additional constraints using L
    rightOf(fred,L,golfer(_,blue)),
    search(bob,L,golfer(_,plaid,_)),
    \+search(tom,L,golfer(_,hideous_orange,_)).

% here we stipulate the colors

is_pants_color(red).
is_pants_color(blue).
is_pants_color(plaid).
is_pants_color(hideous_orange).

% here we stipulate the names

is_name(joe).
is_name(bob).
is_name(tom).
is_name(fred).

% helper predicate

are_pairwise_different(L) :- sort(L,LS), length(L,Len), length(LS,Len).

% Search a golfer by name in the solution list, iteratively. 
% Also return the position 0..3 for fun and profit (allows to express the
% constraint on the position)
% We "know" that names are unique, so cut on the first clause.

search(Name,L,golfer(Name,C,Pos)) :- 
  searchWithPosition(Name,L,golfer(Name,C,Pos),0).

searchWithPosition(Name,[golfer(Name,C)|_],golfer(Name,C,Pos),Pos) :- !.
searchWithPosition(Name,[_|R],golfer(Name,C,PosOut),PosIn) :- 
  PosDown is PosIn+1, searchWithPosition(Name,R,golfer(Name,C,PosOut),PosDown).

% Search the golfer to the right of another golfer by name in the list,
% iteratively.  We "know" that names are unique, so cut on the first clause

rightOf(Name,[golfer(Name,_),golfer(N,C)|_],golfer(N,C)) :- !.
rightOf(Name,[_|R],golfer(N,C)) :- rightOf(Name,R,golfer(N,C)).

Давайте запустим это:

?:- solution(L).
L = [golfer(fred, hideous_orange), 
     golfer(joe, blue), 
     golfer(tom, red), 
     golfer(bob, plaid)]

Answer 1

Компактное решение

golfers(S) :-
  length(G, 4),
  choices([
    g(1, _, _),
    g(2, joe, _),                   % Joe is second in line.
    g(3, _, _),
    g(4, _, _),
    g(_, _, orange),
    g(_, _, red),                   % one is wearing red pants
    g(_, bob, plaid),               % Bob is wearing plaid pants
    g(P, fred, _),                  % The golfer to Fred’s immediate right
    g(Q, _, blue),                  % ....is wearing blue pants
    g(Pos, tom, Pants)              % Tom isn’t in position one or four, and
                                    % ... he isn’t wearing the orange pants
  ], G),
  Q is P+1,
  Pos \= 1, Pos \= 4, Pants \= orange, sort(G,S).

choices([],_).
choices([C|Cs],G) :- member(C,G), choices(Cs,G).

Примечание от OP: почему это работает

• Создайте список G из 4 неинициализированных элементов, используя length/2
• Для каждого элемента C в первом аргументе, переданном в choices/2, убедитесь, что C является членом G.
  • Первые 4 записи будут назначены по порядку (надеюсь, детерминистически), и поскольку они не могут объединиться, это приведет к чему-то вроде [g(1, _G722, _G723), g(2, joe, _G730), g(3, _G736, _G737), g(4, _G743, _G744)] после 4-го звонка member/2,
  • После choices/2 возвращается, G была объединена в структуру, которая выполняет каждое ограничение в списке ограничений, переданных choices/2, особенно:
    • Позиции 1,2,3,4 перечислены
    • Имена Джо, Боб, Фред, Том перечислены
    • Цвета оранжевый, клетчатый, красный, синий в списке
    • ... и это означает, что нам даже не нужно проверять, появляется ли цвет, имя или позиция дважды - он может появляться только один раз.
  • Дополнительные ограничения не могут быть переданы choices/2 (нет возможности сказать такие вещи, как g(P, fred, _), g(P+1, _, blue), g(not-in{1,4}, tom, not-in{orange}) и передать это choices/2). Таким образом, эти дополнительные ограничения проверяются через переменные, объединенные с G-содержимым.
  • Если эти дополнительные ограничения не пройдены, откат choices/2 и, таким образом, более member/2 произойдет. Есть 9 member/2 вызовы в стеке в этой точке, которые будут исчерпывающе испробованы, хотя возврат к предыдущему назначению участника для g(4, _, _) не полезно
  • Как только приемлемое решение найдено, оно сортируется и программа завершается успешно.

Компактное решение, модифицированное

Добавлен OP:

Выше показано, что возможны небольшие улучшения. Эта программа не находит никаких дополнительных (идентичных) решений после первого:

golfers(G) :-
  G=[g(1,_,_),g(2,_,_),g(3,_,_),g(4,_,_)],
  choices([
    g(2, joe, _),              % Joe is second in line.
    g(_, _, orange),
    g(_, _, red),              % one is wearing red pants
    g(_, bob, plaid),          % Bob is wearing plaid pants
    g(P, fred, _),             % The golfer to Fred’s immediate right is 
    g(Q, _, blue),             % ...wearing blue pants
    g(Pos, tom, Pants)         % Tom isn’t in position one or four, and 
                               % ...he isn’t wearing the hideous orange pants
  ], G),
  Q is P+1,
  Pos \= 1, Pos \= 4, Pants \= orange.

choices([],_).
choices([C|Cs],G) :- member(C,G), choices(Cs,G).

Почему это работает

• Определите сразу структуру полученного G вместо создания списка четырех пока неизвестных элементов, используя "длину"
• В этом "proto-G" элементы списка естественным образом сортируются по позиции; мы не будем находить другие решения там, где g(P,_,_) переставляются по положению
  • Таким образом, мы можем избавиться от g(1,_,_), g(3,_,_), g(4,_,_) ограничения
  • Если кто-то еще хочет убедиться, что имена и цвета используются ровно один раз (что не обязательно, так как это должно быть верно по построению), можно было бы захватывать имена и цвета с помощью choices/2 с помощью g(1,N1,C1), g(2,N2,C2), g(3,N3,C3), g(4,N4,C4) и убедитесь, что Ni и C i являются уникальными с помощью sort/2: sort([N1,N2,N3,N4],[bob,fred,joe,tom]), sort([C1,C2,C3,C4],[blue,orange,plaid,red])

Другое решение

Пролог позволяет легко писать "языки". Давайте объявим проблему и создадим микро DSL для решения:

golfers_pants([G1,G2,G3,G4]) :-
  maplist(choice([G1,G2,G3,G4]),[
    % my note: we are going to compute on positions, so fill the 'column' with domain values
    g(1, _, _),
    % Joe is second in line.
    g(2, joe, _),
    g(3, _, _),
    g(4, _, _),
    % my note: someone is wearing 'hideous orange pants' not mentioned positively elsewhere
    g(_, _, orange),
    % one is wearing red pants
    g(_, _, red),
    % Bob is wearing plaid pants
    g(_, bob, plaid),
    % The golfer to Fred’s immediate right is wearing blue pants
    g(P, fred, _), g(Q, _, blue), Q is P+1,
    % Tom isn’t in position one or four, and he isn’t wearing the hideous orange pants
    g(Pos, tom, Pants), Pos \= 1, Pos \= 4, Pants \= orange
  ]).

choice(G,C) :- C = g(_,_,_) -> member(C,G) ; call(C).

Answer 2

Решение Jess, переписанное в Прологе

Это для завершения.

Переписать решение Jess в SWI Prolog (но не в SWISH, потому что теперь мы используем assert) показывает, что:

• Существует много исчерпывающих перечислений "под капотом"
• Прямые производственные системы цепочки, возможно, не лучший инструмент для такого рода проблемы "удовлетворение ограничений по конечному пространству поиска"
• Условия правила могут извлечь выгоду из некоторой концептуальной очистки

Итак, давайте переведем это прямо:

% Define the possible names, colors and positions

names([fred,joe,bob,tom]).
colors([red,blue,plaid,orange]).
positions([1,2,3,4]).

run :- names(Ns),
       colors(Cs),
       positions(Ps),
       fill_working_memory(pantscolor,Ns,Cs),
       fill_working_memory(position,Ns,Ps).                   

fireable(SortedResult) :-
       position(fred,P_fred),
       pantscolor(fred,C_fred),
       position(N,P)         , N \== fred,
                               P is P_fred+1,
       pantscolor(N,blue)    , N \== fred,
                               \+member(C_fred,[blue]),
       position(joe,P_joe)   , P_joe == 2,
                               \+member(P_joe,[P_fred]),
       pantscolor(joe,C_joe) , \+member(C_joe,[C_fred]),
       position(bob, P_bob)  , \+member(P_bob,[P_fred,N,P_joe]),
       pantscolor(bob, C_bob), N \== bob,
                               C_bob = plaid, 
                               \+member(C_bob, [C_fred,C_joe]),
       position(tom, P_tom)  , N \== tom, 
                               \+member(P_tom,[1,4,P_fred,P_joe,P_bob]),
       pantscolor(tom, C_tom), \+member(C_tom,[orange,blue,C_fred,C_joe,C_bob]),
       % build clean result
       Result = [g(P_fred,fred,C_fred),
                 g(P_bob,bob,C_bob),
                 g(P_joe,joe,C_joe),
                 g(P_tom,tom,C_tom)],
       sort(Result,SortedResult).

% -- Helper to assert initial facts into the working memory

fill_working_memory(PredSym,Ns,Vs) :-
    product(Ns,Vs,Cartesian),
    forall(member([N,V], Cartesian), factify(PredSym,N,V)).

factify(PredSym,N,V) :- Term=..([PredSym,N,V]), writeln(Term), assertz(Term).

% -- These should be in a library somewhere --

% Via https://gist.github.com/raskasa/4282471

% pairs(+N,+Bs,-Cs)
% returns in Cs the list of pairs [N,any_element_of_B]

pairs(_,[],[]) :- !.
pairs(N,[B|Bs],[[N,B]|Cs]) :- pairs(N,Bs,Cs).

% product(+As,+Bs,-Cs)
% returns in Cs the cartesian product of lists As and Bs
% product([x,y], [a,b,c], [[x, a], [x, b], [x, c], [y, a], [y, b], [y, c]])
% Would be interesting to make this a product(+As,+Bs,?Cs)

product([],_,[]) :- !.
product([A|As],Bs,Cs) :- pairs(A,Bs,Xs),
                         product(As,Bs,Ys),
                         append(Xs,Ys,Cs).

Давайте запустим это:

?- run, fireable(X).
X = [g(1, fred, orange),
     g(2, joe, blue),
     g(3, tom, red),
     g(4, bob, plaid)] .

По какой-то причине swipl становится медленным после 5-й казни или около того. Сбор мусора начинается?