Initial revision.

[jlisp] / dep.lisp

;;; -*-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 --------------------------------------------------