+++ /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 #:make-leaf-dep #:dep-goodp
- #: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 (value-func)
- "Create a new DEP with the given VALUE-FUNC."
- (let ((dep (%make-dep :value-func value-func)))
- (let ((*pending-deps* (make-queue)))
- (enqueue dep *pending-deps*)
- (recompute-deps))
- dep))
-
-(defun make-leaf-dep (&optional (value nil goodp))
- "Creates a new DEP with the given VALUE, if any."
- (%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))
-
-#+ no
-(defmethod print-object ((dep dep) stream)
- (print-unreadable-object (dep stream :type t :identity t)
- (ensure-dep-has-value dep)
- (if (dep-goodp dep)
- (format stream ":GOOD ~W" (dep-%value dep))
- (format stream ":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 / jlisp / commitdiff