Вот реализация в Common Lisp, которая демонстрирует проблему с наивным подходом к такого рода вопросам.
Прежде всего некоторые определения.
- Ядро отношения представляет собой карту с записями, которые выглядят как
(x . y). R(a, b) если в ядре есть запись типа (a . b). Я не уверен, является ли «ядро» правильным математическим термином (я уверен, что это не так), но это то, что я собираюсь использовать. - Отношение
R равно рефлексивно если R(a, a) для любого a, которое происходит либо в домене, либо в диапазоне отношения. - Транзитивное замыкание из
R, R* является отношениемтакой, что R*(a, b, если R(a, b) или (R(a, c) и R*(c, b)).
Так что я собираюсь реализовать ядро карты просто как список, и я буду явноиспользуйте car, cdr и cons для извлечения частей записей в ядре. Это грязный старомодный Лисп, но в этом случае он довольно хорош, поскольку естественные объекты в этой части языка (понятия) очень хорошо отображаются на объекты в задаче. Заметьте также, что я вообще не пытался использовать какие-либо причудливые структуры данных: все просто идет по спискам. Это замедлит процесс, если ядро будет очень большим. Но оно не очень большое.
Вот ядро, которое вам дано:
(defparameter *kernel*
'((1 . 1)
(1 . 2)
(2 . 1)
(2 . 2)
(3 . 1)
(3 . 4)
(4 . 1)
(4 . 2)
(4 . 4)))
Это ядро не рефлексивно: например, (3 . 3) отсутствует. Вот функция, которая, учитывая ядро, возвращает ее рефлексивную версию. Эта функция имеет очень низкую сложность, но ядро маленькое, и функция вызывается один раз.
(defun reflexifize-kernel (kernel)
;; given the kernel of a map, return a reflexive version of it
;; This has pretty grotty complexity but it gets called only once
(loop for element in (loop with d/r = '()
for e in kernel
do (pushnew (car e) d/r)
do (pushnew (cdr e) d/r)
finally (return d/r))
for ik = (cons element element)
unless (member ik kernel :test #'equal)
collect ik into identities
finally (return (append kernel identities))))
И мы можем проверить это:
> (reflexifize-kernel *kernel*)
((1 . 1)
(1 . 2)
(2 . 1)
(2 . 2)
(3 . 1)
(3 . 4)
(4 . 1)
(4 . 2)
(4 . 4)
(3 . 3))
Вы можете видеть, что оно добавлено соответствующим образом. запись в конце (и она бы добавила больше записей, если бы это было необходимо).
Теперь я напишу функцию, которая, учитывая левую часть отображения и ядра, возвращает две вещи:
- первое совпадение для этой левой части ядра, или
nil, если его нет; - остаток ядра после этого совпадения, или
() если он есть (обратите внимание, что nil и () одинаковы в Common Lisp, но они могут отсутствовать в других Лиспах).
Приятно то, что мы можем простоиспользуйте оставшуюся часть ядра, чтобы найти больше совпадений, и эта функция прекрасно работает с приведенной выше реализацией ядра: это тот случай, когда структуры данных Lisp действительно хорошо работают для нас.
(defun next-match (lhs kernel)
;; return the next match (as (lhs . rhs)) for lhs in kernel, and the
;; remainder of the kernel, or nil and () if there is no match
(let ((found (member lhs kernel :key #'car)))
(if found
(values (first found) (rest found))
(values nil '()))))
ТакТеперь мы можем написать функцию, Rp which true, если R(a, b) true:
(defun Rp (lhs rhs kernel)
;; is R(lhs, rhs) true
(multiple-value-bind (entry remaining-kernel) (next-match lhs kernel)
(cond ((null entry)
nil)
((eql (cdr entry) rhs)
t)
(t (Rp lhs rhs remaining-kernel)))))
Это называется Rp, потому что это предикат (оканчивающийся на p в обычном соглашении Lisp), и он сообщает нам, удовлетворяют ли два элементаR. И, конечно, поскольку CL по умолчанию не учитывает регистр, это та же функция, что и rp.
. И эта функция работает нормально:
> (rp 1 1 (reflexifize-kernel *kernel*))
t
> (rp 1 3 (reflexifize-kernel *kernel*))
nil
И теперь мы можем написать R*p: яснее, я думаю и, безусловно, более эффективно написать «унифицированную» версию R*p, которая не опирается на Rp, но очень похож на нее: у нее действительно только последний шаг, который ищеттранзитивное закрытие.
(defun R*p (lhs rhs kernel)
;; is lhs related to rhs in kernel? (See note below!)
(multiple-value-bind (entry remaining-kernel) (next-match lhs kernel)
(if (null entry)
nil
(let ((match-rhs (cdr entry)))
(if (eql rhs match-rhs)
t
(or (R*p lhs rhs remaining-kernel)
(R*p match-rhs rhs kernel)))))))
ОК, так что это выглядит очевидно правильным, верно?
- сначала мы ищем совпадение для
lhs; - , если естьсовпадение, и его rhs равно
rhs, то все готово; - если их нет,
- сначала найдите другие совпадения в ядре и проверьте их
- если это не сработает, ищите совпадения для найденных нами прав, чье правое число равно
rhs.
И это только прозрачное определение транзитивного замыкания, верно? Поэтому, если мы добавим в него рефлексивное ядро (которое мы можем создать сейчас), оно будет работать.
Ну, нет, это не будет работать. Это не будет работать, потому что в ядре есть петли, которые вам дали. Допустим, мы хотим позвонить (R*p 1 3 (reflexivize-kernel *kernel*)). Из ядра очевидно, что это должно быть ложно.
Но на самом деле функция не завершается. Не удается завершить, потому что он находит запись для R(1, 2) и поэтому начинает искать R*(2, 3): затем находит R(2, 1), начинает искать R*(1, 3) ... упс.
(Примечаниечто приведенная выше реализация выполняет поиск в глубину. Поиск в ширину не помогает: он поможет найти отображение, когда равен , но когда его нет, он простоцикл таким же образом.)
Способ справиться с этим - использовать то, что называется происходит, проверка : при поиске мы отслеживаем то, что уже просматривали при поискедерево. Если мы обнаруживаем, что мы смотрим на lhs, на которые мы уже смотрели, мы немедленно терпим неудачу, поскольку это цикл. Вот реализация версии R*p, которая делает это, используя локальную функцию, поэтому нам не нужно предоставлять список so-far в интерфейсе, что будет раздражать.
(defun R*p (lhs rhs kernel)
;; is lhs related to rhs in kernel, with an occurs check.
(labels ((R*p-loop (lhs rhs kernel so-far)
(if (member lhs so-far)
;; we've looped, give up
nil
(multiple-value-bind (entry remaining-kernel)
(next-match lhs kernel)
(if (null entry)
nil
(let ((match-rhs (cdr entry)))
(if (eql rhs match-rhs)
t
(or (R*p-loop lhs rhs remaining-kernel so-far)
(R*p-loop match-rhs rhs kernel
(cons lhs so-far))))))))))
(R*p-loop lhs rhs kernel '())))
И эта версия работает:
> (R*p 1 3 (reflexifize-kernel *kernel*))
nil
> (R*p 1 1 (reflexifize-kernel *kernel*))
t
> (R*p 1 2 (reflexifize-kernel *kernel*))
t
> (R*p 2 1 (reflexifize-kernel *kernel*))
t
> (R*p 2 3 (reflexifize-kernel *kernel*))
nil