mirror of
https://github.com/RAIRLab/Spectra.git
synced 2025-06-14 18:16:26 +00:00
234 lines
8.7 KiB
Common Lisp
234 lines
8.7 KiB
Common Lisp
;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: snark-agenda -*-
|
||
;;; File: agenda.lisp
|
||
;;; The contents of this file are subject to the Mozilla Public License
|
||
;;; Version 1.1 (the "License"); you may not use this file except in
|
||
;;; compliance with the License. You may obtain a copy of the License at
|
||
;;; http://www.mozilla.org/MPL/
|
||
;;;
|
||
;;; Software distributed under the License is distributed on an "AS IS"
|
||
;;; basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See the
|
||
;;; License for the specific language governing rights and limitations
|
||
;;; under the License.
|
||
;;;
|
||
;;; The Original Code is SNARK.
|
||
;;; The Initial Developer of the Original Code is SRI International.
|
||
;;; Portions created by the Initial Developer are Copyright (C) 1981-2008.
|
||
;;; All Rights Reserved.
|
||
;;;
|
||
;;; Contributor(s): Mark E. Stickel <stickel@ai.sri.com>.
|
||
|
||
(in-package :snark-agenda)
|
||
|
||
(defstruct (agenda
|
||
(:print-function print-agenda3)
|
||
(:copier nil))
|
||
(name "" :read-only t)
|
||
(length 0)
|
||
(length-limit nil)
|
||
(length-limit-deletion-action #'identity :read-only t)
|
||
(same-item-p #'eql :read-only t)
|
||
(buckets (make-sparse-vector)))
|
||
|
||
;;; an agenda index value (priority) is (list integer_1 ... integer_n) or (list* integer_1 ... integer_n)
|
||
;;; which are both treated as the same sequence integer_1 ... integer_n
|
||
;;; this includes (list* integer) = integer as an agenda index value
|
||
;;; agenda index values are compared lexicographically in left-to-right order
|
||
;;; if one is prefix of another, they must be equal, e.g., can't have (2 18) and (2 18 1)
|
||
;;; agenda buckets are deques stored in nested sparse-vectors indexed by agenda index values
|
||
|
||
(defun find-agenda-bucket (buckets value &optional create)
|
||
(labels
|
||
((find-agenda-bucket* (buckets value)
|
||
(cond
|
||
((atom value)
|
||
(or (sparef buckets value)
|
||
(if create (setf (sparef buckets value) (make-deque)) nil)))
|
||
((null (rest value))
|
||
(or (sparef buckets (first value))
|
||
(if create (setf (sparef buckets (first value)) (make-deque)) nil)))
|
||
(t
|
||
(let ((v (sparef buckets (first value))))
|
||
(cond
|
||
(v
|
||
(find-agenda-bucket* v (rest value)))
|
||
(create
|
||
(find-agenda-bucket* (setf (sparef buckets (first value)) (make-sparse-vector)) (rest value)))
|
||
(t
|
||
nil)))))))
|
||
(find-agenda-bucket* buckets value)))
|
||
|
||
(defun first-or-last-nonempty-agenda-bucket (buckets last)
|
||
(labels
|
||
((first-or-last-nonempty-agenda-bucket* (buckets)
|
||
(prog->
|
||
(map-sparse-vector-with-indexes buckets :reverse last ->* x i)
|
||
(cond
|
||
((sparse-vector-p x)
|
||
(first-or-last-nonempty-agenda-bucket* x))
|
||
((deque-empty? x)
|
||
(setf (sparef buckets i) nil))
|
||
(t
|
||
(return-from first-or-last-nonempty-agenda-bucket x))))))
|
||
(first-or-last-nonempty-agenda-bucket* buckets)
|
||
nil))
|
||
|
||
(definline first-nonempty-agenda-bucket (buckets)
|
||
(first-or-last-nonempty-agenda-bucket buckets nil))
|
||
|
||
(definline last-nonempty-agenda-bucket (buckets)
|
||
(first-or-last-nonempty-agenda-bucket buckets t))
|
||
|
||
(defun collect-agenda-buckets (buckets)
|
||
(let ((result nil) result-last)
|
||
(labels
|
||
((collect-agenda-buckets* (buckets revalue)
|
||
(prog->
|
||
(map-sparse-vector-with-indexes buckets ->* x i)
|
||
(cond
|
||
((sparse-vector-p x)
|
||
(collect-agenda-buckets* x (cons i revalue)))
|
||
((deque-empty? x)
|
||
)
|
||
(t
|
||
(collect (list x (if (null revalue) i (reverse (cons i revalue)))) result))))))
|
||
(collect-agenda-buckets* buckets nil)
|
||
result)))
|
||
|
||
(defun agenda-insert (item value agenda &optional at-front)
|
||
(let* ((buckets (agenda-buckets agenda))
|
||
(q (find-agenda-bucket buckets value :create)))
|
||
(unless (and (not (deque-empty? q)) (funcall (agenda-same-item-p agenda) item (if at-front (deque-first q) (deque-last q))))
|
||
(if at-front (deque-push-first q item) (deque-push-last q item))
|
||
(let ((limit (agenda-length-limit agenda))
|
||
(length (agenda-length agenda)))
|
||
(cond
|
||
((and limit (<= limit length))
|
||
(let ((deleted-item (deque-pop-last (last-nonempty-agenda-bucket buckets))))
|
||
(cond
|
||
((eql item deleted-item)
|
||
nil)
|
||
(t
|
||
(funcall (agenda-length-limit-deletion-action agenda) deleted-item)
|
||
t))))
|
||
(t
|
||
(setf (agenda-length agenda) (+ length 1))
|
||
t))))))
|
||
|
||
(defun agenda-delete (item value agenda)
|
||
(let ((length (agenda-length agenda)))
|
||
(unless (eql 0 length)
|
||
(let ((q (find-agenda-bucket (agenda-buckets agenda) value)))
|
||
(when (and q (deque-delete q item))
|
||
(setf (agenda-length agenda) (- length 1))
|
||
t)))))
|
||
|
||
(defun agenda-first (agenda &optional delete)
|
||
(cond
|
||
((listp agenda)
|
||
(dolist (agenda agenda)
|
||
(unless (eql 0 (agenda-length agenda))
|
||
(return (agenda-first agenda delete)))))
|
||
(t
|
||
(let ((length (agenda-length agenda)))
|
||
(unless (eql 0 length)
|
||
(let ((q (first-nonempty-agenda-bucket (agenda-buckets agenda))))
|
||
(cond
|
||
(delete
|
||
(setf (agenda-length agenda) (- length 1))
|
||
(deque-pop-first q))
|
||
(t
|
||
(deque-first q)))))))))
|
||
|
||
(defun pop-agenda (agenda)
|
||
(agenda-first agenda t))
|
||
|
||
(defun map-agenda-buckets (function buckets)
|
||
(prog->
|
||
(map-sparse-vector buckets ->* x)
|
||
(cond
|
||
((sparse-vector-p x)
|
||
(map-agenda-buckets function x))
|
||
(t
|
||
(funcall function x)))))
|
||
|
||
(defun mapnconc-agenda (function agenda)
|
||
(let ((result nil) result-last)
|
||
(prog->
|
||
(map-agenda-buckets (agenda-buckets agenda) ->* q)
|
||
(mapnconc-deque q ->* item)
|
||
(cond
|
||
((or (null function) (eq 'list function) (eq #'list function))
|
||
(collect item result))
|
||
(t
|
||
(ncollect (funcall function item) result))))))
|
||
|
||
(defun agenda-delete-if (function agenda &optional apply-length-limit-deletion-action)
|
||
(prog->
|
||
(and apply-length-limit-deletion-action (agenda-length-limit-deletion-action agenda) -> deletion-action)
|
||
(map-agenda-buckets (agenda-buckets agenda) ->* q)
|
||
(deque-delete-if q ->* v)
|
||
(when (funcall function v)
|
||
(decf (agenda-length agenda))
|
||
(when deletion-action
|
||
(funcall deletion-action v))
|
||
t)))
|
||
|
||
(defun limit-agenda-length (agenda limit)
|
||
(let ((length (agenda-length agenda)))
|
||
(setf (agenda-length-limit agenda) limit)
|
||
(when (and limit (< limit length))
|
||
(let ((i 0))
|
||
(agenda-delete-if (lambda (item) (declare (ignore item)) (> (incf i) limit)) agenda t)))))
|
||
|
||
(defvar *agenda*) ;default agenda(s) for print-agenda to display
|
||
|
||
(defun print-agenda (&key (agenda *agenda*) entries)
|
||
(cond
|
||
((listp agenda)
|
||
(let ((all-empty t))
|
||
(dolist (agenda agenda)
|
||
(unless (eql 0 (agenda-length agenda))
|
||
(setf all-empty nil)
|
||
(print-agenda :agenda agenda :entries entries)))
|
||
(when all-empty
|
||
(format t "~%; All agendas are empty."))))
|
||
(t
|
||
(with-standard-io-syntax2
|
||
(format t "~%; The agenda of ~A has ~D entr~:@P~A"
|
||
(agenda-name agenda)
|
||
(agenda-length agenda)
|
||
(if (eql 0 (agenda-length agenda)) "." ":"))
|
||
(unless (eql 0 (agenda-length agenda))
|
||
(let ((buckets (collect-agenda-buckets (agenda-buckets agenda))))
|
||
(do* ((k (length buckets))
|
||
(k1 (ceiling k 3))
|
||
(k2 (ceiling (- k k1) 2))
|
||
(buckets3 (nthcdr (+ k1 k2) buckets))
|
||
(buckets2 (nbutlast (nthcdr k1 buckets) (- k k1 k2)))
|
||
(buckets1 (nbutlast buckets k2))
|
||
b)
|
||
((null buckets1))
|
||
(setf b (pop buckets1))
|
||
(format t "~%; ~5D with value ~A" (deque-length (first b)) (second b))
|
||
(unless (null buckets2)
|
||
(setf b (pop buckets2))
|
||
(format t "~31T~5D with value ~A" (deque-length (first b)) (second b))
|
||
(unless (null buckets3)
|
||
(setf b (pop buckets3))
|
||
(format t "~61T~5D with value ~A" (deque-length (first b)) (second b))))))
|
||
(when (and entries (not (eql 0 (agenda-length agenda))))
|
||
(prog->
|
||
(dolist (collect-agenda-buckets (agenda-buckets agenda)) ->* x)
|
||
(first x -> q)
|
||
(second x -> value)
|
||
(unless (deque-empty? q)
|
||
(format t "~%;~%; Entries with value ~A:" value)
|
||
(mapnconc-deque (lambda (x) (format t "~%; ~A" x)) q))))))
|
||
nil)))
|
||
|
||
(defun print-agenda3 (agenda stream depth)
|
||
(declare (ignore depth))
|
||
(print-unreadable-object (agenda stream :type t :identity nil)
|
||
(format stream "~S" (agenda-name agenda))))
|
||
|
||
;;; agenda.lisp EOF
|