diff --git a/src/package.lisp b/src/package.lisp index 345b820..0394df4 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -561,6 +561,7 @@ :find-element :remove-element :count-elements-if + :remove-element-if :emptyp :with-min-queue)) @@ -1183,6 +1184,7 @@ :event-available-p :pop-event :remove-event + :remove-event-if :find-event :ask-user-input-string-event :user-input-string-event diff --git a/src/priority-queue.lisp b/src/priority-queue.lisp index 0fb21b3..52e15e2 100644 --- a/src/priority-queue.lisp +++ b/src/priority-queue.lisp @@ -54,6 +54,8 @@ (defgeneric remove-element (object element)) +(defgeneric remove-element-if (object predicate)) + (defgeneric count-elements-if (object predicate &key key-fn)) (defun get-parent-pos (pos) @@ -157,6 +159,46 @@ :key key-fn :start 1)) +(defun remove-at-pos (queue pos) + (with-accessors ((heap heap) + (key-function key-function) + (equal-function equal-function) + (compare-function compare-function)) queue + (let ((old-length (length heap))) + (cond + ((null pos) + nil) + ((= pos 1) + (pop-element queue) + pos) + (t + (misc:swap (elt heap pos) + (elt heap (1- (length heap)))) + (setf (fill-pointer heap) (1- (fill-pointer heap))) + (when (not (= pos (1- old-length))) + (let ((parent-pos (get-parent-pos pos))) + (if (funcall compare-function (elt heap pos) (elt heap parent-pos)) + (rearrange-bottom-up queue pos) + (rearrange-top-bottom queue pos)))) + pos))))) + +(defmethod remove-element-if ((object priority-queue) predicate) + (with-accessors ((heap heap) + (key-function key-function) + (equal-function equal-function) + (compare-function compare-function)) object + (labels ((%remove () + (let* ((actual-predicate (or predicate compare-function)) + (pos (position-if actual-predicate + heap + :start 1 + :key (key-function object)))) + (when pos + (progn + (remove-at-pos object pos) + (%remove)))))) + (%remove)))) + (defmethod remove-element ((object priority-queue) element) (with-accessors ((heap heap) (key-function key-function) @@ -166,17 +208,5 @@ heap :start 1 :key (key-function object) - :test (equal-function object))) - (old-length (length heap))) - (if (and pos - (= pos 1)) - (pop-element object) - (when pos - (misc:swap (elt heap pos) - (elt heap (1- (length heap)))) - (setf (fill-pointer heap) (1- (fill-pointer heap))) - (when (not (= pos (1- old-length))) - (let ((parent-pos (get-parent-pos pos))) - (if (funcall compare-function (elt heap pos) (elt heap parent-pos)) - (rearrange-bottom-up object pos) - (rearrange-top-bottom object pos))))))))) + :test (equal-function object)))) + (remove-at-pos object pos)))) diff --git a/src/program-events.lisp b/src/program-events.lisp index 82f19cc..719f8b7 100644 --- a/src/program-events.lisp +++ b/src/program-events.lisp @@ -154,6 +154,10 @@ (wrapped-in-lock (*events-queue*) (count-elements-if *events-queue* predicate :key-fn #'identity))) +(defun remove-event-if (predicate) + (wrapped-in-lock (*events-queue*) + (remove-element-if *events-queue* predicate))) + (defclass event-on-own-thread (program-event) ((lock :initform (bt:make-recursive-lock) @@ -998,6 +1002,9 @@ (when-let ((stream-object (gemini-viewer:find-db-stream-url uri))) (gemini-viewer:abort-downloading stream-object) (gemini-viewer:remove-db-stream stream-object) + (remove-event-if (lambda (a) + (and (typep a 'gemini-got-line-event) + (string= uri (gemini-viewer:download-uri stream-object))))) (line-oriented-window:resync-rows-db specials:*gemini-streams-window*)))) (defclass gemini-enqueue-download-event (program-event) ())