--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Maintenance and recalculation of dependent values
+;;;
+;;; (c) 2008 Mark Wooding
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:dep
+ (:use #:common-lisp #:queue)
+ (:export #:dep #:depp #:make-dep #:dep-goodp
+ :delay-recomputing-deps
+ #:install-dep-syntax
+ #:dep-value #:dep-make-bad #:dep-bad #:dep-try
+ #:dep-add-listener))
+(in-package #:dep)
+
+;;;--------------------------------------------------------------------------
+;;; Dependencies.
+
+(defstruct (dep (:predicate depp)
+ (:constructor %make-dep))
+ "There are two kinds of `dep', though we use the same object type for both.
+ A leaf dep has no dependencies, and its value is set explicitly by the
+ programmer. A non-leaf dep has a value /function/, which computes the
+ dep's value as a function of other deps' values. The dependencies don't
+ need to be declared in advance, or remain constant over time.
+
+ When not during a recomputation phase (i.e., when `stable'), a dep is
+ either `good' (i.e., it has a value) or `bad'. An attempt to read the
+ value of a bad dep results in a throw of `bad-dep'. Badness propagates
+ automatically during recomputation phases."
+ (%value nil :type t)
+ (value-func nil :type (or function null))
+ (value-predicate #'eql :type function)
+ (goodp nil :type boolean)
+ (state :pending :type (member :stable :pending :recomputing))
+ (listeners nil :type list)
+ (dependents nil :type list))
+
+(defvar *evaluating-dep* nil
+ "The dep currently being evaluated. This is bound only during the call of
+ a value-func, and is used to track the dependencies implied during the
+ function's evaluation.")
+
+(defvar *pending-deps* nil
+ "A queue of deps pending recomputation. This is bound to a queue during
+ recomputation and restored afterwards, so it can also be used as a flag to
+ detect whether recomputation is happening.")
+
+(defun kick-dep (dep)
+ "Call when DEP's value (or good/bad state) has changed. Marks the
+ dependents of DEP as :pending, if they're currently :stable, and then
+ clears the dependent list. Also invokes DEP's listener functions."
+ (dolist (d (dep-dependents dep))
+ (when (eq (dep-state d) :stable)
+ (enqueue d *pending-deps*)
+ (setf (dep-state d) :pending)))
+ (setf (dep-dependents dep) nil)
+ (dolist (l (dep-listeners dep))
+ (funcall l)))
+
+(defun update-dep (dep value &optional (goodp t))
+ "Modify the value of DEP. If GOODP is t, then mark it as good and store
+ VALUE is its new value; otherwise mark it bad. If DEP's value is now
+ different (according to its value-predicate) then return true; otherwise
+ return false."
+ (setf (dep-state dep) :stable)
+ (cond ((not goodp)
+ (if (dep-goodp dep)
+ (progn (setf (dep-goodp dep) nil) t)
+ nil))
+ ((and (dep-goodp dep)
+ (funcall (dep-value-predicate dep) value (dep-%value dep)))
+ nil)
+ (t
+ (setf (dep-goodp dep) t
+ (dep-%value dep) value)
+ t)))
+
+(defun recompute-dep (dep)
+ "Recompute the value of DEP. This function is careful to trap nonlocal
+ transfers from the value-func."
+ (let ((winning nil))
+ (unwind-protect
+ (catch 'dep-bad
+ (setf (dep-state dep) :recomputing)
+ (when (update-dep dep (let ((*evaluating-dep* dep))
+ (funcall (dep-value-func dep))))
+ (kick-dep dep))
+ (setf winning t))
+ (unless winning
+ (when (update-dep dep nil nil)
+ (kick-dep dep))))))
+
+(defun recompute-deps ()
+ "Recompute all the pending deps, and any others that depend on them."
+ (unwind-protect
+ (loop (when (queue-emptyp *pending-deps*)
+ (return))
+ (let ((dep (dequeue *pending-deps*)))
+ (when (eq (dep-state dep) :pending)
+ (recompute-dep dep))))
+ (loop (when (queue-emptyp *pending-deps*)
+ (return))
+ (let ((d (dequeue *pending-deps*)))
+ (setf (dep-state d) :stable
+ (dep-goodp d) nil)))))
+
+(defun ensure-dep-has-value (dep)
+ "Ensure that DEP has a stable value. If DEP is currently computing,
+ signals an error."
+ (ecase (dep-state dep)
+ (:stable)
+ (:pending
+ (recompute-dep dep))
+ (:recomputing
+ (error "Ouch! Cyclic dependency."))))
+
+(defun pulse-dep (dep)
+ "Notifies DEP of a change in its value. If a recomputation phase is
+ currently under way, queue the dependents and leave fixing things up to
+ the outer loop; otherwise start up a recomputation phase."
+ (if *pending-deps*
+ (kick-dep dep)
+ (let ((*pending-deps* (make-queue)))
+ (kick-dep dep)
+ (recompute-deps))))
+
+(defun (setf dep-value) (value dep)
+ "Set DEP's value to be VALUE (and mark it as being good)."
+ (when (dep-value-func dep)
+ (error "Not a leaf dep."))
+ (when (update-dep dep value)
+ (pulse-dep dep))
+ value)
+
+(defun dep-make-bad (dep)
+ "Mark DEP as being bad."
+ (when (dep-value-func dep)
+ (error "Not a leaf dep."))
+ (when (update-dep dep nil nil)
+ (pulse-dep dep)))
+
+(defun dep-add-listener (dep func)
+ "Add a listener function FUNC to the DEP. The FUNC is called each time the
+ DEP's value (or good/bad state) changes. It is called with no arguments,
+ and its return value is ignored."
+ (push func (dep-listeners dep)))
+
+(defun dep-value (dep)
+ "Retrieve the current value from DEP."
+ (when *evaluating-dep*
+ (pushnew *evaluating-dep* (dep-dependents dep)))
+ (ensure-dep-has-value dep)
+ (if (dep-goodp dep) (dep-%value dep) (throw 'dep-bad nil)))
+
+(defun make-dep (&rest args)
+ "Create a new DEP object. There are two basic argument forms:
+
+ (:leaf &optional OBJECT)
+ Return a leaf dep, whose value is OBJECT; if no OBJECT is given, the
+ dep is initially bad.
+
+ (:function FUNCTION)
+ Return a non-leaf dep whose value is computed by FUNCTION.
+
+ Additionally, if the first argument is something other than :leaf or
+ :function (ideally not a keyword, for forward compatibility), then the
+ first argument is inspected: if it's a function, then a function dep is
+ retuerned (as if you'd specified :function); otherwise a leaf dep is
+ returned.
+
+ If no arguments are given, a bad leaf dep is returned."
+
+ (flet ((arg (&optional (default nil defaultp))
+ (cond (args (pop args))
+ (defaultp default)
+ (t (error "Not enough arguments to MAKE-DEP.")))))
+
+ ;; Sort out the arguments.
+ (multiple-value-bind (type value goodp)
+ (if (null args)
+ (values :leaf nil nil)
+ (let ((indicator (pop args)))
+ (cond ((eq indicator :leaf)
+ (if args
+ (values :leaf (pop args) t)
+ (values :leaf nil nil)))
+ ((eq indicator :function)
+ (values :function (arg) nil))
+ ((functionp indicator)
+ (values :function indicator nil))
+ (t
+ (values :leaf indicator t)))))
+ (unless (endp args)
+ (error "Excess arguments to MAKE-DEP."))
+
+ ;; Create the object appropriately.
+ (case type
+ (:function
+ (let ((dep (%make-dep :value-func value :state :pending)))
+ (if *pending-deps*
+ (enqueue dep *pending-deps*)
+ (let ((*pending-deps* (make-queue)))
+ (enqueue dep *pending-deps*)
+ (recompute-deps)))
+ dep))
+ (:leaf
+ (%make-dep :%value value :goodp goodp :state :stable))))))
+
+(defmacro dep-try (expr &body body)
+ "Evaluate EXPR. If it throws dep-bad then evaluate BODY instead."
+ (let ((block-name (gensym "TRY")))
+ `(block ,block-name
+ (catch 'dep-bad
+ (return-from ,block-name ,expr))
+ ,@body)))
+
+(defun dep-bad ()
+ "Call from a value-func: indicates that the dep should marked as bad."
+ (throw 'dep-bad nil))
+
+(defun delay-recomputing-deps* (thunk)
+ "The guts of the DELAY-RECOMPUTATING-DEPS macro. Evaluate THUNK without
+ immediately updating dependencies until THUNK finishes. Returns the
+ value(s) of THUNK."
+ (if *pending-deps*
+ (funcall thunk)
+ (let ((*pending-deps* (make-queue)))
+ (multiple-value-prog1
+ (funcall thunk)
+ (recompute-deps)))))
+
+(defmacro delay-recomputing-deps (&body body)
+ "Evaluate BODY, but delay recomputing any deps until the BODY completes
+ execution.
+
+ Note that deps can report incorrect values while delayed recomputation is
+ in effect. In the current implementation, the direct dependents of a leaf
+ dep whose value has changed will be correctly marked as pending (and
+ recomputed as necessary); higher-level dependents won't be noticed until
+ the direct dependents are recomputed.
+
+ This form is intended to be used for bulk update to leaves, for which
+ purpose it is fairly safe."
+ `(delay-recomputating-deps* #'(lambda () ,@body)))
+
+(defun install-dep-syntax (&optional (readtable *readtable*))
+ "Installs into the given READTABLE some syntactic shortcuts:
+
+ ?FORM -> (dep-value FORM)
+ Extract (or modify, for a leaf dep) the value of the dep indicated by
+ FORM.
+
+ #[FORM ...] -> (make-dep :funcion (lambda () FORM ...))
+ Return a derived dep whose value function computes the given FORMs
+ (as an implicit PROGN)
+
+ Returns the READTABLE."
+ (set-macro-character #\?
+ (lambda (stream char)
+ (declare (ignore char))
+ (list 'dep-value (read stream t nil t)))
+ readtable)
+ (set-syntax-from-char #\] #\) readtable readtable)
+ (set-dispatch-macro-character #\# #\[
+ (lambda (stream arg char)
+ (declare (ignore arg char))
+ `(make-dep :function
+ (lambda ()
+ ,@(read-delimited-list #\]
+ stream
+ t))))
+ readtable)
+ readtable)
+
+(defmethod print-object ((dep dep) stream)
+ (print-unreadable-object (dep stream :type t :identity t)
+ (cond ((not (eq (dep-state dep) :stable))
+ (format stream "~S" (dep-state dep)))
+ ((dep-goodp dep)
+ (format stream "~S ~W" :good (dep-%value dep)))
+ (t
+ (format stream "~S" :bad)))))
+
+#+ test
+(progn
+ (defparameter x (make-leaf-dep 1))
+ (defparameter y (make-leaf-dep 2))
+ (defparameter z (make-dep (lambda () (+ (dep-value x) (dep-value y)))))
+ (defparameter w (make-dep (lambda () (* (dep-value x) (dep-value z)))))
+ (dep-add-listener x (lambda () (format t "x now ~A~%" x)))
+ (dep-add-listener z (lambda () (format t "z now ~A~%" z)))
+ (dep-add-listener w (lambda () (format t "w now ~A~%" w))))
+
+;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; A simple queue
+;;;
+;;; (c) 2008 Mark Wooding
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(defpackage #:queue
+ (:use #:common-lisp)
+ (:export #:make-queue #:queue-emptyp #:enqueue #:dequeue))
+(in-package #:queue)
+
+(defun make-queue ()
+ "Make a new queue object."
+ ;; A queue is just a cons cell. The cdr is the head of the list of items
+ ;; in the queue, and the car points to the last entry in the list. If the
+ ;; queue is empty, then the car points to the queue itself for the sake of
+ ;; uniformity.
+ (let ((q (cons nil nil)))
+ (setf (car q) q)))
+
+(defun queue-emptyp (q)
+ "Answer whether the queue Q is empty."
+ (null (cdr q)))
+
+(defun enqueue (x q)
+ "Enqueue the object X into the queue Q."
+ (let ((c (cons x nil)))
+ (setf (cdr (car q)) c
+ (car q) c)))
+
+(defun dequeue (q)
+ "Remove and return the object at the head of the queue Q."
+ (if (queue-emptyp q)
+ (error "Queue is empty.")
+ (let ((c (cdr q)))
+ (prog1 (car c)
+ (unless (setf (cdr q) (cdr c))
+ (setf (car q) q))))))
+
+#+ test
+(defun queue-check (q)
+ "Check consistency of the queue Q."
+ (assert (car q))
+ (if(null (cdr q))
+ (assert (eq (car q) q))
+ (do ((tail (car q))
+ (collection nil (cons (car item) collection))
+ (item (cdr q) (cdr item)))
+ ((endp item) (nreverse collection))
+ (if (cdr item)
+ (assert (not (eq item tail)))
+ (assert (eq item tail))))))
+
+#+ test
+(defun test-queue ()
+ "Randomized test of the queue functions."
+ (let ((q (make-queue))
+ (want nil))
+ (dotimes (i 10000)
+ (case (random 2)
+ (0 (setf want (nconc want (list i)))
+ (enqueue i q))
+ (1 (if (null want)
+ (assert (queue-emptyp q))
+ (progn
+ (let ((j (dequeue q))
+ (k (pop want)))
+ (assert (= j k)))))))
+ (assert (equal want (queue-check q))))))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / lisp / commitdiff