Как написать код набора покрытия с помощью Lisp? (алгоритм включен) - PullRequest
0 голосов
/ 24 января 2019

У меня проблема с написанием кода задачи с набором обложек с помощью Common Lisp.

(setcover N S), N - неотрицательное целое число, а S - набор подмножеств чисел U = (1 2 ... N).Задача покрытия множеств требует найти (небольшое) количество подмножеств в S, чтобы их объединение покрывало U. Это означает, что каждое число в U содержится по крайней мере в одном из подмножеств в решении.И окончательное решение должно быть жадным

ex:

(let ((S '((1 2 3) (2 4) (3 4) (2 5) (4 5))))
  (setcover 5 S))

output:

((1 2 3) (4 5))

Я попытался написать этот код, и я действительно написал алгоритм дляЭто.(раунд означает рекурсию)

первый раунд: используйте числовую функцию для создания списка (1, 2 .... U), затем используйте общую функцию для сравнения подсписка S и списка U и проверки количества чиселв общемзатем возьмите этот подсписок для построения (в данном примере это (1 2 3)), наконец, удалите (1 2 3) из списка U.

второй раунд: проверьте еще раз, и есть только (4 5) осталось в списке U, поэтому будет использоваться подсписок (4 5).

третий раунд: ничего не осталось, поэтому будет сформирован новый список ((1 2 3) (4 5))

Мои проблемы: как найти наибольшее число из общей функции в каждом раунде?как удалить эти совпадающие числа из списка U (так как он должен быть создан первым)?и как создать новый список в конце?

;create a list U
(defun numbers (N)  
  (if (<= N 0)
      nil
    (append (numbers (- N 1)) (list n))))

;check if this atom exist in the list
(defun check (Atom List)
  (cond
   ((null List) nil)
   ((equal Atom (car List)))
   (t (check Atom (cdr List)))))

;numbers of common numbers that both two lists have
(defun common (L1 L2)
  (cond 
   ((null L1) 0)
   ((check (car L1) L2) (+ 1 (common (cdr L1) L2)))
   (t (common (cdr L1) L2))))

;final setcover function but I have no idea what to do next...
(defun setcover (N S)
  (cond 
   ((if (null S) nil))
   ((listp (car S)) 
    (common (car S) (numbers N)) 
    (setcover N (cdr S)))))

Надеюсь, кто-нибудь может мне помочь.Спасибо!

2019/01/24 (подробное описание вопроса)

Написать функцию Lisp:

(setcover NS) Эта функция должна реализовыватьжадный алгоритм для заданной задачи покрытия.Эта проблема и алгоритм описаны ниже.Статья в Википедии об обложке множеств также объясняет проблему (гораздо более подробно, чем нам нужно).

В (setcover NS) N - неотрицательное целое число, а S - множество подмножеств чисел U =(1 2 ... N).Задача покрытия множеств требует найти (небольшое) число подмножеств в S, чтобы их объединение покрывало U. Это означает, что каждое число в U содержится хотя бы в одном из подмножеств в решении.

Пример:

(let
    ((S '((1 2 3) (2 4) (3 4) (2 5) (4 5))))
    (setcover 5 S)
)

Решение:

((1 2 3) (4 5))

Пояснения: N = 5, поэтому U = (1 2 3 4 5).S состоит из некоторых подмножеств (1 2 3 4 5).Мы ищем небольшое количество этих подмножеств, которые вместе охватывают все пять чисел.

Лучшее решение использует только два подмножества (1 2 3) и (4 5).Другое решение с тремя подмножествами ((1 2 3) (2 4) (2 5)).Еще одним решением является ((1 2 3) (2 4) (3 4) (2 5)).Однако в этом решении вы можете удалить либо (2 4), либо (3 4) и получить меньшее решение, которое по-прежнему охватывает все U.

Оптимальное решение задачи о покрытии множеств означает поиск наименьшего числа подмножествиз S, которые охватывают U. (Количество наборов, а не размер наборов.) К сожалению, эта проблема сложна с точки зрения NP, и, следовательно, эффективный алгоритм не известен.

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

Основная идея - решить проблему в несколько раундов.В каждом раунде мы выбираем еще одно подмножество из S, пока у нас не будет полного покрытия.Мы выбираем подмножество, которое содержит как можно больше пропущенных чисел.

Предположим, что у нас еще осталось несколько чисел в (1 2 ... N) для покрытия.Мы рассмотрим каждое подмножество Si в S и посчитаем, сколько из этих чисел будет покрыто Si.Затем мы жадно выбираем подмножество, которое покрывает больше всего.

ПОДРОБНЫЙ ПРИМЕР

S = ((1 2 3) (2 4) (3 4) (2 5) (4 5))
Subsets in S: S1 = (1 2 3), S2 = (2 4), S3 = (3 4), S4 = (2 5), S5 = (4 5)
N = 5
U = (1 2 3 4 5)

Start of algorithm:
Solution so far = ()
Still to cover = (1 2 3 4 5)

Round 1:
Covered by S1: 3 numbers (1 2 3)
Covered by S2: 2 numbers (2 4)
Covered by S3: 2 numbers 
Covered by S4: 2
Covered by S5: 2
Best subset: S1, covers 3 numbers (1 2 3)
Solution so far = (S1)
Still to cover = (4 5)

Round 2:
Covered by S2: 1 number (4)
Covered by S3: 1 number (4)
Covered by S4: 1 number (5)
Covered by S5: 2 numbers (4 5)
Best: S5, covers (4 5)
Solution so far = (S1 S5)
Still to cover = ()

Round 3:
Nothing left to cover, so stop.
Return solution (S1 S5) = ((1 2 3) (4 5))

Еще пример:

(setcover 2 '((1) (2) (1 2)))
((1 2))

(let
    ((S '((1 2 3 4 5))))
    (setcover 5 S)
)
((1 2 3 4 5))

1 Ответ

0 голосов
/ 24 января 2019

Вот возможное жадное решение с гипотезой о том, что все наборы отсортированы без использования примитивных функций Common Lisp, таких как set-difference, и с использованием только рекурсии (а не итераций или функций высокого порядка).

(defun my-difference (s1 s2)
  "Compute the difference between set s1 and set s2"
  (cond ((null s1) nil)
        ((check (car s1) s2) (my-difference (cdr s1) s2))
        (t (cons (car s1) (my-difference (cdr s1) s2)))))

(defun cover-sets (s1 s2)
  "Compute the greedy cover of set s1 by elements of list of sets s2"
  (cond ((null s1) nil)
        ((null s2) (error "no cover possible"))
        (t (let ((diff (my-difference s1 (car s2))))
             (if (equal diff s1)
                 (cover-sets s1 (cdr s2))
                 (cons (car s2) (cover-sets diff (cdr s2))))))))

(defun setcover (n s)
  "Solve the problem"
  (cover-sets (numbers n) s))

Вот альтернативное решение с примитивными функциями и итерациями:

(defun cover (n s)
  (let ((u (loop for i from 1 to n collect i)))
    (loop for x in s
      for w = (intersection u x)
      when w
        do (setf u (set-difference u x))
        and collect x
      end
      while u)))

Добавление

После обновления поста со спецификациейалгоритм, вот возможное решение (без использования рекурсии):

(defun count-common-elements (s1 s2)
  "return the number of common elements with s1 of each set of s2"
  (mapcar (lambda (x) (length (intersection s1 x))) s2))

(defun index-of-maximum (l)
  "return the index of the maximum element in list l"
  (position (reduce #'max l) l))

(defun setcover (n s)
  (let ((working-set (numbers n))
        (solution nil))
    (loop while working-set
          for i = (index-of-maximum (count-common-elements working-set s))
          for set = (elt s i)
          do (setf working-set (set-difference working-set set)
                   s (remove set s))
          do (push set solution))
   (reverse solution)))

и вот рекурсивное решение:

(defun most-elements (s1 s2 m)
  "find the set with the higher number of elements in common 
 with s1 between m and all the elements of s2"
  (if (null s2)
      m
      (let ((l1 (length (my-difference s1 m)))
            (l2 (length (my-difference s1 (car s2)))))
        (if (< l1 l2)
            (most-elements s1 (cdr s2) m)
            (most-elements s1 (cdr s2) (car s2))))))     

(defun greedy-cover-set (s1 s2)
  "find the greedy cover set of s1 by using the sets elements of s2"
  (cond ((null s1) nil)
        ((null s2) (error "no cover possible"))
        (t (let ((candidate (most-elements s1 s2 nil)))
            (cons
              candidate
              (greedy-cover-set (my-difference s1 candidate)
                                (remove candidate s2)))))))

(defun setcover (n s)
  (greedy-cover-set (numbers n) s))

Обратите внимание, что remove является предопределенной функцией CommonЛисп (см. руководство ).Нетрудно дать его рекурсивное определение.

...