From 2626af6648d844d428b3da1c12d1401e42405593 Mon Sep 17 00:00:00 2001
From: Mark Wooding <mdw@distorted.org.uk>
Date: Tue, 3 Jun 2008 12:27:51 +0100
Subject: [PATCH] queue, dep: Dependent-value management.

Queues are useful data structures in their own right and a Lisp
implementation is handy.

Deps were inspired by Ken Tilton's Cells, but lack the latter's CLOS
trappings and probably its hairier features.  In particular, cyclic
dependencies are not permitted.
---
 dep.lisp   | 312 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 mdw.asd    |   2 +
 queue.lisp |  88 +++++++++++++++++
 3 files changed, 402 insertions(+)
 create mode 100644 dep.lisp
 create mode 100644 queue.lisp

diff --git a/dep.lisp b/dep.lisp
new file mode 100644
index 0000000..5903743
--- /dev/null
+++ b/dep.lisp
@@ -0,0 +1,312 @@
+;;; -*-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 --------------------------------------------------
diff --git a/mdw.asd b/mdw.asd
index 165fa3f..0dc10a7 100644
--- a/mdw.asd
+++ b/mdw.asd
@@ -12,6 +12,8 @@
 	       (:file "anaphora")
 	       (:file "sys-base")
 	       (:file "factorial")
+	       (:file "queue")
+	       (:file "dep" :depends-on ("queue"))
 	       (:file "mdw-mop" :depends-on ("mdw-base"))
 	       (:file "str" :depends-on ("mdw-base"))
 	       (:file "collect" :depends-on ("mdw-base"))
diff --git a/queue.lisp b/queue.lisp
new file mode 100644
index 0000000..03de433
--- /dev/null
+++ b/queue.lisp
@@ -0,0 +1,88 @@
+;;; -*-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 --------------------------------------------------
-- 
2.11.0