# HG changeset patch # User Steve Losh # Date 1488396777 0 # Node ID c49425b33f17d16b7e06cfb6c78d34c62ddb749d # Parent 4d881c9900609dcc96939f87c3530801d99e41c5 Add jankass priority queues diff -r 4d881c990060 -r c49425b33f17 DOCUMENTATION.markdown --- a/DOCUMENTATION.markdown Wed Mar 01 19:14:51 2017 +0000 +++ b/DOCUMENTATION.markdown Wed Mar 01 19:32:57 2017 +0000 @@ -1355,6 +1355,63 @@ +## Package `LOSH.PRIORITY-QUEUES` + +Jankass priority queue implementation. + +### `MAKE-PRIORITY-QUEUE` (function) + + (MAKE-PRIORITY-QUEUE &KEY (PRIORITY-PREDICATE #'<) (ELEMENT-TEST #'EQL)) + +Create and return a fresh priority queue. + + `priority-predicate` is the comparison function used to compare priorities, + and should be a `<`-like predicate. + + `element-test` should be the equality predicate for elements. + + + +### `PQ-DEQUEUE` (function) + + (PQ-DEQUEUE PQ) + +Remove and return the element in `pq` with the lowest-numbered priority. + + If `pq` is empty `nil` will be returned. + + A second value is also returned, which will be `t` if an element was present + or `nil` if the priority queue was empty. + + + +### `PQ-ENSURE` (function) + + (PQ-ENSURE PQ ELEMENT PRIORITY) + +Ensure `element` is in `pq` with `priority`. + + If `element` is already in `pq` its priority will be set to `priority`. + Otherwise it will be inserted as if by calling `pq-insert`. + + Returns `pq` (which may have been modified). + + + +### `PQ-INSERT` (function) + + (PQ-INSERT PQ ELEMENT PRIORITY) + +Insert `element` into `pq` with `priority`. + + Returns `pq` (which has been modified). + + + +### `PRIORITY-QUEUE` (struct) + +Slots: `CONTENTS`, `PREDICATE`, `TEST` + ## Package `LOSH.QUEUES` A simple queue implementation. diff -r 4d881c990060 -r c49425b33f17 losh.lisp --- a/losh.lisp Wed Mar 01 19:14:51 2017 +0000 +++ b/losh.lisp Wed Mar 01 19:32:57 2017 +0000 @@ -616,13 +616,14 @@ ;;;; Mutation ----------------------------------------------------------------- -(defun build-zap (place expr env) - (multiple-value-bind (temps exprs stores store-expr access-expr) - (get-setf-expansion place env) - `(let* (,@(mapcar #'list temps exprs) - (,(car stores) (symbol-macrolet ((% ,access-expr)) - ,expr))) - ,store-expr))) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun build-zap (place expr env) + (multiple-value-bind (temps exprs stores store-expr access-expr) + (get-setf-expansion place env) + `(let* (,@(mapcar #'list temps exprs) + (,(car stores) (symbol-macrolet ((% ,access-expr)) + ,expr))) + ,store-expr)))) (defmacro zapf (&rest place-expr-pairs &environment env) "Update each `place` by evaluating `expr` with `%` bound to the current value. @@ -2135,6 +2136,90 @@ (finding item :such-that (< n weight)))) +;;;; Priority Queues ---------------------------------------------------------- +;;; Jankass priority queue implementation. +(defstruct (priority-queue (:conc-name pq-) + (:constructor make-priority-queue%)) + (contents nil) + (predicate #'<) + (test #'eql)) + + +(defun make-priority-queue (&key (priority-predicate #'<) (element-test #'eql)) + "Create and return a fresh priority queue. + + `priority-predicate` is the comparison function used to compare priorities, + and should be a `<`-like predicate. + + `element-test` should be the equality predicate for elements. + + " + (make-priority-queue% :predicate priority-predicate :test element-test)) + + +(defmethod print-object ((object priority-queue) stream) + (print-unreadable-object (object stream :type t :identity t) + (prin1 (pq-contents object) stream))) + + +(defun pqn-priority (node) + (first node)) + +(defun pqn-element (node) + (second node)) + +(defun pq-resort (pq) + (zapf (pq-contents pq) + (sort % (pq-predicate pq) :key #'pqn-priority)) + pq) + +(defun pq-lookup (pq element) + (find element (pq-contents pq) + :key #'pqn-element + :test (pq-test pq))) + + +(defun pq-insert (pq element priority) + "Insert `element` into `pq` with `priority`. + + Returns `pq` (which has been modified). + + " + (zapf (pq-contents pq) + (merge 'list `((,priority ,element)) % (pq-predicate pq) + :key #'pqn-priority)) + pq) + +(defun pq-ensure (pq element priority) + "Ensure `element` is in `pq` with `priority`. + + If `element` is already in `pq` its priority will be set to `priority`. + Otherwise it will be inserted as if by calling `pq-insert`. + + Returns `pq` (which may have been modified). + + " + (let ((existing (pq-lookup pq element))) + (if existing + (progn (setf (car existing) priority) + (pq-resort pq)) + (pq-insert pq element priority))) + pq) + +(defun pq-dequeue (pq) + "Remove and return the element in `pq` with the lowest-numbered priority. + + If `pq` is empty `nil` will be returned. + + A second value is also returned, which will be `t` if an element was present + or `nil` if the priority queue was empty. + + " + (if (pq-contents pq) + (values (pqn-element (pop (pq-contents pq))) t) + (values nil nil))) + + ;;;; Hash Sets ---------------------------------------------------------------- (defstruct (hash-set (:constructor make-hash-set%)) (storage (error "Required") :type hash-table :read-only t)) @@ -2352,7 +2437,6 @@ (hash-table-keys storage)) - ;;;; Bit Sets ----------------------------------------------------------------- ;;; Implementation of the sets-as-integers idea in the Common Lisp Recipes book. (deftype bset () '(integer 0)) diff -r 4d881c990060 -r c49425b33f17 make-docs.lisp --- a/make-docs.lisp Wed Mar 01 19:14:51 2017 +0000 +++ b/make-docs.lisp Wed Mar 01 19:32:57 2017 +0000 @@ -19,6 +19,7 @@ "LOSH.LICENSING" "LOSH.MATH" "LOSH.MUTATION" + "LOSH.PRIORITY-QUEUES" "LOSH.QUEUES" "LOSH.RANDOM" "LOSH.SEQUENCES" diff -r 4d881c990060 -r c49425b33f17 package.lisp --- a/package.lisp Wed Mar 01 19:14:51 2017 +0000 +++ b/package.lisp Wed Mar 01 19:32:57 2017 +0000 @@ -233,6 +233,16 @@ :notf :callf)) +(defpackage :losh.priority-queues + (:documentation "Jankass priority queue implementation.") + (:export + :priority-queue + :make-priority-queue + + :pq-insert + :pq-ensure + :pq-dequeue)) + (defpackage :losh.queues (:documentation "A simple queue implementation.") (:export @@ -302,6 +312,7 @@ :losh.licensing :losh.math :losh.mutation + :losh.priority-queues :losh.queues :losh.random :losh.sequences