Форум программистов
 

Восстановите пароль или Зарегистрируйтесь на форуме, о проблемах и с заказом рекламы пишите сюда - alarforum@yandex.ru, проверяйте папку спам!

Вернуться   Форум программистов > IT форум > Помощь студентам
Регистрация

Восстановить пароль

Купить рекламу на форуме - 42 тыс руб за месяц

Ответ
 
Опции темы Поиск в этой теме
Старый 15.03.2015, 14:23   #1
vlasova
Новичок
Джуниор
 
Регистрация: 15.03.2015
Сообщений: 1
По умолчанию LISP функции

Помогите разобраться с кодом
непонятна работа функции percolate-up и percolate-down

Код:
(defun make-heap (&optional (length 7))
  (make-array length :adjustable t :fill-pointer 0))
 
(defun left-index (index)
  (1- (* 2 (1+ index))))
 
(defun right-index (index)
  (* 2 (1+ index)))
 
(defun parent-index (index)
  (floor (1- index) 2))
 
(defun percolate-up (heap index predicate)
  (if (zerop index) heap
    (do* ((element (aref heap index))
          (index index pindex)
          (pindex (parent-index index)
                  (parent-index index)))
         ((zerop index) heap)
      (if (funcall predicate element (aref heap pindex))
        (rotatef (aref heap index) (aref heap pindex))
        (return-from percolate-up heap)))))
 
(defun heap-insert (heap element predicate)
  (let ((index (vector-push-extend element heap 2)))
    (percolate-up heap index predicate)))
 
(defun percolate-down (heap index predicate)
  (let ((length (length heap))
        (element (aref heap index)))
    (flet ((maybe-element (index)
             "return the element at index or nil, and a boolean
              indicating whether there was an element."
             (if (< index length)
               (values (aref heap index) t)
               (values nil nil))))
      (do ((index index swap-index)
           (lindex (left-index index) (left-index index))
           (rindex (right-index index) (right-index index))
           (swap-index nil) (swap-child nil))
          (nil)
        ;; Extact the left child if there is one. If there is not,
        ;; return the heap.  Set the left child as the swap-child.
        (multiple-value-bind (lchild lp) (maybe-element lindex)
          (if (not lp) (return-from percolate-down heap)
            (setf swap-child lchild
                  swap-index lindex))
          ;; Extract the right child, if any, and when better than the
          ;; current swap-child, update the swap-child.
          (multiple-value-bind (rchild rp) (maybe-element rindex)
            (when (and rp (funcall predicate rchild lchild))
              (setf swap-child rchild
                    swap-index rindex))
            ;; If the swap-child is better than element, rotate them,
            ;; and continue percolating down, else return heap.
            (if (not (funcall predicate swap-child element))
              (return-from percolate-down heap)
              (rotatef (aref heap index) (aref heap swap-index)))))))))
 
(defun heap-empty-p (heap)
  (eql (length heap) 0))
 
(defun heap-delete-min (heap predicate)
  (assert (not (heap-empty-p heap)) () "Can't pop from empty heap.")
  (prog1 (aref heap 0)
    (setf (aref heap 0) (vector-pop heap))
    (unless (heap-empty-p heap)
      (percolate-down heap 0 predicate))))
 
(defun heapsort (sequence predicate)
  (let ((h (make-heap (length sequence))))
    (map nil #'(lambda (e) (heap-insert h e predicate)) sequence)
    (map-into sequence #'(lambda () (heap-delete-min h predicate)))))
vlasova вне форума Ответить с цитированием
Ответ


Купить рекламу на форуме - 42 тыс руб за месяц



Похожие темы
Тема Автор Раздел Ответов Последнее сообщение
Две функции на lisp veter48 Помощь студентам 1 11.01.2013 01:19
LISP Electroflower Помощь студентам 1 06.01.2012 11:15
lisp Hevadimka Фриланс 0 09.10.2011 12:54
Определение функции в LISP skifkir Помощь студентам 0 18.05.2011 22:35
LISP vitalik_b1 Помощь студентам 0 30.10.2010 14:35