Индивидуальная функция сравнения в общем списке

Question

Мне нужно сравнить два списка и равнозначно делать все, когда у меня есть вложенные списки в порядке, но мне нужна пользовательская функция, которая возвращает T, когда у меня смешан порядок вложенных списков.Что-то вроде:

    (setq temp1 '(((BCAT S) (FEATS NIL)) (DIR FS) (MODAL STAR)
      (((BCAT S) (FEATS NIL)) (MODAL STAR) (DIR BS)  ((FEATS NIL) (BCAT NP)))))

    (setq temp2 '((DIR FS) ((BCAT S) (FEATS NIL)) (MODAL STAR)
      (((BCAT S) (FEATS NIL)) (DIR BS) (MODAL STAR) ((BCAT NP) (FEATS NIL)))))

    (equalp-customized temp1 temp2) ; gotta make this return T

Я пытался найти исходный код equp, я думаю, это была плохая идея, тогда я мог бы изменить его для удовлетворения своих потребностей.Теперь я понятия не имею, с чего начать.Цени любую помощь:)

Answer 1

Я думаю, что делать это наивно, путем рекурсивного сравнения всех элементов, вероятно, слишком медленно, поскольку оно квадратично на каждом уровне.

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

Answer 2

Похоже, что ваши входные деревья состоят только из атомарных 2-элементных списков на самом низком уровне.Если это так, вы можете просто сгладить деревья в списки, а затем проверить на равные множества.(Однако, если списки самого низкого уровня могут содержать произвольное количество атомов, то вам нужно будет извлечь эти списки, сначала пройдя деревья ввода.)

Библиотека Александрии содержит функцию flatten, но онаудалил бы nil записи во входах.Вот альтернативная функция, которая делает то же самое, но с учетом NIL.Результатом является список входных списков из 2 элементов.

(defun level-out (tree)
  "Flattens a tree respecting NILs."
  (loop for item in tree
        when (consp item)
          if (atom (car item))
            append item
          else append (level-out item)))

Так что теперь, например:

(setq flat1 (level-out temp1)) -> (BCAT S FEATSNIL DIR FS ОСОБЕННОСТИ МОДАЛЬНОЙ ЗВЕЗДЫ BCAT S NIL DIR FS ОСОБЕННОСТИ ОСНОВАНИЙ NIL BCAT NP)

Затем следующая функция собирает пары:

(defun pair-up (plist)
  (loop for (1st 2nd) on plist by #'cddr
      collect (list 1st 2nd)))

, давая:

(setq pair1 (pair-up flat1)) -> ((BCAT S) (FEATS NIL) (DIR FS) (MODAL STAR) (BCAT S) (FEATS NIL) (MODAL STAR) (DIR BS) (FEATS NIL) (BCATNP))

Пары теперь в форме для проверки равенства множеств с использованием Александрии:

(defun nested-pairs-equal-p (tree1 tree2)
  (alexandria:set-equal (pair-up (level-out tree1))
                        (pair-up (level-out tree2))
                        :test #’equal))

(nested-pairs-equal-p temp1 temp2) -> T

Извлечение вложенных списков

Собственно, этоможет быть более простым извлекать вложенные списки напрямую с помощью:

(defun level-out-nested-lists (tree)
  (loop for item in tree
      if (and (consp item) (atom (car item)))
      collect item
      else append (level-out-nested-lists item)))

перед проверкой на наличие александрии: set-equal.

Извлечение вложенных списков, проиндексированных по уровню

Основная идея снова состоит в том, чтобы пройтись по двум входным спискам, извлекая элементы самого низкого уровня, но связывая каждый извлеченный элемент с его уровнем в дереве.Следующая функция предназначена для создания списка предметов, где автомобиль - это уровень, а cdr - список предметов, появляющихся на этом уровне:

(defun associate-tree-items-by-level (tree)
  "Returns an alist of items in tree indexed by level."
  (let (alist)
    (labels ((associate-tree-items-by-level-1 (tree level)
               (loop for item in tree
                 when (consp item)
                  if (atom (car item))
                   do (let ((pair (assoc level alist)))
                        (if pair
                          (rplacd pair (push item (cdr pair)))
                          (push (cons level (list item)) alist)))
                   else do (associate-tree-items-by-level-1 item (1+ level)))))
      (associate-tree-items-by-level-1 tree 1)
      (sort alist #'< :key #'first))))

Итак:

(associate-tree-items-by-level
  '(((BCAT S) (FEATS NIL)) (DIR BS) (MODAL STAR) (((BCAT S) (FEATS NIL)) (MODAL STAR) (DIR FS) ((FEATS NIL) (BCAT NP)))))
->  ((1 (MODAL STAR) (DIR BS))
 (2 (DIR FS) (MODAL STAR) (FEATS NIL) (BCAT S))
 (3 (BCAT NP) (FEATS NIL) (FEATS NIL) (BCAT S)))

Все предметы теперь сгруппированы в пакеты (не наборы из-за возможных повторений) и проиндексированы по уровню.Следующая функция должна проверять наличие одинаковых пакетов предметов:

(defun bag-equal-p (bag-list1 bag-list2)
  (and (= (length bag-list1) (length bag-list2))
       (loop with remainder = (copy-list bag-list2)
         for item1 in bag-list1
         do (alexandria:deletef remainder item1 :test #'equal :count 1)
         finally (return (not remainder)))))

Чтобы проверить равенство входов, вы можете сделать что-то вроде:

(every #'bag-equal-p 
  (associate-tree-items-by-level input1)
  (associate-tree-items-by-level input2))

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