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