From a2e7266a20fff562054c0f546e4a49c03b93ce20 Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Tue, 17 Jun 2008 00:43:40 +0100 Subject: [PATCH] Overhaul. The `lisp' collection has a newer, correct version of `dep'. Use that; and avoid duplication using Git submodules. Some interface changes have occurred since then. In particular, * INSTALL-DEP-SYNTAX has moved into the DEP package proper. * MAKE-LEAF-DEP has gone, replaced by an enhanced MAKE-DEP. --- .gitmodules | 3 + Makefile | 14 ++-- build.lisp | 2 +- dep-ui.lisp | 18 +---- dep.lisp | 214 +---------------------------------------------------------- lisp | 1 + queue.lisp | 89 +------------------------ rolling.lisp | 10 +-- run.lisp | 2 +- weak.lisp | 1 + 10 files changed, 22 insertions(+), 332 deletions(-) create mode 100644 .gitmodules mode change 100644 => 120000 dep.lisp create mode 160000 lisp mode change 100644 => 120000 queue.lisp create mode 120000 weak.lisp diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..d417c6a --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "lisp"] + path = lisp + url = git://metalzone.distorted.org.uk/~mdw/lisp/ diff --git a/Makefile b/Makefile index 2832b88..ec088c0 100644 --- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ JAR = jar GPL = /usr/share/common-licenses/GPL-2 INSTALLER = setup-dep-ui.exe -VERSION = 1.0.0 +VERSION = 1.1.0 all: dep-ui.jar @@ -56,18 +56,18 @@ DISTDIR = dep-ui-$(VERSION) distdir: rm -rf $(DISTDIR) mkdir $(DISTDIR) - ln \ - jj.lisp swing.lisp queue.lisp dep.lisp dep-ui.lisp \ - run.lisp Startup.java rolling.lisp \ - dep-ui.nsis \ - $(DISTDIR) + for i in jj.lisp swing.lisp queue.lisp dep.lisp dep-ui.lisp \ + run.lisp Startup.java rolling.lisp weak.lisp \ + dep-ui.nsis; do \ + ln -s ../$$i $(DISTDIR); \ + done zip: distdir zip -r $(DISTDIR).zip $(DISTDIR) rm -rf $(DISTDIR) tar: distdir - tar cvfz $(DISTDIR).tar.gz $(DISTDIR) + tar chvfz $(DISTDIR).tar.gz $(DISTDIR) rm -rf $(DISTDIR) ### \ No newline at end of file diff --git a/build.lisp b/build.lisp index 35aabe5..48c315e 100644 --- a/build.lisp +++ b/build.lisp @@ -1,7 +1,7 @@ ;;; -*-lisp-*- (let ((sys:*compile-file-zip* nil)) - (dolist (file '("jj" "swing" "queue" "dep" "dep-ui")) + (dolist (file '("jj" "swing" "weak" "queue" "dep" "dep-ui")) (compile-file file) (load file))) (exit) diff --git a/dep-ui.lisp b/dep-ui.lisp index f31bebc..d6e483c 100644 --- a/dep-ui.lisp +++ b/dep-ui.lisp @@ -25,7 +25,7 @@ (:use #:common-lisp #:jj #:swing #:java #:dep #:extensions) (:export #:make-label #:make-input #:make-output #:make-group #:make-radio-dep #:within-group #:defwindow #:make-window - #:install-dep-syntax #:add-reason #:drop-reason)) + #:add-reason #:drop-reason)) (in-package #:dep-ui) @@ -180,22 +180,6 @@ `(let ((*panel* (make-group ,label))) ,@body)) -(defun install-dep-syntax (&optional (readtable *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 (lambda () - ,@(read-delimited-list #\] - stream - t)))) - readtable)) - (let ((reasons 0)) (defun add-reason () (incf reasons)) diff --git a/dep.lisp b/dep.lisp deleted file mode 100644 index 07460b8..0000000 --- a/dep.lisp +++ /dev/null @@ -1,213 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/dep.lisp b/dep.lisp new file mode 120000 index 0000000..961d986 --- /dev/null +++ b/dep.lisp @@ -0,0 +1 @@ +lisp/dep.lisp \ No newline at end of file diff --git a/lisp b/lisp new file mode 160000 index 0000000..af33e77 --- /dev/null +++ b/lisp @@ -0,0 +1 @@ +Subproject commit af33e77c00654c222a8a04a5e69a5eb1f56c1e8c diff --git a/queue.lisp b/queue.lisp deleted file mode 100644 index 03de433..0000000 --- a/queue.lisp +++ /dev/null @@ -1,88 +0,0 @@ -;;; -*-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 -------------------------------------------------- diff --git a/queue.lisp b/queue.lisp new file mode 120000 index 0000000..b98c8cd --- /dev/null +++ b/queue.lisp @@ -0,0 +1 @@ +lisp/queue.lisp \ No newline at end of file diff --git a/rolling.lisp b/rolling.lisp index 18a67bd..61874c7 100644 --- a/rolling.lisp +++ b/rolling.lisp @@ -24,11 +24,11 @@ (install-dep-syntax) (defwindow rolling-window () ("Rolling") - (let* ((width (make-leaf-dep)) - (thick (make-leaf-dep)) - (length (make-leaf-dep)) - (stock-type (make-leaf-dep :round)) - (stock-size (make-leaf-dep)) + (let* ((width (make-dep)) + (thick (make-dep)) + (length (make-dep)) + (stock-type (make-dep :round)) + (stock-size (make-dep)) (volume #[(* ?width ?thick ?length)]) (stock-length #[(/ ?volume (case ?stock-type diff --git a/run.lisp b/run.lisp index 09f6b54..742b0d2 100644 --- a/run.lisp +++ b/run.lisp @@ -2,7 +2,7 @@ ;;; Driver for the system. -(dolist (file '("jj" "swing" "queue" "dep" "dep-ui")) +(dolist (file '("jj" "swing" "queue" "weak" "dep" "dep-ui")) (sys:load-system-file file)) (use-package '(#:dep #:dep-ui)) diff --git a/weak.lisp b/weak.lisp new file mode 120000 index 0000000..1ab5993 --- /dev/null +++ b/weak.lisp @@ -0,0 +1 @@ +lisp/weak.lisp \ No newline at end of file -- 2.11.0