From astalla at common-lisp.net Sun Jan 3 23:35:45 2010
From: astalla at common-lisp.net (Alessio Stalla)
Date: Sun, 03 Jan 2010 18:35:45 -0500
Subject: [snow-cvs] r41 - in trunk/examples: . swixml
Message-ID:
Author: astalla
Date: Sun Jan 3 18:35:44 2010
New Revision: 41
Log:
Added the examples directory with the helloworld SwiXml example.
Added:
trunk/examples/
trunk/examples/swixml/
trunk/examples/swixml/README.txt
trunk/examples/swixml/helloworld.lisp
Added: trunk/examples/swixml/README.txt
==============================================================================
--- (empty file)
+++ trunk/examples/swixml/README.txt Sun Jan 3 18:35:44 2010
@@ -0,0 +1,4 @@
+The examples in this directory are the Snow version of the SwiXml examples
+located at . When SwiXml supports
+some feature that Snow does not, the SwiXml code is kept in a comment near
+its translation into Snow.
Added: trunk/examples/swixml/helloworld.lisp
==============================================================================
--- (empty file)
+++ trunk/examples/swixml/helloworld.lisp Sun Jan 3 18:35:44 2010
@@ -0,0 +1,49 @@
+(in-package :snow-user)
+(in-readtable snow:syntax)
+
+(let ((clicks (make-var 0)) tf)
+ (flet ((submit (event)
+ (declare (ignore event))
+ (setf (widget-text tf) (str (widget-text tf) "#"))
+ (incf (var clicks))))
+ (with-gui ()
+ (frame (:size #C(640 280) :title "Hello Snow World" :on-close :exit)
+ (panel (:layout "grow, wrap")
+ (label :text "Hello World!" :font (font "Georgia" 12 :bold)
+ :foreground :blue) ;;labelfor="tf"
+ (child (setf tf (text-field :text "Snow")));;columns="20" TODO :var tf
+ (button :text "Click Here" :on-action #'submit))
+ (panel (:layout "dock south")
+ (label :text "Clicks:" :font (font "Georgia" 36 :bold))
+ (label :font (font "Georgia" 36 :bold) :text $(c? (str (var clicks)))))))))
+
+#||
+The original example used the SwiXml idiom of coding a Java class to handle
+the events; an instance of this class gets injected the components with an
+ID into its JavaBean properties.
+The Snow version does not rely on a Java class; instead it handles events in
+Lisp and uses data binding to update the GUI. It is of course possible to
+handle the events in Java, but Snow does not currently support automatic
+injection of widgets into the properties of a Java object.
+||#
+
+#|| Original example:
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+||#
From astalla at common-lisp.net Wed Jan 6 22:46:01 2010
From: astalla at common-lisp.net (Alessio Stalla)
Date: Wed, 06 Jan 2010 17:46:01 -0500
Subject: [snow-cvs] r42 - in trunk: examples/swixml lib src/java/snow
src/lisp/snow src/lisp/snow/swing
Message-ID:
Author: astalla
Date: Wed Jan 6 17:46:01 2010
New Revision: 42
Log:
:id is now applicable to all widgets and has the added meaning that, if names a bound lexical variable, it is assigned the widget.
Removed snow-cells read conditionals.
Updated abcl (eliminated redefinition warnings).
Modified:
trunk/examples/swixml/helloworld.lisp
trunk/lib/abcl.jar
trunk/src/java/snow/Snow.java
trunk/src/lisp/snow/data-binding.lisp
trunk/src/lisp/snow/packages.lisp
trunk/src/lisp/snow/snow.asd
trunk/src/lisp/snow/snow.lisp
trunk/src/lisp/snow/start.lisp
trunk/src/lisp/snow/swing/swing.lisp
Modified: trunk/examples/swixml/helloworld.lisp
==============================================================================
--- trunk/examples/swixml/helloworld.lisp (original)
+++ trunk/examples/swixml/helloworld.lisp Wed Jan 6 17:46:01 2010
@@ -11,11 +11,12 @@
(panel (:layout "grow, wrap")
(label :text "Hello World!" :font (font "Georgia" 12 :bold)
:foreground :blue) ;;labelfor="tf"
- (child (setf tf (text-field :text "Snow")));;columns="20" TODO :var tf
+ (text-field :id tf :text "Snow");;columns="20" TODO :var tf
(button :text "Click Here" :on-action #'submit))
(panel (:layout "dock south")
(label :text "Clicks:" :font (font "Georgia" 36 :bold))
- (label :font (font "Georgia" 36 :bold) :text $(c? (str (var clicks)))))))))
+ (label :font (font "Georgia" 36 :bold) :text $(c? (str (var clicks)))))
+ (show self)))))
#||
The original example used the SwiXml idiom of coding a Java class to handle
Modified: trunk/lib/abcl.jar
==============================================================================
Binary files. No diff available.
Modified: trunk/src/java/snow/Snow.java
==============================================================================
--- trunk/src/java/snow/Snow.java (original)
+++ trunk/src/java/snow/Snow.java Wed Jan 6 17:46:01 2010
@@ -189,11 +189,7 @@
public static synchronized ScriptEngine init() throws ScriptException {
if(!init) {
initAux();
- lispEngine.eval("(pushnew :snow-cells *features*)");
lispEngine.eval("(asdf:oos 'asdf:load-op :snow)");
-
- //lispEngine.eval("(snow:install-graphical-debugger) (ohmygod)");
- //lispEngine.eval("(snow::inspect-object (snow::new \"javax.swing.JButton\"))");
init = true;
return lispEngine;
} else {
Modified: trunk/src/lisp/snow/data-binding.lisp
==============================================================================
--- trunk/src/lisp/snow/data-binding.lisp (original)
+++ trunk/src/lisp/snow/data-binding.lisp Wed Jan 6 17:46:01 2010
@@ -182,7 +182,6 @@
(setf (gethash 'simple ht) 'make-simple-data-binding)
(setf (gethash 'var ht) 'make-simple-data-binding)
(setf (gethash 'bean ht) 'make-bean-data-binding)
- #+snow-cells
(progn
(setf (gethash 'cell ht) 'make-cell-data-binding)
(setf (gethash 'slot ht) 'make-slot-data-binding))
@@ -221,7 +220,7 @@
,*package*)) ;;Packages are externalizable: http://www.lispworks.com/documentation/HyperSpec/Body/03_bdbb.htm
(#\(
(let ((list (read stream)))
- (if #+snow-cells (eq (car list) 'cells:c?) #-snow-cells nil
+ (if (eq (car list) 'cells:c?)
`(make-data-binding 'cell ,list)
`(make-data-binding ',(car list) ,@(cdr list)))))
(t `(make-simple-data-binding ,(read stream)))))))
Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp (original)
+++ trunk/src/lisp/snow/packages.lisp Wed Jan 6 17:46:01 2010
@@ -30,8 +30,8 @@
(defpackage :snow
- (:use :common-lisp :java :cl-utilities :named-readtables #+snow-cells :cells)
- (:shadow #+snow-cells #:dbg)
+ (:use :common-lisp :java :cl-utilities :named-readtables :cells)
+ (:shadow #:dbg #:self)
(:export
;;Widgets
#:button
@@ -88,10 +88,6 @@
#:slot
#:var
#:simple-data-binding
- #+snow-cells
- #:c-expr
- #+snow-cells
- #:c-value
;;Various
#:call-in-gui-thread
#:color
@@ -115,5 +111,6 @@
#:new))
(defpackage :snow-user
- (:use :common-lisp :snow :java :ext :named-readtables #+snow-cells :cells)
- (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*))
\ No newline at end of file
+ (:use :common-lisp :snow :java :ext :named-readtables :cells)
+ (:shadowing-import-from :snow
+ #:make-dialog-prompt-stream #:*gui-backend* #:self))
\ No newline at end of file
Modified: trunk/src/lisp/snow/snow.asd
==============================================================================
--- trunk/src/lisp/snow/snow.asd (original)
+++ trunk/src/lisp/snow/snow.asd Wed Jan 6 17:46:01 2010
@@ -32,7 +32,7 @@
(asdf:defsystem :snow
:serial t
:version "0.2"
- :depends-on (:cl-utilities :named-readtables #+snow-cells :cells)
+ :depends-on (:cl-utilities :named-readtables :cells)
:components ((:file "packages")
(:file "sexy-java")
(:file "utils")
@@ -41,7 +41,6 @@
(:file "widgets")
(:file "repl")
(:file "data-binding")
- #+snow-cells
(:file "cells")
(:file "backend")
(:file "debugger")
Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp (original)
+++ trunk/src/lisp/snow/snow.lisp Wed Jan 6 17:46:01 2010
@@ -188,7 +188,7 @@
(apply #'make-layout-manager self
(ensure-list (or layout-manager :default)))))
-(defun generate-default-children-processing-code (id children)
+(defun generate-default-children-processing-code (id children &optional env)
"Can be used inside a macro defining a container widget to generate the code to process its body, adding children to it."
(let ((code
(loop
@@ -198,18 +198,18 @@
((get (car form) 'widget-p) form)
(t `(let ((*parent* nil)) ,form)))
form))))
- `((let (,@(when id `((,id self))) (*parent* self))
+ `((let ((*parent* self))
, at code))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun common-widget-args ()
- '(layout binding (enabled-p t) (visible-p t) location size border font
+ '(id layout binding (enabled-p t) (visible-p t) location size border font
background foreground
on-mouse-click on-mouse-press on-mouse-release
on-mouse-enter on-mouse-exit
on-mouse-drag on-mouse-move))
(defun common-container-widget-args ()
- '(id (layout-manager :default)))
+ '((layout-manager :default)))
(defun common-widget-args-declarations ()
(let ((arg-names (mapcar (lambda (x) (if (atom x) x (car x)))
(common-widget-args))))
@@ -221,7 +221,9 @@
:for value :in (cdr args) by #'cddr
:when (not (member key filtered-keys))
:collect key :and
- :collect value)))
+ :collect value))
+ (defun filter-unevaluated-widget-args (args)
+ (filter-arglist args '(:id))))
(definterface setup-mouse-listeners *gui-backend*
(widget on-mouse-click on-mouse-press on-mouse-release
@@ -275,25 +277,36 @@
#+emacs (put 'define-container-widget 'lisp-indent-function 3)
(defmacro define-widget-macro (name arglist constructor &body body)
- `(progn
- (defmacro ,name ,(splice-into (common-widget-args) '&common-widget-args
- arglist)
- `(let ((self ,,constructor)) ;The lexical variable self is always bound to the current widget.
- ,, at body
- self))
- (setf (get ',name 'widget-p) t)))
+ (with-unique-names (env)
+ `(progn
+ (defmacro ,name ,(append (splice-into (common-widget-args)
+ '&common-widget-args
+ arglist)
+ `(&environment ,env))
+ `(let ((self ,,constructor))
+ ;;The lexical variable self is always bound to the current widget.
+ ,(if id ;;id is one of the common args
+ (if (sys:variable-information id ,env) ;;id is lexically bound
+ `(progn
+ (setf ,id self)
+ ,, at body)
+ `(let ((,id self))
+ ,, at body))
+ `(progn ,, at body))
+ self))
+ (setf (get ',name 'widget-p) t))))
(define-widget-macro with-widget
- ((widget &rest args &key id &common-widget-args) &body body)
+ ((widget &rest args &key &common-widget-args) &body body)
`(dont-add ,widget)
`(progn
,@(generate-default-children-processing-code id body)
- (setup-widget self ,@(filter-arglist args '(:id)))))
+ (setup-widget self ,@(filter-unevaluated-widget-args args))))
(define-widget-macro child
(widget &rest args &key &common-widget-args)
`(dont-add ,widget)
- `(setup-widget self , at args))
+ `(setup-widget self ,@(filter-unevaluated-widget-args args)))
(defmacro define-widget (name keys constructor &body body)
"Convenience macro for defining a widget."
@@ -304,7 +317,7 @@
(let ((self (apply (function ,',constructor) args)))
(apply #'setup-widget self args)
self))
- ,@,args)
+ ,@(filter-unevaluated-widget-args ,args))
`(progn
,, at body))))
@@ -320,7 +333,7 @@
(apply #'setup-container-widget self args)
self))
;;remove id because it must not be evaluated
- ,@(filter-arglist ,args '(:id)))
+ ,@(filter-unevaluated-widget-args ,args))
`(progn
,(progn , at body) ;Bug in ABCL? ,, at body fails when body is NIL: Wrong number of arguments for CONS - it generates (cons (append (generate...) (apply...)))
,@(generate-default-children-processing-code id ,macro-body)))))
Modified: trunk/src/lisp/snow/start.lisp
==============================================================================
--- trunk/src/lisp/snow/start.lisp (original)
+++ trunk/src/lisp/snow/start.lisp Wed Jan 6 17:46:01 2010
@@ -76,4 +76,5 @@
(snow-about))))))
(scroll (:layout "grow")
(gui-repl :dispose-on-close frame
- :environment `((*package* ,(find-package :snow-user)))))))
+ :environment `((*package* ,(find-package :snow-user))
+ (*readtable* ,(find-readtable 'snow:syntax)))))))
Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp (original)
+++ trunk/src/lisp/snow/swing/swing.lisp Wed Jan 6 17:46:01 2010
@@ -29,8 +29,9 @@
;;; exception statement from your version.
(defpackage :snow-swing
- (:use :common-lisp :snow :java :ext :named-readtables #+snow-cells :cells)
- (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*))
+ (:use :common-lisp :snow :java :ext :named-readtables :cells)
+ (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*
+ #:self))
(in-package :snow-swing)
From astalla at common-lisp.net Mon Jan 11 21:38:18 2010
From: astalla at common-lisp.net (Alessio Stalla)
Date: Mon, 11 Jan 2010 16:38:18 -0500
Subject: [snow-cvs] r43 - in trunk: lib src/java/snow src/java/snow/swing
src/lisp/snow/showcase
Message-ID:
Author: astalla
Date: Mon Jan 11 16:38:17 2010
New Revision: 43
Log:
Updated to latest ABCL (pre-0.18) which changes its streams implementation and some API.
Fixed the showcase which was broken due to ambiguous import of the symbol SELF (exported by both Snow and Cells).
Modified:
trunk/lib/abcl.jar
trunk/src/java/snow/DialogPromptStream.java
trunk/src/java/snow/swing/ConsoleDocument.java
trunk/src/lisp/snow/showcase/showcase.lisp
Modified: trunk/lib/abcl.jar
==============================================================================
Binary files. No diff available.
Modified: trunk/src/java/snow/DialogPromptStream.java
==============================================================================
--- trunk/src/java/snow/DialogPromptStream.java (original)
+++ trunk/src/java/snow/DialogPromptStream.java Mon Jan 11 16:38:17 2010
@@ -5,7 +5,7 @@
import java.io.StringReader;
import java.io.StringWriter;
-import org.armedbear.lisp.Stream;
+import org.armedbear.lisp.*;
/**
* A bidirectional stream that captures input from a modal dialog. The dialog reports a label (prompt line)
@@ -18,16 +18,17 @@
*/
public abstract class DialogPromptStream extends Stream {
- private StringWriter writtenSoFar = new StringWriter();
- private Reader reader = new Reader() {
-
- private StringReader stringReader = null;
- private int inputSize = 0;
-
- @Override
- public void close() throws IOException {
- closeDialog();
- }
+ private StringWriter writtenSoFar = new StringWriter();
+ private Reader reader = new Reader() {
+
+ private StringReader stringReader = null;
+ private int inputSize = 0;
+
+
+ @Override
+ public void close() throws IOException {
+ closeDialog();
+ }
@Override
public int read(char[] cbuf, int off, int len) throws IOException {
@@ -52,13 +53,14 @@
};
- /**
- * Inits this stream. Should be called by subclasses' constructors.
- */
- protected DialogPromptStream() {
- initAsCharacterOutputStream(writtenSoFar);
- initAsCharacterInputStream(reader);
- }
+ /**
+ * Inits this stream. Should be called by subclasses' constructors.
+ */
+ protected DialogPromptStream() {
+ super(Symbol.SYSTEM_STREAM);
+ initAsCharacterOutputStream(writtenSoFar);
+ initAsCharacterInputStream(reader);
+ }
/**
* Closes the dialog when this stream is closed, aborting the read operation.
Modified: trunk/src/java/snow/swing/ConsoleDocument.java
==============================================================================
--- trunk/src/java/snow/swing/ConsoleDocument.java (original)
+++ trunk/src/java/snow/swing/ConsoleDocument.java Mon Jan 11 16:38:17 2010
@@ -52,14 +52,7 @@
import javax.swing.text.DefaultStyledDocument;
import javax.swing.text.JTextComponent;
-import org.armedbear.lisp.Function;
-import org.armedbear.lisp.Interpreter;
-import org.armedbear.lisp.LispObject;
-import org.armedbear.lisp.LispThread;
-import org.armedbear.lisp.SpecialBindingsMark;
-import org.armedbear.lisp.Stream;
-import org.armedbear.lisp.Symbol;
-import org.armedbear.lisp.TwoWayStream;
+import org.armedbear.lisp.*;
import static org.armedbear.lisp.Lisp.*;
@@ -124,8 +117,8 @@
private final Thread replThread;
public ConsoleDocument(LispObject replFunction) {
- final LispObject replWrapper = makeReplWrapper(new StreamEx(new BufferedReader(reader)),
- new StreamEx(new BufferedWriter(writer)),
+ final LispObject replWrapper = makeReplWrapper(new Stream(Symbol.SYSTEM_STREAM, new BufferedReader(reader)),
+ new Stream(Symbol.SYSTEM_STREAM, new BufferedWriter(writer)),
replFunction);
replThread = new Thread("REPL-thread-" + System.identityHashCode(this)) {
public void run() {
@@ -202,18 +195,6 @@
return writer;
}
- public static class StreamEx extends Stream {
-
- public StreamEx(Reader r) {
- initAsCharacterInputStream(r);
- }
-
- public StreamEx(Writer w) {
- initAsCharacterOutputStream(w);
- }
-
- }
-
public void setupTextComponent(final JTextComponent txt) {
addDocumentListener(new DocumentListener() {
Modified: trunk/src/lisp/snow/showcase/showcase.lisp
==============================================================================
--- trunk/src/lisp/snow/showcase/showcase.lisp (original)
+++ trunk/src/lisp/snow/showcase/showcase.lisp Mon Jan 11 16:38:17 2010
@@ -1,6 +1,7 @@
(defpackage :snow-showcase
(:use :common-lisp :snow :java :ext :named-readtables :cells)
- (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*))
+ (:shadowing-import-from :snow #:make-dialog-prompt-stream #:*gui-backend*
+ #:self))
(in-package :snow-showcase)
(in-readtable snow:syntax)
@@ -45,7 +46,7 @@
(defmodel my-model ()
((a :accessor aaa :initform (c-in "4"))
- (b :accessor bbb :initform (c? (concatenate 'string (aaa self) "2")))))
+ (b :accessor bbb :initform (c? (concatenate 'string (aaa cells:self) "2")))))
(defvar *bean* (new "snow.showcase.SnowExample"))
(defvar *variable* (make-var "42"))
From astalla at common-lisp.net Mon Jan 18 20:17:16 2010
From: astalla at common-lisp.net (Alessio Stalla)
Date: Mon, 18 Jan 2010 15:17:16 -0500
Subject: [snow-cvs] r44 - in trunk: examples/swixml src/java/snow
src/lisp/snow src/lisp/snow/swing
Message-ID:
Author: astalla
Date: Mon Jan 18 15:17:16 2010
New Revision: 44
Log:
Cleverer resource loading/compilation/evaluation which should make it easier to pass Java objects to Snow "scripts".
Theoretical (untested) support for "backing beans" i.e. widgets injected in jproperties, event listeners can be strings naming methods
Added:
trunk/src/java/snow/AbstractSnowlet.java
trunk/src/java/snow/Snowlet.java
Modified:
trunk/examples/swixml/helloworld.lisp
trunk/src/java/snow/Snow.java
trunk/src/lisp/snow/data-binding.lisp
trunk/src/lisp/snow/packages.lisp
trunk/src/lisp/snow/snow.lisp
trunk/src/lisp/snow/swing/swing.lisp
Modified: trunk/examples/swixml/helloworld.lisp
==============================================================================
--- trunk/examples/swixml/helloworld.lisp (original)
+++ trunk/examples/swixml/helloworld.lisp Mon Jan 18 15:17:16 2010
@@ -11,7 +11,7 @@
(panel (:layout "grow, wrap")
(label :text "Hello World!" :font (font "Georgia" 12 :bold)
:foreground :blue) ;;labelfor="tf"
- (text-field :id tf :text "Snow");;columns="20" TODO :var tf
+ (text-field :id tf :text "Snow");;columns="20"
(button :text "Click Here" :on-action #'submit))
(panel (:layout "dock south")
(label :text "Clicks:" :font (font "Georgia" 36 :bold))
Added: trunk/src/java/snow/AbstractSnowlet.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/AbstractSnowlet.java Mon Jan 18 15:17:16 2010
@@ -0,0 +1,71 @@
+/*
+ * AbstractSnowlet.java
+ *
+ * Copyright (C) 2010 Alessio Stalla
+ *
+ * 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.
+ *
+ * As a special exception, the copyright holders of this library give you
+ * permission to link this library with independent modules to produce an
+ * executable, regardless of the license terms of these independent
+ * modules, and to copy and distribute the resulting executable under
+ * terms of your choice, provided that you also meet, for each linked
+ * independent module, the terms and conditions of the license of that
+ * module. An independent module is a module which is not derived from
+ * or based on this library. If you modify this library, you may extend
+ * this exception to your version of the library, but you are not
+ * obligated to do so. If you do not wish to do so, delete this
+ * exception statement from your version.
+ */
+
+package snow;
+
+import javax.script.Bindings;
+import com.jgoodies.binding.PresentationModel;
+
+public abstract class AbstractSnowlet implements Snowlet {
+
+ private PresentationModel presentationModel;
+ private Object backingBean;
+
+ public Object eval() {
+ Bindings b = Snow.getScriptEngine().createBindings();
+ b.put("snow:*backing-bean*", backingBean);
+ b.put("snow:*presentation-model*", presentationModel);
+ try {
+ return eval(b);
+ } catch(Exception e) {
+ throw new RuntimeException("Exception while evaluating snowlet " + this, e);
+ }
+ }
+
+ protected abstract Object eval(Bindings bindings) throws Exception;
+
+ public PresentationModel getPresentationModel() {
+ return presentationModel;
+ }
+
+ public void setPresentationModel(PresentationModel presentationModel) {
+ this.presentationModel = presentationModel;
+ }
+
+ public Object getBackingBean() {
+ return backingBean;
+ }
+
+ public void setBackingBean(Object backingBean) {
+ this.backingBean = backingBean;
+ }
+}
\ No newline at end of file
Modified: trunk/src/java/snow/Snow.java
==============================================================================
--- trunk/src/java/snow/Snow.java (original)
+++ trunk/src/java/snow/Snow.java Mon Jan 18 15:17:16 2010
@@ -32,27 +32,20 @@
package snow;
-import java.io.File;
-import java.io.FileOutputStream;
-import java.io.IOException;
-import java.io.InputStreamReader;
-import java.io.Reader;
import java.net.URI;
import java.net.URISyntaxException;
import java.net.URL;
import java.util.zip.ZipEntry;
import java.util.zip.ZipInputStream;
-import javax.script.Compilable;
-import javax.script.Invocable;
-import javax.script.ScriptEngine;
-import javax.script.ScriptEngineManager;
-import javax.script.ScriptException;
+import javax.script.*;
import java.security.*;
import org.armedbear.lisp.Interpreter;
+import com.jgoodies.binding.PresentationModel;
+
import java.io.*;
public abstract class Snow {
@@ -197,16 +190,21 @@
}
}
- public static synchronized ScriptEngine initIfNecessary() throws ScriptException {
+ public static synchronized ScriptEngine initIfNecessary() {
if(!init) {
- init();
+ try {
+ init();
+ } catch(ScriptException e) {
+ throw new RuntimeException("Snow initialization failed", e);
+ }
}
return lispEngine;
}
-
+
/**
* Compiles and loads a Lisp file from the classpath, relative to aClass.
*/
+ @Deprecated
public static Object evalResource(Class> aClass, String resourcePath) throws ScriptException {
return evalResource(aClass, resourcePath, true);
}
@@ -214,23 +212,28 @@
/**
* Loads a Lisp file from the classpath, relative to aClass. If compileItFirst is true, the file is compiled before being loaded.
*/
+ @Deprecated
public static Object evalResource(Class> aClass, String resourcePath, boolean compileItFirst) throws ScriptException {
Reader r = new InputStreamReader(aClass.getResourceAsStream(resourcePath));
return evalResource(r, compileItFirst);
}
+ @Deprecated
public static Object evalResource(String resourcePath) throws ScriptException {
return evalResource(Snow.class, resourcePath, true);
}
+ @Deprecated
public static Object evalResource(String resourcePath, boolean compileItFirst) throws ScriptException {
return evalResource(Snow.class, resourcePath, compileItFirst);
}
+ @Deprecated
public static Object evalResource(Reader reader) throws ScriptException {
return evalResource(reader, true);
}
+ @Deprecated
public static Object evalResource(Reader reader, boolean compileItFirst) throws ScriptException {
initIfNecessary();
if(compileItFirst) {
@@ -239,6 +242,57 @@
return lispEngine.eval(reader);
}
}
+
+ /**
+ * Returns a Snowlet running interpreted code read from the provided Reader.
+ * This Snowlet's eval() method may only be called once.
+ */
+ public static Snowlet getInterpretedSnowlet(final Reader reader) {
+ initIfNecessary();
+ return new AbstractSnowlet() {
+ private boolean eval = false;
+ public Object eval(Bindings bindings) throws Exception {
+ if(!eval) {
+ eval = true;
+ } else {
+ throw new IllegalStateException("Already evaluated");
+ }
+ return lispEngine.eval(reader, bindings);
+ }
+ };
+ }
+
+ public static Snowlet getInterpretedSnowlet(final URL url) {
+ initIfNecessary();
+ return new AbstractSnowlet() {
+ public Object eval(Bindings bindings) throws Exception {
+ return lispEngine.eval(new InputStreamReader(url.openStream()), bindings);
+ }
+ };
+ }
+
+ public static Snowlet getCompiledSnowlet(final Reader reader) {
+ initIfNecessary();
+ final CompiledScript c;
+ try {
+ c = getCompilable().compile(reader);
+ } catch(ScriptException e) {
+ throw new RuntimeException("Compilation error", e);
+ }
+ return new AbstractSnowlet() {
+ public Object eval(Bindings bindings) throws Exception {
+ return c.eval(bindings);
+ }
+ };
+ }
+
+ public static Snowlet getCompiledSnowlet(final URL url) {
+ try {
+ return getCompiledSnowlet(new InputStreamReader(url.openStream()));
+ } catch(IOException e) {
+ throw new RuntimeException("Couldn't open stream for URL: " + url, e);
+ }
+ }
public static ScriptEngine getScriptEngine() {
return lispEngine;
@@ -254,19 +308,19 @@
public static void main(final String[] args) {
try {
+ //Needed for Java WebStart
+ Policy.setPolicy
+ (new Policy() {
+ public PermissionCollection getPermissions(CodeSource codesource) {
+ Permissions perms = new Permissions();
+ perms.add(new AllPermission());
+ return (perms);
+ }
+ });
if(args.length == 0) { //Launch GUI REPL
- evalResource(Snow.class, "/snow/start.lisp", false);
+ getCompiledSnowlet(Snow.class.getResource("/snow/start.lisp")).eval();
} else if("--showcase".equals(args[0])) {
- //Needed for Java WebStart
- Policy.setPolicy
- (new Policy() {
- public PermissionCollection getPermissions(CodeSource codesource) {
- Permissions perms = new Permissions();
- perms.add(new AllPermission());
- return (perms);
- }
- });
- evalResource(Snow.class, "/snow/showcase/showcase.lisp", false);
+ getInterpretedSnowlet(Snow.class.getResource("/snow/showcase/showcase.lisp")).eval();
getInvocable().invokeFunction("snow-showcase::showcase", true);
} else {//Launch regular ABCL
//Copied from org.armedbear.lisp.Main.main()
Added: trunk/src/java/snow/Snowlet.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/Snowlet.java Mon Jan 18 15:17:16 2010
@@ -0,0 +1,53 @@
+/*
+ * Snowlet.java
+ *
+ * Copyright (C) 2010 Alessio Stalla
+ *
+ * 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.
+ *
+ * As a special exception, the copyright holders of this library give you
+ * permission to link this library with independent modules to produce an
+ * executable, regardless of the license terms of these independent
+ * modules, and to copy and distribute the resulting executable under
+ * terms of your choice, provided that you also meet, for each linked
+ * independent module, the terms and conditions of the license of that
+ * module. An independent module is a module which is not derived from
+ * or based on this library. If you modify this library, you may extend
+ * this exception to your version of the library, but you are not
+ * obligated to do so. If you do not wish to do so, delete this
+ * exception statement from your version.
+ */
+
+package snow;
+
+import com.jgoodies.binding.PresentationModel;
+
+public interface Snowlet {
+
+ /**
+ * Runs the snowlet.
+ * @return whatever the snowlet code returns.
+ */
+ public Object eval();
+
+ public PresentationModel getPresentationModel();
+
+ public void setPresentationModel(PresentationModel presentationModel);
+
+ public Object getBackingBean();
+
+ public void setBackingBean(Object backingBean);
+
+}
\ No newline at end of file
Modified: trunk/src/lisp/snow/data-binding.lisp
==============================================================================
--- trunk/src/lisp/snow/data-binding.lisp (original)
+++ trunk/src/lisp/snow/data-binding.lisp Mon Jan 18 15:17:16 2010
@@ -1,4 +1,4 @@
-;;; binding-jgoodies.lisp
+;;; data-binding.lisp
;;;
;;; Copyright (C) 2008-2009 Alessio Stalla
;;;
@@ -117,9 +117,11 @@
"triggerCommit")
presentation-model))
-(defmacro form ((bean) &body body)
- `(let ((*presentation-model*
- (new "com.jgoodies.binding.PresentationModel" ,bean)))
+(defun make-default-presentation-model (bean)
+ (new "com.jgoodies.binding.PresentationModel" bean))
+
+(defmacro with-presentation-model (pm &body body)
+ `(let ((*presentation-model* ,pm))
, at body))
(defclass bean-data-binding (data-binding)
Modified: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- trunk/src/lisp/snow/packages.lisp (original)
+++ trunk/src/lisp/snow/packages.lisp Mon Jan 18 15:17:16 2010
@@ -84,13 +84,17 @@
#:make-simple-data-binding
#:make-slot-data-binding
#:bean
- #:cell
+ #:cell
#:slot
#:var
+ #:*presentation-model*
#:simple-data-binding
+ #:with-presentation-model
;;Various
+ #:*backing-bean*
#:call-in-gui-thread
#:color
+ #:&common-widget-args
#:defimplementation
#:definterface
#:font
Modified: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- trunk/src/lisp/snow/snow.lisp (original)
+++ trunk/src/lisp/snow/snow.lisp Mon Jan 18 15:17:16 2010
@@ -89,12 +89,12 @@
`(if *dynamic-environment*
(with-dynamic-environment (*dynamic-environment*)
, at body)
- (let* ((,gui-backend-var *gui-backend*)
- (,package-var *package*)
- (,terminal-io-var *terminal-io*)
- (,standard-input-var *standard-input*)
- (,standard-output-var *standard-output*)
- (,error-output-var *error-output*)) ;;Etc...
+ (let ((,gui-backend-var *gui-backend*)
+ (,package-var *package*)
+ (,terminal-io-var *terminal-io*)
+ (,standard-input-var *standard-input*)
+ (,standard-output-var *standard-output*)
+ (,error-output-var *error-output*)) ;;Etc...
(dynamic-wind
(let ((*gui-backend* ,gui-backend-var)
(*package* ,package-var)
@@ -276,7 +276,17 @@
#+emacs (put 'define-widget 'lisp-indent-function 3)
#+emacs (put 'define-container-widget 'lisp-indent-function 3)
+(defvar *backing-bean* nil)
+
+(defun maybe-inject-widget (widget property-name)
+ (when *backing-bean*
+ ;;sub-optimal: should ignore property not found, but propagate other errors
+ (ignore-errors (setf (jproperty-value *backing-bean* property-name)
+ widget))))
+
(defmacro define-widget-macro (name arglist constructor &body body)
+ "Defines a macro that expands to code constructing and initializing a widget, and setting up the environment expected by Snow. must contain exactly one occurrence of the symbol snow:&common-widget-args, which define-widget-macro will replace with the common part of the argument list of every widget macro."
+ ;;Todo check that arglist contains exactly one &common-widget-args
(with-unique-names (env)
`(progn
(defmacro ,name ,(append (splice-into (common-widget-args)
@@ -289,8 +299,10 @@
(if (sys:variable-information id ,env) ;;id is lexically bound
`(progn
(setf ,id self)
+ (maybe-inject-widget self ,(dashed->camelcased id))
,, at body)
`(let ((,id self))
+ (maybe-inject-widget self ,(dashed->camelcased id))
,, at body))
`(progn ,, at body))
self))
@@ -345,22 +357,3 @@
(defmacro dont-add (&body body)
`(let ((*parent* nil))
, at body))
-
-#|| (with-unique-names (gui-backend-var package-var
- dynamic-environment terminal-io-var)
- `(let* ((,gui-backend-var ,gui-backend)
- (*gui-backend* ,gui-backend-var)
- (,package-var *package*)
- (,terminal-io-var *terminal-io*)) ;;Etc...
- (dynamic-wind
- (let ((*gui-backend* ,gui-backend-var)
- (*package* ,package-var)
- (*debugger-hook* *graphical-debugger-hook*)
- (*terminal-io* ,terminal-io-var))
- (proceed
- (let ((,dynamic-environment (capture-dynamic-environment)))
- (call-in-gui-thread
- (lambda ()
- (with-dynamic-environment (,dynamic-environment)
- (let ((*dynamic-environment* ,dynamic-environment))
- , at body)))))))))))||#
\ No newline at end of file
Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp (original)
+++ trunk/src/lisp/snow/swing/swing.lisp Mon Jan 18 15:17:16 2010
@@ -40,18 +40,23 @@
, at body))
(defun make-action-listener (obj)
- (if (or (functionp obj) (symbolp obj))
- (jmake-proxy "java.awt.event.ActionListener"
- (snow::lambda/dynamic-environment (this method-name event)
- (funcall obj event)))
-; (let ((env (or snow::*dynamic-environment*
-; (snow::capture-dynamic-environment))))
-; (lambda (this method-name event)
-; (declare (ignore this method-name))
-; (snow::with-dynamic-environment (env)
-; (let ((snow::*dynamic-environment* env))
-; (funcall obj event))))))
- obj)) ;This allows to use a native Java action listener
+ (cond
+ ((or (functionp obj) (symbolp obj))
+ (jmake-proxy "java.awt.event.ActionListener"
+ (snow::lambda/dynamic-environment (this method-name event)
+ (funcall obj event))))
+ ((stringp obj)
+ (unless *backing-bean*
+ (error "No backing bean specified while action listener is a method name: ~A~%" obj))
+ (make-action-listener (jmethod (jclass-of *backing-bean*) obj
+ (jclass "java.awt.ActionEvent"))))
+ ((jinstance-of-p obj (jclass "java.lang.reflect.Method"))
+ (unless *backing-bean*
+ (error "No backing bean specified while action listener is a jmethod: ~A~%" obj))
+ (make-action-listener
+ (let ((bb *backing-bean*))
+ #'(lambda (evt) (jcall obj bb evt)))))
+ (t obj))) ;This allows to use a native Java action listener
(defimpl make-layout-manager (widget layout &rest args)
(if (typep layout 'java-object)
From astalla at common-lisp.net Mon Jan 18 21:51:07 2010
From: astalla at common-lisp.net (Alessio Stalla)
Date: Mon, 18 Jan 2010 16:51:07 -0500
Subject: [snow-cvs] r45 - in trunk: src/lisp/snow/swing test/src/snow
Message-ID:
Author: astalla
Date: Mon Jan 18 16:51:06 2010
New Revision: 45
Log:
Fixed action listener creation with backing bean
Minimal test for backing bean support
Modified:
trunk/src/lisp/snow/swing/swing.lisp
trunk/test/src/snow/BindingTest.java
Modified: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- trunk/src/lisp/snow/swing/swing.lisp (original)
+++ trunk/src/lisp/snow/swing/swing.lisp Mon Jan 18 16:51:06 2010
@@ -49,7 +49,7 @@
(unless *backing-bean*
(error "No backing bean specified while action listener is a method name: ~A~%" obj))
(make-action-listener (jmethod (jclass-of *backing-bean*) obj
- (jclass "java.awt.ActionEvent"))))
+ (jclass "java.awt.event.ActionEvent"))))
((jinstance-of-p obj (jclass "java.lang.reflect.Method"))
(unless *backing-bean*
(error "No backing bean specified while action listener is a jmethod: ~A~%" obj))
Modified: trunk/test/src/snow/BindingTest.java
==============================================================================
--- trunk/test/src/snow/BindingTest.java (original)
+++ trunk/test/src/snow/BindingTest.java Mon Jan 18 16:51:06 2010
@@ -1,12 +1,8 @@
package snow;
-import java.awt.event.ActionEvent;
-import java.awt.event.ActionListener;
+import java.awt.event.*;
-import javax.swing.JButton;
-import javax.swing.JFrame;
-import javax.swing.JLabel;
-import javax.swing.JTextField;
+import javax.swing.*;
import net.miginfocom.swing.MigLayout;
@@ -18,6 +14,7 @@
import com.jgoodies.binding.beans.PropertyAdapter;
import com.jgoodies.binding.value.ValueModel;
import java.beans.*;
+import java.io.*;
import snow.binding.*;
public class BindingTest {
@@ -50,7 +47,7 @@
frame.add(resetButton);
frame.setDefaultCloseOperation(frame.EXIT_ON_CLOSE);
frame.pack();
- frame.setVisible(true);
+ //frame.setVisible(true);
}
@Test
@@ -78,6 +75,31 @@
model.setValue("42");
assertEquals("42", bean.getBean().getProperty());
}
+
+ public static class BackingBean {
+ private JButton button;
+ public boolean buttonPressed = false;
+ public void setButtonProperty(JButton b) {
+ button = b;
+ }
+ public JButton getButtonProperty() {
+ return button;
+ }
+ public void buttonAction(ActionEvent e) {
+ buttonPressed = true;
+ }
+ }
+
+ @Test
+ public void testBackingBean() {
+ Snowlet s = Snow.getInterpretedSnowlet(new StringReader("(in-package :snow-user) (setq *debugger-hook* nil) (button :id button-property :on-action \"buttonAction\")"));
+ BackingBean b = new BackingBean();
+ s.setBackingBean(b);
+ Object result = s.eval();
+ assertEquals(result, b.getButtonProperty());
+ b.getButtonProperty().doClick();
+ assertTrue(b.buttonPressed);
+ }
public static void main(String[] args) {
new BindingTest().testBinding();
From astalla at common-lisp.net Tue Jan 26 20:16:21 2010
From: astalla at common-lisp.net (Alessio Stalla)
Date: Tue, 26 Jan 2010 15:16:21 -0500
Subject: [snow-cvs] r46 - in trunk/src/lisp/snow: . swing
Message-ID:
Author: astalla
Date: Tue Jan 26 15:16:20 2010
New Revision: 46
Log:
Refactoring: eliminated definterface-defimplementation.
If and when SWT will be supported, I will fork the project specifically for
SWT, sharing the code that is in common.
SWT is different enough from Swing that changing the functional API would not
be enough; the macros must be changed as well.
Added:
trunk/src/lisp/snow/swing-data-binding.lisp
trunk/src/lisp/snow/swing.lisp (contents, props changed)
Removed:
trunk/src/lisp/snow/cells.lisp
trunk/src/lisp/snow/swing/
Modified:
trunk/src/lisp/snow/data-binding.lisp
trunk/src/lisp/snow/repl.lisp
trunk/src/lisp/snow/snow.asd
trunk/src/lisp/snow/start.lisp
trunk/src/lisp/snow/widgets.lisp
Modified: trunk/src/lisp/snow/data-binding.lisp
==============================================================================
--- trunk/src/lisp/snow/data-binding.lisp (original)
+++ trunk/src/lisp/snow/data-binding.lisp Tue Jan 26 15:16:20 2010
@@ -225,4 +225,4 @@
(if (eq (car list) 'cells:c?)
`(make-data-binding 'cell ,list)
`(make-data-binding ',(car list) ,@(cdr list)))))
- (t `(make-simple-data-binding ,(read stream)))))))
+ (t `(make-simple-data-binding ,(read stream)))))))
\ No newline at end of file
Modified: trunk/src/lisp/snow/repl.lisp
==============================================================================
--- trunk/src/lisp/snow/repl.lisp (original)
+++ trunk/src/lisp/snow/repl.lisp Tue Jan 26 15:16:20 2010
@@ -1,6 +1,6 @@
;;; repl.lisp
;;;
-;;; Copyright (C) 2008-2009 Alessio Stalla
+;;; Copyright (C) 2008-2010 Alessio Stalla
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
@@ -31,10 +31,25 @@
(in-package :snow)
-(definterface make-gui-repl *gui-backend* (&key dispose-on-close environment)
- "Creates a component that allows to interact with the Lisp system by typing text in a text area and receiving output in the same text area.")
+;;REPL
+(defun make-gui-repl (&key dispose-on-close environment)
+ "Creates a component that allows to interact with the Lisp system by typing text in a text area and receiving output in the same text area."
+ (let ((text-area (new "javax.swing.JTextArea"))
+ (repl-doc (new "snow.swing.ConsoleDocument"
+ (compile nil
+ `(lambda ()
+ (snow::with-snow-dynamic-environment
+ (let (, at environment)
+ (top-level::top-level-loop))))))))
+ (setf (widget-property text-area :document) repl-doc)
+ (invoke "setupTextComponent" repl-doc text-area)
+ (when dispose-on-close
+ (invoke "disposeOnClose" repl-doc dispose-on-close))
+ text-area))
+
+(defun dispose-gui-repl (repl)
+ "Performs operations necessary to dispose of a repl's allocated resources."
+ (invoke "dispose" (widget-property repl :document)))
(define-widget gui-repl (dispose-on-close environment) make-gui-repl)
-(definterface dispose-gui-repl *gui-backend* (repl)
- "Performs operations necessary to dispose of a repl's allocated resources.")
Modified: trunk/src/lisp/snow/snow.asd
==============================================================================
--- trunk/src/lisp/snow/snow.asd (original)
+++ trunk/src/lisp/snow/snow.asd Tue Jan 26 15:16:20 2010
@@ -31,17 +31,17 @@
;;Core stuff + cells if needed
(asdf:defsystem :snow
:serial t
- :version "0.2"
+ :version "0.3"
:depends-on (:cl-utilities :named-readtables :cells)
:components ((:file "packages")
(:file "sexy-java")
(:file "utils")
(:file "cx-dynamic-environments")
(:file "snow")
+ (:file "swing")
(:file "widgets")
(:file "repl")
(:file "data-binding")
- (:file "cells")
- (:file "backend")
+ (:file "swing-data-binding")
(:file "debugger")
(:file "inspector")))
\ No newline at end of file
Modified: trunk/src/lisp/snow/start.lisp
==============================================================================
--- trunk/src/lisp/snow/start.lisp (original)
+++ trunk/src/lisp/snow/start.lisp Tue Jan 26 15:16:20 2010
@@ -31,11 +31,11 @@
(in-package :snow)
(defun snow-about ()
- (dialog (:id dlg :title "Snow v0.2" :visible-p t)
+ (dialog (:id dlg :title "Snow v0.3" :visible-p t)
(label :layout "wrap"
- :text "Snow version 0.2")
+ :text "Snow version 0.3")
(label :layout "wrap"
- :text "Copyright (C) 2008-2009 Alessio Stalla")
+ :text "Copyright (C) 2008-2010 Alessio Stalla")
(label :layout "wrap"
:text "This program is distributed under the GNU GPL; see the file copying for details.")
(label :layout "wrap"
Added: trunk/src/lisp/snow/swing-data-binding.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/swing-data-binding.lisp Tue Jan 26 15:16:20 2010
@@ -0,0 +1,56 @@
+;;; swing-data-binding.lisp
+;;;
+;;; Copyright (C) 2008-2010 Alessio Stalla
+;;;
+;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+;;;
+;;; As a special exception, the copyright holders of this library give you
+;;; permission to link this library with independent modules to produce an
+;;; executable, regardless of the license terms of these independent
+;;; modules, and to copy and distribute the resulting executable under
+;;; terms of your choice, provided that you also meet, for each linked
+;;; independent module, the terms and conditions of the license of that
+;;; module. An independent module is a module which is not derived from
+;;; or based on this library. If you modify this library, you may extend
+;;; this exception to your version of the library, but you are not
+;;; obligated to do so. If you do not wish to do so, delete this
+;;; exception statement from your version.
+
+(in-package :snow)
+
+(defmethod bind-widget ((widget (jclass "javax.swing.JTextField")) binding)
+ (jstatic (jmethod "com.jgoodies.binding.adapter.Bindings"
+ "bind"
+ "javax.swing.JTextField"
+ "com.jgoodies.binding.value.ValueModel"
+ "boolean")
+ nil widget (make-model binding)
+ (make-immediate-object t :boolean)))
+
+(defmethod bind-widget ((widget (jclass "javax.swing.JLabel")) binding)
+ (jstatic (jmethod "com.jgoodies.binding.adapter.Bindings"
+ "bind"
+ "javax.swing.JLabel"
+ "com.jgoodies.binding.value.ValueModel")
+ nil widget (make-model binding)))
+
+(defmethod (setf widget-property) ((value data-binding) (widget (jclass "java.awt.Component")) name)
+ (jstatic (jmethod "com.jgoodies.binding.adapter.Bindings"
+ "bind"
+ "javax.swing.JComponent"
+ "java.lang.String"
+ "com.jgoodies.binding.value.ValueModel")
+ nil widget (dashed->camelcased name) (make-model value))
+ value)
\ No newline at end of file
Added: trunk/src/lisp/snow/swing.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/swing.lisp Tue Jan 26 15:16:20 2010
@@ -0,0 +1,210 @@
+;;; swing.lisp
+;;;
+;;; Copyright (C) 2008-2010 Alessio Stalla
+;;;
+;;; 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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+;;;
+;;; As a special exception, the copyright holders of this library give you
+;;; permission to link this library with independent modules to produce an
+;;; executable, regardless of the license terms of these independent
+;;; modules, and to copy and distribute the resulting executable under
+;;; terms of your choice, provided that you also meet, for each linked
+;;; independent module, the terms and conditions of the license of that
+;;; module. An independent module is a module which is not derived from
+;;; or based on this library. If you modify this library, you may extend
+;;; this exception to your version of the library, but you are not
+;;; obligated to do so. If you do not wish to do so, delete this
+;;; exception statement from your version.
+
+(in-package :snow)
+
+(defun setup-button (btn text on-action)
+ (when text
+ (setf (widget-property btn :text) text))
+ (when on-action
+ (invoke "addActionListener"
+ btn
+ (make-action-listener on-action))))
+
+(defun make-action-listener (obj)
+ (cond
+ ((or (functionp obj) (symbolp obj))
+ (jmake-proxy "java.awt.event.ActionListener"
+ (lambda/dynamic-environment (this method-name event)
+ (funcall obj event))))
+ ((stringp obj)
+ (unless *backing-bean*
+ (error "No backing bean specified while action listener is a method name: ~A~%" obj))
+ (make-action-listener (jmethod (jclass-of *backing-bean*) obj
+ (jclass "java.awt.event.ActionEvent"))))
+ ((jinstance-of-p obj (jclass "java.lang.reflect.Method"))
+ (unless *backing-bean*
+ (error "No backing bean specified while action listener is a jmethod: ~A~%" obj))
+ (make-action-listener
+ (let ((bb *backing-bean*))
+ #'(lambda (evt) (jcall obj bb evt)))))
+ (t obj))) ;This allows to use a native Java action listener
+
+(defun make-layout-manager (widget layout &rest args)
+ (if (typep layout 'java-object)
+ layout
+ (ecase layout
+ ((or :default :mig) (apply #'new "net.miginfocom.swing.MigLayout" args))
+ (:box (new "javax.swing.BoxLayout"
+ (if (jinstance-of-p widget "javax.swing.JFrame")
+ (invoke "getContentPane" widget)
+ widget)
+ (ecase (car args)
+ (:x (jfield "javax.swing.BoxLayout" "X_AXIS"))
+ (:y (jfield "javax.swing.BoxLayout" "Y_AXIS")))))
+ (:flow (new "java.awt.FlowLayout"))
+ (:border (new "java.awt.BorderLayout"))
+ ((nil) nil))))
+
+(defun (setf layout-manager) (lm widget)
+ (setf (widget-property widget :layout) lm))
+
+(defun setup-mouse-listeners
+ (widget on-mouse-click on-mouse-press on-mouse-release
+ on-mouse-enter on-mouse-exit on-mouse-drag on-mouse-move)
+ (let ((mouse-input-listener
+ (new "snow.swing.MouseInputListener"
+ on-mouse-click on-mouse-press on-mouse-release
+ on-mouse-enter on-mouse-exit
+ on-mouse-drag on-mouse-move)))
+ (when (or on-mouse-click on-mouse-press on-mouse-release
+ on-mouse-enter on-mouse-exit)
+ (invoke "addMouseListener" widget mouse-input-listener))
+ (when (or on-mouse-drag on-mouse-move)
+ (invoke "addMouseMotionListener" widget mouse-input-listener))))
+
+(defconstant +add-to-container+ (jmethod "java.awt.Container" "add" "java.awt.Component"))
+
+(defconstant +add-to-container-with-constraints+ (jmethod "java.awt.Container" "add" "java.lang.String" "java.awt.Component"))
+
+(defun call-in-gui-thread (fn)
+ (jstatic "invokeLater" "javax.swing.SwingUtilities"
+ (new "snow.FunctionRunnable" fn)))
+
+;;Base API implementation
+(defun add-child (child &optional (parent *parent*) layout-constraints)
+ (if layout-constraints
+ (jcall +add-to-container-with-constraints+
+ parent
+ layout-constraints
+ child)
+ (jcall +add-to-container+ parent child)))
+
+(defun (setf widget-enabled-p) (value widget)
+ (setf (widget-property widget :enabled) value))
+
+(defun widget-enabled-p (widget)
+ (widget-property widget :enabled))
+
+(defun (setf widget-font) (value widget)
+ (setf (widget-property widget :font) value))
+
+(defun (setf widget-background) (value widget)
+ (setf (widget-property widget :background) value))
+
+(defun (setf widget-foreground) (value widget)
+ (setf (widget-property widget :foreground) value))
+
+(defun (setf widget-location) (value widget)
+ (invoke "setLocation" widget (aref value 0) (aref value 1)))
+
+(defun (setf widget-size) (value widget)
+ (invoke "setSize" widget (realpart value) (imagpart value)))
+
+(defun (setf widget-text) (value widget)
+ (setf (widget-property widget :text) value))
+
+(defun widget-text (widget)
+ (widget-property widget :text))
+
+(defun (setf widget-visible-p) (value widget)
+ (setf (widget-property widget :visible) value))
+
+(defun widget-visible-p (widget)
+ (widget-property widget :visible))
+
+(defun make-border (border-spec)
+ (if (jinstance-of-p border-spec "javax.swing.border.Border")
+ border-spec
+ (let ((border (ensure-list border-spec)))
+ (ecase (car border)
+ (:bevel
+ (let ((type (ecase (or (cadr border) :lowered)
+ (:lowered
+ (jfield "javax.swing.border.BevelBorder" "LOWERED"))
+ (:raised
+ (jfield "javax.swing.border.BevelBorder" "RAISED")))))
+ (jcall (jmethod "javax.swing.BorderFactory"
+ "createBevelBorder" "int")
+ nil type)))
+ (:compound
+ (let ((outer (cadr border)) (inner (caddr border)))
+ (jcall (jmethod "javax.swing.BorderFactory"
+ "createCompoundBorder"
+ "javax.swing.border.Border"
+ "javax.swing.border.Border")
+ nil outer inner)))
+ (:empty
+ (if (cdr border)
+ (if (= 4 (length (cdr border)))
+ (jcall (jmethod "javax.swing.BorderFactory"
+ "createEmptyBorder" "int" "int" "int" "int")
+ nil (second border) (third border) (fourth border)
+ (fifth border))
+ (error "Wrong number of arguments for empty border: ~A (~S)"
+ (length (cdr border)) (cdr border)))
+ (jcall (jmethod "javax.swing.BorderFactory"
+ "createEmptyBorder")
+ nil)))
+ ))))
+
+(defun (setf widget-border) (value widget)
+ (when (jinstance-of-p widget "javax.swing.JComponent")
+ (invoke "setBorder" widget (if value (make-border value) nil))))
+
+(defun dispose (obj)
+ (invoke "dispose" obj))
+
+(defun show (obj)
+ (invoke "show" obj))
+
+(defun hide (obj)
+ (invoke "hide" obj))
+
+(defun color (color-spec)
+ (cond
+ ((integerp color-spec) (new "java.awt.Color" color-spec))
+ ((keywordp color-spec) (case color-spec
+ (:black (jfield "java.awt.Color" "BLACK"))
+ (:blue (jfield "java.awt.Color" "BLUE"))
+ (:green (jfield "java.awt.Color" "GREEN"))
+ (:red (jfield "java.awt.Color" "RED"))
+ (:white (jfield "java.awt.Color" "WHITE"))))
+ (t (error "Invalid color: ~A" color-spec))))
+
+(defun font (name size &optional style)
+ (let ((style-int (case style
+ ((or :plain nil) (jfield "java.awt.Font" "PLAIN"))
+ (:bold (jfield "java.awt.Font" "BOLD"))
+ (:italic (jfield "java.awt.Font" "ITALIC"))
+ (:bold-italic (logior (jfield "java.awt.Font" "BOLD")
+ (jfield "java.awt.Font" "ITALIC")))
+ (t (error "Unknown font style: ~A" style)))))
+ (new "java.awt.Font" name style-int size)))
Modified: trunk/src/lisp/snow/widgets.lisp
==============================================================================
--- trunk/src/lisp/snow/widgets.lisp (original)
+++ trunk/src/lisp/snow/widgets.lisp Tue Jan 26 15:16:20 2010
@@ -1,6 +1,6 @@
;;; widgets.lisp
;;;
-;;; Copyright (C) 2008-2009 Alessio Stalla
+;;; Copyright (C) 2008-2010 Alessio Stalla
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
@@ -30,14 +30,42 @@
(in-package :snow)
-;;Windows
-(definterface make-frame *gui-backend* (&key menu-bar title on-close
- &allow-other-keys))
+(defmacro defwidget (name &rest args)
+ (let ((maker-sym (intern (str (symbol-name '#:make-) (symbol-name name)))))
+ `(define-widget ,name (, at args &allow-other-keys) ,maker-sym)))
+
+;;Windows and dialogs
+(defun make-frame (&key menu-bar title visible-p on-close
+ &allow-other-keys)
+ (let ((f (new "javax.swing.JFrame")))
+ (set-widget-properties f
+ :title title
+ :visible (jbool visible-p))
+ (when menu-bar
+ (setf (widget-property f "JMenuBar") menu-bar))
+ (when on-close
+ (let ((on-close
+ (case on-close
+ ((#'ext:exit 'ext:exit :exit)
+ (lambda (evt)
+ (declare (ignore evt))
+ (ext:exit)))
+ (t on-close))))
+ (invoke "addWindowListener" f (new "snow.swing.WindowListener"
+ nil nil on-close nil nil nil nil))))
+ f))
(define-container-widget frame (menu-bar title on-close) make-frame)
-(definterface make-dialog *gui-backend*
- (&key parent title modal-p visible-p &allow-other-keys))
+(defun make-dialog (&key parent title modal-p visible-p &allow-other-keys)
+ (let ((d (jnew "javax.swing.JDialog"
+ parent
+ (if modal-p
+ (jfield "java.awt.Dialog$ModalityType" "APPLICATION_MODAL")
+ (jfield "java.awt.Dialog$ModalityType" "MODELESS")))))
+ (set-widget-properties d
+ :title title)
+ d))
(define-widget-macro dialog
((&rest args &key &common-widget-args
@@ -55,29 +83,51 @@
,@(generate-default-children-processing-code id body)
(setf (widget-visible-p self) ,visible-p)))
+(defun pack (window)
+ (jcall (jmethod "java.awt.Window" "pack") window)
+ window)
+
;;Menus
-(definterface make-menu-bar *gui-backend* (&key &allow-other-keys))
+(defun make-menu-bar (&key &allow-other-keys)
+ (jnew "javax.swing.JMenuBar"))
(define-container-widget menu-bar () make-menu-bar)
-(definterface make-menu *gui-backend* (&key text &allow-other-keys))
+(defun make-menu (&key text &allow-other-keys)
+ (if text
+ (jnew "javax.swing.JMenu" text)
+ (jnew "javax.swing.JMenu")))
(define-container-widget menu (text) make-menu)
-(definterface make-menu-item *gui-backend*
- (&key text on-action &allow-other-keys))
+(defun make-menu-item (&key text on-action &allow-other-keys)
+ (let ((m (new "javax.swing.JMenuItem")))
+ (setup-button m text on-action)
+ m))
(define-widget menu-item (text on-action) make-menu-item)
;;Panels
-(definterface make-panel *gui-backend* (&key &allow-other-keys))
+(defun make-panel (&key &allow-other-keys)
+ (jnew "javax.swing.JPanel"))
(define-container-widget panel () make-panel)
(defvar *tabs*)
-(definterface make-tabs *gui-backend* (&key (wrap t) (tab-placement :top)
- &allow-other-keys))
+(defun make-tabs (&key (wrap t) (tab-placement :top) &allow-other-keys)
+ (let ((tabs (jnew "javax.swing.JTabbedPane")))
+ (invoke "setTabLayoutPolicy" tabs
+ (if wrap
+ (jfield "javax.swing.JTabbedPane" "WRAP_TAB_LAYOUT")
+ (jfield "javax.swing.JTabbedPane" "SCROLL_TAB_LAYOUT")))
+ (invoke "setTabPlacement" tabs
+ (ecase tab-placement
+ (:top (jfield "javax.swing.JTabbedPane" "TOP"))
+ (:bottom (jfield "javax.swing.JTabbedPane" "BOTTOM"))
+ (:left (jfield "javax.swing.JTabbedPane" "LEFT"))
+ (:right (jfield "javax.swing.JTabbedPane" "RIGHT"))))
+ tabs))
(define-widget-macro tabs
((&rest args &key id &common-widget-args (wrap t) (tab-placement :top))
@@ -96,19 +146,33 @@
(add-child (progn , at body) *tabs* ,name)
(error "tab outside tabset: ~A" ,name)))
-(definterface make-scroll-panel *gui-backend* (view))
+(defun make-scroll-panel (view)
+ (let ((p (jnew "javax.swing.JScrollPane")))
+ (setf (scroll-panel-view p) view)
+ p))
-(definterface scroll-panel-view *gui-backend* (self))
+(defun scroll-panel-view (self)
+ (jproperty-value self "viewportView"))
-(definterface (setf scroll-panel-view) *gui-backend* (view self))
+(defun (setf scroll-panel-view) (view self)
+ (setf (jproperty-value self "viewportView") view))
(define-widget-macro scroll
((&rest args &key &common-widget-args) body)
`(make-scroll-panel (dont-add ,body))
`(setup-widget self , at args))
-(definterface make-split-panel *gui-backend*
- (child1 child2 &key (orientation :horizontal) smoothp))
+(defun make-split-panel (child1 child2
+ &key (orientation :horizontal) smoothp)
+ (new "javax.swing.JSplitPane"
+ (ecase orientation
+ ((or :horizontal :h nil)
+ #.(jfield "javax.swing.JSplitPane" "HORIZONTAL_SPLIT"))
+ ((or :vertical :v)
+ #.(jfield "javax.swing.JSplitPane" "VERTICAL_SPLIT")))
+ (jbool smoothp)
+ child1
+ child2))
(define-widget-macro split
((&rest args &key &common-widget-args orientation smoothp)
@@ -116,34 +180,97 @@
`(make-split-panel (dont-add ,child1) (dont-add ,child2)
:orientation ,orientation :smoothp ,smoothp)
`(setup-widget self ,@(filter-arglist args '(:orientation :smoothp))))
-
-(defmacro defwidget (name &rest args)
- (let* ((maker-sym (intern (str (symbol-name '#:make-) (symbol-name name)))))
- `(progn
- (definterface ,maker-sym *gui-backend* (&key , at args &allow-other-keys))
- (define-widget ,name (, at args &allow-other-keys) ,maker-sym))))
-
+
;;Buttons and similar
-(defwidget button text on-action)
+(defun make-button (&key text on-action &allow-other-keys)
+ (let ((btn (new "javax.swing.JButton")))
+ (setup-button btn text on-action)
+ btn))
-(defwidget check-box text selected-p)
+(defwidget button text on-action)
-;;Misc
+(defun make-check-box (&key text selected-p &allow-other-keys)
+ (let ((btn (new "javax.swing.JCheckBox")))
+ (when text
+ (setf (widget-property btn :text) text))
+ (setf (widget-property btn :selected)
+ (if selected-p selected-p (jbool nil)))
+ btn))
-(defwidget progress-bar value orientation (paint-border t) progress-string)
+(defwidget check-box text selected-p)
;;Text
+(defun make-label (&key text &allow-other-keys)
+ (let ((lbl (new "javax.swing.JLabel")))
+ (when text
+ (setf (widget-property lbl :text) text))
+ lbl))
(defwidget label text)
+(defun make-text-field (&key text &allow-other-keys)
+ (let ((field (new "javax.swing.JTextField")))
+ (when text
+ (setf (widget-property field :text) text))
+ field))
+
(defwidget text-field text)
+(defun make-text-area (&key text &allow-other-keys)
+ (let ((text-area (new "javax.swing.JTextArea")))
+ (when text
+ (setf (widget-property text-area :text) text))
+ text-area))
+
(defwidget text-area text)
+(defun make-dialog-prompt-stream ()
+ (jnew "snow.SwingDialogPromptStream"))
+
;;Lists
+(defun make-list-model (list)
+ (new "snow.list.ConsListModel" list))
+
+(defun make-list-widget (&key model prototype-cell-value selected-index
+ (cell-renderer (new "snow.list.ConsListCellRenderer"))
+ &allow-other-keys)
+ (let ((list (new "javax.swing.JList")))
+ (when model (setf (widget-property list :model) model))
+ (setf (widget-property list :cell-renderer) cell-renderer)
+ (setf (widget-property list :prototype-cell-value) prototype-cell-value)
+ (when selected-index
+ (setf (widget-property list :selected-index) selected-index))
+ list))
(defwidget list-widget model selected-index)
;;Trees
+(defun make-tree-model (list)
+ (new "snow.tree.ConsTreeModel" list))
+
+(defun make-tree (&key model (cell-renderer (new "snow.tree.ConsTreeCellRenderer"))
+ &allow-other-keys)
+ (let ((tree (new "javax.swing.JTree")))
+ (when model (setf (widget-property tree :model) model))
+ (setf (widget-property tree :cell-renderer) cell-renderer)
+ tree))
+
+(defwidget tree model)
+
+;;Misc
+(defconstant +swingconstant-vertical+ (jfield "javax.swing.SwingConstants" "VERTICAL"))
+
+(defun make-progress-bar (&key value orientation (paint-border t) progress-string &allow-other-keys)
+ (let ((pbar (jnew "javax.swing.JProgressBar")))
+ (when value
+ (setf (widget-property pbar :value) value))
+ (when orientation
+ (setf (widget-property pbar :orientation) +swingconstant-vertical+))
+ (when (not paint-border)
+ (setf (widget-property pbar :border-painted) (jbool nil)))
+ (when progress-string
+ (setf (widget-property pbar :string-painted) (jbool t))
+ (setf (widget-property pbar :string) progress-string))
+ pbar))
-(defwidget tree model)
\ No newline at end of file
+(defwidget progress-bar value orientation (paint-border t) progress-string)
\ No newline at end of file
From astalla at common-lisp.net Tue Jan 26 20:21:02 2010
From: astalla at common-lisp.net (Alessio Stalla)
Date: Tue, 26 Jan 2010 15:21:02 -0500
Subject: [snow-cvs] r48 - trunk/lib
Message-ID:
Author: astalla
Date: Tue Jan 26 15:21:02 2010
New Revision: 48
Log:
Moving lib folder to separate dependencies/ path.
Removed:
trunk/lib/
From astalla at common-lisp.net Tue Jan 26 20:26:03 2010
From: astalla at common-lisp.net (Alessio Stalla)
Date: Tue, 26 Jan 2010 15:26:03 -0500
Subject: [snow-cvs] r49 - trunk
Message-ID:
Author: astalla
Date: Tue Jan 26 15:26:03 2010
New Revision: 49
Log:
Added svn:externals property to automatically fetch dependencies in the lib directory.
Modified:
trunk/ (props changed)
From astalla at common-lisp.net Fri Jan 29 17:25:46 2010
From: astalla at common-lisp.net (Alessio Stalla)
Date: Fri, 29 Jan 2010 12:25:46 -0500
Subject: [snow-cvs] r50 - trunk
Message-ID:
Author: astalla
Date: Fri Jan 29 12:25:45 2010
New Revision: 50
Log:
Fixed wrong external which made anonymous checkout fail.
Modified:
trunk/ (props changed)
From astalla at common-lisp.net Tue Jan 26 20:20:07 2010
From: astalla at common-lisp.net (Alessio Stalla)
Date: Tue, 26 Jan 2010 15:20:07 -0500
Subject: [snow-cvs] r47 - in dependencies: . trunk trunk/cells
trunk/cells/Use Cases trunk/cells/Use Cases/dow-jones
trunk/cells/cells-test trunk/cells/doc
trunk/cells/gui-geometry trunk/cells/tutorial
trunk/cells/utils-kt trunk/cl-utilities-1.2.4
trunk/cl-utilities-1.2.4/doc trunk/named-readtables
trunk/named-readtables/doc trunk/named-readtables/tests
Message-ID:
Author: astalla
Date: Tue Jan 26 15:20:07 2010
New Revision: 47
Log:
Importing lib folder to separate dependencies/ path.
Added:
dependencies/
dependencies/trunk/
dependencies/trunk/abcl.jar (contents, props changed)
dependencies/trunk/binding-2.0.6.jar (contents, props changed)
dependencies/trunk/cells/
dependencies/trunk/cells/README.txt (contents, props changed)
dependencies/trunk/cells/Use Cases/
dependencies/trunk/cells/Use Cases/dow-jones/
dependencies/trunk/cells/Use Cases/dow-jones/dow-jones.lpr (contents, props changed)
dependencies/trunk/cells/Use Cases/dow-jones/stock-exchange.lisp (contents, props changed)
dependencies/trunk/cells/cell-types.lisp (contents, props changed)
dependencies/trunk/cells/cells-manifesto.txt (contents, props changed)
dependencies/trunk/cells/cells-store.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/
dependencies/trunk/cells/cells-test/boiler-examples.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/build-sys.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/cells-test.asd (contents, props changed)
dependencies/trunk/cells/cells-test/cells-test.lpr (contents, props changed)
dependencies/trunk/cells/cells-test/deep-cells.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/df-interference.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/echo-setf.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/hello-world-q.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/hello-world.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/internal-combustion.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/lazy-propagation.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/output-setf.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/person.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/synapse-testing.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-cycle.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-cyclicity.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-ephemeral.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-family.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-kid-slotting.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-lazy.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test-synapse.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test.lisp (contents, props changed)
dependencies/trunk/cells/cells-test/test.lpr (contents, props changed)
dependencies/trunk/cells/cells.asd (contents, props changed)
dependencies/trunk/cells/cells.lisp (contents, props changed)
dependencies/trunk/cells/cells.lpr (contents, props changed)
dependencies/trunk/cells/constructors.lisp (contents, props changed)
dependencies/trunk/cells/defmodel.lisp (contents, props changed)
dependencies/trunk/cells/defpackage.lisp (contents, props changed)
dependencies/trunk/cells/doc/
dependencies/trunk/cells/doc/01-Cell-basics.lisp (contents, props changed)
dependencies/trunk/cells/doc/cell-doc.lisp (contents, props changed)
dependencies/trunk/cells/doc/cells-overview.pdf (contents, props changed)
dependencies/trunk/cells/doc/hw.lisp (contents, props changed)
dependencies/trunk/cells/doc/motor-control.lisp (contents, props changed)
dependencies/trunk/cells/family-values.lisp (contents, props changed)
dependencies/trunk/cells/family.lisp (contents, props changed)
dependencies/trunk/cells/fm-utilities.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/
dependencies/trunk/cells/gui-geometry/coordinate-xform.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/defpackage.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/geo-data-structures.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/geo-family.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/geo-macros.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/geometer.lisp (contents, props changed)
dependencies/trunk/cells/gui-geometry/gui-geometry.asd (contents, props changed)
dependencies/trunk/cells/gui-geometry/gui-geometry.lpr (contents, props changed)
dependencies/trunk/cells/initialize.lisp (contents, props changed)
dependencies/trunk/cells/integrity.lisp (contents, props changed)
dependencies/trunk/cells/link.lisp (contents, props changed)
dependencies/trunk/cells/load.lisp (contents, props changed)
dependencies/trunk/cells/md-slot-value.lisp (contents, props changed)
dependencies/trunk/cells/md-utilities.lisp (contents, props changed)
dependencies/trunk/cells/model-object.lisp (contents, props changed)
dependencies/trunk/cells/propagate.lisp (contents, props changed)
dependencies/trunk/cells/slot-utilities.lisp (contents, props changed)
dependencies/trunk/cells/synapse-types.lisp (contents, props changed)
dependencies/trunk/cells/synapse.lisp (contents, props changed)
dependencies/trunk/cells/test-cc.lisp (contents, props changed)
dependencies/trunk/cells/test-cycle.lisp (contents, props changed)
dependencies/trunk/cells/test-ephemeral.lisp (contents, props changed)
dependencies/trunk/cells/test-propagation.lisp (contents, props changed)
dependencies/trunk/cells/test-synapse.lisp (contents, props changed)
dependencies/trunk/cells/test.lisp (contents, props changed)
dependencies/trunk/cells/trc-eko.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/
dependencies/trunk/cells/tutorial/01-lesson.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/01a-dataflow.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/01b-change-handling.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/01c-cascade.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/02-lesson.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/03-ephemeral.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/04-formula-once-then-input.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/test.lisp (contents, props changed)
dependencies/trunk/cells/tutorial/tutorial.lpr (contents, props changed)
dependencies/trunk/cells/utils-kt/
dependencies/trunk/cells/utils-kt/core.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/datetime.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/debug.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/defpackage.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/detritus.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/flow-control.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/quad.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/split-sequence.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/strings.lisp (contents, props changed)
dependencies/trunk/cells/utils-kt/utils-kt.asd (contents, props changed)
dependencies/trunk/cells/utils-kt/utils-kt.lpr (contents, props changed)
dependencies/trunk/cells/variables.lisp (contents, props changed)
dependencies/trunk/cl-utilities-1.2.4/
dependencies/trunk/cl-utilities-1.2.4/README
dependencies/trunk/cl-utilities-1.2.4/cl-utilities.asd
dependencies/trunk/cl-utilities-1.2.4/collecting.lisp
dependencies/trunk/cl-utilities-1.2.4/compose.lisp
dependencies/trunk/cl-utilities-1.2.4/copy-array.lisp
dependencies/trunk/cl-utilities-1.2.4/doc/
dependencies/trunk/cl-utilities-1.2.4/doc/collecting.html
dependencies/trunk/cl-utilities-1.2.4/doc/compose.html
dependencies/trunk/cl-utilities-1.2.4/doc/copy-array.html
dependencies/trunk/cl-utilities-1.2.4/doc/expt-mod.html
dependencies/trunk/cl-utilities-1.2.4/doc/extremum.html
dependencies/trunk/cl-utilities-1.2.4/doc/index.html
dependencies/trunk/cl-utilities-1.2.4/doc/once-only.html
dependencies/trunk/cl-utilities-1.2.4/doc/read-delimited.html
dependencies/trunk/cl-utilities-1.2.4/doc/rotate-byte.html
dependencies/trunk/cl-utilities-1.2.4/doc/split-sequence.html
dependencies/trunk/cl-utilities-1.2.4/doc/style.css
dependencies/trunk/cl-utilities-1.2.4/doc/with-unique-names.html
dependencies/trunk/cl-utilities-1.2.4/expt-mod.lisp
dependencies/trunk/cl-utilities-1.2.4/extremum.lisp
dependencies/trunk/cl-utilities-1.2.4/once-only.lisp
dependencies/trunk/cl-utilities-1.2.4/package.lisp
dependencies/trunk/cl-utilities-1.2.4/package.sh (contents, props changed)
dependencies/trunk/cl-utilities-1.2.4/read-delimited.lisp
dependencies/trunk/cl-utilities-1.2.4/rotate-byte.lisp
dependencies/trunk/cl-utilities-1.2.4/split-sequence.lisp
dependencies/trunk/cl-utilities-1.2.4/test.lisp
dependencies/trunk/cl-utilities-1.2.4/with-unique-names.lisp
dependencies/trunk/commons-logging.jar (contents, props changed)
dependencies/trunk/miglayout-3.7.1.jar (contents, props changed)
dependencies/trunk/named-readtables/
dependencies/trunk/named-readtables/LICENSE
dependencies/trunk/named-readtables/cruft.lisp
dependencies/trunk/named-readtables/define-api.lisp
dependencies/trunk/named-readtables/doc/
dependencies/trunk/named-readtables/doc/named-readtables.html
dependencies/trunk/named-readtables/named-readtables.asd
dependencies/trunk/named-readtables/named-readtables.lisp
dependencies/trunk/named-readtables/package.lisp
dependencies/trunk/named-readtables/tests/
dependencies/trunk/named-readtables/tests/package.lisp
dependencies/trunk/named-readtables/tests/rt.lisp
dependencies/trunk/named-readtables/tests/tests.lisp
dependencies/trunk/named-readtables/utils.lisp
Added: dependencies/trunk/abcl.jar
==============================================================================
Binary file. No diff available.
Added: dependencies/trunk/binding-2.0.6.jar
==============================================================================
Binary file. No diff available.
Added: dependencies/trunk/cells/README.txt
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/README.txt Tue Jan 26 15:20:07 2010
@@ -0,0 +1,101 @@
+-*- text -*-
+
+***** About Cells *****
+
+(Installation instructions follow)
+
+Cells is a mature, stable extension to CLOS that allows you to create
+classes, the instances of which have slots whose values are determined
+by a formula. Think of the slots as cells in a spreadsheet (get it?),
+and you've got the right idea. You can use any arbitrary Common Lisp
+expression to specify the value of a cell. The Cells system takes care
+of tracking dependencies among cells, and propagating values. It is
+distributed under an MIT-style license.
+
+Documentation/support is in the form of:
+
+ the cells-devel mailing list (users and developers both welcome)
+ .\docs\01-cell-basics.lisp
+ .\docs\motor-control.lisp ;; actually Bill Clementson's blog entry
+ extensive examples in the Cells-test regression test suite
+ the companion Celtk module, which happens also to provide a substantial and
+ growing portable, native Common Lisp GUI.
+
+The above examples have all been tested against the current release of Cells.
+Now in .\doc is cells-overview.pdf. That is pretty rough and obsolete in re the
+code, but some of it might be enlightening.
+
+Cells is written in portable ANSI Common Lisp. It makes very
+light use of the introspective portions of the MOP, and contains a few
+workarounds for shortcomings in common implementations.
+
+Cells is known to currently work on the following Lisp implementations:
+
+ * Allegro
+ * SBCL
+ * CLISP
+ * LispWorks
+ * OpenMCL
+
+Partially supported are:
+
+ * CMUCL
+ * Corman Lisp
+ * MCL
+
+One of the Cells tests fails with CMUCL. This appears to be caused by
+a bug in CMUCL's CLOS implementation, but has not been investigated in
+great depth.
+
+Cells is believed to work with Corman CL, but has not been recently
+tested. In the past, MCL was supported, but a it does not currently
+pass the test suite. Ressurecting full support for any of these
+implementations should be easy.
+
+Porting Cells to an unsupported but ANSI-conforming Lisp
+implementation should be trivial: mostly a matter of determining the
+package where the MOP lives. In reality, however, you might have to
+find workarounds for bugs in ANSI compliance.
+
+***** Installation *****
+
+[ Cells follows the usual convention for asdf and asdf-installable
+ packages. If you know what that means, that's all you need to
+ know. ]
+
+Installation is trivial for asdf-install users:
+
+ (asdf-install:install :cells)
+
+Users without asdf-install will need to download the distribution from
+common-lisp.net. If your implementation does not come with ASDF,
+please complain to the implementor, then load the asdf.lisp file
+included in the Cells distribution.
+
+Unpack the distribution where you will.
+
+Unix users: If you do not already have an asdf central registry,
+create a directory calld asdf-registry under your home directory and
+push this onto asdf:*central-registry*. Create symlinks there to the
+cells.asd and cells-test.asd files in the distribution. Alternately,
+follow the instructions for Windows users.
+
+Windows and Classic Mac users: Push the directory where you unpacked
+the Cells distribution onto asdf:*central-registry*.
+
+You can now load Cells in the usual manner for asdf.
+
+SLIME:
+
+ ,load-system cells
+
+SBCL:
+
+ (require :cells)
+
+Other systems:
+
+ (asdf:oos 'asdf:load-op :cells)
+
+You may wish to run the test suite. To do so, use asdf to load the
+:cells-test system.
Added: dependencies/trunk/cells/Use Cases/dow-jones/dow-jones.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/Use Cases/dow-jones/dow-jones.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,81 @@
+;; -*- lisp-version: "7.0 [Windows] (Jun 10, 2005 13:34)"; cg: "1.54.2.17"; -*-
+
+(in-package :cg-user)
+
+(defpackage :CELLS)
+
+(define-project :name :dow-jones
+ :modules (list (make-instance 'module :name "stock-exchange.lisp"))
+ :projects (list (make-instance 'project-module :name
+ "..\\..\\cells"))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :cells
+ :main-form nil
+ :compilation-unit t
+ :verbose nil
+ :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane
+ :cg.bitmap-pane.clipboard :cg.bitmap-stream
+ :cg.button :cg.caret :cg.check-box :cg.choice-list
+ :cg.choose-printer :cg.clipboard
+ :cg.clipboard-stack :cg.clipboard.pixmap
+ :cg.color-dialog :cg.combo-box :cg.common-control
+ :cg.comtab :cg.cursor-pixmap :cg.curve
+ :cg.dialog-item :cg.directory-dialog
+ :cg.directory-dialog-os :cg.drag-and-drop
+ :cg.drag-and-drop-image :cg.drawable
+ :cg.drawable.clipboard :cg.dropping-outline
+ :cg.edit-in-place :cg.editable-text
+ :cg.file-dialog :cg.fill-texture
+ :cg.find-string-dialog :cg.font-dialog
+ :cg.gesture-emulation :cg.get-pixmap
+ :cg.get-position :cg.graphics-context
+ :cg.grid-widget :cg.grid-widget.drag-and-drop
+ :cg.group-box :cg.header-control :cg.hotspot
+ :cg.icon :cg.icon-pixmap :cg.item-list
+ :cg.keyboard-shortcuts :cg.lettered-menu
+ :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget
+ :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip
+ :cg.message-dialog :cg.multi-line-editable-text
+ :cg.multi-line-lisp-text :cg.multi-picture-button
+ :cg.multi-picture-button.drag-and-drop
+ :cg.multi-picture-button.tooltip :cg.os-widget
+ :cg.os-window :cg.outline
+ :cg.outline.drag-and-drop
+ :cg.outline.edit-in-place :cg.palette
+ :cg.paren-matching :cg.picture-widget
+ :cg.picture-widget.palette :cg.pixmap
+ :cg.pixmap-widget :cg.pixmap.file-io
+ :cg.pixmap.printing :cg.pixmap.rotate :cg.printing
+ :cg.progress-indicator :cg.project-window
+ :cg.property :cg.radio-button :cg.rich-edit
+ :cg.rich-edit-pane :cg.rich-edit-pane.clipboard
+ :cg.rich-edit-pane.printing :cg.sample-file-menu
+ :cg.scaling-stream :cg.scroll-bar
+ :cg.scroll-bar-mixin :cg.selected-object
+ :cg.shortcut-menu :cg.static-text :cg.status-bar
+ :cg.string-dialog :cg.tab-control
+ :cg.template-string :cg.text-edit-pane
+ :cg.text-edit-pane.file-io :cg.text-edit-pane.mark
+ :cg.text-or-combo :cg.text-widget :cg.timer
+ :cg.toggling-widget :cg.toolbar :cg.tooltip
+ :cg.trackbar :cg.tray :cg.up-down-control
+ :cg.utility-dialog :cg.web-browser
+ :cg.web-browser.dde :cg.wrap-string
+ :cg.yes-no-list :cg.yes-no-string :dde)
+ :splash-file-module (make-instance 'build-module :name "")
+ :icon-file-module (make-instance 'build-module :name "")
+ :include-flags '(:top-level :debugger)
+ :build-flags '(:allow-runtime-debug :purify)
+ :autoload-warning t
+ :full-recompile-for-runtime-conditionalizations nil
+ :default-command-line-arguments "+M +t \"Console for Debugging\""
+ :additional-build-lisp-image-arguments '(:read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :on-initialization 'cells::run-trading-day
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/Use Cases/dow-jones/stock-exchange.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/Use Cases/dow-jones/stock-exchange.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,954 @@
+(in-package :cells)
+
+#|
+
+The deal is this: explanations of chunks of code appear /below/ them.
+
+Now here are Ron's functional requirements: process a stream of messages from an
+imagined source of financial data. Actually, Ron has an intermediate process
+reading a real source and producing a somewhat-digested stream in Lisp-friendly
+format. Sample:
+
+(:date 5123 :weekday 3)
+(:index ((AA 29.30 7.3894672) (AIG 53.30 7.3894672)(AXP 53.00 7.3894672)
+(BA 59.87 7.3894672) (C 46.80 7.3894672) (CAT 87.58 7.3894672) (DD 47.74 7.3894672)
+(DIS 26.25 7.3894672) (GE 36.10 7.3894672) (GM 27.77 7.3894672) (HD 36.75 7.3894672)
+(HON 35.30 7.3894672) (HPQ 21.00 7.3894672) (IBM 76.47 7.3894672)
+(INTC 23.75 7.3894672) (JNJ 68.73 7.3894672) (JPM 35.50 7.3894672) (KO 43.76 7.3894672)
+(MCD 29.80 7.3894672) (MMM 76.76 7.3894672) (MO 65.99 7.3894672) (MRK 34.42 7.3894672)
+(MSFT 25.36 7.3894672) (PFE 27.5 7.3894672) (PG 54.90 7.3894672) (SBC 23.8 7.3894672)
+(UTX 100.96 7.3894672) (VZ 36.75 7.3894672) (WMT 48.40 7.3894672) (XOM 56.50 7.3894672)))
+(:trade INTC 0.001932 :last 23.75)
+(:trade MSFT 0.001932 :last 25.36)
+(:trade INTC 0.011931 :last 23.75)
+(:trade MSFT 0.011931 :last 25.36)
+(:trade MSFT 0.041965 :last 25.32)
+(:trade UTX 0.067027 :last 101.39)
+...etc...
+
+Date messages encode date as (+ (* (- year 2000) 1000) julian-days). Weekday is dicey,
+so the tutorial deduces the Lisp weekday and stores that.
+
+Index messages define which tickers are in the index and their weights.
+Entries are: (ticker-symbol initial-price index-weight)
+
+Trade messages are (ticker-symbol ticker-minute :LAST price)
+Ticker-minute is time since open, in minutes. Negative indicates pre-open trading.
+
+To get the ball rolling, we just want to print out each trade as received, with the
+addition of an indicator as to which way the price moved: -1, 0, or 1 for down, unchanged, or up.
+
+For the index, we want to track the minute of the last trade affecting the index, the
+weighted index value, and the last move of each index entry.
+
+|#
+(defparameter *trc-trades* t)
+
+#+test
+(run-trading-day)
+
+(defun run-trading-day ()
+ (cell-reset)
+ (let ((*trc-trades* nil)
+ (t-day (make-be 'trading-day)))
+
+ ;; - always call CELLS-RESET when starting a test run
+ ;; - (make-be ...) -> (to-be (make-instance ...))
+ ;; - TO-BE jumpstarts a Cells instance into the flow. (FN to-be)
+ #+(or)
+ (with-open-file (t-data (make-pathname
+ :directory '(:absolute "0dev" "cells" "Use Cases" "dow-jones")
+ :name "trades0504" :type "txt"))
+ (with-metrics (nil t "run-trading-day")
+ (loop for message = (read t-data nil :eof)
+ until (eq message :eof)
+ do (count-it :dow-message)
+ (setf (message t-day) message)))
+ )
+
+ (with-open-file (t-data (make-pathname
+ :directory '(:absolute "0dev" "cells" "Use Cases" "dow-jones")
+ :name "stock-exchange" :type "lisp"))
+ (with-metrics (nil t "run-trading-day")
+ (loop with in-data = nil
+ do (if (not in-data)
+ (setf in-data (msg-start (read-line t-data nil :eof)))
+ (let ((message (read t-data nil :eof)))
+ (count-it :dow-message)
+ (if (eql (car message) :close)
+ (loop-finish)
+ (setf (message t-day) message)))))))
+
+ (trc "index value = " (value (car (indexes t-day))))))
+
+;; --- trading day ---------------------------------
+;;
+
+(defmodel trading-day ()
+ ((message :initarg :message :accessor message
+ :initform (c-in nil) ;; c-in -> c-input, how data enters a model (see FN c-input)
+ :cell :ephemeral) ;; handling transient phenomena in a steady-state paradigm (FN ephemeral)
+
+ (date :initarg :date :accessor date
+ :initform (c? (or .cache ;; advanced trick using prior value (see FN date/.cache)
+ (when (eql :date (car (^message)))
+ (destructuring-bind (&key date weekday)
+ (^message)
+ (declare (ignore weekday)) ;; derive from date
+ (encode-julian-date (+ 2000 (floor date 1000)) (mod date 1000)))))))
+
+ (weekday :initarg :weekday :accessor weekday
+ :initform (c? (when (^date)
+ (multiple-value-bind (second minute hour date month year day daylight-p zone)
+ (decode-universal-time (^date))
+ (declare (ignorable second minute hour date month year daylight-p zone))
+ day))))
+
+ ;; not much new here, but astute readers will wonder if this cell gets optimized away
+ ;; when (^date) on its second evaluation uses its .cache and gets optimized away.
+ ;;
+ ;; yes. Just checked to be sure.
+
+ (trade :cell :ephemeral :initarg :trade :accessor trade
+ :initform (c? (when (eql :trade (car (^message)))
+ (message-to-trade (^message)))))
+ ;;
+ ;; nothing new here, but note that again we use the :ephemeral option
+ ;;
+ (indexes :initarg :indexes :accessor indexes
+ :initform (c? (with-c-cache ('cons)
+ (when (eql :index (car (^message)))
+ (make-be 'index
+ :trading-day self
+ :index-def (second (^message)))))))
+ (tickers :cell nil :reader tickers :initform (make-hash-table :rehash-size 50))
+ ))
+
+
+(def-c-output trade ((self trading-day) trade) ;; FN def-c-output
+ (when trade ;; FN trade setf optimization
+ (count-it :raw-trades)
+ (push trade (trades (ensure-ticker self (trade-ticker-sym trade))))))
+
+(defun trading-day-ticker (day sym)
+ (gethash sym (tickers day)))
+
+(defun (setf trading-day-ticker) (ticker day sym)
+ (setf (gethash sym (tickers day)) ticker))
+
+(defun ensure-ticker (trading-day ticker-sym &optional price minute)
+ (or (trading-day-ticker trading-day ticker-sym)
+ (setf (trading-day-ticker trading-day ticker-sym)
+ (make-be 'ticker :ticker-sym ticker-sym
+ :trades (c-in (when price
+ (list (make-trade :ticker-sym ticker-sym
+ :minute minute :price price))))))))
+
+(defmodel ticker (model)
+ ((ticker-sym :cell nil :initarg :ticker-sym :reader ticker-sym)
+ (trades :initarg :trades :accessor trades :initform (c-in nil))
+ (last-trade-info :reader last-trade-info
+ :initform (c? (bwhen (trade (first (^trades)))
+ (bif (penult-trade (and (trade-price trade)
+ (find-if 'trade-price (rest (^trades)))))
+ (let* ((last (trade-price trade))
+ (penult (trade-price penult-trade))
+ (move (cond
+ ((< last penult) -1)
+ ((= last penult) 0)
+ (t 1))))
+ (values
+ (cons penult-trade move)
+ (if (zerop move) :no-propagate :propagate)))
+ (values (cons trade 0) :propagate)))))))
+
+(defun last-trade (ticker)
+ (car (last-trade-info ticker)))
+(defun last-move (ticker)
+ (cdr (last-trade-info ticker)))
+
+(defun ticker-price (ticker)
+ (bwhen (trade (last-trade ticker))
+ (trade-price trade)))
+
+(defun ticker-trade-minute (ticker)
+ (bwhen (trade (last-trade ticker))
+ (trade-minute trade)))
+
+(def-c-output trades ((self ticker)) ;; FN trades def-c-output
+ (when *trc-trades*
+ (loop for trade in (set-difference new-value old-value)
+ do (format t "~&at ~a min, ~a at ~a, change ~a"
+ (trade-minute trade) (ticker-sym self) (trade-price trade)
+ (or (last-move self) "")))))
+
+;; --- index ---------------------------------------------------
+
+(defmodel index ()
+ ((index-def :cell nil :initarg :index-def :initform nil :accessor index-def)
+ (trading-day :cell nil :initarg :trading-day :initform nil :accessor trading-day)
+ (ticker-weights :initarg :ticker-weights :accessor ticker-weights
+ :initform (c? (loop for (ticker-sym price weight) in (index-def self)
+ collecting (cons (ensure-ticker (trading-day self) ticker-sym price -60)
+ ;; whoa, a mid-rule to-be! (FN ticker-weights rule)
+ weight))))
+
+ (state :reader state
+ :initform (let ((moves (make-hash-table :size 50)))
+ (c-formula (:lazy nil) ;; do not re-compute on every trade (see FN lazy)
+ (count-it :index-state-calc)
+ (clrhash moves) ;; Re-use OK since fresh cons triggers dataflow (FN state rule)
+ (let ((minutes (loop for (ticker . nil) in (ticker-weights self)
+ maximizing (ticker-trade-minute ticker))))
+ (without-c-dependency ;; dependency on trade minute suffices (see FN without-c-dependency)
+ (loop for (ticker . weight) in (ticker-weights self)
+ summing (* weight (ticker-price ticker)) into value
+ do (setf (gethash (ticker-sym ticker) moves) (last-move ticker))
+ finally (return (list minutes value moves))))))))
+
+ (value :reader value :initform (c? (second (^state))))
+ ;;
+ ;; allows dependency on just value, which will not change on unchanged trades (FN value cell)
+ ))
+
+
+(defun index-minutes (index) (first (state index)))
+(defun index-moves (index) (third (state index)))
+(defun index-ticker-sym-move (index ticker-sym) (gethash ticker-sym (index-moves index)))
+(defun index-ticker-move (index ticker) (index-ticker-sym-move index (ticker-sym ticker)))
+
+(def-c-output value ((self index))
+ (when *trc-trades*
+ (trc "index time:" (index-minutes self) :value new-value :was old-value)))
+
+;;; --- trade ---------------------------------------------------------------------
+
+(defstruct trade minute ticker-sym price)
+
+(defun message-to-trade (message)
+ (destructuring-bind (ticker-sym ticker-min &key last) (rest message)
+ (make-trade
+ :ticker-sym ticker-sym
+ :minute ticker-min
+ :price last)))
+
+;;; --- utilities ---------------------------------------------------------
+
+(defun encode-julian-date (year julian)
+ (+ (encode-universal-time 0 0 0 1 1 year )
+ (* (1- julian) 86400))) ;; seconds in a day
+
+;; I am sorry, that is all there is to tell. So we have a mindless main loop and a few declarations
+;; and somehow we get all the functionality desired. [OK, granted, this is a pretty simple
+;; batch process which would not be too complicated in non-Cells form. In that regard, it
+;; is a good tutorial use case but does not show off Cells very much.] Anyway...
+;;
+;; It occurs to me that the above notes do not convey how the damn thing works. So let us walk
+;; thru a hand-execution of the above sample data.
+;;
+;; (make-be 'trading-day) -> (to-be (make-instance 'trading-day))
+;;
+;; Each ruled Cell gets evaluated. Each Cell slot -- constant, input, or ruled -- is output.
+;; So with trading-day:
+;;
+;; message is input, and has no associated output function
+;;
+;; date is evaluated:
+;;; (or .cache
+;;; (when (eql :date (car (^message)))
+;;; (destructuring-bind (&key date weekday)
+;;; (^message)
+;;; (declare (ignore weekday)) ;; derive from date
+;;; (encode-julian-date (+ 2000 (floor date 1000)) (mod date 1000)))))
+;;
+;; .cache is nil, but so is (message self). NIL is returned, there is no output.
+;; date now has a dependency on message.
+;;
+;; weekday is evaluated
+;;; (c? (when (^date)
+;;; (multiple-value-bind (second minute hour date month year day daylight-p zone)
+;;; (decode-universal-time (^date))
+;;; (declare (ignorable second minute hour date month year daylight-p zone))
+;;; day))))
+;; date is nil, so weekday is NIL but has a dependency on date. No output is defined.
+;;
+;; trade is evaluated
+;;; (c? (when (eql :trade (car (^message)))
+;;; (message-to-trade (^message)))))
+;; message is NIL, so NIL is returned. trade now has a dependency on message. The output
+;; method on trade is invoked, but has no interest in NIL new values.
+;;
+;; indexes is evaluated:
+;;; (with-c-cache ('cons)
+;;; (when (eql :index (car (^message)))
+;;; (make-be 'index
+;;; :trading-day self
+;;; :index-def (second (^message)))))))
+;; message is NIL, so NIL is returned, a dependency on message created. No output defined.
+;;
+;; (setf (message t-day) )
+;;
+;; Many rules are dispatched: date, trade, and indexes. Only date processes :date messages.
+;; it returns a converted date, and still has a dependency on message. Weekday has a dependency
+;; on date, so that rule gets dispatched. It returns a weekday calculated off the date, and
+;; keeps the dependency on that. Other rules return
+;; NIL, which is the same value they had before. Nothing else is done (and in this case, that
+;; would only have been to call the output method on trade.
+;;
+;; (setf (message t-day) )
+;;
+;; The date rule runs and returns its .cache without accessing any cell. The Cell internals
+;; optimize away the fact that date ever had a rule or any kind of cell. It sees weekday
+;; was a dependent on date and nothing else, so it optimizes that away, too. Slots end up
+;; with the last values calculated, and now look to other rules as if they were constant
+;; all along.
+;;
+;; The trade rule runs and comes up empty again. The indexes rule runs and adds a new
+;; index list to its current contents, which happens to be NIL.
+;;
+;;;; make-be is called on the index instance. Each slot gets processed in turn in a
+;;;; fashion similar to that for trading-day. When the ticker-weights rule runs, ticker
+;;;; instances for each ticker in the index are created and passed to TO-BE, in the
+;;;; function ensure-ticker. No dependencies are created since index-def is not a Cell,
+;;;; so the ticker-weights cell gets optimized away.
+;;;;
+;;;; as each ticker is created and processed by TO-BE:
+;;;;;;;
+;;;; the state rule is evaluated and computes an initial index state off the data
+;;;; provided in the index-def. state ends up with dependencies on each ticker in the
+;;;; index.
+;; [rest under construction]
+;;
+
+;;; =============================================================================
+;;; Footnotes
+;;; =============================================================================
+;
+;; --- FN to-be --------------------------------------
+;; TO-BE jumpstarts a Cells instance into the flow. Literally, as in
+;; the dataflow. It evaluates ruled slots to establish dependencies (those
+;; get established during evaluation) and in turn arrange for state change
+;; within the model to propagate to the instance's ruled Cells. It also
+;; DEF-C-OUTPUTs all cell slots so the outside world is consistent
+;; with the model state. More on def-c-output below.
+;
+;; --- FN c-input ------------------------------------
+;;
+;; c-in is short for c-input, which simply means imperative application code
+;; can SETF this slot. (Note that this is just the initform for this slot,
+;; which can be overridden by subclasses or at make-instance time, and if
+;; the override is not another C-IN or C-INPUT, then all bets are off. ie, The
+;; SETF ability depends on the type of Cell (if any) associated at run-time
+;; with the slot of an instance. It
+;; is not an attribute of the slot as with the :cell slot option discussed just below.
+;;
+;; Anyway, C-IN lets us make a lot of points about Cells.
+;;
+;; First, no model is
+;; an island; the dataflow has to start somewhere. Just as a VisiCalc spreadsheet
+;; has cells where you can type, say, different interest rates to see how that
+;; effects the rest of a financial model, a Cell-based application model needs
+;; some way to interface with the outside world, if only the mouse and keyboard
+;; of a GUI application.
+;;
+;; The way we do that is by having conventional application code feed (SETF) data into
+;; the dataflow model at what we call cell inputs. In a typical GUI app, this means
+;; having callbacks registered with the window manager. The callbacks then take their
+;; arguments (window events such as mouse-downs and key-presses) and setf that
+;; info to slots of a window or system instance modelling the window or operating
+;; system, slots mediated by c-input Cells.
+;;
+;; In this simple use case we have just one stream of external inputs (messages
+;; from some financial data service) being SETFed into one slot, the message
+;; slot of an instance of the trading-day class.
+;;
+;; Second, the Cells design enforces discipline. So in case you are
+;; wondering, no, if you do not bind a C-INPUT to a slot of an instance, you cannot
+;; SETF that slot from imperative code. (Aside: (SETF SLOT-VALUE) /is/ a back door
+;; allowing you to wreak havoc on your dataflow model if you so choose (but it will
+;; wreak havoc).)
+;;
+;; Third, you might wonder why slots meant as inputs cannot just have no Cell at all
+;; associated with them at run-time, and then have the Cell internals accept that
+;; as a SETF-able state. Well, it is a long story, but it turns out that a lot of
+;; Cells overhead can be avoided if we distinguish a slot whose value will never
+;; change from an input slot which will be SETF'ed. A simple example of a constant
+;; slot would be the bounding rectangle of a push button. Those values have to be
+;; Cells because in other graphical elements sharing the same superclass, the bounding
+;; rectangle changes. A good example is the win32-style scroll bar thumb, which changes
+;; size to reflect how much of the total file is visible. Anyway, it turns out that
+;; a significant performance boost comes from having Cells which happen to access
+;; a constant value not record a dependency on that value and, where a rule evaluation
+;; turns out not to access any non-constant other Cell slot, likewise convert the ruled
+;; slot into a constant slot. Sorry you asked?
+;;
+;; --- FN ephemeral -----------------------------------------------------------
+;;
+;; Whoa, here is an advanced topic. Ephemeral means "fleeting". Before getting into
+;; that, the other options for the :cell option are T and NIL. T is the default.
+;; NIL means you get a normal slot having nothing to do with Cells. Now about
+;; that :ephemeral option: Messages are
+;; like events: they happen, then they are no more. This is a problem for
+;; Cells, which like a VisiCalc spreadsheet model (say, your household budget)
+;; is all about steady-state occasionally perturbed by inputs. That is vague.
+;; Here is a concrete example: suppose you have some game where the user has
+;; to press a key when two randomly moving shapes overlap. You will have a hit rule
+;; that says (abbreviated somewhat):
+;;
+;; (and (eql (event *sys*) :keypress) (shapes-overlap-p *sys*))
+;;
+;; OK, the key is pressed but the shapes do not overlap. No cigar. Now a few
+;; seconds later the shapes do overlap. The key is not being pressed, but the
+;; EVENT slot of the *sys* instance (modelling the computer system) still
+;; says :keypress. bad news. Obviously we need to process an event and then
+;; clear the value before processing any other model input. Now perhaps we could
+;; simply have imperative code which says:
+;;
+;; (setf (event *sys*) :keypress)
+;; (setf (event *sys*) nil)
+;;
+;; But that is different. That suggests an application semantic in which the
+;; EVENT slot changes from :keypress to NIL. It will trigger all the usual
+;; dataflow, to see if the model should react. But in fact what we /really/
+;; need is /not/ to clear the EVENT slot. What we really need is
+;; ephemeral SETF behavior from a mechanism designed for steady-state.
+;; We need the EVENT slot to take on a value just long enough to perturb our
+;; model and then cease to be without fanfare.
+;;
+;; So we extend the Cells model with the :ephemeral option on a slot, and have
+;; Cell internals watch out for that and silently clear the slot once a value
+;; has been propagated to other Cells and output (again, outputs
+;; are discussed below.)
+;;
+;; A final newbie note: watch the bouncing options. Ephemerality is a slot option,
+;; not something one tailors to the instance. Think about it. Think about the
+;; slot names. "message", "event". We want to get ephemeral behavior for these
+;; slots no matter what cell (input or ruled) we choose to associate with them.
+;; So it is more convenient and reliable to endow the slot itself with ephemerality.
+;; in other cases we see different instances enjoying different Cell-ish qualities
+;; for the same slot, sometimes constant, sometimes computed, sometimes being
+;; SETFed by imperative code outside the dataflow model. These variations are
+;; then found in the type of runtime Cell associated with the Cell slot.
+;;
+;; --- FN date/.cache --------------------------------------------------
+;;
+;;
+;; There is a lot going on here, too, including some premature optimization.
+;;
+;; First of all, .cache is just a local variable, bound by the expansion
+;; of the C? macro to the latest value calculated for this rule. It starts out as NIL, so
+;; the rule next reads the message slot of the same trading-day instance. How so?
+;;
+;; ^message is a macro written by the defmodel macro. It expands simply to:
+;;
+;; (message self)
+;;
+;; It used to expand to more, including vital Cell plumbing. Now I keep it around just
+;; because I love that self-documenting quality. And yes, I have adopted the
+;; Smalltalk "self" convention over the C++ "this" convention. There is no need
+;; to use these (^macros), just code ( self) and you will establish a
+;; dependency on the message slot. What does dependency mean?
+;;
+;; Simply that the next time the message slot changes (the default test between old and
+;; new values is EQL, but can be overridden), the Cells engine will immediately kick
+;; the DATE rule to see if it wants to compute a different value.
+;;
+;; A very important point is that dependencies are established automatically simply
+;; by invoking the reader or accessor associated with a slot, and that this happens
+;; dynamically at run-time, not by inspection of code. A second point is that the
+;; dependency is established even if the read takes place in a called function.
+;;
+;; There is a backdoor. No dependencies are established in code wrapped by
+;; the macro WITHOUT-C-DEPENDENCY.
+;;
+;; Another important point is that dependencies are re-decided completely each time
+;; a rule is invoked. So this particular rule is an oddball: it will produce only one value, when a :date
+;; message is received
+;; and teh first non-NIL value is returned. On the next message (of any kind) .cache will be
+;; non-NIL and the rule will simply return that value.
+;; During this last evaluation the cell will not access, hence no longer
+;; depend on, the message slot or any other slot and it will get optimized away. This
+;; improves performance, since the message slot no longer bothers propagating to
+;; the date slot and Cell internals no longer have to invoke the rule. Otherwise, every
+;; new message for the entire day (none of which would be :date messages) would kick
+;; off this rule.
+;;
+;; --- FN with-c-cache ------------------------------------
+;;
+;; I am actually doing something new here. The idea is that again we deviate
+;; slightly from the spreadsheet paradigm and want to accumulate data
+;; from a stream of ephemeral values. Normally we calculate a slot value in
+;; its entirety from data at hand, even if only ephemerally. Here we want
+;; to add a newly computed result to a list of prior such results.
+;;
+;; with-c-cache will accept any two-argument function, and when the enclosed
+;; form returns a non-nil value, pass that and the .cache to the specified
+;; function.
+;;
+;; --- FN def-c-output --------------------------------------------
+;;
+;; Above is another optimization, and the long-awaited discussion of Cell
+;; output.
+;;
+;; Output reinforces the "no model is an island" theme. We create
+;; models to obtain interesting outputs from inputs, where the model
+;; provides the interest. For a RoboCup player simulation, the inputs are
+;; sensory information about the game, provided in a stream from a server
+;; application managing multiple client players and coaches. The outputs are
+;; messages to the server indicating player choices about turning, running,
+;; and kicking. In between, the game play model is supposed to compute
+;; actions producing more or less capable soccer play.
+;;
+;; --- FN trade setf optimization ---------------------------------------
+;
+;; But this is strange "output". It actually changes internal model state.
+;; It is no output at all, just feeding dataflow back into a different
+;; model input. Whassup?
+;;
+;; Like I said, it is an optimization. A ticker instance could have a
+;; rule which watched the message stream looking for trades on that ticker,
+;; but then every ticker would be watching the message stream.
+;;
+;; Instead, we simply leverage an "output" method to procedurally decide which
+;; ticker has been traded and directly add the trade to that ticker's list
+;; of trades.
+;;
+;; --- FN trades def-c-output --------------------------------------
+;;
+;; Now the above is a proper output. Merely a print trace to standard output, but
+;; that happens to be all the output we want just now. In a real trading application,
+;; there probably would not be an output on this slot. Some gui widget might "output"
+;; by telling the OS to redraw it, or some trader instance might decide to output
+;; a buy order to an exchange, but that is about it.
+;;
+;; --- FN ticker-weights rule --------------------------------------
+;;
+;; A curiosity here is that ensure-ticker will often be making and to-be-ing new model
+;; instances while this rule is running. No problem, though it would be possible to
+;; get into trouble if such destructive (well, constructive) operations triggered
+;; dataflow back to this same rule. Here we are safe; it does not. In fact...
+;;
+;; This rule runs once and then gets optimized away, because in this simple case
+;; index-def is a constant, not even a cell. Should we someday want to handle
+;; changes to an index during a trading-day, this would have to change.
+;;
+;; --- FN lazy ------------------------------------------------------
+;;
+;; Lazy ruled cells do not get calculated until someone asks their value,
+;; and once they are evaluated and dependencies have been established,
+;; they merely will be flagged "obsolete" should any of those dependencies
+;; change in value.
+;;
+;; --- FN state rule ------------------------------------------------
+;;
+;; c? ends up wrapping its body in a lambda form which becomes the rule for this
+;; slot, and here that lambda form will close over the MOVES hash-table. Neat, eh?
+;; What is going on is that we do not anticipate in the application design that
+;; any cell will depend in isolation on the move of one ticker in the index. So
+;; we can allocate just one hashtable at make-instance time and reuse that each
+;; time the rule gets evaluated. Cells depending on the state Cell will know
+;; when that aggregate value gets recomputed because the finally clause conses
+;; up a new list each time.
+;;
+;; --- FN without-c-dependency -------------------------------------
+;;
+;; Our application knowledge tells us the dependency on ticker minute will suffice
+;; to keep index state up to date, so we save a lot of internal cells overhead
+;; by taking a chance and disabling dependency creation within the wrapper
+;; with-c-output. (The danger is that someone later adds a desired dependency reference
+;; to the rule without noticing the wrapper.)
+;;
+;; --- FN value Cell --------------------------------------------------
+;;
+;; Weird, right? Well, we noticed that many trades came thru at the same price
+;; sequentially. The rule above for STATE gets kicked off on each trade, and the
+;; index gets recomputed. Because it is an aggregate, we get a new list for state
+;; even if the trade was at an unchanged priced and the index value does not change.
+;;
+;; Now suppose there was some BUY! rule which cared only about the index value, and not
+;; the latest minute traded of that value, which /would/ change if a new trade at
+;; an unchanged price were received. Because a new list gets consed up (never mind the
+;; new trade minute), The BUY! rule would get kicked off because of the new list in the
+;; the STATE slot. Not even overriding the default EQL test with EQUAL would work,
+;; because the trade minute would have changed.
+;;
+;; What to do? The above. Let VALUE get recalculated unnecessarily and return unchanged,
+;; then code the BUY! rule to use VALUE. VALUE will get kicked off, but not BUY!, which
+;; would likely be computationally intense.
+;;
+
+#| TRADEDATA
+(:date 5123 :weekday 3)
+(:index ((AA 29.30 7.3894672) (AIG 53.30 7.3894672)(AXP 53.00 7.3894672)
+(BA 59.87 7.3894672) (C 46.80 7.3894672) (CAT 87.58 7.3894672) (DD 47.74 7.3894672)
+(DIS 26.25 7.3894672) (GE 36.10 7.3894672) (GM 27.77 7.3894672) (HD 36.75 7.3894672)
+(HON 35.30 7.3894672) (HPQ 21.00 7.3894672) (IBM 76.47 7.3894672)
+(INTC 23.75 7.3894672) (JNJ 68.73 7.3894672) (JPM 35.50 7.3894672) (KO 43.76 7.3894672)
+(MCD 29.80 7.3894672) (MMM 76.76 7.3894672) (MO 65.99 7.3894672) (MRK 34.42 7.3894672)
+(MSFT 25.36 7.3894672) (PFE 27.5 7.3894672) (PG 54.90 7.3894672) (SBC 23.8 7.3894672)
+(UTX 100.96 7.3894672) (VZ 36.75 7.3894672) (WMT 48.40 7.3894672) (XOM 56.50 7.3894672)))
+(:trade INTC 0.001932 :last 23.75)
+(:trade MSFT 0.001932 :last 25.36)
+(:trade INTC 0.011931 :last 23.75)
+(:trade MSFT 0.011931 :last 25.36)
+(:trade MSFT 0.041965 :last 25.32)
+(:trade UTX 0.067027 :last 101.39)
+(:trade INTC 0.067062 :last 23.82)
+(:trade MSFT 0.070397 :last 25.37)
+(:trade INTC 0.070397 :last 23.82)
+(:trade MSFT 0.074167 :last 25.32)
+(:trade INTC 0.081800 :last 23.83)
+(:trade MSFT 0.097178 :last 25.33)
+(:trade MSFT 0.106488 :last 25.32)
+(:trade INTC 0.110410 :last 23.82)
+(:trade INTC 0.124263 :last 23.83)
+(:trade MSFT 0.130411 :last 25.33)
+(:trade INTC 0.143792 :last 23.81)
+(:trade MSFT 0.143792 :last 25.33)
+(:trade DIS 0.150441 :last 26.25)
+(:trade INTC 0.160480 :last 23.82)
+(:trade MSFT 0.160480 :last 25.33)
+(:trade HPQ 0.166767 :last 21.00)
+(:trade INTC 0.178832 :last 23.82)
+(:trade MSFT 0.183710 :last 25.33)
+(:trade DIS 0.187167 :last 26.25)
+(:trade AIG 0.193117 :last 53.60)
+(:trade INTC 0.196399 :last 23.81)
+(:trade PFE 0.200523 :last 27.51)
+(:trade MSFT 0.200523 :last 25.33)
+(:trade GE 0.202185 :last 36.11)
+(:trade MSFT 0.207199 :last 25.37)
+(:trade BA 0.209810 :last 59.75)
+(:trade INTC 0.210524 :last 23.83)
+(:trade MSFT 0.230556 :last 25.37)
+(:trade INTC 0.230556 :last 23.83)
+(:trade BA 0.234812 :last 59.76)
+(:trade MSFT 0.240580 :last 25.37)
+(:trade INTC 0.247233 :last 23.83)
+(:trade MSFT 0.256892 :last 25.37)
+(:trade UTX 0.257729 :last 101.33)
+(:trade GE 0.261942 :last 36.11)
+(:trade AIG 0.267072 :last 53.60)
+(:trade MSFT 0.272956 :last 25.36)
+(:trade INTC 0.275617 :last 23.83)
+(:trade WMT 0.280660 :last 48.40)
+(:trade SBC 0.284975 :last 23.78)
+(:trade GE 0.289229 :last 36.10)
+(:trade MSFT 0.292285 :last 25.35)
+(:trade DIS 0.295646 :last 26.30)
+(:trade HPQ 0.303630 :last 21.04)
+(:trade IBM 0.305629 :last 76.60)
+(:trade INTC 0.307321 :last 23.81)
+(:trade INTC 0.310671 :last 23.81)
+(:trade SBC 0.316331 :last 23.76)
+(:trade AIG 0.322292 :last 53.60)
+(:trade MSFT 0.324057 :last 25.36)
+(:trade MCD 0.324057 :last 29.79)
+(:trade UTX 0.325694 :last 101.15)
+(:trade INTC 0.327348 :last 23.81)
+(:trade IBM 0.336878 :last 76.60)
+(:trade MSFT 0.342414 :last 25.37)
+(:trade MSFT 0.345710 :last 25.37)
+(:trade HD 0.346983 :last 36.82)
+(:trade BA 0.347295 :last 59.80)
+(:trade MCD 0.360765 :last 29.80)
+(:trade HPQ 0.364067 :last 21.03)
+(:trade MSFT 0.364067 :last 25.37)
+(:trade SBC 0.367409 :last 23.79)
+(:trade MSFT 0.392928 :last 25.36)
+(:trade AIG 0.407453 :last 53.55)
+(:trade HPQ 0.407533 :last 21.03)
+(:trade SBC 0.407533 :last 23.79)
+(:trade MSFT 0.407533 :last 25.36)
+(:trade INTC 0.407533 :last 23.82)
+(:trade HPQ 0.407533 :last 21.03)
+(:trade HD 0.407545 :last 36.84)
+(:trade BA 0.413185 :last 59.80)
+(:trade INTC 0.414117 :last 23.81)
+(:trade PFE 0.420796 :last 27.51)
+(:trade DIS 0.424120 :last 26.30)
+(:trade AIG 0.424654 :last 53.58)
+(:trade INTC 0.427471 :last 23.81)
+(:trade XOM 0.429865 :last 56.85)
+(:trade IBM 0.431927 :last 76.65)
+(:trade HPQ 0.432407 :last 21.04)
+(:trade HD 0.432507 :last 36.84)
+(:trade MCD 0.439207 :last 29.80)
+(:trade MSFT 0.442518 :last 25.36)
+(:trade DIS 0.442518 :last 26.30)
+(:trade MSFT 0.453747 :last 25.36)
+(:trade PFE 0.458821 :last 27.52)
+(:trade IBM 0.459026 :last 76.66)
+(:trade HON 0.467342 :last 35.36)
+(:trade XOM 0.469083 :last 56.88)
+(:trade INTC 0.470871 :last 23.80)
+(:trade SBC 0.476712 :last 23.79)
+(:trade BA 0.476730 :last 59.80)
+(:trade MCD 0.479248 :last 29.80)
+(:trade HPQ 0.479248 :last 21.03)
+(:trade AIG 0.480883 :last 53.57)
+(:trade MSFT 0.482567 :last 25.36)
+(:trade INTC 0.482567 :last 23.80)
+(:trade IBM 0.484223 :last 76.73)
+(:trade MSFT 0.494243 :last 25.36)
+(:trade AIG 0.497551 :last 53.57)
+(:trade PFE 0.497569 :last 27.53)
+(:trade INTC 0.504245 :last 23.80)
+(:trade HD 0.504660 :last 36.84)
+(:trade IBM 0.504849 :last 76.73)
+(:trade GM 0.507621 :last 30.53)
+(:trade SBC 0.511484 :last 23.79)
+(:trade HPQ 0.514265 :last 21.04)
+(:trade HD 0.514798 :last 36.85)
+(:trade MSFT 0.517601 :last 25.32)
+(:trade WMT 0.524286 :last 48.46)
+(:trade IBM 0.524286 :last 76.74)
+(:trade INTC 0.529220 :last 23.80)
+(:trade HPQ 0.536813 :last 21.04)
+(:trade PG 0.537627 :last 54.91)
+(:trade PFE 0.540979 :last 27.54)
+(:trade INTC 0.544290 :last 23.80)
+(:trade PG 0.547549 :last 54.91)
+(:trade XOM 0.547624 :last 56.85)
+(:trade HON 0.547687 :last 35.40)
+(:trade UTX 0.550986 :last 101.33)
+(:trade HD 0.555694 :last 36.85)
+(:trade MSFT 0.560792 :last 25.35)
+(:trade INTC 0.564337 :last 23.80)
+(:trade XOM 0.566779 :last 56.85)
+(:trade BA 0.567359 :last 59.81)
+(:trade HON 0.581023 :last 35.41)
+(:trade INTC 0.589796 :last 23.80)
+(:trade BA 0.596050 :last 59.80)
+(:trade CAT 0.612134 :last 87.83)
+(:trade WMT 0.618386 :last 48.44)
+(:trade INTC 0.620474 :last 23.80)
+(:trade MCD 0.624417 :last 29.80)
+(:trade MSFT 0.627748 :last 25.35)
+(:trade BA 0.630881 :last 59.83)
+(:trade AIG 0.634410 :last 53.56)
+(:trade MCD 0.637785 :last 29.79)
+(:trade HON 0.637785 :last 35.40)
+(:trade INTC 0.649577 :last 23.79)
+(:trade BA 0.655889 :last 59.85)
+(:trade HD 0.662287 :last 36.83)
+(:trade AIG 0.669431 :last 53.53)
+(:trade HON 0.671133 :last 35.44)
+(:trade MCD 0.674457 :last 29.79)
+(:trade MO 0.683443 :last 66.20)
+(:trade INTC 0.687668 :last 23.79)
+(:trade MSFT 0.691181 :last 25.35)
+(:trade PFE 0.694477 :last 27.54)
+(:trade MSFT 0.720936 :last 25.35)
+(:trade GM 0.726237 :last 30.50)
+(:trade WMT 0.730056 :last 48.40)
+(:trade IBM 0.740544 :last 76.74)
+(:trade PG 0.744569 :last 54.91)
+(:trade HON 0.752103 :last 35.46)
+(:trade CAT 0.753014 :last 87.85)
+(:trade MO 0.763918 :last 66.20)
+(:trade MSFT 0.764592 :last 25.35)
+(:trade HON 0.771289 :last 35.46)
+(:trade BA 0.772935 :last 59.75)
+(:trade JPM 0.773229 :last 35.51)
+(:trade MSFT 0.774612 :last 25.35)
+(:trade PG 0.776267 :last 54.91)
+(:trade AIG 0.781168 :last 53.54)
+(:trade HD 0.782946 :last 36.87)
+(:trade CAT 0.784614 :last 87.85)
+(:trade XOM 0.786285 :last 56.88)
+(:trade MSFT 0.792950 :last 25.36)
+(:trade UTX 0.794689 :last 101.40)
+(:trade INTC 0.797969 :last 23.78)
+(:trade IBM 0.801301 :last 76.74)
+(:trade HD 0.809652 :last 36.87)
+(:trade JPM 0.809652 :last 35.51)
+(:trade MSFT 0.811489 :last 25.37)
+(:trade MO 0.812994 :last 66.20)
+(:trade IBM 0.816563 :last 76.75)
+(:trade MCD 0.828046 :last 29.77)
+(:trade UTX 0.829055 :last 101.37)
+(:trade MSFT 0.833420 :last 25.36)
+(:trade GM 0.837650 :last 30.50)
+(:trade IBM 0.838004 :last 76.75)
+(:trade HON 0.838531 :last 35.47)
+(:trade XOM 0.841372 :last 56.88)
+(:trade MCD 0.841894 :last 29.78)
+(:trade KO 0.853202 :last 43.98)
+(:trade UTX 0.858235 :last 101.38)
+(:trade INTC 0.864331 :last 23.82)
+(:trade PFE 0.869104 :last 27.55)
+(:trade HON 0.873063 :last 35.48)
+(:trade IBM 0.873095 :last 76.77)
+(:trade HD 0.873132 :last 36.87)
+(:trade XOM 0.884796 :last 56.86)
+(:trade UTX 0.884820 :last 101.38)
+(:trade HON 0.888886 :last 35.48)
+(:trade INTC 0.891420 :last 23.81)
+(:trade CAT 0.895715 :last 87.86)
+(:trade MO 0.898111 :last nil) ;; 66.19)
+(:trade XOM 0.898111 :last 56.87)
+(:trade IBM 0.899775 :last 76.78)
+(:trade BA 0.899775 :last 59.83)
+(:trade MSFT 0.901469 :last 25.38)
+(:trade HD 0.906673 :last 36.86)
+(:trade HPQ 0.908113 :last 21.03)
+(:trade CAT 0.916467 :last 87.85)
+(:trade BA 0.916467 :last 59.83)
+(:trade MSFT 0.918773 :last 25.38)
+(:trade PFE 0.926271 :last 27.57)
+(:trade MO 0.926288 :last 66.18)
+(:trade WMT 0.929791 :last 48.40)
+(:trade KO 0.932333 :last 43.98)
+(:trade JNJ 0.933224 :last 68.15)
+(:trade PG 0.936516 :last 54.91)
+(:trade INTC 0.938989 :last 23.81)
+(:trade IBM 0.942596 :last 76.78)
+(:trade XOM 0.944052 :last 56.89)
+(:trade INTC 0.944885 :last 23.81)
+(:trade BA 0.946486 :last 59.85)
+(:trade IBM 0.958178 :last 76.78)
+(:trade INTC 0.959853 :last 23.81)
+(:trade JPM 0.959897 :last 35.50)
+(:trade WMT 0.961498 :last 48.40)
+(:trade MCD 0.963195 :last 29.77)
+(:trade HPQ 0.966525 :last 21.03)
+(:trade AIG 0.968663 :last 53.54)
+(:trade XOM 0.978210 :last 56.89)
+(:trade AIG 0.979896 :last 53.55)
+(:trade CAT 0.979896 :last 87.85)
+(:trade MCD 0.984732 :last 29.77)
+(:trade PG 0.985307 :last 54.90)
+(:trade WMT 0.995716 :last 48.41)
+(:trade MSFT 1.005256 :last 25.38)
+(:trade PFE 1.005256 :last 27.55)
+(:trade JPM 1.008448 :last 35.48)
+(:trade CAT 1.011343 :last 87.86)
+(:trade XOM 1.011825 :last 56.88)
+(:trade INTC 1.012667 :last 23.79)
+(:trade JNJ 1.018655 :last 68.15)
+(:trade KO 1.021589 :last 43.99)
+(:trade INTC 1.026597 :last 23.78)
+(:trade HD 1.029577 :last 36.85)
+(:trade MSFT 1.029936 :last 25.39)
+(:trade JPM 1.033267 :last 35.49)
+(:trade C 1.064996 :last 46.80)
+(:trade CAT 1.065946 :last 87.85)
+(:trade MCD 1.066687 :last 29.75)
+(:trade MRK 1.066687 :last 34.33)
+(:trade PFE 1.066687 :last 27.55)
+(:trade INTC 1.066687 :last 23.79)
+(:trade INTC 1.066687 :last 23.79)
+(:trade XOM 1.068360 :last 56.88)
+(:trade JPM 1.068360 :last 35.49)
+(:trade XOM 1.068360 :last 56.89)
+(:trade KO 1.068360 :last 43.99)
+(:trade MRK 1.070274 :last 34.34)
+(:trade HON 1.073312 :last 35.49)
+(:trade PFE 1.080025 :last 27.55)
+(:trade MCD 1.080025 :last 29.75)
+(:trade INTC 1.080025 :last 23.79)
+(:trade AIG 1.083337 :last 53.55)
+(:trade GM 1.083420 :last 30.55)
+(:trade XOM 1.086739 :last 56.89)
+(:trade HON 1.093425 :last 35.49)
+(:trade HPQ 1.093425 :last 21.03)
+(:trade INTC 1.093425 :last 23.79)
+(:trade MSFT 1.093425 :last 25.37)
+(:trade JPM 1.098339 :last 35.49)
+(:trade IBM 1.099113 :last 76.86)
+(:trade XOM 1.104257 :last 56.89)
+(:trade MCD 1.104268 :last 29.74)
+(:trade GE 1.108379 :last 36.14)
+(:trade MSFT 1.108408 :last 25.40)
+(:trade XOM 1.115052 :last 56.89)
+(:trade JPM 1.118397 :last 35.50)
+(:trade GM 1.118397 :last 30.55)
+(:trade C 1.125426 :last 46.78)
+(:trade MCD 1.132390 :last 29.74)
+(:trade WMT 1.133494 :last 48.40)
+(:trade MRK 1.135099 :last 34.33)
+(:trade MSFT 1.135099 :last 25.39)
+(:trade INTC 1.135099 :last 23.78)
+(:trade INTC 1.146096 :last 23.79)
+(:trade KO 1.146108 :last 43.99)
+(:trade WMT 1.155346 :last 48.41)
+(:trade PG 1.158447 :last 54.90)
+(:trade WMT 1.162645 :last 48.41)
+(:trade HON 1.162660 :last 35.52)
+(:trade KO 1.162672 :last 43.98)
+(:trade JNJ 1.166783 :last 68.20)
+(:trade DIS 1.166815 :last 26.34)
+(:trade HD 1.166856 :last 36.90)
+(:trade MCD 1.171129 :last 29.74)
+(:trade INTC 1.175130 :last 23.79)
+(:trade JPM 1.178485 :last 35.50)
+(:trade KO 1.178485 :last 43.98)
+(:trade MSFT 1.184447 :last 25.39)
+(:trade AIG 1.191811 :last 53.56)
+(:trade WMT 1.195138 :last 48.41)
+(:trade MSFT 1.199050 :last 25.39)
+(:trade MO 1.201440 :last 66.18)
+(:trade INTC 1.201841 :last 23.80)
+(:trade DIS 1.201841 :last 26.34)
+(:trade JNJ 1.202292 :last 68.20)
+(:trade C 1.205172 :last 46.79)
+(:trade KO 1.205172 :last 43.98)
+(:trade WMT 1.209557 :last 48.40)
+(:trade INTC 1.209927 :last 23.79)
+(:trade VZ 1.209962 :last 34.75)
+(:trade MSFT 1.213558 :last 25.37)
+(:trade C 1.220169 :last 46.79)
+(:trade DIS 1.220225 :last 26.34)
+(:trade PFE 1.220225 :last 27.55)
+(:trade JNJ 1.220921 :last 68.20)
+(:trade MMM 1.223614 :last 76.70)
+(:trade INTC 1.226875 :last 23.79)
+(:trade DIS 1.230230 :last 26.34)
+(:trade HPQ 1.230230 :last 21.03)
+(:trade HON 1.230230 :last 35.52)
+(:trade PFE 1.230230 :last 27.56)
+(:trade SBC 1.230230 :last 23.78)
+(:trade C 1.236915 :last 46.79)
+(:trade MSFT 1.240577 :last 25.40)
+(:trade DIS 1.243960 :last 26.34)
+(:trade SBC 1.250258 :last 23.78)
+(:trade MCD 1.250258 :last 29.74)
+(:trade MSFT 1.250258 :last 25.40)
+(:trade INTC 1.253588 :last 23.79)
+(:trade HON 1.253588 :last 35.53)
+(:trade MCD 1.257704 :last 29.74)
+(:trade MSFT 1.262803 :last 25.37)
+(:trade KO 1.271926 :last 43.99)
+(:trade JPM 1.271926 :last 35.51)
+(:trade VZ 1.276339 :last 34.75)
+(:trade MSFT 1.280283 :last 25.40)
+(:trade HPQ 1.280283 :last 21.03)
+(:trade DIS 1.288624 :last 26.34)
+(:trade GE 1.288664 :last 36.14)
+(:trade JPM 1.288664 :last 35.51)
+(:trade AIG 1.290300 :last 53.59)
+(:trade CAT 1.290300 :last 87.86)
+(:trade IBM 1.290300 :last 76.85)
+(:trade SBC 1.291940 :last 23.77)
+(:trade XOM 1.301948 :last 56.88)
+(:trade DIS 1.303625 :last 26.34)
+(:trade AIG 1.304047 :last 53.60)
+(:trade KO 1.305316 :last 43.99)
+(:trade JPM 1.305316 :last 35.51)
+(:trade C 1.305316 :last 46.79)
+(:trade KO 1.314761 :last 43.99)
+(:trade DIS 1.316972 :last 26.35)
+(:trade HON 1.316972 :last 35.54)
+(:trade CAT 1.317022 :last 87.86)
+(:trade IBM 1.317022 :last 76.85)
+(:trade GE 1.318640 :last 36.15)
+(:trade WMT 1.320354 :last 48.41)
+(:trade HPQ 1.322354 :last 21.04)
+(:trade AIG 1.331152 :last 53.59)
+(:close)
+|#
+
+(defun msg-start (m)
+ (search "TRADEDATA" m))
+
Added: dependencies/trunk/cells/cell-types.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cell-types.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,190 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(defstruct (cell (:conc-name c-))
+ model
+ slot-name
+ value
+
+ inputp ;; t for old c-variable class
+ synaptic
+ (caller-store (make-fifo-queue) :type cons) ;; (C3) probably better to notify callers FIFO
+
+ (state :nascent :type symbol) ;; :nascent, :awake, :optimized-away
+ (value-state :unbound :type symbol) ;; {:unbound | :unevaluated | :uncurrent | :valid}
+ ; uncurrent (aka dirty) new for 06-10-15. we need this so
+ ; c-quiesce can force a caller to update when asked
+ ; in case the owner of the quiesced cell goes out of existence
+ ; in a way the caller will not see via any kids dependency. Saw
+ ; this one coming a long time ago: depending on cell X implies
+ ; a dependency on the existence of instance owning X
+ (pulse 0 :type fixnum)
+ (pulse-last-changed 0 :type fixnum) ;; lazys can miss changes by missing change of X followed by unchange of X in subsequent DP
+ (pulse-observed 0 :type fixnum)
+ lazy
+ (optimize t)
+ debug
+ md-info)
+
+
+
+;_____________________ print __________________________________
+
+#+sigh
+(defmethod print-object :before ((c cell) stream)
+ (declare (ignorable stream))
+ #+shhh (unless (or *stop* *print-readably*)
+ (format stream "[~a~a:" (if (c-inputp c) "i" "?")
+ (cond
+ ((null (c-model c)) #\0)
+ ((eq :eternal-rest (md-state (c-model c))) #\_)
+ ((not (c-currentp c)) #\#)
+ (t #\space)))))
+
+(defmethod print-object ((c cell) stream)
+ (declare (ignorable stream))
+ (if *stop*
+ (format stream "<~d:~a ~a/~a = ~a>"
+ (c-pulse c)
+ (subseq (string (c-state c)) 0 1)
+ (symbol-name (or (c-slot-name c) :anoncell))
+ (md-name (c-model c))
+ (type-of (c-value c)))
+ (let ((*print-circle* t))
+ #+failsafe (format stream "~a/~a" (c-model c)(c-slot-name c))
+ (if *print-readably*
+ (call-next-method)
+ (progn
+ (c-print-value c stream)
+ (format stream "<~d:~a ~a/~a = ~a>"
+ (c-pulse c)
+ (subseq (string (c-state c)) 0 1)
+ (symbol-name (or (c-slot-name c) :anoncell))
+ (print-cell-model (c-model c))
+ (if (consp (c-value c))
+ "LST" (c-value c))))))))
+
+(export! print-cell-model)
+
+(defgeneric print-cell-model (md)
+ (:method (other) (print-object other nil)))
+
+(defmethod trcp :around ((c cell))
+ (and ;*c-debug*
+ (or (c-debug c)
+ (call-next-method))))
+
+(defun c-callers (c)
+ "Make it easier to change implementation"
+ (fifo-data (c-caller-store c)))
+
+(defun caller-ensure (used new-caller)
+ (unless (find new-caller (c-callers used))
+ (trc nil "caller-ensure fifo-adding new-caller" new-caller :used used)
+ (fifo-add (c-caller-store used) new-caller)))
+
+(defun caller-drop (used caller)
+ (fifo-delete (c-caller-store used) caller))
+
+; --- ephemerality --------------------------------------------------
+;
+; Not a type, but an option to the :cell parameter of defmodel
+;
+(defun ephemeral-p (c)
+ (eql :ephemeral (md-slot-cell-type (type-of (c-model c)) (c-slot-name c))))
+
+(defun ephemeral-reset (c)
+ (when (ephemeral-p c) ;; so caller does not need to worry about this
+ ;
+ ; as of Cells3 we defer resetting ephemerals because everything
+ ; else gets deferred and we cannot /really/ reset it until
+ ; within finish_business we are sure all callers have been recalculated
+ ; and all outputs completed.
+ ;
+ ; ;; good q: what does (setf 'x) return? historically nil, but...?
+ ;
+ ;;(trcx bingo-ephem c)
+ (with-integrity (:ephemeral-reset c)
+ (trc nil "!!!!!!!!!!!!!! ephemeral-reset resetting:" c)
+ (md-slot-value-store (c-model c) (c-slot-name c) nil)
+ (setf (c-value c) nil))))
+
+; -----------------------------------------------------
+
+(defun c-validate (self c)
+ (when (not (and (c-slot-name c) (c-model c)))
+ (format t "~&unadopted cell: ~s md:~s" c self)
+ (c-break "unadopted cell ~a ~a" self c)
+ (error 'c-unadopted :cell c)))
+
+(defstruct (c-ruled
+ (:include cell)
+ (:conc-name cr-))
+ (code nil :type list) ;; /// feature this out on production build
+ rule)
+
+(defun c-optimized-away-p (c)
+ (eq :optimized-away (c-state c)))
+
+;----------------------------
+
+(defmethod trcp-slot (self slot-name)
+ (declare (ignore self slot-name)))
+
+(defstruct (c-dependent
+ (:include c-ruled)
+ (:conc-name cd-))
+ ;; chop (synapses nil :type list)
+ (useds nil :type list)
+ (usage (blank-usage-mask)))
+
+(defun blank-usage-mask ()
+ (make-array 16 :element-type 'bit
+ :initial-element 0))
+
+(defstruct (c-drifter
+ (:include c-dependent)))
+
+(defstruct (c-drifter-absolute
+ (:include c-drifter)))
+
+;_____________________ accessors __________________________________
+
+(defmethod c-useds (other) (declare (ignore other)))
+(defmethod c-useds ((c c-dependent)) (cd-useds c))
+
+(defun c-validp (c)
+ (eql (c-value-state c) :valid))
+
+(defun c-unboundp (c)
+ (eql :unbound (c-value-state c)))
+
+
+;__________________
+
+(defmethod c-print-value ((c c-ruled) stream)
+ (format stream "~a" (cond ((c-validp c) (cons (c-value c) ""))
+ ((c-unboundp c) "")
+ ((not (c-currentp c)) "dirty")
+ (t ""))))
+
+(defmethod c-print-value (c stream)
+ (declare (ignore c stream)))
+
Added: dependencies/trunk/cells/cells-manifesto.txt
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-manifesto.txt Tue Jan 26 15:20:07 2010
@@ -0,0 +1,592 @@
+In the text that follows, [xxx] signifies a footnote named "xxx" and
+listed alphabetically at the end.
+
+Summary
+-------
+Cells is a mature, stable extension to CLOS[impl] allowing one to create classes
+whose instances can have slot values determined by instance-specific formulas.
+
+Example
+-------
+For example, in a text editor application we might have (condensed):
+
+ (make-instance 'menu-item
+ :label "Cut"
+ :enabled (c? (bwhen (f (focus *window*))
+ (and (typep f 'text-widget)
+ (selection-range f)))))
+
+Translated, the enabled state of the Cut menu item follows
+whether or not the user is focused on a text-edit widget and
+whether they have in fact selected a range of text.
+
+Meanwhile, the selection-range rule might be:
+
+(let (start)
+ (c? (if (mouse-down? .w.)
+ (bwhen (c (mouse-pos-to-char self (mouse-pos .w.)))
+ (if start
+ (list start c)
+ (setf start c)))
+ (setf start nil))))
+
+Now the only imperative code needed is some glue reading the OS event loop
+converting raw mouse down and mouse move events into window (the .w. symbol-macro)
+attributes such as mouse-down? and mouse-pos. The desired functionality is achieved
+by declarative rules which (like selection-range above) are entirely responsible for
+deciding the selection range.
+
+A final trick comes from slot observers. Suppose we are thinly wrapping a C GUI and need to
+do something in the C library to actually make menu items available or not.
+It might look something like this:
+
+ (defobserver enabled ((self menu-item) new-value old-value old-value-bound?)
+ (menu-item-set (c-ptr self) (if new-value 1 0)))
+
+ie, Some model attributes must be propagated outside the model as they change, and observers
+are callbacks we can provide to handle change.
+
+Motivation
+----------
+As a child I watched my father toil at home for hours over paper
+spreadsheets with pencil and slide rule. After he changed one value,
+he had to propagate that change to other cells by first remembering
+which other ones included the changed cell in their computation.
+Then he had to do the calculations for those, erase, enter...
+and then repeat that process to propagate those changes in a
+cascade across the paper.
+
+VisiCalc let my father take the formula he had in mind and
+put it into (declare it to) the electronic spreadsheet. Then VisiCalc
+could do the tedious work: recalculating, knowing what to recalculate,
+and knowing in what order to recalculate.
+
+Cells do for programmers what electronic spreadsheets did for my father.
+Without Cells, CLOS slots are like cells of a paper spreadsheet.
+A single key-down event can cause a cascade of change throughout an
+application. The programmer has to arrange for it all to happen,
+all in the right order: delete any selected text, insert
+the new character, re-wrap the text, update the undo mechanism, revisit
+the menu statuses ("Cut" is no longer enabled), update the scroll bars,
+possibly scroll the window, flag the file as unsaved...
+
+Here is a real-world case study:
+
+"The last company I worked with made a product that was a control unit
+for some mechanical devices, presenting both sensor readings coming in
+from those devices and an interface to program the devices. Consider
+it like a very sophisticated microwave oven, perhaps with a
+temperature probe.
+
+"The UI code was a frighteningly complex rat's nest. Input data
+arriving from the sensors changed certain state values, which caused
+the display to update, but the system state also changed, and rules
+had to be evaluated, the outcome of which might be tuning to the
+running job or warning messages presented to the user, and in the
+meantime the user may be adjusting the running job. I'm sure there are
+even more interactions I'm leaving out.
+
+"There was no "large idea" in this code to organize these dependencies
+or orchestrate the data flow. The individual facilities were
+well-formed enough: "message" input and output, GUI widgets and forms,
+real-world entities modeled as entities in the code. However, the
+connections between these things were ad-hoc and not formalized. Every
+change to the system would provoke defects, and the failure usually
+involved not propagating some event, propagating it at the wrong time,
+or propagating it to the wrong recipients."
+ --- Steven Harris, on comp.lang.lisp
+
+What Mr. Harris describes is what Fred Brooks [bullet] said was an essential
+property of software development, meaning by essential that there was no
+way around it, and thus his prediction that a software silver bullet was
+in principle impossible.
+
+Which brings us to Cells. See also [axiom] Phillip Eby's developing axiomatic
+definition he is developing in support of Ryan Forseth's SoC project. Mr. Eby was
+inspired by his involvement to develop Trellis, his own Cells work-alike library
+for Python.
+
+DEFMODEL and Slot types
+-----------------------
+Classes, some of whose slots may be mediated by Cells, are defined by DEFMODEL, which is exactly
+like DEFCLASS but adds support for two slot definition options, :cell and :unchanged-if. Classes
+defined by DEFMODEL can inherit from normal CLOS classes.
+
+New slot definition options
+----------------------------
+
+ :cell {nil | t | :ephemeral}
+
+:cell is optional. The default is ":cell t", meaning the Cells engine will manage the slot to give
+it the spreadsheet-like characteristics. Specifying NIL signifies that this slot is entirely
+outside any handling by the Cells engine; it is just a plain CLOS slot.
+
+This next bit will not make sense until we have explained propagation of state change, but
+specifying :ephemeral causes the Cells engine to reset the apparent slot
+value to NIL immediately and only after fully propagating any value assumed by the slot, either
+by assignment to an input Cell (the vastly more common case) or by a rule calculation.
+
+Ephemeral cells are necessary to correctly model events in the otherwise steady-state
+spreadsheet paradigm.
+
+ :unchanged-if
+
+Specifying :unchanged-if is optional. [Come to think of it, it should be an error to specify
+both :cell nil and :unchanged-if.] If specified, the named function is a predicate
+of two arguments, the new and old value in that order. The predicate determines if a subsequent
+slot value (either computed or assigned to an input) is unchanged in the sense that no propagation
+is necessary, either to dependent ruled cells or (getting ahead of ourselves again) "on change" observers.
+The default unchanged test is EQL.
+
+Cell types
+----------
+The Cells library allows the programmer to specify at make-instance time that a Cell
+slot of an instance be mediated for the life of that instance by one of:
+
+ -- a so-called "input" Cell;
+ -- a "ruled" Cell; or
+ -- no Cell at all.
+
+Note that different instances of the same class may do different things Cells-wise with the same slot.
+One label widget may have a fixed width of 42 and text "Hi, Mom!", where another might have
+an input Cell mediating the text (so edit logic can assign new values as the user types) and a
+rule mediating the width so the widget can have a minimum width of 42(so it does not disappear altogether)
+yet grow based on text length and relevant font metrics to always leave room for one more character
+(if the GUI design calls for that).
+
+To summarize, the class specification supplied with DEFMODEL specifies whether a slot can /ever/
+be managed by the Cells engine. For those that can, at and only at instance initialization time
+different instances can have different Cell types and rules specified to mediate the same slot.
+
+Input Cells
+-----------
+A slot mediated by an input Cell may be assigned new values at runtime. These are how Cell-based models
+get data from the world outside the model -- it cannot be rules all the way down. Typically, these
+input assignements are made by code polling OS events via some GetNextEvent API call, or by callbacks
+registered with an event system such as win32 WindowProc functions. Other code may poll sockets or
+serial inputs from an external device.
+
+Ruled Cells
+-----------
+Ruled Cells come with an instance-specific rule in the form of an anonymous function of two variables,
+the instance owning the slot and the prior value (if any) computed by the rule. These rules consist of
+arbitrarily complex Common Lisp code, and are invoked immediately after instance initialization (but see
+the next bit on lazy cells).
+
+When a rule runs, any dynamic read (either expressly in the rule source or during the execution of
+some function invoked by the rule) of a slot of any instance mediated by a Cell of any type establishes a
+runtime dependency of the ruled cell on the slot of the instance that was read. Note then that thanks
+to code branching, dependencies can vary after every rule invocation.
+
+Lazy Ruled Cells
+----------------
+Laziness is cell-specific, applies only to ruled cells, and comes in four varieties:
+
+ :once-asked -- this will get evaluated and "observed" on initialization, but then not get reevaluated
+immediately if dependencies change, rather only when read by application code.
+
+ :until-asked -- this does not get evaluated/observed until read by application code, but then it becomes
+un-lazy, eagerly reevaluated as soon as any dependency changes (not waiting until asked).
+
+ :always -- not evaluated/observed until read, and not reevaluated until read after a dependency changes.
+
+Dataflow
+--------
+When application code assigns a new value to an input Cell (a quick way of saying an instance slot mediated by
+an input Cell) -- typically by code polling OS events or a socket or an input device -- a cascade of recalculation
+ensues to bring direct and indirect ruled dependents current with the new value assigned to the input Cell.
+
+No Cell at All
+--------------
+Because of all that, it is an error to assign a new value to a slot of an instance not mediated by any Cell.
+The Cells engine can do a handy optimization by treating such slots as constants and not creating dependencies when ruled
+Cells read these. But then we cannot let these Cells vary and still guarantee data integrity, because
+we no longer know who else to update in light of such variation. The optimization, by the way, extends to
+eliminating ruled Cells which, after any computation, end up not depending on any other cell.
+
+Again, note that this is different from specifying ":cell nil" for some slot. Here, the Cells engine
+has been told to manage some slot, but for some instance the slot has been authored to bear some value
+for the lifetime of that instance.
+
+Observers
+---------
+To allow the emergent animated data model to operate usefully on the world outside the model--if only to
+update the screen--programmers may specify so-called observer callbacks dispatched according to: slot name,
+instance, new value, old value, and whether the old value actually existed (false only on the first go).
+Observers are inherited according to the rules of CLOS class inheritance. If multiple primary observer
+methods apply because of inheritance, they all get run, most specific last.
+
+ie, observers are a GF with PROGN method combination.
+
+Observers get called in two circumstances: as part of Model object initialization, in a processing step
+just after CLOS instance initialization, and when a slot changes value. Any observer of a Cell slot
+is guaranteed to be called at least once during intialization even if a cell slot is bound to a constant
+or if it is an input or ruled Cell that never changes value.
+
+It is legal for observer code to assign to input Cells, but (a) special syntax is required to defer execution
+until the observed state change has fully propagated; and (b) doing so compromises the declarative
+quality of an application -- one can no longer look to one rule to see how a slot (in this case the
+input slot being assigned by the observer) gets its value. A reasonable usage might be one with
+a cycle, where changing slot A requires a change to slot B, and changing slot B requires a change to
+slot A, such as the scroll thumb position and the amount a document has been scrolled.
+
+Finally, to make it possible for such a declarative model to talk intelligibly to imperative systems such as
+Tcl/Tk which sometimes requires a precise sequence of commands for something to work at all, a mechanism exists by
+which client code can (a) queue tasks for execution after a data change has fully propagated and (b) process
+those tasks with a client-supplied handler. Tasks are queued with arbitrary keying data which can be used by
+the handler to sort or compress the queued tasks.
+
+
+Data Integrity
+--------------
+When application code assigns to some input cell X, the Cells engine guarantees:
+
+ - recomputation exactly once of all and only state affected by the change to X, directly or indirectly through
+ some intermediate datapoint. note that if A depends on B, and B depends on X, when B gets recalculated
+ it may come up with the same value as before. In this case A is not considered to have been affected
+ by the change to X and will not be recomputed.
+
+ - recomputations, when they read other datapoints, must see only values current with the new value of X.
+ Example: if A depends on B and X, and B depends on X, when X changes and A reads B and X to compute a
+ new value, B must return a value recomputed from the new value of X.
+
+ - similarly, client observer callbacks must see only values current with the new value of X; and
+
+ - a corollary: should a client observer SETF a datapoint Y, all the above must
+ happen with values current with not just X, but also with the value of Y /prior/
+ to the change to Y.
+
+ - Deferred "client" code must see only values current with X and not any values current with some
+ subsequent change to Y queued by an observer
+
+Benefits
+--------
+Program state guaranteed to be self-consistent, without programmer effort. Dependencies are identified
+by the engine, and change propagation happens automatically.
+
+Greater object re-use. Slots of instances can be authored with rules, not just literal values. In a sense,
+we get greater reuse by allowing instances to override slot derivations instance by instance. But not slot
+expressions, which are still class-oriented. By this I mean the observers expressing changes in value are
+dispatched by the class of the instance and so are not instance-specific. (Such a thing has been
+suggested, however.) Another strong bit of class-orientation comes from the fact that code reading
+slot X of some instance Y obviously does so without knowing how the returned value was derived. It knows
+only that the slot is named X, and will do things with that value assuming only that it has the
+X attribute of the instance Y. So again: the derivation of a slot value is potentially instance-oriented
+under Cells, but its expression or manifestation is still class-oriented.
+
+Natural decomposition of overall application complexity into so many simple rules and slot observers.
+Let's return for a moment to VisiCalc and its descendants. In even the most complex financial spreadsheet
+model, no one cell rule accesses more than a relatively few other spreadsheet cells (counting a row or
+column range as one reference). Yet the complex model emerges. All the work of tracking dependencies
+is handled by the spreadsheet software, which requires no special declaration by the modeller. They simply
+write the Cell rule. In writing the rule, they are concerned only with the derivation of one datapoint from
+a population of other datapoints. No effort goes into arranging for the rule to get run at the right time,
+and certainly no energy is spent worrying about what other cells might be using the authored cell. That
+cell has certain semantics -- "account balance", perhaps -- and the modeller need only worry about writing
+a correct, static computation of those semantics.
+
+Same with Cells. :) The only difference is that VisiCalc has one "observer" requirement for all cells:
+update the screen. In Cells applications, a significant amount of application functionality -- indeed, all
+its outputs -- end up in cell observers. But as discussed above, this additional burden falls only on
+the class designer when they decide to add a slot to a class. As instances are created and different rules
+specified for different slots to achieve custom behavior, the effort is the same as for the VisiCalc user.
+
+Model Building
+--------------
+Everything above could describe one instance of one class defined by DEFMODEL. A real application has
+multiple instances of multiple classes. So...
+
+-- cells can depend on other cells from any other instance. Since a rule gets passed only "self", Cell users
+need something like the Family class included with the Cells package effectively to turn a collection of
+instances into a network searchable by name or type.
+
+-- The overall model population must be maintainable by Cell slots such as the "kids" slot of the Family
+class. The burden here is on the Cells engine to allow one cell of one child to ask for the value of a cell of
+another child and vice versa (with different Cells), when both children are the product of the same rule,
+or different rules when "cousins" are exchanging information. So we must gracefully traverse the parent/kids
+tree dispatching kids rules just in time to produce the other instance sought.
+
+-- kid-slotting: used almost exclusively so far for orderly GUI layout, a parent must be able to specify
+rules for specific slots of kids. Example: a "stack" class wants to provide rules for child geometry
+specifying left, right, or centered alignment and vertical stacking (with optional spacing) one below
+the other. The idea is that we want to author classes of what might be GUI subcomponents without worrying
+about how they will be arranged in some container.
+
+-- finalization: when an instance appears in the "old kids" but not in the "new kids", a Cells engine
+may need to arrange for all Cells to "unsubscribe" from their dependents. Cells takes care of that if
+one calls "not-to-be" on an instance.
+
+
+Suggested Applications
+----------------------
+Any application that must maintain an interesting, long-lived data model incorporating a stream of unpredictable
+data. Two examples: any GUI application and a RoboCup soccer client.
+
+An application needing to shadow data between two systems. Examples: a Lisp GUI imlemented by thinly wrapping a
+C GUI library, where Lisp-land activity must be propagated to the C GUI, and C GUI events must propagate
+to Lisp-land. See the Cells-Gtk or Celtk projects. Also, a persistent CLOS implementation that must echo
+CLOS instance data into, say, SQL tables.
+
+Prior Art (in increasing order of priorness (age))
+---------
+Functional reactive programming:
+ This looks to be the most active, current, and vibrant subset of folks working on this sort of stuff.
+ Links:
+ FlapJax (FRP-powered web apps) http://www.flapjax-lang.org/
+ http://lambda-the-ultimate.org/node/1771
+ http://www.haskell.org/frp/
+ FrTime (scheme FRP implementation, no great links) http://pre.plt-scheme.org/plt/collects/frtime/doc.txt
+
+Adobe Adam, originally developed only to manage complex GUIs. [Adam]
+
+COSI, a class-based Cells-alike used at STSCI in software used to
+schedule Hubble telescope viewing time. [COSI]
+
+Garnet's KR: http://www.cs.cmu.edu/~garnet/
+Also written in Lisp. Cells looks much like KR, though Cells was
+developed in ignorance of KR (or any other prior art). KR has
+an astonishing number of backdoors to its constraint
+engine, none of which have turned out to be necessary for Cells.
+
+The entire constraint programming field, beginning I guess with Guy Steele's
+PhD Thesis in which he develops a constraint programming language or two:
+ http://portal.acm.org/citation.cfm?id=889490&dl=ACM&coll=ACM
+ http://www.cs.utk.edu/~bvz/quickplan.html
+
+Flow-based programming, developed by J. Paul Morrison at IBM, 1971.
+ http://en.wikipedia.org/wiki/Flow-based_programming
+
+Sutherland, I. Sketchpad: A Man Machine Graphical Communication System. PhD thesis, MIT, 1963.
+Steele himself cites Sketchpad as inexplicably unappreciated prior
+art to his Constraints system:
+
+See also:
+ The spreadsheet paradigm: http://www.cs.utk.edu/~bvz/active-value-spreadsheet.html
+ The dataflow paradigm: http://en.wikipedia.org/wiki/Dataflow
+ Frame-based programming
+ Definitive-programming
+
+Commentary
+----------
+-- Jack Unrue, comp.lang.lisp
+"Cells provides the plumbing for data dependency management which every
+non-trivial program must have; a developer using Cells can focus on
+computing program state and reacting to state changes, leaving Cells to worry about
+how that state is propagated. Cells does this by enabling a declarative
+mechanism built via an extension to CLOS, and hence achieves its goal in a way
+that meshes well with with typical Common Lisp programming style."
+
+-- Bill Clementson, http://bc.tech.coop/blog/030911.html
+"Kenny Tilton has been talking about his Cells implementation on comp.lang.lisp
+for some time but I've only just had a look at it over the past few evenings.
+It's actually pretty neat. Kenny describes Cells as, conceptually, analogous to
+a spreadsheet cell (e.g. -- something in which you can put a value or a formula
+and have it updated automatically based on changes in other "cell" values).
+Another way of saying this might be that Cells allows you to define classes
+whose slots can be dynamically (and automatically) updated and for which
+standard observers can be defined that react to changes in those slots."
+
+-- "What is Cells?", Cells-GTk FAQ, http://common-lisp.net/project/cells-gtk/faq.html#q2
+"If you are at all familiar with developing moderately complex software that
+is operated through a GUI, then you have probably
+learned this lesson: Keeping what is presented through the GUI in-sync with what
+the user is allowed to do, and in-sync with the computational state of the
+program is often tedious, complicated work. .... Cells-GTK helps
+with these tasks by providing an abstraction over the details; each of the tasks
+just listed can be controlled by (a) formula that specify the value of
+attributes of graphic features in the part-subpart declaration (that declaration
+is called 'defpart' in cells-gtk); and, (b) formula that specify the value of CLOS slots."
+
+-- Phillip Eby, PyCells and peak.events,
+ http://www.eby-sarna.com/pipermail/peak/2006-May/002545.html
+"What I discovered is quite cool. The Cells system *automatically
+discovers* dynamic dependencies, without having to explicitly specify that
+X depends on Y, as long as X and Y are both implemented using cell
+objects. The system knows when you are computing a value for X, and
+registers the fact that Y was read during this computation, thus allowing
+it to automatically invalidate the X calculation if Y changes....
+Aside from the automatic dependency detection, the cells system has
+another trick that is able to significantly reduce the complexity of
+event cascades, similar to what I was trying (but failing) to do using
+the "scheduled thread" concept in peak.events.
+Specifically, the cells system understands how to make event-based updates
+orderly and deterministic, in a way that peak.events cannot. It
+effectively divides time into "propagation" and "non-propagation"
+states. Instead of simply making callbacks whenever a computed value
+changes, the system makes orderly updates by queueing invalidated cells for
+updating. Also, if you write code that sets a new value imperatively (as
+opposed to it being pulled declaratively), the actual set operation is
+deferred until all computed cells are up-to-date with the current state of
+the universe."
+
+_____________
+Uncommentary
+
+-- Peter Seibel, comp.lang.lisp:
+"I couldn't find anything that explained what [Cells] was and why I should care."
+
+-- Alan Crowe, comp.lang.lisp:
+"Further confession: I'm bluffing. I've grasped that Cells is
+interesting, but I haven't downloaded it yet, and I haven't
+checked out how it works or what /exactly/ it does."
+
+_________
+Footnotes
+
+[Adam] "Adam is a modeling engine and declarative language for describing constraints and
+relationships on a collection of values, typically the parameters to an
+application command. When bound to a human interface (HI) Adam provides
+the logic that controls the HI behavior. Adam is similar in concept to a spreadsheet
+or a forms manager. Values are set and dependent values are recalculated.
+Adam provides facilities to resolve interrelated dependencies and to track
+those dependencies, beyond what a spreadsheet provides."
+http://opensource.adobe.com/group__asl__overview.html#asl_overview_intro_to_adam_and_eve
+________
+[bullet] This resolves a problem Fred Brooks identified in 1987: ""The essence of a software
+entity is a construct of interlocking concepts: data sets, relationships among data items, algorithms,
+and invocations of functions... Software systems have orders-of-magnitude more states than
+computers do...a scaling-up of a software entity is not merely a repetition of the same elements
+in larger sizes; it is necessarily an increase in the number of different elements. In most cases,
+the elements interact with each other in some nonlinear fashion, and the complexity of the whole
+increases much more than linearly."
+-- http://www.virtualschool.edu/mon/SoftwareEngineering/BrooksNoSilverBullet.html
+______
+[COSI] "The Constraint Sequencing Infrastructure (COSI) is an extension to
+the Common Lisp Object System (*(CLOS)) which supports a constraint
+based object-oriented programming model. .....
+
+"A constraint is a specialized method which will be automatically
+re-run by the COSI infrastructure whenever any of its input values
+change. Input values are any of the object attributes that are
+accessed by the constraint, and which are therefore assumed to
+alter the processing within the constraint.
+
+"Whenever a state change occurs those constraints which depend upon
+that state are added to a propagation queue. When the system is
+queried a propagation cycle runs ensuring that the state of the
+system is consistent with all constraints prior to returning a value."
+-- http://www.cliki.net/ACL2/COSI?source
+______
+[impl] The Cells library as it stands is all about doing interesting things
+with slots of CLOS instances, but Cells is not only about CLOS or even Lisp.
+One Cells user is known to have mediated a global variable with a Cell, some work
+was done on having slots of DEFSTRUCTs mediated by Cells, and ports to C++, Java, and
+Python have been explored.
+
+_______
+[axiom] Phillip Eby's axiomatic specification of Cells:
+
+Data Pulse Axioms
+=================
+
+Overview: updates must be synchronous (all changed cells are updated at
+once), consistent (no cell rule sees out of date values), and minimal (only
+necessary rules run).
+
+1. Global Update Counter:
+ There is a global update counter. (Guarantees that there is a
+globally-consistent notion of the "time" at which updates occur.)
+
+2. Per-Cell "As Of" Value:
+ Every cell has a "current-as-of" update count, that is initialized with
+a value that is less than the global update count will ever be.
+
+3. Out-of-dateness:
+ A cell is out of date if its update count is lower than the update
+count of any of the cells it depends on.
+
+4. Out-of-date Before:
+ When a rule-driven cell's value is queried, its rule is only run if the
+cell is out of date; otherwise a cached previous value is
+returned. (Guarantees that a rule is not run unless its dependencies have
+changed since the last time the rule was run.)
+
+5. Up-to-date After:
+ Once a cell's rule is run (or its value is changed, if it is an input
+cell), its update count must be equal to the global update
+count. (Guarantees that a rule cannot run more than once per update.)
+
+6. Inputs Move The System Forward
+ When an input cell changes, it increments the global update count and
+stores the new value in its own update count.
+
+
+Dependency Discovery Axioms
+===========================
+
+Overview: cells automatically notice when other cells depend on them, then
+notify them at most once if there is a change.
+
+
+1. Thread-local "current rule cell":
+ There is a thread-local variable that always contains the cell whose
+rule is currently being evaluated in the corresponding thread. This
+variable can be empty (e.g. None).
+
+2. "Currentness" Maintenance:
+ While a cell rule's is being run, the variable described in #1 must be
+set to point to the cell whose rule is being run. When the rule is
+finished, the variable must be restored to whatever value it had before the
+rule began. (Guarantees that cells will be able to tell who is asking for
+their values.)
+
+3. Dependency Creation:
+ When a cell is read, it adds the "currently-being evaluated" cell as a
+listener that it will notify of changes.
+
+4. Dependency Creation Order:
+ New listeners are added only *after* the cell being read has brought
+itself up-to-date, and notified any *previous* listeners of the
+change. (Ensures that the listening cell does not receive redundant
+notification if the listened-to cell has to be brought up-to-date first.)
+
+5. Dependency Minimalism:
+ A listener should only be added if it does not already present in the
+cell's listener collection. (This isn't strictly mandatory, the system
+behavior will be correct but inefficient if this requirement isn't met.)
+
+6. Dependency Removal:
+ Just before a cell's rule is run, it must cease to be a listener for
+any other cells. (Guarantees that a dependency from a previous update
+cannot trigger an unnecessary repeated calculation.)
+
+7. Dependency Notification
+ Whenever a cell's value changes (due to a rule change or input change),
+it must notify all of its listeners that it has changed, in such a way that
+*none* of the listeners are asked to recalculate their value until *all* of
+the listeners have first been notified of the change. (This guarantees
+that inconsistent views cannot occur.)
+
+7a. Deferred Recalculation
+ The recalculation of listeners (not the notification of the listeners'
+out-of-dateness) must be deferred if a cell's value is currently being
+calculated. As soon as there are no cells being calculated, the deferred
+recalculations must occur. (This guarantees that in the absence of
+circular dependencies, no cell can ask for a value that's in the process of
+being calculated.)
+
+8. One-Time Notification Only
+ A cell's listeners are removed from its listener collection as soon as
+they have been notified. In particular, the cell's collection of listeners
+must be cleared *before* *any* of the listeners are asked to recalculate
+themselves. (This guarantees that listeners reinstated as a side effect of
+recalculation will not get a duplicate notification in the current update,
+or miss a notification in a future update.)
+
+9. Conversion to Constant
+ If a cell's rule is run and no dependencies were created, the cell must
+become a "constant" cell, and do no further listener additions or
+notification, once any necessary notifications to existing listeners are
+completed. (That is, if the rule's run changed the cell's value, it must
+notify its existing listeners, but then the listener collection must be
+cleared -- *again*, in addition to the clearing described in #8.)
+
+10. No Changes During Notification:
+ It is an error to change an input cell's value while change
+notifications are taking place.
+
+11. Weak Notification
+ Automatically created inter-cell links must not inhibit garbage
+collection of either cell. (Technically optional, but very easy to do.)
+
+
Added: dependencies/trunk/cells/cells-store.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-store.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,248 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells Store -- Dependence on a Hash-Table
+
+Copyright (C) 2008 by Peter Hildebrandt
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(export! cells-store bwhen-c-stored c?-with-stored with-store-item store-add store-lookup store-remove store-items)
+
+(defmacro c?-with-stored ((var key store &optional default) &body body)
+ `(c? (bwhen-c-stored (,var ,key ,store ,default)
+ , at body)))
+
+(defmacro bwhen-c-stored ((var key store &optional if-not) &body body)
+ (with-gensyms (gkey gstore glink gifnot)
+ `(let ((,gkey ,key)
+ (,gstore ,store)
+ (,gifnot ,if-not))
+ (let ((,glink (query-c-link ,gkey ,gstore)))
+ (declare (ignorable ,glink))
+ (trc nil "executing bwhen-c-stored" self :update-tick ,glink :lookup (store-lookup ,gkey ,gstore))
+ (bif (,var (store-lookup ,gkey ,gstore))
+ (progn
+ , at body)
+ ,gifnot)))))
+
+(defmodel cells-store (family)
+ ((data :accessor data :initarg :data :cell nil))
+ (:default-initargs
+ :data (make-hash-table)))
+
+;;; infrastructure for manipulating the store and kicking rules
+
+(defmethod entry (key (store cells-store))
+ (gethash key (data store)))
+
+(defmethod (setf entry) (new-data key (store cells-store))
+ (setf (gethash key (data store)) new-data))
+
+(defmethod c-link (key (store cells-store))
+ (car (entry key store)))
+
+(defmethod (setf c-link) (new-c-link key (store cells-store))
+ (if (consp (entry key store))
+ (setf (car (entry key store)) new-c-link)
+ (setf (entry key store) (cons new-c-link nil)))
+ new-c-link)
+
+(defmethod item (key (store cells-store))
+ (cdr (entry key store)))
+
+(defmethod (setf item) (new-item key (store cells-store))
+ (if (consp (entry key store))
+ (setf (cdr (entry key store)) new-item)
+ (setf (entry key store) (cons nil new-item)))
+ new-item)
+
+;;; c-links
+
+(defmodel c-link ()
+ ((value :accessor value :initform (c-in 0) :initarg :value)))
+
+(defmethod query-c-link (key (store cells-store))
+ (trc "c-link> query link" key store (c-link key store))
+ (value (or (c-link key store)
+ (setf (c-link key store) (make-instance 'c-link)))))
+
+(defmethod kick-c-link (key (store cells-store))
+ (bwhen (link (c-link key store))
+ (trc "c-link> kick link" key store link)
+ (with-integrity (:change :kick-c-link)
+ (incf (value link)))))
+
+(defmacro with-store-item ((item key store) &body body)
+ `(prog1
+ (symbol-macrolet ((,item '(item key store)))
+ (progn
+ , at body))
+ (kick-c-link ,key ,store)))
+
+
+(defmacro with-store-entry ((key store &key quiet) &body body)
+ `(prog1
+ (progn
+ , at body)
+ (unless ,quiet
+ (kick-c-link ,key ,store))))
+
+;;; item management
+
+(defmethod store-add (key (store cells-store) object &key quiet)
+ (with-store-entry (key store :quiet quiet)
+ (when (item key store)
+ (trc "overwriting item" key (item key store)))
+ (setf (item key store) object)))
+
+(defmethod store-lookup (key (store cells-store) &optional default)
+ (when (mdead (item key store))
+ (with-store-entry (key store)
+ (trc "looked up dead item -- resetting to nil" key store)
+ (setf (item key store) nil)))
+ (or (item key store) default))
+
+(defmethod store-remove (key (store cells-store) &key quiet)
+ (with-store-entry (key store :quiet quiet)
+ (setf (item key store) nil)))
+
+(defmethod store-items ((store cells-store) &key (include-keys nil))
+ (loop for key being the hash-keys in (data store)
+ for val being the hash-values in (data store)
+ if (and (cdr val) include-keys) collect (cons key (cdr val))
+ else if (cdr val) collect it))
+
+;;; unit test
+
+(export! test-cells-store)
+
+(defmodel test-store-item (family)
+ ())
+
+(defvar *observers*)
+
+(defobserver .value ((self test-store-item))
+ (trc " changed value" :self self :to (value self))
+ (when (boundp '*observers*)
+ (push self *observers*)))
+
+(defmacro with-assert-observers ((desc &rest asserted-observers) &body body)
+ `(let ((*observers* nil))
+ (trc ,desc " -- checking observers")
+ , at body
+ (let ((superfluous-observers (loop for run in *observers* if (not (member run (list , at asserted-observers))) collect run))
+ (failed-observers (loop for asserted in (list , at asserted-observers) if (not (member asserted *observers*)) collect asserted)))
+ (trc "called observers on" *observers* :superflous superfluous-observers :failed failed-observers)
+ (assert (not superfluous-observers))
+ (assert (not failed-observers)))))
+
+(defmacro assert-values ((desc) &body objects-and-values)
+ `(progn
+ (trc ,desc)
+ ,@(loop for (obj val) in objects-and-values
+ collect `(assert (eql (value ,obj) ,val)))))
+
+(defun test-cells-store ()
+ (trc "testing cells-store -- making objects")
+ (let* ((store (make-instance 'cells-store))
+ (foo (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing)
+ (bwhen (val (value v)) val))))
+ (foo+1 (make-instance 'test-store-item :value (c?-with-stored (v :foo store 'nothing)
+ (bwhen (val (value v)) (1+ val)))))
+ (bar (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing)
+ (bwhen (val (value v)) val))))
+ (bar-1 (make-instance 'test-store-item :value (c?-with-stored (v :bar store 'nothing)
+ (bwhen (val (value v)) (1- val)))))
+ (bypass-lookup? (make-instance 'family :value (c-in t)))
+ (baz (make-instance 'test-store-item :value (c? (if (value bypass-lookup?)
+ 'no-lookup
+ (bwhen-c-stored (v :bar store 'nothing)
+ (value v)))))))
+
+ (assert-values ("assert fresh initialization")
+ (foo 'nothing)
+ (foo+1 'nothing)
+ (bar 'nothing)
+ (bar-1 'nothing))
+
+ (with-assert-observers ("adding foo" foo foo+1)
+ (store-add :foo store (make-instance 'family :value (c-in nil))))
+
+ (assert-values ("added foo = nil")
+ (foo nil)
+ (foo+1 nil)
+ (bar 'nothing)
+ (bar-1 'nothing))
+
+ (with-assert-observers ("changing foo" foo foo+1)
+ (setf (value (store-lookup :foo store)) 1))
+
+ (assert-values ("changed foo = 1")
+ (foo 1)
+ (foo+1 2)
+ (bar 'nothing)
+ (bar-1 'nothing))
+
+ (with-assert-observers ("adding bar = 42" bar bar-1)
+ (store-add :bar store (make-instance 'family :value (c-in 42))))
+
+ (assert-values ("changed foo = 1")
+ (foo 1)
+ (foo+1 2)
+ (bar 42)
+ (bar-1 41))
+
+ (with-assert-observers ("changing bar to 2" bar bar-1)
+ (setf (value (store-lookup :bar store)) 2))
+
+ (assert-values ("changed foo = 1")
+ (foo 1)
+ (foo+1 2)
+ (bar 2)
+ (bar-1 1))
+
+ (assert-values ("baz w/o lookup")
+ (baz 'no-lookup))
+
+ (with-assert-observers ("activating lookup" baz)
+ (setf (value bypass-lookup?) nil))
+
+ (assert-values ("baz w/lookup")
+ (baz 2))
+
+ (with-assert-observers ("deleting foo" foo foo+1)
+ (store-remove :foo store))
+
+ (assert-values ("deleted foo")
+ (foo 'nothing)
+ (foo+1 'nothing)
+ (bar 2)
+ (bar-1 1))
+
+ (with-assert-observers ("deleting bar" bar bar-1 baz)
+ (store-remove :bar store))
+
+ (assert-values ("deleted bar")
+ (foo 'nothing)
+ (foo+1 'nothing)
+ (bar 'nothing)
+ (bar-1 'nothing)
+ (baz 'nothing))
+
+ (with-assert-observers ("de-activating lookup" baz)
+ (setf (value bypass-lookup?) t))
+
+ (assert-values ("baz w/o lookup")
+ (baz 'no-lookup))))
\ No newline at end of file
Added: dependencies/trunk/cells/cells-test/boiler-examples.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/boiler-examples.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,290 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+;;
+;; OK, nothing new here, just some old example code I found lying around. FWIW...
+;;
+
+(defmodel boiler1 ()
+ ((id :cell nil :initarg :id :accessor id :initform (random 1000000))
+ (status :initarg :status :accessor status :initform nil) ;; vanilla cell
+ (temp :initarg :temp :accessor temp :initform nil)
+ (vent :initarg :vent :accessor vent :initform nil)
+ ))
+
+(def-cell-test boiler-1 ()
+
+ ;; resets debugging/testing specials
+ (cells-reset)
+
+ (let ((b (make-instance 'boiler1
+ :temp (c-in 20)
+ :status (c? (if (< (temp self) 100)
+ :on
+ :off))
+ :vent (c? (ecase (^status) ;; expands to (status self) and also makes coding synapses convenient
+ (:on :open)
+ (:off :closed))))))
+
+ (ct-assert (eql 20 (temp b)))
+ (ct-assert (eql :on (status b)))
+ (ct-assert (eql :open (vent b)))
+
+ (setf (temp b) 100) ;; triggers the recalculation of status and then of vent
+
+ (ct-assert (eql 100 (temp b)))
+ (ct-assert (eql :off (status b)))
+ (ct-assert (eql :closed (vent b)))
+ ))
+
+#+(or)
+(boiler-1)
+
+;
+; now let's see how output functions can be used...
+; and let's also demonstrate inter-object dependency by
+; separating out the thermometer
+;
+
+;;; note that thermometer is just a regular slot, it is
+;;; not cellular.
+
+(defmodel boiler2 ()
+ ((status :initarg :status :accessor status :initform nil)
+ (vent :initarg :vent :accessor vent :initform nil)
+ (thermometer :cell nil :initarg :thermometer :accessor thermometer :initform nil)
+ ))
+
+;;; defobserver ((slot-name) (&optional method-args) &body body
+
+;;; the defobserver macro defines a method with
+;;; three arguments -- by default, these arguments are named
+;;; self -- bound to the instance being operated on
+;;; old-value -- bound to the previous value of the cellular slot
+;;; named slot-name, of the instance being operated on.
+;;; new-value -- bound to the new value of said cellular slot
+
+;;; (this is why the variables self, old-value, and new-value can exist
+;;; below in the body, when it appears they are not defined in any
+;;; lexical scope)
+
+;;; the body of the macro defines code which is executed
+;;; when the the slot-name slot is initialized or changed.
+
+(defobserver status ((self boiler2))
+ (trc "output> boiler status" self :oldstatus= old-value :newstatus= new-value)
+ ;
+ ; << in real life call boiler api here to actually turn it on or off >>
+ ;
+ )
+
+(defobserver vent ((self boiler2))
+ (trc "output> boiler vent changing from" old-value :to new-value)
+ ;
+ ; << in real life call boiler api here to actually open or close it >>
+ ;
+ )
+
+
+(defmodel quiet-thermometer ()
+ ((temp :initarg :temp :accessor temp :initform nil)
+ ))
+
+(defmodel thermometer (quiet-thermometer)())
+
+;;; notice instead of oldvalue and newvalue, here the
+;;; old and new values are bound to parameters called oldtemp
+;;; and newtemp
+
+(defobserver temp ((self thermometer) newtemp oldtemp)
+ (trc "output> thermometer temp changing from" oldtemp :to newtemp))
+
+;--------------------------
+
+
+;;; here we introduce the to-be-primary construct, which causes
+;;; immediate initialization of cellular slots.
+
+;;; notice how the status cell of a boiler2 can depend
+;;; on the temp slot of a thermometer, illustrating how
+;;; dependencies can be made between the cellular slots of
+;;; instances of different classes.
+
+
+(def-cell-test boiler-2 ()
+ (cells-reset)
+ (let ((b (make-instance 'boiler2
+ :status (c? (eko ("boiler2 status c?")
+ (if (< (temp (thermometer self)) 100)
+ :on :off)))
+ :vent (c? (ecase (^status)
+ (:on :open)
+ (:off :closed)))
+ :thermometer (make-instance 'thermometer
+ :temp (c-in 20)))))
+
+ (ct-assert (eql 20 (temp (thermometer b))))
+ (ct-assert (eql :on (status b)))
+ (ct-assert (eql :open (vent b)))
+
+ (setf (temp (thermometer b)) 100)
+
+ (ct-assert (eql 100 (temp (thermometer b))))
+ (ct-assert (eql :off (status b)))
+ (ct-assert (eql :closed (vent b)))
+ ))
+
+#+(or)
+(boiler-2)
+
+;;; ***********************************************
+;;; ***********************************************
+;;; ***********************************************
+
+#| intro to cells, example 3 |#
+
+;;; ***********************************************
+;;; ***********************************************
+;;; ***********************************************
+
+
+;;; note: we use boiler2 and thermometer from example 2 in example 3,
+;;; along with their def-output methods defined in example 2.
+;;;
+;;; also: these do not use ct-assert to perform automatic testing, but
+;;; they do illustrate a possible real-world application of synapses. to
+;;; observe the difference made by synapses, one must look at the trace output
+;
+; now let's look at synapses, which mediate a dependency between two cells.
+; the example here has an input argument (sensitivity-enabled) which when
+; enables gives the temp cell an (fsensitivity 0.05) clause.
+
+; the example simulates a thermometer perhaps
+; malfunctioning which is sending streams of values randomly plus or minus
+; two-hundredths of a degree. does not sound serious, except...
+;
+; if you run the example as is, when the temperature gets to our on/off threshhold
+; of 100, chances are you will see the boiler toggle itself on and off several times
+; before the temperature moves away from 100.
+;
+; building maintenance personel will report this odd behavior, probably hearing the
+; vent open and shut and open again several times in quick succession.
+
+; the problem is traced to the cell rule which reacts too slavishly to the stream
+; of temperature values. a work order is cut to replace the thermometer, and to reprogram
+; the controller not to be so slavish. there are lots of ways to solve this; here if
+; you enable sensitivity by running example 4 you can effectively place a synapse between the
+; temperature cell of the thermometer and the status cell of the boiler which
+; does not even trigger the status cell unless the received value differs by the
+; specified amount from the last value which was actually relayed.
+
+; now the boiler simply cuts off as the temperature passes 100, and stays off even if
+; the thermometer temperature goes to 99.98. the trace output shows that although the temperature
+; of the thermometer is changing, only occasionally does the rule to decide the boiler
+; status get kicked off.
+;
+
+
+
+(def-cell-test boiler-3 (&key (sensitivity-enabled t))
+ (declare (ignorable sensitivity-enabled))
+ (cells-reset)
+ #+soon
+ (let ((b (make-instance 'boiler2
+ :status (c? (let ((temp (if sensitivity-enabled
+ (temp (thermometer self) (f-sensitivity 0.05))
+ (temp (thermometer self)))))
+ ;;(trc "status c? sees temp" temp)
+ (if (< temp 100) :on :off)
+ ))
+ :vent (c? (ecase (^status) (:on :open) (:off :closed)))
+ :thermometer (make-instance 'quiet-thermometer :temp (c-in 20))
+ )))
+ ;
+ ; let's simulate a thermometer which, when the temperature is actually
+ ; any given value t will indicate randomly anything in the range
+ ; t plus/minus 0.02. no big deal unless the actual is exactly our
+ ; threshold point of 100...
+ ;
+ (dotimes (x 4)
+ ;;(trc "top> ----------- set base to" (+ 98 x))
+ (dotimes (y 10)
+ (let ((newtemp (+ 98 x (random 0.04) -.02))) ;; force random variation around (+ 98 x)
+ ;;(trc "top> ----------- set temp to" newtemp)
+ (setf (temp (thermometer b)) newtemp))))))
+
+
+(def-cell-test boiler-4 () (boiler-3 :sensitivity-enabled t))
+
+;;
+;; de-comment 'trc statements above to see what is happening
+;;
+#+(or)
+(boiler-3)
+
+#+(or)
+(boiler-4)
+
+(def-cell-test boiler-5 ()
+
+ (cells-reset)
+ #+soon
+ (let ((b (make-instance 'boiler2
+ :status (c-in :off)
+ :vent (c? (trc "caculating vent" (^status))
+ (if (eq (^status) :on)
+ (if (> (temp (thermometer self) (f-debug 3)) 100)
+ :open :closed)
+ :whatever-off))
+ :thermometer (make-instance 'quiet-thermometer
+ :temp (c-in 20)))))
+
+ (dotimes (x 4)
+ (dotimes (n 4)
+ (incf (temp (thermometer b))))
+ (setf (status b) (case (status b) (:on :off)(:off :on))))))
+
+#+(or)
+
+(boiler-5)
+
+(def-cell-test f-debug (sensitivity &optional subtypename)
+ (declare (ignore sensitivity subtypename))
+ #+soon
+ (mk-synapse (prior-fire-value)
+ :fire-p (lambda (syn new-value)
+ (declare (ignorable syn))
+ (eko ("fire-p decides" prior-fire-value sensitivity)
+ (delta-greater-or-equal
+ (delta-abs (delta-diff new-value prior-fire-value subtypename) subtypename)
+ (delta-abs sensitivity subtypename)
+ subtypename)))
+
+ :fire-value (lambda (syn new-value)
+ (declare (ignorable syn))
+ (eko ("f-sensitivity relays")
+ (setf prior-fire-value new-value)) ;; no modulation of value, but do record for next time
+ )))
Added: dependencies/trunk/cells/cells-test/build-sys.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/build-sys.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,56 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*-
+;;;
+;;; Copyright ? 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(defpackage #:cells-build-package
+ (:use #:cl))
+
+(in-package #:cells-build-package)
+
+(defun build-sys (system$ &key source-directory force)
+ (let (
+ ;;; --------------------------------------
+ ;;; Step 2: Implementation-specific issues
+ ;;;
+ ;;; Let's assume this is fixed in CMUCL 19a, and fix it later if need be.
+ #+cmu18
+ (ext:*derive-function-types* nil)
+
+ #+lispworks
+ (hcl::*handle-existing-defpackage* (list :add))
+ )
+
+ ;;----------------------------------------
+ ;; source-directory validation...
+ ;;
+ (assert (pathnamep source-directory)
+ (source-directory)
+ "source-directory not supplied, please edit build.lisp to specify the location of the source.")
+ (let ((project-asd (merge-pathnames (format nil "~a.asd" system$)
+ source-directory)))
+ (unless (probe-file project-asd)
+ (error "~a not found. revise build.lisp if asd file is somewhere else." project-asd)))
+
+ ;;;----------------------------------
+ ;;; ok. build...
+ ;;;
+ (push source-directory asdf:*central-registry*)
+ (asdf:operate 'asdf:load-op (intern system$ :keyword) :force force)))
\ No newline at end of file
Added: dependencies/trunk/cells/cells-test/cells-test.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/cells-test.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,26 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+(asdf:defsystem :cells-test
+ :name "cells-test"
+ :author "Kenny Tilton "
+ :maintainer "Kenny Tilton "
+ :licence "MIT Style"
+ :description "Cells Regression Test/Documentation"
+ :long-description "Informatively-commented regression tests for Cells"
+ :serial t
+ :depends-on (:cells)
+ :components ((:file "test")
+ (:file "hello-world")
+ (:file "test-kid-slotting")
+ (:file "test-lazy")
+ (:file "person")
+ (:file "df-interference")
+ (:file "test-family")
+ (:file "output-setf")
+ (:file "test-cycle")
+ (:file "test-ephemeral")
+ (:file "test-synapse")
+ (:file "deep-cells")))
+
+
+
Added: dependencies/trunk/cells/cells-test/cells-test.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/cells-test.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,104 @@
+;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*-
+
+(in-package :cg-user)
+
+(defpackage :CELLS)
+
+(define-project :name :cells-test
+ :modules (list (make-instance 'module :name "test.lisp")
+ (make-instance 'module :name "hello-world.lisp")
+ (make-instance 'module :name "test-kid-slotting.lisp")
+ (make-instance 'module :name "test-lazy.lisp")
+ (make-instance 'module :name "person.lisp")
+ (make-instance 'module :name "df-interference.lisp")
+ (make-instance 'module :name "test-family.lisp")
+ (make-instance 'module :name "output-setf.lisp")
+ (make-instance 'module :name "test-cycle.lisp")
+ (make-instance 'module :name "test-ephemeral.lisp")
+ (make-instance 'module :name "test-synapse.lisp")
+ (make-instance 'module :name "deep-cells.lisp")
+ (make-instance 'module :name "clos-training.lisp")
+ (make-instance 'module :name "do-req.lisp"))
+ :projects (list (make-instance 'project-module :name "..\\cells"
+ :show-modules nil))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :cells
+ :main-form nil
+ :compilation-unit t
+ :verbose nil
+ :runtime-modules (list :cg-dde-utils :cg.base :cg.bitmap-pane
+ :cg.bitmap-pane.clipboard :cg.bitmap-stream
+ :cg.button :cg.caret :cg.check-box
+ :cg.choice-list :cg.choose-printer
+ :cg.clipboard :cg.clipboard-stack
+ :cg.clipboard.pixmap :cg.color-dialog
+ :cg.combo-box :cg.common-control :cg.comtab
+ :cg.cursor-pixmap :cg.curve :cg.dialog-item
+ :cg.directory-dialog :cg.directory-dialog-os
+ :cg.drag-and-drop :cg.drag-and-drop-image
+ :cg.drawable :cg.drawable.clipboard
+ :cg.dropping-outline :cg.edit-in-place
+ :cg.editable-text :cg.file-dialog
+ :cg.fill-texture :cg.find-string-dialog
+ :cg.font-dialog :cg.gesture-emulation
+ :cg.get-pixmap :cg.get-position
+ :cg.graphics-context :cg.grid-widget
+ :cg.grid-widget.drag-and-drop :cg.group-box
+ :cg.header-control :cg.hotspot :cg.html-dialog
+ :cg.html-widget :cg.icon :cg.icon-pixmap
+ :cg.ie :cg.item-list :cg.keyboard-shortcuts
+ :cg.lamp :cg.lettered-menu :cg.lisp-edit-pane
+ :cg.lisp-text :cg.lisp-widget :cg.list-view
+ :cg.mci :cg.menu :cg.menu.tooltip
+ :cg.message-dialog
+ :cg.multi-line-editable-text
+ :cg.multi-line-lisp-text
+ :cg.multi-picture-button
+ :cg.multi-picture-button.drag-and-drop
+ :cg.multi-picture-button.tooltip :cg.ocx
+ :cg.os-widget :cg.os-window :cg.outline
+ :cg.outline.drag-and-drop
+ :cg.outline.edit-in-place :cg.palette
+ :cg.paren-matching :cg.picture-widget
+ :cg.picture-widget.palette :cg.pixmap
+ :cg.pixmap-widget :cg.pixmap.file-io
+ :cg.pixmap.printing :cg.pixmap.rotate
+ :cg.printing :cg.progress-indicator
+ :cg.project-window :cg.property
+ :cg.radio-button :cg.rich-edit
+ :cg.rich-edit-pane
+ :cg.rich-edit-pane.clipboard
+ :cg.rich-edit-pane.printing
+ :cg.sample-file-menu :cg.scaling-stream
+ :cg.scroll-bar :cg.scroll-bar-mixin
+ :cg.selected-object :cg.shortcut-menu
+ :cg.static-text :cg.status-bar
+ :cg.string-dialog :cg.tab-control
+ :cg.template-string :cg.text-edit-pane
+ :cg.text-edit-pane.file-io
+ :cg.text-edit-pane.mark :cg.text-or-combo
+ :cg.text-widget :cg.timer :cg.toggling-widget
+ :cg.toolbar :cg.tooltip :cg.trackbar :cg.tray
+ :cg.up-down-control :cg.utility-dialog
+ :cg.web-browser :cg.web-browser.dde
+ :cg.wrap-string :cg.yes-no-list
+ :cg.yes-no-string :dde)
+ :splash-file-module (make-instance 'build-module :name "")
+ :icon-file-module (make-instance 'build-module :name "")
+ :include-flags (list :top-level :debugger)
+ :build-flags (list :allow-runtime-debug :purify)
+ :autoload-warning t
+ :full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
+ :default-command-line-arguments "+M +t \"Console for Debugging\""
+ :additional-build-lisp-image-arguments (list :read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :build-number 0
+ :on-initialization 'cells::test-cells
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/cells-test/deep-cells.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/deep-cells.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,53 @@
+(in-package :cells)
+
+(defvar *client-log*)
+(defvar *obs-1-count*)
+
+(defmodel deep ()
+ ((cell-2 :cell :ephemeral :initform (c-in 'two) :accessor cell-2)
+ (cell-1 :initform (c? (list 'one (^cell-2) (^cell-3))) :accessor cell-1)
+ (cell-3 :initform (c-in 'c3-unset) :accessor cell-3)))
+
+(defobserver cell-1 ()
+ (trc "cell-1 observer raw now enqueing client to run first. (new,old)=" new-value old-value)
+ (with-integrity (:client 1)
+ (trc "cell-1 :client now running" new-value (incf *obs-1-count*))
+ (eko ("c1-obs->*client-log*: ")
+ (setf *client-log* (list new-value)))))
+
+(defobserver cell-2 ()
+ (trc "cell-2 observer raw now enqueing change and client to run second. (new,old)=" new-value old-value)
+ (with-integrity (:change)
+ (trc "cell-2 observer :change now running" *client-log*)
+ (ct-assert (equal *client-log* '((one two c3-unset) two c3-unset)))
+ (setf (^cell-3) (case new-value (two 'three) (otherwise 'trouble))))
+ (with-integrity (:client 2)
+ (trc "client cell-2 :client running")
+ (eko ("c2-obs->*client-log*: ")
+ (setf *client-log* (append *client-log* (list new-value))))))
+
+(defobserver cell-3 ()
+ (trc "cell-3 observer raw now enqueing client to run third. (new,old)=" new-value old-value)
+ (with-integrity (:client 3)
+ (trc "cell-3 observer :client now running" new-value)
+ (eko ("c3-obs->*client-log*: ")
+ (setf *client-log* (append *client-log* (list new-value))))))
+
+(defun deep-queue-handler (client-q)
+ (loop for (defer-info . task) in (prog1
+ (sort (fifo-data client-q) '< :key 'car)
+ (fifo-clear client-q))
+ do
+ (trc nil "!!! --- deep-queue-handler dispatching" defer-info)
+ (funcall task :user-q defer-info)))
+
+(def-cell-test go-deep ()
+ (cells-reset 'deep-queue-handler)
+ (setf *obs-1-count* 0)
+ (make-instance 'deep)
+ (ct-assert (eql 2 *obs-1-count*)) ;; because the cell-2 observer does a setf on something used by c1
+ (trc "testing *client-log*" *client-log*)
+ (ct-assert (tree-equal *client-log* '((one nil three) three))))
+
+
+
Added: dependencies/trunk/cells/cells-test/df-interference.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/df-interference.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,120 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defvar *eex* 0)
+
+(defmodel xx3 ()
+ ((aa :initform (c-in 0) :initarg :aa :accessor aa)
+ (dd :initform (c? (min 0 (+ (^cc) (^bb)))) :initarg :dd :accessor dd)
+ (ddx :initform (c? (+ (^cc) (^bb))) :initarg :ddx :accessor ddx)
+ (cc :initform (c? (+ (^aa) (^bb))) :initarg :cc :reader cc)
+ (bb :initform (c? (* 2 (^aa))) :initarg :bb :accessor bb)
+ (ee :initform (c? (+ (^aa) (^dd))) :initarg :ee :reader ee)
+ (eex :initform (c? (trc "in rule of eex, *eex* now" *eex*)
+ (+ (^aa) (^ddx))) :initarg :eex :reader eex)
+ ))
+
+(defobserver aa ((self xx3))
+ (trc nil "output aa:" new-value))
+
+(defobserver bb ((self xx3))
+ (trc nil "output bb:" new-value))
+
+(defobserver cc ((self xx3))
+ (trc nil "output cc:" new-value))
+
+(defobserver dd ((self xx3))
+ (trc nil "output dd:" new-value))
+
+(defobserver ee ((self xx3))
+ (trc nil "output ee:" new-value))
+
+(defobserver eex ((self xx3))
+ (incf *eex*)
+ (trc "output eex:" new-value *eex*))
+
+;;
+;; here we look at just one problem, what i call dataflow interference. consider
+;; a dependency graph underlying:
+;;
+;; - a depends on b and c, and...
+;; - b depends on c
+;;
+;; if c changes, depending on the accident of the order in which a and b happened to
+;; be first evaluated, a might appear before b on c's list of dependents (callers). then the
+;; following happens:
+;;
+;; - c triggers a
+;; - a calculates off the new value of c and an obsolete cached value for b
+;; - a outputs an invalid value and triggers any dependents, all of whom recalculate
+;; using a's invalid value
+;; - c triggers b
+;; - b recalculates and then triggers a, which then recalculates correctly and outputs and triggers
+;; the rest of the df graph back into line
+;;
+;; the really bad news is that outputs go outside the model: what if the invalid output caused
+;; a missile launch? sure, a subsequent correct calculation comes along shortly, but
+;; irrevocable damage may have been done.
+;;
+
+(def-cell-test df-test ()
+ (cells-reset)
+ (let* ((*eex* 0)
+ (it (make-instance 'xx3)))
+ (trc "eex =" *eex*)
+ (ct-assert (eql *eex* 1))
+ ;;(inspect it);;(cellbrk)
+ (ct-assert (and (eql (aa it) 0)(eql (bb it) 0)(eql (cc it) 0)))
+ (ct-assert (and (eql (dd it) 0)(eql (ddx it) 0)(eql (ee it) 0)(eql (eex it) 0)))
+
+ ;;;- interference handling
+ ;;;
+ (let ((*eex* 0))
+ (trc "--------- 1 => (aa it) --------------------------")
+ (setf (aa it) 1)
+
+ (ct-assert (and (eql (aa it) 1)(eql (bb it) 2)(eql (cc it) 3)))
+ (trc "dd,ddx:" (dd it) (ddx it) )
+ (ct-assert (and (eql (dd it) 0)(eql (ddx it) 5)))
+ (ct-assert (and (eql (ee it) 1)(eql (eex it) 6)))
+ (ct-assert (eql *eex* 1)))
+
+ (let ((*eex* 0))
+ (trc "--------- 2 => (aa it) --------------------------")
+ (setf (aa it) 2)
+ (ct-assert (and (eql (aa it) 2)(eql (bb it) 4)(eql (cc it) 6)
+ (eql (dd it) 0)(eql (ddx it) 10)(eql (ee it) 2)(eql (eex it) 12)))
+ (ct-assert (eql *eex* 1)))
+
+ (dolist (c (cells it))
+ (trc "cell is" c)
+ (when (typep (cdr c) 'cell)
+ (print `(notifier ,c))
+ (dolist (u (c-callers (cdr c)))
+ (print `(___ ,u)))))
+ ))
+
+
Added: dependencies/trunk/cells/cells-test/echo-setf.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/echo-setf.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,47 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defmodel bing (model)
+ ((bang :initform (c-in nil) :accessor bang)))
+
+(def-c-output bang ()
+ (bwhen (p .parent)
+ (setf (bang p) new-value)))
+
+(defmodel bings (bing family)
+ ()
+ (:default-initargs
+ :kids (c? (loop repeat 2
+ collect (make-instance 'bing)))))
+
+(defun cv-echo-setf ()
+ (cell-reset)
+ (let ((top (make-instance 'bings
+ :kids (c-in nil))))
+ (push (make-instance 'bings) (kids top))))
+
+#+(or)
+(cv-echo-setf)
Added: dependencies/trunk/cells/cells-test/hello-world-q.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/hello-world-q.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,81 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+;;;
+;;;(defstrudel computer
+;;; (happen :cell :ephemeral :initform (c-in nil))
+;;; (location :cell t
+;;; :initform (c? (case (^happen)
+;;; (:leave :away)
+;;; (:arrive :at-home)
+;;; (t (c-value c))))
+;;; :accessor location)
+;;; (response :cell :ephemeral :initform nil :initarg :response :accessor response)))
+
+(def-c-output response((self computer) new-response old-response)
+ (when new-response
+ (format t "~&computer: ~a" new-response)))
+
+(def-c-output happen((self computer))
+ (when new-value
+ (format t "~&happen: ~a" new-value)))
+
+(defun hello-world-q ()
+ (let ((dell (make-instance 'computer
+ :response (c? (bwhen (h (happen self))
+ (if (eql (^location) :at-home)
+ (case h
+ (:knock-knock "who's there?")
+ (:world "hello, world."))
+ ""))))))
+ (dotimes (n 2)
+ (setf (happen dell) :knock-knock))
+ (setf (happen dell) :arrive)
+ (setf (happen dell) :knock-knock)
+ (setf (happen dell) :world)
+ (values)))
+
+#+(or)
+(hello-world)
+
+#+(or)
+(traceo sm-echo)
+
+
+#| output
+
+happen: knock-knock
+computer:
+happen: knock-knock
+computer:
+happen: arrive
+happen: knock-knock
+computer: who's there?
+happen: world
+computer: hello, world.
+
+|#
+
Added: dependencies/trunk/cells/cells-test/hello-world.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/hello-world.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,78 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+
+(defmd computer ()
+ (happen (c-in nil) :cell :ephemeral)
+ (location (c? (case (^happen)
+ (:leave :away)
+ (:arrive :at-home)
+ (t .cache)))) ;; ie, unchanged
+ (response nil :cell :ephemeral))
+
+(defobserver response(self new-response old-response)
+ (when new-response
+ (format t "~&computer: ~a" new-response)))
+
+(defobserver happen()
+ (when new-value
+ (format t "~&happen: ~a" new-value)))
+
+(def-cell-test hello-world ()
+ (let ((dell (make-instance 'computer
+ :response (c? (bwhen (h (happen self))
+ (if (eql (^location) :at-home)
+ (case h
+ (:knock-knock "who's there?")
+ (:world "hello, world."))
+ ""))))))
+ (dotimes (n 2)
+ (setf (happen dell) :knock-knock))
+
+ (setf (happen dell) :arrive)
+ (setf (happen dell) :knock-knock)
+ (setf (happen dell) :leave)
+ (values)))
+
+#+(or)
+(hello-world)
+
+
+#| output
+
+happen: KNOCK-KNOCK
+computer:
+happen: KNOCK-KNOCK
+computer:
+happen: ARRIVE
+happen: KNOCK-KNOCK
+computer: who's there?
+happen: LEAVE
+computer:
+
+
+|#
+
Added: dependencies/trunk/cells/cells-test/internal-combustion.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/internal-combustion.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,362 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+
+(in-package :cells)
+
+(defmodel engine ()
+ ((fuel :cell nil :initarg :fuel :initform nil :accessor fuel)
+ (cylinders :initarg :cylinders :initform (c-in 4) :accessor cylinders)
+ (valves-per-cylinder :initarg :valves-per-cylinder :initform 2 :accessor valves-per-cylinder)
+ (valves :initarg :valves
+ :accessor valves
+ :initform (c? (* (valves-per-cylinder self)
+ (cylinders self))))
+ (mod3 :initarg :mod3 :initform nil :accessor mod3)
+ (mod3ek :initarg :mod3ek :initform nil :accessor mod3ek)
+ ))
+
+(defmethod c-unchanged-test ((self engine) (slotname (eql 'mod3)))
+ (lambda (new-value old-value)
+ (flet ((test (it) (zerop (mod it 3))))
+ (eql (test new-value) (test old-value)))))
+
+(defobserver mod3ek () (trc "mod3ek output" self))
+
+(defmethod c-unchanged-test ((self engine) (slotname (eql 'mod3ek)))
+ (lambda (new-value old-value)
+ (flet ((test (it) (zerop (mod it 3))))
+ (eql (test new-value) (test old-value)))))
+
+(defobserver cylinders ()
+ ;;(when *dbg* (break))
+ (trc "cylinders output" self old-value new-value))
+
+(defvar *propagations* nil)
+
+(defmodel engine-w-initform ()
+ ((cylinders :initform 33 :reader cylinders)))
+
+(defclass non-model ()())
+(defmodel faux-model (non-model)())
+(defmodel true-model ()())
+(defmodel indirect-model (true-model)())
+
+
+(def-cell-test cv-test-engine ()
+ (when *stop* (break "stopped! 2"))
+ ;;
+ ;; before we get to engines, a quick check that we are correctly enforcing the
+ ;; requirment that classes defined by defmodel inherit from model-object
+ ;;
+ (ct-assert (make-instance 'non-model))
+ (ct-assert (make-instance 'true-model))
+ (ct-assert (make-instance 'indirect-model))
+ (ct-assert (handler-case
+ (progn
+ (make-instance 'faux-model)
+ nil) ;; bad to reach here
+ (t (error) (trc "error is" error)
+ error)))
+ ;; --------------------------------------------------------------------------
+ ;; -- make sure non-cell slots still work --
+ ;;
+ ;; in mop-based implementations we specialize the slot-value-using-class accessors
+ ;; to make cells work. rather than slow down all slots where a class might have only
+ ;; a few cell-mediated slots, we allow a class to pick and choose which slots are cell-mediated.
+ ;;
+ ;; here we make sure all is well in re such mixing of cell and non-cell, by exercising first
+ ;; the reader and then the writer.
+ ;;
+ ;; the read is not much of a test since it should work even if through some error the slot
+ ;; gets treated as if it were cell. but the setf will fail since cell internals reject changes
+ ;; to cellular slots unless they are c-variable. (why this is so has to do with efficiency,
+ ;; and will be covered when we get to cells being optimized away.)
+ ;;
+ (ct-assert
+ (eql :gas (fuel (make-instance 'engine :fuel :gas))))
+ (ct-assert
+ (eql :diesel (setf (fuel (make-instance 'engine :fuel :gas)) :diesel)))
+ ;;
+ ;;
+ #+(or) ;; not an error: Cloucell needed to hold a Cell in a non cellular slot. duh.
+ (ct-assert
+ (handler-case
+ (progn
+ (make-instance 'engine :fuel (c-in :gas))
+ nil) ;; bad to reach here
+ (t (error) (trc "error is" error)
+ error)))
+ ;;
+ ;; ---------------------------------------------------------------------------
+ ;; (1) reading cellular slots (2) instantiated as constant, variable or ruled
+ ;;
+ ;; aside from the simple mechanics of successfuly accessing cellular slots, this
+ ;; code exercises the implementation task of binding a cell to a slot such that
+ ;; a standard read op finds the wrapped value, including a functional value (the c?)
+ ;;
+ ;; aside; the cell pattern includes a transparency requirement so cells will be
+ ;; programmer-friendly and in turn yield greater productivity gains. below we /initialize/
+ ;; the cylinders cell to (c-in 4) and then (c? (+ 2 2)), but when you read those slots the
+ ;; cell implementation structures are not returned, the value 4 is returned.
+ ;;
+ ;; aside: the value 4 itself occupies the actual slot. this helped when we used Cells
+ ;; with a persistent CLOS tool which maintained inverse indices off slots if asked.
+ ;;
+ (ct-assert
+ (progn
+ (eql 33 (cylinders (make-instance 'engine-w-initform)))))
+
+ (ct-assert
+ (eql 4 (cylinders (make-instance 'engine :cylinders 4))))
+
+ (ct-assert
+ (eql 4 (cylinders (make-instance 'engine :cylinders (c-in 4)))))
+
+ (ct-assert
+ (eql 4 (cylinders (make-instance 'engine :cylinders (c? (+ 2 2))))))
+
+ (ct-assert
+ (eql 16 (valves (make-instance 'engine
+ :cylinders 8
+ :valves (c? (* (cylinders self) (valves-per-cylinder self)))
+ :valves-per-cylinder (c? (floor (cylinders self) 4)))))) ;; admittedly weird semantics
+
+ ;; ----------------------------------------------------------
+ ;; initialization output
+ ;;
+ ;; cells are viewed in part as supportive of modelling. the output functions provide
+ ;; a callback allowing state changes to be manifested outside the dataflow, perhaps
+ ;; by updating the screen or by operating some real-world device through its api.
+ ;; that way a valve model instance could drive a real-world valve.
+ ;;
+ ;; it seems best then that the state of model and modelled should as much as possible
+ ;; be kept consistent with each other, and this is why we "output" cells as soon as they
+ ;; come to life as well as when they change.
+ ;;
+ ;; one oddball exception is that cellular slots for which no output is defined do not get outputted
+ ;; initially. why not? this gets a little complicated.
+ ;;
+ ;; first of all, outputting requires evaluation of a ruled cell. by checking first
+ ;; if a cell even is outputted, and punting on those that are not outputted we can defer
+ ;; the evaluation of any ruled cell bound to an unoutputted slot until such a slot is
+ ;; read by other code. i call this oddball because it is a rare slot that is
+ ;; neither outputted nor used directly or indirectly by an outputted slot. but i have had fairly
+ ;; expensive rules on debugging slots which i did not want kicked off until i had
+ ;; to check their values in the inspector. ie, oddball.
+ ;;
+
+ (macrolet ((output-init (newv cylini)
+ `(progn
+ (output-clear 'cylinders)
+ (output-clear 'valves)
+ (trc "starting output init test" ,newv ',cylini)
+ (make-instance 'engine
+ :cylinders ,cylini
+ :valves ,cylini)
+ (ct-assert (outputted 'cylinders))
+ (ct-assert (eql ,newv (output-new 'cylinders)))
+ ;(ct-assert (not (output-old-boundp 'cylinders)))
+ ;(ct-assert (not (outputted 'valves)))
+ )))
+ (output-init 6 6)
+ (output-init 10 (c-in 10))
+ (output-init 5 (c? (+ 2 3)))
+ )
+
+ ;; ----------------------------------------------------------------
+ ;; write cell slot
+ ;;
+ ;; for now only variable cells (slots mediated by c-variable structures) can be
+ ;; modified via setf. an exception (drifter cells) may get resurrected soon. but as mentioned
+ ;; above, an optimization discussed below requires rejection of changes to cellular slots
+ ;; instantiated without any cell, and for purity the cell engine rejects setf's of slots mediated
+ ;; by ruled cells. the idea being that we want the semantics of a ruled
+ ;; cell to be fully defined by its rule, not arbitrary setf's from anywhere in the code.
+ ;;
+ ;; aside: variable cells can be setf'ed from anywhere, a seeming loss of semantic
+ ;; control by the above purist view. but variables exist mainly to allow inputs to a dataflow model
+ ;; from outside the model, usually in an event-loop processing os events, so spaghetti dataflow
+ ;; should not follow from this.
+ ;;
+ ;; that said, in weak moments i resort to having the output of one cell setf some other variable cell,
+ ;; but i always think of these as regrettable gotos and maybe someday i will try to polish them out
+ ;; of existence test.
+ ;;
+ ;;-------------------------
+ ;;
+ ;; first verify acceptable setf...
+ ;;
+ (ct-assert
+ (let ((e (make-instance 'engine :cylinders (c-in 4))))
+ (setf (cylinders e) 6)
+ (eql 6 (cylinders e))))
+ ;;
+ ;; ...and two not acceptable...
+ ;;
+ (ct-assert
+ (handler-case
+ (let ((e (make-instance 'engine :cylinders 4)))
+ (setf (cylinders e) 6)
+ nil) ;; bad to reach here
+ (t (error)
+ (trc "error correctly is" error)
+ (cells-reset)
+ t))) ;; something non-nil to satisfy assert
+
+ (let ((e (make-instance 'engine :cylinders (c? (+ 2 2)))))
+ (assert *c-debug*)
+ (ct-assert
+ (handler-case
+ (progn
+ (setf (cylinders e) 6)
+ nil) ;; bad to reach here
+ (t (error) (trc "error correctly is" error)
+ (setf *stop* nil)
+ t))))
+ (when *stop* (break "stopped! 1"))
+ (cv-test-propagation-on-slot-write)
+ (cv-test-no-prop-unchanged)
+
+ ;;
+ ;; here we exercise a feature which allows the client programmer to override the default
+ ;; test of eql when comparing old and new values. above we defined nonsense slot mod3 (unoutputted)
+ ;; and mod3ek (outputted) with a custom "unchanged" test:
+ ;;
+
+ ;;
+ #+(or) (let ((e (make-instance 'engine
+ :mod3 (c-in 3)
+ :mod3ek (c-in 3)
+ :cylinders (c? (* 4 (mod3 self))))))
+
+ (ct-assert (eql 12 (cylinders e)))
+ (output-clear 'mod3)
+ (output-clear 'mod3ek)
+ (trc "mod3 outputes cleared, setting mod3s now")
+ (setf (mod3 e) 6
+ (mod3ek e) 6)
+ ;;
+ ;; both 3 and 6 are multiples of 3, so the engine guided by the above
+ ;; override treats the cell as unchanged; no output, no recalculation
+ ;; of the cylinders cell
+ ;;
+ (ct-assert (not (outputted 'mod3ek))) ;; no real need to check mod3 unoutputted
+ (ct-assert (eql 12 (cylinders e)))
+ ;;
+ ;; now test in the other direction to make sure change according to the
+ ;; override still works.
+ ;;
+ (setf (mod3 e) 5
+ (mod3ek e) 5)
+ (ct-assert (outputted 'mod3ek))
+ (ct-assert (eql 20 (cylinders e)))
+ )
+ )
+
+(def-cell-test cv-test-propagation-on-slot-write ()
+ ;; ---------------------------------------------------------------
+ ;; propagation (output and trigger dependents) on slot write
+ ;;
+ ;; propagation involves both outputing my change and notifying cells dependent on me
+ ;; that i have changed and that they need to recalculate themselves.
+ ;;
+ ;; the standard output callback is passed the slot-name, instance, new value,
+ ;; old value and a flag 'old-value-boundp indicating, well, whether the new value
+ ;; was the first ever for this instance.
+ ;;
+ ;; the first set of tests make sure actual change is handled correctly
+ ;;
+ (output-clear 'cylinders)
+ (output-clear 'valves)
+ (output-clear 'valves-per-cylinder)
+ (when *stop* (break "stopped!"))
+ (let ((e (make-instance 'engine
+ :cylinders 4
+ :valves-per-cylinder (c-in 2)
+ :valves (c? (* (valves-per-cylinder self) (cylinders self))))))
+ ;;
+ ;; these first tests check that cells get outputted appropriately at make-instance time (the change
+ ;; is from not existing to existing)
+ ;;
+ (ct-assert (and (eql 4 (output-new 'cylinders))
+ (not (output-old-boundp 'cylinders))))
+
+ (ct-assert (valves-per-cylinder e)) ;; but no output is defined for this slot
+
+ (ct-assert (valves e))
+ ;;
+ ;; now we test true change from one value to another
+ ;;
+ (setf (valves-per-cylinder e) 4)
+ ;;
+ (ct-assert (eql 16 (valves e)))
+ ))
+
+(def-cell-test cv-test-no-prop-unchanged ()
+ ;;
+ ;; next we check the engines ability to handle dataflow efficiently by /not/ reacting
+ ;; to coded setfs which in fact produce no change.
+ ;;
+ ;; the first takes a variable cylinders cell initiated to 4 and again setf's it to 4. we
+ ;; confirm that the cell does not output and that a cell dependent on it does not get
+ ;; triggered to recalculate. ie, the dependency's value has not changed so the dependent
+ ;; cell's cached value remains valid.
+ ;;
+ (cells-reset)
+ (output-clear 'cylinders)
+ (let* ((*dbg* t)
+ valves-fired
+ (e (make-instance 'engine
+ :cylinders (c-in 4)
+ :valves-per-cylinder 2
+ :valves (c-formula (:lazy t)
+ (setf valves-fired t)
+ (trc "!!!!!! valves")
+ (* (valves-per-cylinder self) (cylinders self))))))
+ (trc "!!!!!!!!hunbh?")
+ (ct-assert (outputted 'cylinders))
+ (output-clear 'cylinders)
+ (ct-assert (not valves-fired)) ;; no output is defined so evaluation is deferred
+ (trc "sampling valves....")
+ (let ()
+ (ct-assert (valves e)) ;; wake up unoutputted cell
+ )
+ (ct-assert valves-fired)
+ (setf valves-fired nil)
+
+ (ct-assert (and 1 (not (outputted 'cylinders))))
+ (setf (cylinders e) 4) ;; same value
+ (trc "same cyl")
+ (ct-assert (and 2 (not (outputted 'cylinders))))
+ (ct-assert (not valves-fired))
+
+ (setf (cylinders e) 6)
+ (ct-assert (outputted 'cylinders))
+ (ct-assert (not valves-fired))
+ (ct-assert (valves e))(ct-assert valves-fired)))
+
+#+(or)
+
+(cv-test-engine)
Added: dependencies/trunk/cells/cells-test/lazy-propagation.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/lazy-propagation.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,82 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defvar *area*)
+(defvar *density*)
+
+(defmodel cirkl ()
+ ((radius :initform (c-in 10) :initarg :radius :accessor radius)
+ (area :initform (c?_ (incf *area*) (trc "in area rule it is now" *area*)
+ (* pi (^radius) (^radius))) :initarg :area :accessor area)
+ (density :initform (c?_ (incf *density*)
+ (/ 1000 (^area))) :initarg :density :accessor density)))
+
+
+#+(or)
+(cv-laziness)
+
+(def-cell-test cv-laziness ()
+ (macrolet ((chk (area density)
+ `(progn
+ (assert (= ,area *area*) () "area is ~a, should be ~a" *area* ,area)
+ (assert (= ,density *density*) () "density is ~a, should be ~a" *density* ,density)
+ (trc nil "cv-laziness ok with:" ,area ,density)))
+ )
+ (let ((*c-debug* t))
+ (cells-reset)
+
+ (let* ((*area* 0)
+ (*density* 0)
+ (it (make-instance 'cirkl)))
+ (chk 0 0)
+
+ (print `(area is ,(area it)))
+ (chk 1 0)
+
+ (setf (radius it) 1)
+ (chk 1 0)
+
+ (print `(area is now ,(area it)))
+ (chk 2 0)
+ (assert (= (area it) pi))
+
+ (setf (radius it) 2)
+ (print `(density is ,(density it)))
+ (chk 3 1)
+
+ (setf (radius it) 3)
+ (chk 3 1)
+ (print `(area is ,(area it)))
+ (chk 4 1)
+ it))))
+
+#+(or)
+(cv-laziness)
+
+(defobserver area ()
+ (trc "area is" new-value :was old-value))
+
+
Added: dependencies/trunk/cells/cells-test/output-setf.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/output-setf.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,59 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defmodel bing (model)
+ ((bang :initform (c-in nil) :accessor bang)))
+
+(defobserver bang ()
+ (trc "new bang" new-value self)
+ (bwhen (p .parent)
+ (with-integrity (:change)
+ (setf (bang p) new-value)))
+ #+(or) (dolist (k (^kids))
+ (setf (bang k) (if (numberp new-value)
+ (1+ new-value)
+ 0))))
+
+(defmodel bings (bing family)
+ ()
+ (:default-initargs
+ :kids (c? (loop repeat 2
+ collect (make-instance 'bing
+ :fm-parent self
+ :md-name (copy-symbol 'kid))))))
+
+(def-cell-test cv-output-setf ()
+ (cells-reset)
+ (let ((top (make-instance 'bings
+ :md-name 'top
+ :kids (c-in nil))))
+ (push (make-instance 'bings
+ :fm-parent top) (kids top))
+ (dolist (k (kids (car (kids top))))
+ (setf (bang k) (kid-no k)))))
+
+#+(or)
+(cv-output-setf)
Added: dependencies/trunk/cells/cells-test/person.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/person.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,324 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defvar *name-ct-calc* 0)
+
+(defmodel person ()
+ ((speech :cell :ephemeral :initform (c-in nil) :initarg :speech :accessor speech)
+ (thought :cell :ephemeral :initform (c? (speech self)) :initarg :thought :accessor thought)
+ (names :initform nil :initarg :names :accessor names)
+ (pulse :initform nil :initarg :pulse :accessor pulse)
+ (name-ct :initarg :name-ct :accessor name-ct
+ :initform (c? "name-ct"
+ (incf *name-ct-calc*)
+ (length (names self))))))
+
+#+test
+(progn
+ (cells-reset)
+ (inspect
+ (make-instance 'person
+ :names '("speedy" "chill")
+ :pulse (c-in 60)
+ :speech (c? (car (names self)))
+ :thought (c? (when (< (pulse self) 100) (speech self))))))
+
+(defobserver names ((self person) new-names)
+ (format t "~&you can call me ~a" new-names))
+
+(defmethod c-unchanged-test ((self person) (slotname (eql 'names)))
+ 'equal)
+
+(defvar *thought* "failed")
+(defvar *output-speech* "failed")
+
+(defobserver thought ((self person) new-value)
+ (when new-value
+ (trc "output thought" self new-value)
+ (setq *thought* new-value)
+ (trc "i am thinking" new-value)))
+
+(defobserver speech ()
+ (setf *output-speech* new-value))
+
+(defmodel sick ()
+ ((e-value :cell :ephemeral :initarg :e-value :accessor e-value)
+ (s-value :initarg :s-value :reader s-value)))
+
+(defobserver s-value ()
+ :test)
+
+(defobserver e-value ()
+ :test)
+
+(def-cell-test cv-test-person ()
+ (cv-test-person-1)
+ (cv-test-person-3)
+ (cv-test-person-4)
+ (cv-test-person-5)
+ ;; (cv-test-talker)
+ )
+
+(def-cell-test cv-test-person-1 ()
+ ;;
+ ;; a recent exchange with someone who has developed with others a visual
+ ;; programming system was interesting. i mentioned my dataflow thing, he mentioned
+ ;; they liked the event flow model. i responded that events posed a problem for
+ ;; cells. consider something like:
+ ;;
+ ;; (make-instance 'button
+ ;; :clicked (c-in nil)
+ ;; :action (c? (when (clicked self) (if (- (time-now *cg-system*) (last-click-time.....
+ ;;
+ ;; well, once the button is clicked, that cell has the value t. the rest of the rule executes
+ ;; and does whatever, the rule completes. finis? no. the time-now cell of
+ ;; the system instance continues to tick-tick-tick. at each tick the action cell gets triggered,
+ ;; and (here is the problem) the clicked cell still says t.
+ ;;
+ ;; the problem is that clicked is event-ish. the semantics are not "has it ever been clicked",
+ ;; they are more like "when the /passing/ click occurs...". we could try requiring the programmer
+ ;; always to execute:
+ ;;
+ ;; (setf (clicked it) t)
+ ;; (setf (clicked it nil)
+ ;;
+ ;; ...but in fact cells like this often are ruled cells which watch mouse actions and check if the
+ ;; mouse up was in the control where the mousedown occurred. so where to put a line of code
+ ;; to change clicked back to nil? a deep fix seemed appropriate: teach cells about events, so...
+ ;;
+ ;; cellular slots can be defined to be :ephemeral if the slot will be used for
+ ;; event-like data. [defining slots and not cells as ephemeral means one cannot arrange for such a
+ ;; slot to have a non-ephemeral value for one instance and ephemeral values for other instances. we
+ ;; easily could go the other way on this, but this seems right.]
+ ;;
+ ;; the way ephemerals work is this: when a new value arrives in an ephemeral slot it is outputted and
+ ;; propagated to dependent cells normally, but then internally the slot value is cleared to nil.
+ ;; thus during the output and any dataflow direct or indirect the value is visible to other code, but
+ ;; no longer than that. note that setting the slot back to nil bypasses propagation: no output, no
+ ;; triggering of slot dependents.
+ ;;
+ ;;
+ (let ((p (make-instance 'person :speech (c-in nil))))
+ ;;
+ ;; - ephemeral c-variable cells revert to nil if setf'ed non-nil later
+ ;;
+ (setf (speech p) "thanks for all the fish")
+ (ct-assert (null (speech p)))
+ (ct-assert (equal *output-speech* "thanks for all the fish"))
+ (ct-assert (equal *thought* "thanks for all the fish")) ;; thought is ephemeral as well, so tricky test
+ ;;
+ ;; now check the /ruled/ ephemeral got reset to nil
+ ;;
+ (ct-assert (null (thought p)))))
+
+
+
+(def-cell-test cv-test-person-3 ()
+ ;; -------------------------------------------------------
+ ;; dynamic dependency graph maintenance
+ ;;
+ ;; dependencies of a cell are those other cells actually accessed during the latest
+ ;; invocation of the rule. note that a cellular slot may be constant, not mediated by a
+ ;; cell, in which case the access does not record a dependency.
+ ;;
+ (let ((p (make-instance 'person
+ :names (c-in '("speedy" "chill"))
+ :pulse (c-in 60)
+ :speech "nice and easy does it"
+ :thought (c? (if (> (pulse self) 180)
+ (concatenate 'string (car (names self)) ", slow down!")
+ (speech self))))))
+ ;;
+ ;; with the (variable=1) pulse not > 80, the branch taken leads to (constant=0) speech, so:
+ ;;
+ (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought)))))
+ ;;
+ ;; with the (variable=1) pulse > 80, the branch taken leads to (variable=1) names, so:
+ ;;
+ (setf (pulse p) 200)
+ (ct-assert (eql 2 (length (cd-useds (md-slot-cell p 'thought)))))
+ ;;
+ ;; let's check the engine's ability reliably to drop dependencies by lowering the pulse again
+ ;;
+ (setf (pulse p) 50)
+ (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought)))))))
+
+
+(def-cell-test cv-test-person-4 ()
+ (let ((p (make-instance 'person
+ :names '("speedy" "chill")
+ :pulse (c-in 60)
+ :speech (c? (car (names self)))
+ :thought (c? (when (< (pulse self) 100) (speech self))))))
+ ;;
+ ;; now let's see if cells are correctly optimized away when:
+ ;;
+ ;; - they are defined and
+ ;; - all cells accessed are constant.
+ ;;
+ (ct-assert (null (md-slot-cell p 'speech)))
+ #-its-alive!
+ (progn
+ (ct-assert (assoc 'speech (cells-flushed p)))
+ (ct-assert (c-optimized-away-p (cdr (assoc 'speech (cells-flushed p))))))
+
+ (ct-assert (not (c-optimized-away-p (md-slot-cell p 'thought)))) ;; pulse is variable, so cannot opti
+ (ct-assert (eql 1 (length (cd-useds (md-slot-cell p 'thought))))) ;; but speech is opti, so only 1 used
+ ))
+
+(def-cell-test cv-test-person-5 ()
+ ;;
+ ;; for now cells do not allow cyclic dependency, where a computation of a cell leads back
+ ;; to itself. we could do something like have the self-reference return the cached value
+ ;; or (for the first evaluation) a required seed value. we already have logic which says
+ ;; that, if setf on a variable cell cycles back to setf on the same cell we simply stop, so
+ ;; there is no harm on the propagation side. but so far no need for such a thing.
+ ;;
+ ;; one interesting experiment would be to change things so propagation looping back on itself
+ ;; would be allowed. we would likewise change things so propagation was breadth first. then
+ ;; state change, once set in motion, would continue indefinitely. (propagation would also have to
+ ;; be non-recursive.) we would want to check for os events after each propagation and where
+ ;; real-time synchronization was necessary do some extra work. this in contrast to having a timer
+ ;; or os null events artificially move forward the state of, say, a simulation of a physical system.
+ ;; allowing propagation to loop back on itslef means the system would simply run, and might make
+ ;; parallelization feasible since we already have logic to serialize where semantically necessary.
+ ;; anyway, a prospect for future investigation.
+ ;;
+ ;; make sure cyclic dependencies are trapped:
+ ;;
+ (cells-reset)
+ #+its-alive! t
+ #-its-alive!
+ (ct-assert
+ (handler-case
+ (progn
+ (pulse (make-instance 'person
+ :names (c? (trc "calculating names" self)
+ (maptimes (n (pulse self))))
+ :pulse (c? (trc "calculating pulse" self)
+ (length (names self)))))
+ nil)
+ (t (error)
+ (describe error)
+ (setf *stop* nil)
+ t))))
+;;
+;; we'll toss off a quick class to test tolerance of cyclic
+
+(defmodel talker8 ()
+ ((words8 :initform (c-input (:cyclicp t) "hello, world")
+ :initarg :words8 :accessor words8)
+ (idea8 :initform (c-in "new friend!") :initarg :idea8 :accessor idea8)
+ (mood8 :initform (c-in "happy as clam") :initarg :mood8 :accessor mood8)))
+
+(defmodel talker ()
+ ((words :initform (c-in "hello, world") :initarg :words :accessor words)
+ (idea :initform (c-in "new friend!") :initarg :idea :accessor idea)
+ ))
+
+(defobserver words ((self talker) new-words)
+ (trc "new words" new-words)
+ (setf (idea self) (concatenate 'string "idea " new-words)))
+
+(defmethod c-unchanged-test ((self talker) (slotname (eql 'words)))
+ 'string-equal)
+
+(defobserver idea ((self talker) new-idea)
+ (trc "new idea" new-idea)
+ (setf (words self) (concatenate 'string "say " new-idea)))
+
+(defmethod c-unchanged-test ((self talker) (slotname (eql 'idea)))
+ 'string-equal)
+
+(defobserver words8 ((self talker8) new-words8)
+ (trc "new words8, sets idea8 to same" new-words8 *causation*)
+ (with-integrity (:change)
+ (setf (idea8 self) (concatenate 'string "+" new-words8))))
+
+(defmethod c-unchanged-test ((self talker8) (slotname (eql 'words8)))
+ 'string-equal)
+
+(defobserver idea8 ((self talker8) new-idea8)
+ (trc "new idea8, sets mood8 to same" new-idea8 *causation*)
+ (with-integrity (:change)
+ (setf (mood8 self) (concatenate 'string "+" new-idea8))))
+
+(defmethod c-unchanged-test ((self talker8) (slotname (eql 'idea8)))
+ 'string-equal)
+
+(defobserver mood8 ((self talker8) new-mood8)
+ (trc "new mood8, sets words8 to same:" new-mood8 *causation*)
+ (with-integrity (:change)
+ (setf (words8 self) (concatenate 'string "+" new-mood8))))
+
+(defmethod c-unchanged-test ((self talker8) (slotname (eql 'mood8)))
+ 'string-equal)
+
+(defmacro ct-assert-error (&body body)
+ `(ct-assert
+ (handler-case
+ (prog1 nil
+ , at body)
+ (t (error)
+ (trc "ct-assert-error" error)
+ (setf *stop* nil)
+ t))))
+
+#+(or) ; FIXME: this test is borked
+(def-cell-test cv-test-talker ()
+ ;;
+ ;; make sure cyclic setf is trapped
+ ;;
+ (cells-reset)
+
+ ;;; (trc "start unguarded cyclic")
+ ;;;
+ ;;; (let ((tk (make-instance 'talker)))
+ ;;; (setf (idea tk) "yes")
+ ;;; (string-equal "yes" (words tk))
+ ;;; (setf (words tk) "no")
+ ;;; (string-equal "no" (idea tk)))
+
+ (trc "start guarded cyclic")
+
+ #+(or) (ct-assert-error
+ (let ((tk (make-instance 'talker)))
+ (setf (idea tk) "yes")
+ (ct-assert (string-equal "yes" (words tk)))
+ (setf (words tk) "no")
+ (ct-assert (string-equal "no" (idea tk)))))
+ ;;
+ ;; make sure cells declared to be cyclic are allowed
+ ;; and halt (because after the first cyclic setf the cell in question
+ ;; is being given the same value it already has, and propagation stops.
+ ;;
+ (make-instance 'talker8)
+ #+(or) (let ((tk (make-instance 'talker8)))
+ (setf (idea8 tk) "yes")
+ (string-equal "yes" (words8 tk))
+ (setf (words8 tk) "no")
+ (string-equal "no" (idea8 tk)))
+ )
Added: dependencies/trunk/cells/cells-test/synapse-testing.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/synapse-testing.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,77 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defmodel counter-10 ()
+ ((ct :initarg :ct :initform nil :accessor ct)
+ (ct10 :initarg :ct10 :initform nil
+ :accessor ct10)))
+
+(defun cv-test-f-sensitivity ()
+ (cell-reset)
+ (with-metrics (t nil "cv-test-f-sensitivity")
+ (let ((self (make-be 'counter-10
+ :ct (c-in 0)
+ :ct10 (c? (count-it :ct10-rule)
+ (f-sensitivity :dummy-id (10)
+ (^ct))))))
+ (cv-assert (zerop (^ct10)))
+ (loop for n below 30
+ do (cv-assert (eq (^ct10) (* 10 (floor (^ct) 10))))
+ (incf (ct self))))
+ (cv-assert (eql 4 (count-of :ct10-rule)))))
+
+(defun cv-test-f-delta ()
+ (cell-reset)
+ (with-metrics (t nil "cv-test-f-delta")
+ (let ((self (make-be 'counter-10
+ :ct (c-in 0)
+ :ct10 (c? (count-it :ct10-rule)
+ (trc "runnning ct10-rule 1")
+ (f-delta :dummy ()
+ (^ct))))))
+ (cv-assert (zerop (^ct10)))
+ (cv-assert (zerop (^ct)))
+ (loop for n below 4
+ do (trc "loop incf ct" n)
+ (incf (ct self) n)
+ (cv-assert (eql (^ct10) n))))
+ (cv-assert (eql 4 (count-of :ct10-rule))))
+
+ (with-metrics (t nil "cv-test-f-delta-sensitivity")
+ (let ((self (make-be 'counter-10
+ :ct (c-in 0)
+ :ct10 (c? (count-it :ct10-rule)
+ (f-delta :xxx (:sensitivity 4)
+ (^ct))))))
+ (cv-assert (null (^ct10)))
+ (cv-assert (zerop (^ct)))
+ (loop for n below 4
+ do (trc "loop incf ct" n)
+ (incf (ct self) n)
+ (ecase n
+ ((0 1 2) (cv-assert (null (^ct10))))
+ (3 (cv-assert (eql (^ct10) 6)))
+ (4 (cv-assert (eql (^ct10) 4)))))
+ (cv-assert (eql 2 (count-of :ct10-rule))))))
+
Added: dependencies/trunk/cells/cells-test/test-cycle.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-cycle.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,79 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+
+(defmodel m-cyc ()
+ ((m-cyc-a :initform (c-in nil) :initarg :m-cyc-a :accessor m-cyc-a)
+ (m-cyc-b :initform (c-in nil) :initarg :m-cyc-b :accessor m-cyc-b)))
+
+(defobserver m-cyc-a ()
+ (print `(output m-cyc-a ,self ,new-value ,old-value))
+ (with-integrity (:change)
+ (setf (m-cyc-b self) new-value)))
+
+(defobserver m-cyc-b ()
+ (print `(output m-cyc-b ,self ,new-value ,old-value))
+ (with-integrity (:change)
+ (setf (m-cyc-a self) new-value)))
+
+(def-cell-test m-cyc () ;;def-cell-test m-cyc
+ (let ((m (make-instance 'm-cyc)))
+ (print `(start ,(m-cyc-a m)))
+ (setf (m-cyc-a m) 42)
+ (assert (= (m-cyc-a m) 42))
+ (assert (= (m-cyc-b m) 42))))
+
+#+(or)
+(m-cyc)
+
+(defmodel m-cyc2 ()
+ ((m-cyc2-a :initform (c-in 0) :initarg :m-cyc2-a :accessor m-cyc2-a)
+ (m-cyc2-b :initform (c? (1+ (^m-cyc2-a)))
+ :initarg :m-cyc2-b :accessor m-cyc2-b)))
+
+(defobserver m-cyc2-a ()
+ (print `(output m-cyc2-a ,self ,new-value ,old-value))
+ #+(or) (when (< new-value 45)
+ (setf (m-cyc2-b self) (1+ new-value))))
+
+(defobserver m-cyc2-b ()
+ (with-integrity (:change self)
+ (print `(output m-cyc2-b ,self ,new-value ,old-value))
+ (when (< new-value 45)
+ (setf (m-cyc2-a self) (1+ new-value)))))
+
+(def-cell-test m-cyc2
+ (let ((m (make-instance 'm-cyc2)))
+ (print '(start))
+ (setf (m-cyc2-a m) 42)
+ (describe m)
+ (assert (= (m-cyc2-a m) 44))
+ (assert (= (m-cyc2-b m) 45))
+ ))
+
+#+(or)
+(m-cyc2)
+
+
Added: dependencies/trunk/cells/cells-test/test-cyclicity.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-cyclicity.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,94 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defmodel ring-node ()
+ ((router-ids :cell nil :initform nil :initarg :router-ids :accessor router-ids)
+ (system-status :initform (c-in 'up) :initarg :system-status :accessor system-status
+ :documentation "'up, 'down, or 'unknown if unreachable")
+ (reachable :initarg :reachable :accessor reachable
+ :initform (c? (not (null ;; convert to boolean for readable test output
+ (find self (^reachable-nodes .parent))))))))
+
+(defun up (self) (eq 'up (^system-status)))
+
+(defmodel ring-net (family)
+ (
+ (ring :cell nil :initform nil :accessor ring :initarg :ring)
+ (sys-node :cell nil :initform nil :accessor sys-node :initarg :sys-node)
+ (reachable-nodes :initarg :reachable-nodes :accessor reachable-nodes
+ :initform (c? (contiguous-nodes-up
+ (find (sys-node self) (^kids)
+ :key 'md-name))))
+ )
+ (:default-initargs
+ :kids (c? (assert (sys-node self))
+ (assert (find (sys-node self) (ring self)))
+ (loop with ring = (ring self)
+ for triples on (cons (last1 ring)
+ (append ring (list (first ring))))
+ when (third triples)
+ collect (destructuring-bind (ccw node cw &rest others) triples
+ (declare (ignorable others))
+ (print (list ccw node cw))
+ (make-instance 'ring-node
+ :md-name node
+ :router-ids (list ccw cw)))))))
+
+(defun contiguous-nodes-up (node &optional (visited-nodes (list)))
+ (assert (not (find (md-name node) visited-nodes)))
+
+ (if (not (up node))
+ (values nil (push (md-name node) visited-nodes))
+ (progn
+ (push (md-name node) visited-nodes)
+ (values
+ (list* node
+ (mapcan (lambda (router-id)
+ (unless (find router-id visited-nodes)
+ (multiple-value-bind (ups new-visiteds)
+ (contiguous-nodes-up (fm-other! node router-id) visited-nodes)
+ (setf visited-nodes new-visiteds)
+ ups)))
+ (router-ids node)))
+ visited-nodes))))
+
+(defun test-ring-net ()
+ (flet ((dump-net (net msg)
+ (print '----------------------)
+ (print `(*** dump-net ,msg ******))
+ (dolist (n (kids net))
+ (print (list n (system-status n)(reachable n)(router-ids n))))))
+ (cell-reset)
+ (let ((net (make-instance 'ring-net
+ :sys-node 'two
+ :ring '(one two three four five six))))
+ (dump-net net "initially")
+ (setf (system-status (fm-other! net 'three)) 'down)
+ (dump-net net "down goes three!!")
+ (setf (system-status (fm-other! net 'six)) 'down)
+ (dump-net net "down goes six!!!"))))
+
+#+do-it
+(test-ring-net)
+
\ No newline at end of file
Added: dependencies/trunk/cells/cells-test/test-ephemeral.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-ephemeral.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,64 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+(defmodel m-ephem ()
+ ((m-ephem-a :cell :ephemeral :initform nil :initarg :m-ephem-a :accessor m-ephem-a)
+ (m-test-a :cell nil :initform nil :initarg :m-test-a :accessor m-test-a)
+ (m-ephem-b :cell :ephemeral :initform nil :initarg :m-ephem-b :accessor m-ephem-b)
+ (m-test-b :cell nil :initform nil :initarg :m-test-b :accessor m-test-b)))
+
+(defobserver m-ephem-a ()
+ (setf (m-test-a self) new-value))
+
+(defobserver m-ephem-b ()
+ (trc "out ephem-B copying to test-B" new-value)
+ (setf (m-test-b self) new-value))
+
+(def-cell-test m-ephem
+ (let ((m (make-instance 'm-ephem
+ :m-ephem-a (c-in nil)
+ :m-ephem-b (c? (prog2
+ (trc "Start calc ephem-B")
+ (* 2 (or (^m-ephem-a) 0))
+ (trc "Stop calc ephem-B"))))))
+ (ct-assert (null (slot-value m 'm-ephem-a)))
+ (ct-assert (null (m-ephem-a m)))
+ (ct-assert (null (m-test-a m)))
+ (ct-assert (null (slot-value m 'm-ephem-b)))
+ (ct-assert (null (m-ephem-b m)))
+ (ct-assert (zerop (m-test-b m)))
+ (trc "setting ephem-A to 3")
+ (setf (m-ephem-a m) 3)
+ (ct-assert (null (slot-value m 'm-ephem-a)))
+ (ct-assert (null (m-ephem-a m)))
+ (ct-assert (eql 3 (m-test-a m)))
+ ;
+ (ct-assert (null (slot-value m 'm-ephem-b)))
+ (ct-assert (null (m-ephem-b m)))
+ (ct-assert (eql 6 (m-test-b m)))
+ ))
+
+
+
Added: dependencies/trunk/cells/cells-test/test-family.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-family.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,158 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defmodel human (family)
+ ((age :initarg :age :accessor age :initform 10)))
+
+(defobserver .kids ((self human))
+ (when new-value
+ (print `(i have ,(length new-value) kids))
+ (dolist (k new-value)
+ (trc "one kid is named" (md-name k) :age (age k)))))
+
+(defobserver age ((k human))
+ (format t "~&~a is ~d years old" (md-name k) (age k)))
+
+(def-cell-test cv-test-family ()
+ (cells-reset)
+ (let ((mom (make-instance 'human)))
+ ;
+ ; the real power of cells appears when a population of model-objects are linked by cells, as
+ ; when a real-word collection of things all potentially affect each other.
+ ;
+ ; i use the family class to create a simple hierarchy in which kids have a pointer to their
+ ; parent (.fm-parent, accessor fm-parent) and a parent has a cellular list of their .kids (accessor kids)
+ ;
+ ; great expressive power comes from having kids be cellular; the model population changes as
+ ; the model changes in other ways. but this creates a delicate timing problem: kids must be fully
+ ; spliced into the model before their ruled cellular slots can be accessed, because a cell rule
+ ; itself might try to navigate the model to get to a cell value of some other model-object.
+ ;
+ ; the cell engine handles this in two steps. first, deep in the state change handling code
+ ; the .kids slot gets special handling (this is new for 2002, and come to think of it i will
+ ; have to expose that hook to client code so others can create models from structures other
+ ; than family) during which the fm-parent gets populated, among other things. second, the output of
+ ; kids calls to-be on each kid.
+ ;
+ ; one consequence of this is that one not need call to-be on new instances being added to
+ ; a larger model family, it will be done as a matter of course.
+ ;
+ (push (make-instance 'human :fm-parent mom :md-name 'natalia :age (c-in 23)) (kids mom))
+ (push (make-instance 'human :fm-parent mom :md-name 'veronica :age (c? (- (age (fm-other natalia)) 6))) (kids mom))
+ (push (make-instance 'human :fm-parent mom :md-name 'aaron :age (c? (- (age (fm-other veronica)) 4))) (kids mom))
+ (push (make-instance 'human :fm-parent mom :md-name 'melanie :age (c? (- (age (fm-other veronica)) 12))) (kids mom))
+ ;
+ ; some of the above rules invoke the macro fm-other. that searches the model space, first searching the
+ ; kids of the starting point (which defaults to a captured 'self), then recursively up to the
+ ; parent and the parent's kids (ie, self's siblings)
+ ;
+ (flet ((nat-age (n)
+ (setf (age (fm-other natalia :starting mom)) n)
+ (dolist (k (kids mom))
+ (ct-assert
+ (eql (age k)
+ (ecase (md-name k)
+ (natalia n)
+ (veronica (- n 6))
+ (aaron (- n 10))
+ (melanie (- n 18))))))))
+ (nat-age 23)
+ (nat-age 30)
+ (pop (kids mom))
+ (nat-age 40))))
+
+#+(or)
+
+(cv-test-family)
+
+;------------ family-values ------------------------------------------
+;;;
+;;; while family-values is itself rather fancy, the only cell concept introduced here
+;;; is that cell rules have convenient access to the current value of the slot, via
+;;; the symbol-macro ".cache" (leading and trailing full-stops). to see this we need to
+;;; go to the definition of family-values and examine the rule for the kids cell:
+;;;
+;;; (c? (assert (listp (kidvalues self)))
+;;; (eko (nil "gridhost kids")
+;;; (let ((newkids (mapcan (lambda (kidvalue)
+;;; (list (or (find kidvalue .cache :key (kvkey self) :test (kvkeytest self))
+;;; (trc nil "family-values forced to make new kid" self .cache kidvalue)
+;;; (funcall (kidfactory self) self kidvalue))))
+;;; (^kidvalues))))
+;;; (nconc (mapcan (lambda (oldkid)
+;;; (unless (find oldkid newkids)
+;;; (when (fv-kid-keep self oldkid)
+;;; (list oldkid))))
+;;; .cache)
+;;; newkids))))
+;;;
+;;; for efficiency's sake, family-values (fvs) generate kids only as needed based on determining
+;;; kidvalues cell. wherever possible existing kids are kept. this is done by looking in the current
+;;; value of the kids slot for a kid matching each new kidvalue and reusing that. we cannot use the
+;;; accessor kids because the first time thru the cell is internally invalid, so the rule will get dispatched
+;;; again in an infinite loop if we go through the accessor protocol.
+;;;
+;;; mind you, we could just use slot-value; .cache is just a convenience.
+;;;
+(defmodel bottle (model)
+ ((label :initarg :label :initform "unlabeled" :accessor label)))
+
+#+(or)
+(cv-family-values)
+
+(def-cell-test cv-family-values ()
+ (let* ((kf-calls 0)
+ (wall (make-instance 'family-values
+ :kv-collector (lambda (mdv)
+ (eko ("kidnos")(when (numberp mdv)
+ (loop for kn from 1 to (floor mdv)
+ collecting kn))))
+ :value (c-in 5)
+ :kv-key #'value
+ :kid-factory (lambda (f kv)
+ (incf kf-calls)
+ (trc "making kid" kv)
+ (make-instance 'bottle
+ :fm-parent f
+ :value kv
+ :label (c? (format nil "bottle ~d out of ~d on the wall"
+ (^value)
+ (length (kids f)))))))))
+ (ct-assert (eql 5 kf-calls))
+
+ (setq kf-calls 0)
+ (decf (value wall))
+ (ct-assert (eql 4 (length (kids wall))))
+ (ct-assert (zerop kf-calls))
+
+ (setq kf-calls 0)
+ (incf (value wall))
+ (ct-assert (eql 5 (length (kids wall))))
+ (ct-assert (eql 1 kf-calls))
+
+ ))
+
+#+(or)
+(cv-family-values)
Added: dependencies/trunk/cells/cells-test/test-kid-slotting.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-kid-slotting.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,84 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defmd image (family) left top width height)
+
+(defun i-right (x) (+ (left x) (width x)))
+(defun i-bottom (x) (+ (top x) (height x)))
+
+(defmd stack (image)
+ justify
+ (.kid-slots :initform (lambda (self)
+ (declare (ignore self))
+ (list
+ (mk-kid-slot (left :if-missing t)
+ (c? (+ (left .parent)
+ (ecase (justify .parent)
+ (:left 0)
+ (:center (floor (- (width .parent) (^width)) 2))
+ (:right (- (width .parent) (^width)))))))
+ (mk-kid-slot (top)
+ (c? (bif (psib (psib))
+ (i-bottom psib)
+ (top .parent))))))
+ :accessor kid-slots
+ :initarg :kid-slots))
+;;
+;; kid-slotting exists largely so graphical containers can be defined which arrange their
+;; component parts without those parts' cooperation. so a stack class can be defined as shown
+;; and then arbitrary components thrown in as children and they will be, say, right-justified
+;; because they will be endowed with rules as necessary to achieve that end by the parent stack.
+;;
+;; note the ifmissing option, which defaults to nil. the stack's goal is mainly to manage the
+;; top attribute of each kid to match any predecessor's i-bottom attribute. the stack will as a
+;; a convenience arrange for horizontal justification, but if some kid chose to define its
+;; left attribute that would be honored.
+;;
+(def-cell-test cv-kid-slotting ()
+ (cells-reset)
+ (let ((stack (make-instance 'stack
+ :left 10 :top 20
+ :width 500 :height 1000
+ :justify (c-in :left)
+ :kids (c? (eko ("kids") (loop for kn from 1 to 4
+ collect (make-kid 'image
+ :top 0 ;; overridden
+ :width (* kn 10)
+ :height (* kn 50)))))
+ )))
+ (ct-assert (eql (length (kids stack)) 4))
+ (ct-assert (and (eql 10 (left stack))
+ (every (lambda (k) (eql 10 (left k)))
+ (kids stack))))
+ (ct-assert (every (lambda (k)
+ (eql (top k) (i-bottom (fm-prior-sib k))))
+ (cdr (kids stack))))
+
+ (setf (justify stack) :right)
+ (ct-assert (and (eql 510 (i-right stack))
+ (every (lambda (k) (eql 510 (i-right k)))
+ (kids stack))))
+ ))
Added: dependencies/trunk/cells/cells-test/test-lazy.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-lazy.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,141 @@
+(in-package :cells)
+
+(defvar *tests* ())
+
+
+(defmacro deftest (name form &rest values)
+ "Po man's RT."
+ (let ((test-name (intern (format nil "TEST ~A" name))))
+ `(progn
+ (defun ,test-name ()
+ (let ((name ',name)
+ (form ',form)
+ (expected-values ',values)
+ (actual-values (multiple-value-list
+ (handler-case ,form
+ (error (val) val)))))
+ (assert (equal actual-values ',values) (actual-values)
+ "Test ~S failed~% ~
+ Form: ~A~% ~
+ Expected values: ~{~S~^; ~}~% ~
+ Actual values: ~{~S~^; ~}"
+ name form expected-values actual-values)
+ ',name))
+ (pushnew ',name *tests*)
+ ',name)))
+
+(defun do-test (name)
+ (let ((test (intern (format nil "TEST ~A" name) (symbol-package name))))
+ (funcall test)))
+
+(defun cv-test-lazy ()
+ (every #'do-test (reverse *tests*)))
+
+(defmacro unbound-error-p (form)
+ `(handler-case
+ (progn
+ ;;(print `(checking unbound error ,',form))
+ ,form nil)
+ (unbound-cell () t)))
+
+(defun make-cell-valid (self slot)
+ (setf (c-state (md-slot-cell self slot)) :valid))
+
+(defmodel unbound-values ()
+ ((val1 :initform (c-input ()) :initarg val1 :accessor test-val1)
+ (val2 :initform (c-input ()) :initarg val2 :accessor test-val2)))
+
+(defmodel unbound-formulas (unbound-values)
+ ((formula :initform nil ;; no longer an exception made for unechoed slots re c-awakening
+ :accessor test-formula)
+ (lazy-formula :initform (c-formula (:lazy t)
+ (^test-val1)
+ (^test-val2))
+ :accessor test-lazy-formula)))
+
+(defmodel unbound-formulas2 (unbound-values)
+ ((formula :initform (c? (^test-val1)
+ (^test-val2))
+ :accessor test-formula)
+ (lazy-formula :initform (c-formula (:lazy t)
+ (^test-val1)
+ (^test-val2))
+ :accessor test-lazy-formula)))
+
+(deftest unbound-values
+ (let ((self (make-instance 'unbound-values)))
+ (values (unbound-error-p (test-val1 self))
+ (unbound-error-p (test-val2 self))))
+ t t)
+
+(deftest md-slot-makunbound
+ (let ((self (progn (make-instance 'unbound-values
+ 'val1 (c-in nil) 'val2 (c-in nil)))))
+ (md-slot-makunbound self 'val1)
+ (md-slot-makunbound self 'val2)
+ (values (unbound-error-p (test-val1 self))
+ (unbound-error-p (test-val2 self))))
+ t t)
+
+(deftest formula-depends-on-unbound
+ (let ((obj1 (progn (make-instance 'unbound-formulas)))
+ (obj2 (progn (make-instance 'unbound-formulas))))
+ (values ;(unbound-error-p (test-formula obj1))
+ (unbound-error-p (test-lazy-formula obj1))
+
+ (unbound-error-p (test-lazy-formula obj2))
+ ;(unbound-error-p (test-formula obj2))
+ ))
+ t t)
+
+(deftest unbound-ok-for-unbound-formulas
+ (unbound-error-p
+ (progn (let ((self (progn (make-instance 'unbound-formulas))))
+ (setf (test-val1 self) t
+ (test-val2 self) t))
+ (let ((self (progn (make-instance 'unbound-formulas))))
+ (setf (test-val2 self) t
+ (test-val1 self) t))))
+ nil)
+
+(deftest unbound-errs-for-eager
+ (let ((self (progn (make-instance 'unbound-formulas2
+ 'val1 (c-in 1) 'val2 (c-in 2)))))
+ (values (test-formula self)
+ (unbound-error-p (md-slot-makunbound self 'val1))
+ (unbound-error-p (md-slot-makunbound self 'val2))
+ ))
+ 2 t t
+ )
+
+(deftest unbound-ok-for-unchecked-lazy
+ (let ((self (progn (make-instance 'unbound-formulas
+ 'val1 (c-in 1) 'val2 (c-in 2)))))
+ (values (test-lazy-formula self)
+ (unbound-error-p (md-slot-makunbound self 'val1))
+ (unbound-error-p (md-slot-makunbound self 'val2))))
+ 2 nil nil)
+
+#+(or)
+(cv-test-lazy)
+
+(defparameter *lz1-count* 0)
+
+(defmd lz-simple ()
+ (lz1 (c?_ (incf *lz1-count*)
+ (* 2 (^lz2))))
+ (lz2 (c-in 0)))
+
+(defun lz-test ()
+ (cells-reset)
+ (let ((*lz1-count* 0)
+ (lz (make-instance 'lz-simple)))
+ (assert (zerop *lz1-count*))
+ (incf (lz2 lz))
+ (assert (zerop *lz1-count*))
+ (assert (= (lz1 lz) 2))
+ (assert (= 1 *lz1-count*))
+ lz))
+
+#+test
+(lz-test)
Added: dependencies/trunk/cells/cells-test/test-synapse.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test-synapse.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,122 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+(defmodel m-syn ()
+ ((m-syn-a :initform nil :initarg :m-syn-a :accessor m-syn-a)
+ (m-syn-b :initform nil :initarg :m-syn-b :accessor m-syn-b)
+ (m-syn-factor :initform nil :initarg :m-syn-factor :accessor m-syn-factor)
+ (m-sens :initform nil :initarg :m-sens :accessor m-sens)
+ (m-plus :initform nil :initarg :m-plus :accessor m-plus)
+ ))
+
+(defobserver m-syn-b ()
+ (print `(output m-syn-b ,self ,new-value ,old-value)))
+
+(def-cell-test m-syn-bool
+ (let* ((delta-ct 0)
+ (m (make-instance 'm-syn
+ :m-syn-a (c-in nil)
+ :m-syn-b (c? (incf delta-ct)
+ (trc "syn-b containing rule firing!!!!!!!!!!!!!!" delta-ct)
+ (bwhen (msg (with-synapse :xyz42 ()
+ (trc "synapse fires!!! ~a" (^m-syn-a))
+ (bIF (k (find (^m-syn-a) '(:one :two :three)))
+ (values k :propagate)
+ (values NIL :no-propagate))))
+ msg)))))
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (null (m-syn-b m)))
+ (setf (m-syn-a m) :nine)
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (null (m-syn-b m)))
+ (setf (m-syn-a m) :one)
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (eq :one (m-syn-b m)))
+ (setf (m-syn-a m) :nine)
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (eq :one (m-syn-b m)))))
+
+(def-cell-test m-syn
+ (let* ((delta-ct 0)
+ (sens-ct 0)
+ (plus-ct 0)
+ (m (make-instance 'm-syn
+ :m-syn-a (c-in 0)
+ :m-syn-b (c? (incf delta-ct)
+ (trc nil "syn-b rule firing!!!!!!!!!!!!!! new delta-ct:" delta-ct)
+ (eko (nil "syn-b rule returning")
+ (f-delta :syna-1 (:sensitivity 2)
+ (^m-syn-a))))
+ :m-syn-factor (c-in 1)
+ :m-sens (c? (incf sens-ct)
+ (trc nil "m-sens rule firing ~d !!!!!!!!!!!!!!" sens-ct)
+ (* (^m-syn-factor)
+ (f-sensitivity :sensa (3) (^m-syn-a))))
+ :m-plus (c? (incf plus-ct)
+ (trc nil "m-plus rule firing!!!!!!!!!!!!!!" plus-ct)
+ (f-plusp :syna-2 (- 2 (^m-syn-a)))))))
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (= 1 sens-ct))
+ (ct-assert (= 1 plus-ct))
+ (ct-assert (= 0 (m-sens m)))
+ (trc "make-instance verified. about to incf m-syn-a")
+ (incf (m-syn-a m))
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (= 1 sens-ct))
+ (ct-assert (= 1 plus-ct))
+ (ct-assert (= 0 (m-sens m)))
+ (trc "about to incf m-syn-a 2")
+ (incf (m-syn-a m) 2)
+ (trc nil "syn-b now" (m-syn-b m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 2 sens-ct))
+ (ct-assert (= 2 plus-ct))
+
+ (ct-assert (= 3 (m-sens m)))
+ (trc "about to incf m-syn-a")
+ (incf (m-syn-a m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 2 sens-ct))
+ (trc "about to incf m-syn-factor")
+ (incf (m-syn-factor m))
+ (ct-assert (= 3 sens-ct))
+ (ct-assert (= (m-sens m) (* (m-syn-factor m) (m-syn-a m))))
+ (trc "about to incf m-syn-a xxx")
+ (incf (m-syn-a m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 3 sens-ct))
+ (trc "about to incf m-syn-a yyyy")
+ (incf (m-syn-a m))
+ (ct-assert (= 3 delta-ct))
+ (ct-assert (= 4 sens-ct))
+ (ct-assert (= 2 plus-ct))
+ (describe m)
+ (print '(start))))
+
+(defobserver m-syn-a ()
+ (trc "!!! M-SYN-A now =" new-value))
+
+#+(or)
+(m-syn)
+
Added: dependencies/trunk/cells/cells-test/test.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,273 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+#| Synapse Cell Unification Notes
+
+- start by making Cells synapse-y
+
+- make sure outputs show right old and new values
+- make sure outputs fire when they should
+
+- wow: test the Cells II dictates: no output callback sees stale data, no rule
+sees stale data, etc etc
+
+- test a lot of different synapses
+
+- make sure they fire when they should, and do not when they should not
+
+- make sure they survive an evaluation by the caller which does not branch to
+them (ie, does not access them)
+
+- make sure they optimize away
+
+- test with forms which access multiple other cells
+
+- look at direct alteration of a caller
+
+- does SETF honor not propagating, as well as a c-ruled after re-calcing
+
+- do diff unchanged tests such as string-equal work
+
+|#
+
+#| do list
+
+
+-- test drifters (and can they be handled without creating a special
+subclass for them?)
+
+|#
+
+(eval-when (compile load)
+ (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))))
+
+(in-package :cells)
+
+(defvar *cell-tests* nil)
+
+#+go
+(test-cells)
+
+
+(defun test-cells ()
+ (dribble "/home/alessio/0algebra/cells-test.txt")
+ (progn ;prof:with-profiling (:type :time)
+ (time
+ (progn
+ (loop for test in (reverse *cell-tests*)
+ when t ; (eq 'cv-test-person-5 test)
+ do (cell-test-init test)
+ (funcall test))
+ (print (make-string 40 :initial-element #\*))
+ (print (make-string 40 :initial-element #\*))
+ (print "*** Cells-test successfully completed **")
+ (print (make-string 40 :initial-element #\*))
+ (print (make-string 40 :initial-element #\*)))))
+ ;(prof:show-call-graph)
+ (dribble))
+
+(defun cell-test-init (name)
+ (print (make-string 40 :initial-element #\!))
+ (print `(starting test ,name))
+ (print (make-string 40 :initial-element #\!))
+ (cells-reset))
+
+(defmacro def-cell-test (name &rest body)
+ `(progn
+ (pushnew ',name *cell-tests*)
+ (defun ,name ()
+ (cells-reset)
+ , at body)))
+
+(defmacro ct-assert (form &rest stuff)
+ `(progn
+ (print `(attempting ,',form))
+ (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff))))
+
+;; test huge number of useds by one rule
+
+(defmd m-index (family)
+ :value (c? (bwhen (ks (^kids))
+ ;(trc "chya" (mapcar 'value ks))
+ (apply '+ (mapcar 'value ks)))))
+
+(def-cell-test many-useds
+ (let ((i (make-instance 'm-index)))
+ (loop for n below 100
+ do (push (make-instance 'model
+ :fm-parent i
+ :value (c-in n))
+ (kids i)))
+ (trc "index total" (value i))
+ (ct-assert (= 4950 (value i)))))
+
+#+test
+(many-useds)
+
+(defmd m-null ()
+ (aa :cell nil :initform nil :initarg :aa :accessor aa))
+
+
+(def-cell-test m-null
+ (let ((m (make-instance 'm-null :aa 42)))
+ (ct-assert (= 42 (aa m)))
+ (ct-assert (= 21 (let ((slot 'aa))
+ (funcall (fdefinition `(setf ,slot)) (- (aa m) 21) m))))
+ :okay-m-null))
+
+(defmd m-solo () m-solo-a m-solo-b)
+
+(def-cell-test m-solo
+ (let ((m (make-instance 'm-solo
+ :m-solo-a (c-in 42)
+ :m-solo-b (c? (trc "b fires")(* 2 (^m-solo-a))))))
+ (ct-assert (= 42 (m-solo-a m)))
+ (ct-assert (= 84 (m-solo-b m)))
+ (decf (m-solo-a m))
+ (ct-assert (= 41 (m-solo-a m)))
+ (ct-assert (= 82 (m-solo-b m)))
+ :okay-m-null))
+
+(defmd m-var () m-var-a m-var-b)
+
+(defobserver m-var-b ()
+ (print `(output m-var-b ,self ,new-value ,old-value)))
+
+(def-cell-test m-var
+ (let ((m (make-instance 'm-var :m-var-a (c-in 42) :m-var-b 1951)))
+ (ct-assert (= 42 (m-var-a m)))
+ (ct-assert (= 21 (decf (m-var-a m) 21)))
+ (ct-assert (= 21 (m-var-a m)))
+ :okay-m-var))
+
+(defmd m-var-output ()
+ cbb
+ (aa :cell nil :initform nil :initarg :aa :accessor aa))
+
+(defobserver cbb ()
+ (trc "output cbb" self)
+ (setf (aa self) (- new-value (if old-value-boundp
+ old-value 0))))
+
+(def-cell-test m-var-output
+ (let ((m (make-instance 'm-var-output :cbb (c-in 42))))
+ (ct-assert (eql 42 (cbb m)))
+ (ct-assert (eql 42 (aa m)))
+ (ct-assert (eql 27 (decf (cbb m) 15)))
+ (ct-assert (eql 27 (cbb m)))
+ (ct-assert (eql -15 (aa m)))
+ (list :okay-m-var (aa m))))
+
+(defmd m-var-linearize-setf () ccc ddd)
+
+(defobserver ccc ()
+ (with-integrity (:change)
+ (setf (ddd self) (- new-value (if old-value-boundp
+ old-value 0)))))
+
+(def-cell-test m-var-linearize-setf
+ (let ((m (make-instance 'm-var-linearize-setf
+ :ccc (c-in 42)
+ :ddd (c-in 1951))))
+
+ (ct-assert (= 42 (ccc m)))
+ (ct-assert (= 42 (ddd m)))
+ (ct-assert (= 27 (decf (ccc m) 15)))
+ (ct-assert (= 27 (ccc m)))
+ (ct-assert (= -15 (ddd m)))
+ :okay-m-var))
+
+;;; -------------------------------------------------------
+
+(defmd m-ruled ()
+ eee
+ (fff (c? (floor (^ccc) 2))))
+
+(defobserver eee ()
+ (print `(output> eee ,new-value old ,old-value)))
+
+(defobserver fff ()
+ (print `(output> eee ,new-value old ,old-value)))
+
+(def-cell-test m-ruled
+ (let ((m (make-instance 'm-ruled
+ :eee (c-in 42)
+ :fff (c? (floor (^eee) 2)))))
+ (trc "___Initial TOBE done____________________")
+ (print `(pulse ,*data-pulse-id*))
+ (ct-assert (= 42 (eee m)))
+ (ct-assert (= 21 (fff m)))
+ (ct-assert (= 36 (decf (eee m) 6)))
+ (print `(pulse ,*data-pulse-id*))
+ (ct-assert (= 36 (eee m)))
+ (ct-assert (= 18 (fff m)) m)
+ :okay-m-ruled))
+
+(defmd m-worst-case ()
+ (wc-x (c-input () 2))
+ (wc-a (c? (prog2
+ (trc "Start A")
+ (when (oddp (wc-x self))
+ (wc-c self))
+ (trc "Stop A"))))
+ (wc-c (c? (evenp (wc-x self))))
+ (wc-h (c? (or (wc-c self)(wc-a self)))))
+
+(defun dependency-dump (self)
+ (let ((slot-cells (loop for esd in (class-slots (class-of self))
+ for sn = (slot-definition-name esd)
+ for c = (md-slot-cell self sn)
+ when c
+ collect (cons sn c))))
+ (trc "dependencies of" self)
+ (loop for (sn . c) in slot-cells
+ do (trc "slot" sn :callers (mapcar 'c-slot-name (c-callers c))))))
+
+(def-cell-test m-worst-case
+ (let ((m (make-instance 'm-worst-case)))
+ (dependency-dump m)
+ (trc "___Initial TOBE done____________________")
+ (ct-assert (eql t (wc-c m)))
+ (ct-assert (eql nil (wc-a m)))
+ (ct-assert (eql t (wc-h m)))
+ (dependency-dump m)
+ (ct-assert (eql 3 (incf (wc-x m))))))
+
+(defmd c?n-class ()
+ aaa bbb
+ (sum (c? (+ (^aaa) (^bbb)))))
+
+(def-cell-test test-c?n ()
+ (let ((self (make-instance 'c?n-class
+ :aaa (c?n (+ (^bbb) 2))
+ :bbb (c-in 40))))
+ (ct-assert (= (^bbb) 40)) ;; make sure I have not broken (setf slot-value)...it happens
+ (ct-assert (= (^aaa) 42)) ;; make sure the rule ran and the value stored as the slot value
+ (ct-assert (= (^sum) 82)) ;; make sure a normal rule works off the others
+ (setf (^bbb) 100)
+ (ct-assert (= (^bbb) 100)) ;; just checking
+ (ct-assert (= (^aaa) 42)) ;; make sure the rule did not run again
+ (ct-assert (= (^sum) 142)) ;; ... but the other rule does fire
+ (setf (^aaa) -58)
+ (ct-assert (= (^aaa) -58)) ;; ... we can setf the once-ruled slot
+ (ct-assert (= (^sum) 42)) ;; ... propagation still works from the once-ruled, now-input slot
+ ))
Added: dependencies/trunk/cells/cells-test/test.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells-test/test.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,13 @@
+;; -*- lisp-version: "8.0 [Windows] (Mar 7, 2006 20:04)"; cg: "1.81"; -*-
+
+(in-package :cg-user)
+
+(defpackage :CELLS)
+
+(define-project :name :test
+ :modules (list (make-instance 'module :name "test.lisp")
+ (make-instance 'module :name "test-ephemeral.lisp")
+ (make-instance 'module :name "test-cycle.lisp")
+ (make-instance 'module :name "test-synapse.lisp")
+ (make-instance 'module :name "output-timing.lisp"))
+ :projects (list (make-instance 'project-module :name "..\\cells"))
\ No newline at end of file
Added: dependencies/trunk/cells/cells.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,47 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+#+(or allegro lispworks cmu mcl clisp cormanlisp sbcl scl abcl)
+(progn
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
+(asdf:defsystem :cells
+ :name "cells"
+ :author "Kenny Tilton "
+ :maintainer "Kenny Tilton "
+ :licence "Lisp LGPL"
+ :description "Cells"
+ :long-description "Cells: a dataflow extension to CLOS."
+ :version "3.0"
+ :serial t
+ :depends-on (:utils-kt)
+ :components ((:file "defpackage")
+ (:file "trc-eko")
+ (:file "cells")
+ (:file "integrity")
+ (:file "cell-types")
+ (:file "constructors")
+ (:file "initialize")
+ (:file "md-slot-value")
+ (:file "slot-utilities")
+ (:file "link")
+ (:file "propagate")
+ (:file "synapse")
+ (:file "synapse-types")
+ (:file "model-object")
+ (:file "defmodel")
+ (:file "md-utilities")
+ (:file "family")
+ (:file "fm-utilities")
+ (:file "family-values")
+ (:file "test-propagation")
+ (:file "cells-store")
+ (:file "test-cc")))
+
+(defmethod perform ((o load-op) (c (eql (find-system :cells))))
+ (pushnew :cells *features*))
+
+(defmethod perform ((o test-op) (c (eql (find-system :cells))))
+ (oos 'load-op :cells-test))
+
+(defmethod perform ((o test-op) (c (eql :cells)))
+ (oos 'load-op :cells-test)))
Added: dependencies/trunk/cells/cells.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,190 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+#| Notes
+
+I don't like the way with-cc defers twice, first the whole thing and then when the
+body finally runs we are still within the original integrity and each setf gets queued
+to UFB separately before md-slot-value-assume finally runs. I think all that is going on here
+is that we want the programmer to use with-cc to show they know the setf will not be returning
+a useful value. But since they have coded the with-cc we should be able to figure out a way to
+let those SETFs thru as if they were outside integrity, and then we get a little less UFBing
+but even better SETF behaves as it should.
+
+It would be nice to do referential integrity and notice any time a model object gets stored in
+a cellular slot (or in a list in such) and then mop those up on not-to-be.
+
+|#
+
+(in-package :cells)
+
+(defparameter *c-prop-depth* 0)
+(defparameter *causation* nil)
+
+(defparameter *data-pulse-id* 0)
+(define-symbol-macro .dpid *data-pulse-id*)
+(defparameter *finbiz-id* 0) ;; debugging tool only
+(define-symbol-macro .fbid *finbiz-id*)
+
+(export! .dpid .fbid)
+(defparameter *c-debug* nil)
+(defparameter *defer-changes* nil)
+(defparameter *within-integrity* nil)
+(defvar *istack*)
+(defparameter *client-queue-handler* nil)
+(defparameter *unfinished-business* nil)
+(defparameter *not-to-be* nil)
+
+(defparameter *awake* nil)
+(defparameter *awake-ct* nil)
+
+#+test
+(cells-reset)
+
+(defun cells-reset (&optional client-queue-handler &key debug)
+ (utils-kt-reset)
+ (setf
+ *c-debug* debug
+ *c-prop-depth* 0
+ *awake-ct* nil
+ *awake* nil
+ *not-to-be* nil
+ *data-pulse-id* 0
+ *finbiz-id* 0
+ *defer-changes* nil ;; should not be necessary, but cannot be wrong
+ *client-queue-handler* client-queue-handler
+ *within-integrity* nil
+ *unfinished-business* nil
+ *trcdepth* 0)
+ (trc nil "------ cell reset ----------------------------"))
+
+(defun c-stop (&optional why)
+ (setf *stop* t)
+ (print `(c-stop-entry ,why))
+ (format t "~&C-STOP> stopping because ~a" why) )
+
+(define-symbol-macro .stop
+ (c-stop :user))
+
+(defun c-stopped ()
+ *stop*)
+
+(export! .stopped .cdbg)
+
+(define-symbol-macro .cdbg
+ *c-debug*)
+
+(define-symbol-macro .stopped
+ (c-stopped))
+
+(defmacro c-assert (assertion &optional places fmt$ &rest fmt-args)
+ (declare (ignorable assertion places fmt$ fmt-args))
+ #+(or)`(progn)
+ `(unless *stop*
+ (unless ,assertion
+ ,(if fmt$
+ `(c-break ,fmt$ , at fmt-args)
+ `(c-break "failed assertion: ~a" ',assertion)))))
+
+(defvar *call-stack* nil)
+(defvar *depender* nil)
+;; 2008-03-15: *depender* let's us differentiate between the call stack and
+;; and dependency. The problem with overloading *call-stack* with both roles
+;; is that we miss cyclic reentrance when we use without-c-dependency in a
+;; rule to get "once" behavior or just when fm-traversing to find someone
+
+(defmacro def-c-trace (model-type &optional slot cell-type)
+ `(defmethod trcp ((self ,(case cell-type
+ (:c? 'c-dependent)
+ (otherwise 'cell))))
+ (and (typep (c-model self) ',model-type)
+ ,(if slot
+ `(eq (c-slot-name self) ',slot)
+ `t))))
+
+(defmacro without-c-dependency (&body body)
+ ` (let (*depender*)
+ , at body))
+
+(export! .cause)
+
+(define-symbol-macro .cause
+ (car *causation*))
+
+(define-condition unbound-cell (unbound-slot)
+ ((cell :initarg :cell :reader cell :initform nil)))
+
+(defgeneric slot-value-observe (slotname self new old old-boundp cell)
+ #-(or cormanlisp)
+ (:method-combination progn))
+
+#-cells-testing
+(defmethod slot-value-observe #-(or cormanlisp) progn
+ (slot-name self new old old-boundp cell)
+ (declare (ignorable slot-name self new old old-boundp cell)))
+
+#+hunh
+(fmakunbound 'slot-value-observe)
+; -------- cell conditions (not much used) ---------------------------------------------
+
+(define-condition xcell () ;; new 2k0227
+ ((cell :initarg :cell :reader cell :initform nil)
+ (app-func :initarg :app-func :reader app-func :initform 'bad-cell)
+ (error-text :initarg :error-text :reader error-text :initform "??>")
+ (other-data :initarg :other-data :reader other-data :initform ""))
+ (:report (lambda (c s)
+ (format s "~& trouble with cell ~a in function ~s,~s: ~s"
+ (cell c) (app-func c) (error-text c) (other-data c)))))
+
+(define-condition c-enabling ()
+ ((name :initarg :name :reader name)
+ (model :initarg :model :reader model)
+ (cell :initarg :cell :reader cell))
+ (:report (lambda (condition stream)
+ (format stream "~&unhandled : ~s" condition)
+ (break "~&i say, unhandled : ~s" condition))))
+
+(define-condition c-fatal (xcell)
+ ((name :initform :anon :initarg :name :reader name)
+ (model :initform nil :initarg :model :reader model)
+ (cell :initform nil :initarg :cell :reader cell))
+ (:report (lambda (condition stream)
+ (format stream "~&fatal cell programming error: ~s" condition)
+ (format stream "~& : ~s" (name condition))
+ (format stream "~& : ~s" (model condition))
+ (format stream "~& : ~s" (cell condition)))))
+
+
+(define-condition asker-midst-askers (c-fatal)
+ ())
+;; "see listener for cell rule cycle diagnotics"
+
+(define-condition c-unadopted (c-fatal) ()
+ (:report
+ (lambda (condition stream)
+ (format stream "~&unadopted cell >: ~s" (cell condition))
+ (format stream "~& >: often you mis-edit (c? (c? ...)) nesting is error"))))
+
+(defun c-break (&rest args)
+ (unless *stop*
+ (let ((*print-level* 5)
+ (*print-circle* t)
+ (args2 (mapcar 'princ-to-string args)))
+ (c-stop :c-break)
+ ;(format t "~&c-break > stopping > ~{~a ~}" args2)
+ (apply 'error args2))))
\ No newline at end of file
Added: dependencies/trunk/cells/cells.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/cells.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,57 @@
+;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*-
+
+(in-package :cg-user)
+
+(defpackage :CELLS)
+
+(define-project :name :cells
+ :modules (list (make-instance 'module :name "defpackage.lisp")
+ (make-instance 'module :name "trc-eko.lisp")
+ (make-instance 'module :name "cells.lisp")
+ (make-instance 'module :name "integrity.lisp")
+ (make-instance 'module :name "cell-types.lisp")
+ (make-instance 'module :name "constructors.lisp")
+ (make-instance 'module :name "initialize.lisp")
+ (make-instance 'module :name "md-slot-value.lisp")
+ (make-instance 'module :name "slot-utilities.lisp")
+ (make-instance 'module :name "link.lisp")
+ (make-instance 'module :name "propagate.lisp")
+ (make-instance 'module :name "synapse.lisp")
+ (make-instance 'module :name "synapse-types.lisp")
+ (make-instance 'module :name "model-object.lisp")
+ (make-instance 'module :name "defmodel.lisp")
+ (make-instance 'module :name "md-utilities.lisp")
+ (make-instance 'module :name "family.lisp")
+ (make-instance 'module :name "fm-utilities.lisp")
+ (make-instance 'module :name "family-values.lisp")
+ (make-instance 'module :name "test-propagation.lisp")
+ (make-instance 'module :name "cells-store.lisp")
+ (make-instance 'module :name "test-cc.lisp"))
+ :projects (list (make-instance 'project-module :name
+ "utils-kt\\utils-kt" :show-modules
+ nil))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :cells
+ :main-form nil
+ :compilation-unit t
+ :verbose nil
+ :runtime-modules nil
+ :splash-file-module (make-instance 'build-module :name "")
+ :icon-file-module (make-instance 'build-module :name "")
+ :include-flags (list :local-name-info)
+ :build-flags (list :allow-debug :purify)
+ :autoload-warning t
+ :full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
+ :default-command-line-arguments "+cx +t \"Initializing\""
+ :additional-build-lisp-image-arguments (list :read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :build-number 0
+ :on-initialization 'cells::test-with-cc
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/constructors.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/constructors.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,219 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(eval-now!
+ (export '(.cache-bound-p
+
+ ;; Cells Constructors
+ c?n
+ c?once
+ c?n-until
+ c?1
+ c_1
+ c?+n
+
+ ;; Debug Macros and Functions
+ c?dbg
+ c_?dbg
+ c-input-dbg
+
+ )))
+
+;___________________ constructors _______________________________
+
+(defmacro c-lambda (&body body)
+ `(c-lambda-var (slot-c) , at body))
+
+(defmacro c-lambda-var ((c) &body body)
+ `(lambda (,c &aux (self (c-model ,c))
+ (.cache (c-value ,c))
+ (.cache-bound-p (cache-bound-p ,c)))
+ (declare (ignorable .cache .cache-bound-p self))
+ , at body))
+
+(defmacro with-c-cache ((fn) &body body)
+ (let ((new (gensym)))
+ `(or (bwhen (,new (progn , at body))
+ (funcall ,fn ,new .cache))
+ .cache)))
+
+;-----------------------------------------
+
+(defmacro c? (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :rule (c-lambda , at body)))
+
+(defmacro c?+n (&body body)
+ `(make-c-dependent
+ :inputp t
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :rule (c-lambda , at body)))
+
+(defmacro c?n (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! '(without-c-dependency , at body)
+ :inputp t
+ :value-state :unevaluated
+ :rule (c-lambda (without-c-dependency , at body))))
+
+(export! c?n-dbg)
+
+(defmacro c?n-dbg (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! '(without-c-dependency , at body)
+ :inputp t
+ :debug t
+ :value-state :unevaluated
+ :rule (c-lambda (without-c-dependency , at body))))
+
+(defmacro c?n-until (args &body body)
+ `(make-c-dependent
+ :optimize :when-value-t
+ :code #+its-alive! nil #-its-alive! ',body
+ :inputp t
+ :value-state :unevaluated
+ :rule (c-lambda , at body)
+ , at args))
+
+(defmacro c?once (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! '(without-c-dependency , at body)
+ :inputp nil
+ :value-state :unevaluated
+ :rule (c-lambda (without-c-dependency , at body))))
+
+(defmacro c_1 (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! '(without-c-dependency , at body)
+ :inputp nil
+ :lazy t
+ :value-state :unevaluated
+ :rule (c-lambda (without-c-dependency , at body))))
+
+(defmacro c?1 (&body body)
+ `(c?once , at body))
+
+(defmacro c?dbg (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :debug t
+ :rule (c-lambda , at body)))
+
+(defmacro c?_ (&body body)
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :lazy t
+ :rule (c-lambda , at body)))
+
+(defmacro c_? (&body body)
+ "Lazy until asked, then eagerly propagating"
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :lazy :until-asked
+ :rule (c-lambda , at body)))
+
+(defmacro c_?dbg (&body body)
+ "Lazy until asked, then eagerly propagating"
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',body
+ :value-state :unevaluated
+ :lazy :until-asked
+ :rule (c-lambda , at body)
+ :debug t))
+
+(defmacro c?? ((&key (tagp nil) (in nil) (out t))&body body)
+ (let ((result (copy-symbol 'result))
+ (thetag (gensym)))
+ `(make-c-dependent
+ :code ',body
+ :value-state :unevaluated
+ :rule (c-lambda
+ (let ((,thetag (gensym "tag"))
+ (*trcdepth* (1+ *trcdepth*))
+ )
+ (declare (ignorable self ,thetag))
+ ,(when in
+ `(trc "c??> entry" (c-slot-name c) (c-model c) (when ,tagp ,thetag)))
+ (count-it :c?? (c-slot-name c) (md-name (c-model c)))
+ (let ((,result (progn , at body)))
+ ,(when out `(trc "c?? result:" ,result (c-slot-name c) (when ,tagp ,thetag)))
+ ,result))))))
+
+(defmacro c-formula ((&rest keys &key lazy &allow-other-keys) &body forms)
+ (assert (member lazy '(nil t :once-asked :until-asked :always)))
+ `(make-c-dependent
+ :code #+its-alive! nil #-its-alive! ',forms
+ :value-state :unevaluated
+ :rule (c-lambda , at forms)
+ , at keys))
+
+(defmacro c-input ((&rest keys) &optional (value nil valued-p))
+ `(make-cell
+ :inputp t
+ :value-state ,(if valued-p :valid :unbound)
+ :value ,value
+ , at keys))
+
+(defmacro c-in (value)
+ `(make-cell
+ :inputp t
+ :value-state :valid
+ :value ,value))
+
+(export! c-in-lazy c_in)
+
+(defmacro c-in-lazy (&body body)
+ `(c-input (:lazy :once-asked) (progn , at body)))
+
+(defmacro c_in (&body body)
+ `(c-input (:lazy :once-asked) (progn , at body)))
+
+(defmacro c-input-dbg (&optional (value nil valued-p))
+ `(make-cell
+ :inputp t
+ :debug t
+ :value-state ,(if valued-p :valid :unbound)
+ :value ,value))
+
+(defmacro c... ((value) &body body)
+ `(make-c-drifter
+ :code ',body
+ :value-state :valid
+ :value ,value
+ :rule (c-lambda , at body)))
+
+(defmacro c-abs (value &body body)
+ `(make-c-drifter-absolute
+ :code ',body
+ :value-state :valid
+ :value ,value
+ :rule (c-lambda , at body)))
+
+
+(defmacro c-envalue (&body body)
+ `(make-c-envaluer
+ :envalue-rule (c-lambda , at body)))
+
Added: dependencies/trunk/cells/defmodel.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/defmodel.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,207 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+(defmacro defmodel (class directsupers slotspecs &rest options)
+ ;;(print `(defmodel sees directsupers ,directsupers using ,(or directsupers :model-object)))
+ (assert (not (find class directsupers))() "~a cannot be its own superclass" class)
+ `(progn
+ (setf (get ',class :cell-types) nil)
+ (setf (get ',class 'slots-excluded-from-persistence)
+ (loop for slotspec in ',slotspecs
+ unless (and (getf (cdr slotspec) :ps t)
+ (getf (cdr slotspec) :persistable t))
+ collect (car slotspec)))
+ (loop for slotspec in ',slotspecs
+ do (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t)
+ &allow-other-keys)
+ slotspec
+ (declare (ignorable slotargs))
+ (when cell
+ (setf (md-slot-cell-type ',class slotname) cell))))
+ ;; define slot macros before class so they can appear in
+ ;; initforms and default-initargs
+ ,@(loop for slotspec in slotspecs
+ nconcing (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t) (accessor slotname) reader
+ &allow-other-keys)
+ slotspec
+ (declare (ignorable slotargs ))
+ (when cell
+ (list (let* ((reader-fn (or reader accessor))
+ (deriver-fn (intern$ "^" (symbol-name reader-fn))))
+ `(eval-when (:compile-toplevel :execute :load-toplevel)
+ (unless (macro-function ',deriver-fn)
+ (defmacro ,deriver-fn ()
+ `(,',reader-fn self)))
+ #+sbcl (unless (fboundp ',reader-fn)
+ (defgeneric ,reader-fn (slot)))))))))
+
+ ;
+ ; ------- defclass --------------- (^slot-value ,model ',',slotname)
+ ;
+ (prog1
+ (defclass ,class ,(or directsupers '(model-object)) ;; now we can def the class
+ ,(mapcar (lambda (s)
+ (list* (car s)
+ (let ((ias (cdr s)))
+ (remf ias :persistable)
+ (remf ias :ps)
+ ;; We handle accessor below
+ (when (getf ias :cell t)
+ (remf ias :reader)
+ (remf ias :writer)
+ (remf ias :accessor))
+ (remf ias :cell)
+ (remf ias :owning)
+ (remf ias :unchanged-if)
+ ias))) (mapcar #'copy-list slotspecs))
+ (:documentation
+ ,@(or (cdr (find :documentation options :key #'car))
+ '("chya")))
+ (:default-initargs ;; nil ok and needed: acl oddity in re not clearing d-i's sans this
+ ,@(cdr (find :default-initargs options :key #'car)))
+ (:metaclass ,(or (cadr (find :metaclass options :key #'car))
+ 'standard-class)))
+
+ (defmethod shared-initialize :after ((self ,class) slot-names &rest iargs &key)
+ (declare (ignore slot-names iargs))
+ ,(when (and directsupers (not (member 'model-object directsupers)))
+ `(unless (typep self 'model-object)
+ (error "If no superclass of ~a inherits directly
+or indirectly from model-object, model-object must be included as a direct super-class in
+the defmodel form for ~a" ',class ',class))))
+
+ ;
+ ; slot accessors once class is defined...
+ ;
+ ,@(mapcar (lambda (slotspec)
+ (destructuring-bind
+ (slotname &rest slotargs
+ &key (cell t) unchanged-if (accessor slotname) reader writer type
+ &allow-other-keys)
+ slotspec
+
+ (declare (ignorable slotargs))
+ (when cell
+ (let* ((reader-fn (or reader accessor))
+ (writer-fn (or writer accessor))
+ )
+ `(progn
+ ,(when writer-fn
+ `(defmethod (setf ,writer-fn) (new-value (self ,class))
+ (setf (md-slot-value self ',slotname)
+ ,(if type
+ `(coerce new-value ',type)
+ 'new-value))))
+ ,(when reader-fn
+ `(defmethod ,reader-fn ((self ,class))
+ (md-slot-value self ',slotname)))
+ ,(when unchanged-if
+ `(def-c-unchanged-test (,class ,slotname) ,unchanged-if)))))))
+ slotspecs))
+ (loop for slotspec in ',slotspecs
+ do (destructuring-bind
+ (slotname &rest slotargs &key (cell t) owning &allow-other-keys)
+ slotspec
+ (declare (ignorable slotargs))
+ (when (and cell owning)
+ (setf (md-slot-owning-direct? ',class slotname) owning))))))
+
+(defun defmd-canonicalize-slot (slotname
+ &key
+ (cell nil cell-p)
+ (ps t ps-p)
+ (persistable t persistable-p)
+ (owning nil owning-p)
+ (type nil type-p)
+ (initform nil initform-p)
+ (initarg (intern (symbol-name slotname) :keyword))
+ (documentation nil documentation-p)
+ (unchanged-if nil unchanged-if-p)
+ (reader slotname reader-p)
+ (writer `(setf ,slotname) writer-p)
+ (accessor slotname accessor-p)
+ (allocation nil allocation-p))
+ (list* slotname :initarg initarg
+ (append
+ (when cell-p (list :cell cell))
+ (when ps-p (list :ps ps))
+ (when persistable-p (list :persistable persistable))
+ (when owning-p (list :owning owning))
+ (when type-p (list :type type))
+ (when initform-p (list :initform initform))
+ (when unchanged-if-p (list :unchanged-if unchanged-if))
+ (when reader-p (list :reader reader))
+ (when writer-p (list :writer writer))
+ (when (or accessor-p
+ (not (and reader-p writer-p)))
+ (list :accessor accessor))
+ (when allocation-p (list :allocation allocation))
+ (when documentation-p (list :documentation documentation)))))
+
+(defmacro defmd (class superclasses &rest mdspec)
+ `(defmodel ,class (, at superclasses model)
+ ,@(let (definitargs class-options slots)
+ (loop with skip
+ for (spec next) on mdspec
+ if skip
+ do (setf skip nil)
+ else do (etypecase spec
+ (cons
+ (cond
+ ((keywordp (car spec))
+ (assert (find (car spec) '(:documentation :metaclass)))
+ (push spec class-options))
+ ((find (cadr spec) '(:initarg :type :ps :persistable :cell :initform :allocation :reader :writer :accessor :documentation))
+ (push (apply 'defmd-canonicalize-slot spec) slots))
+ (t ;; shortform (slotname initform &rest slotdef-key-values)
+ (push (apply 'defmd-canonicalize-slot
+ (list* (car spec) :initform (cadr spec) (cddr spec))) slots))))
+ (keyword
+ (setf definitargs (append definitargs (list spec next)))
+ (setf skip t))
+ (symbol (push (list spec :initform nil
+ :initarg (intern (symbol-name spec) :keyword)
+ :accessor spec) slots)))
+ finally
+ (return (list* (nreverse slots)
+ (delete nil
+ (list* `(:default-initargs , at definitargs)
+ (nreverse class-options)))))))))
+
+
+
+#+test
+(progn
+ (defclass md-test-super ()())
+
+ (defmd defmd-test (md-test-super)
+ (aaa :cell nil :initform nil :initarg :aaa :accessor aaa) ;; defmd would have written the same
+ (aa2 :documentation "hi mom")
+ bbb
+ (ccc 42 :allocation :class)
+ (ddd (c-in nil) :cell :ephemeral)
+ :superx 42 ;; default-initarg
+ (:documentation "as if!")))
+
+
+
Added: dependencies/trunk/cells/defpackage.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/defpackage.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,64 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 2008 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :common-lisp-user)
+
+(defpackage :cells
+ (:use #:common-lisp #:utils-kt #+abcl #:sys)
+ (:import-from
+ ;; MOP
+ #+allegro #:excl
+ #+clisp #:clos
+ #+cmu #:mop
+ #+cormanlisp #:common-lisp
+ #+lispworks #:clos
+ #+sbcl #:sb-mop
+ #+openmcl-partial-mop #:openmcl-mop
+ #+(and mcl (not openmcl-partial-mop)) #:ccl
+ #+abcl #:mop
+ #-(or allegro clisp cmu cormanlisp lispworks mcl sbcl abcl)
+ #.(cerror "Provide a package name."
+ "Don't know how to find the MOP package for this Lisp.")
+
+ #:class-precedence-list
+ #-(and mcl (not openmcl-partial-mop)) #:class-slots
+ #:slot-definition-name
+ #:class-direct-subclasses
+ )
+ (:export #:cell #:.md-name
+ #:c-input #:c-in #:c-in8
+ #:c-formula #:c? #:c_? #:c?8 #:c?_ #:c??
+ #:with-integrity #:without-c-dependency #:self #:*parent*
+ #:.cache #:.with-c-cache #:c-lambda
+ #:defmodel #:defmd #:defobserver #:slot-value-observe #:def-c-unchanged-test
+ #:new-value #:old-value #:old-value-boundp #:c...
+ #:md-awaken
+ #:mkpart #:make-kid #:the-kids #:nsib #:value #:^value #:.value #:kids #:^kids #:.kids
+ #:cells-reset #:upper #:fm-max #:nearest #:fm-min-kid #:fm-max-kid #:mk-kid-slot
+ #:def-kid-slots #:find-prior #:fm-pos #:kid-no #:fm-includes #:fm-ascendant-common
+ #:fm-kid-containing #:fm-find-if #:fm-ascendant-if #:c-abs #:fm-collect-if #:psib
+ #:not-to-be #:ssibno
+ #:c-debug #:c-break #:c-assert #:c-stop #:c-stopped #:c-assert #:.stop #:delta-diff
+ #:wtrc #:wnotrc #:eko-if #:trc #:wtrc #:eko #:ekx #:trcp #:trcx)
+ #+allegro (:shadowing-import-from #:excl #:fasl-write #:fasl-read #:gc)
+ )
+
Added: dependencies/trunk/cells/doc/01-Cell-basics.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/doc/01-Cell-basics.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,431 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+#|
+
+[A minimal primer on cells, last tested on march 13, 2006 against cells3]
+
+cells
+-----
+think of a clos slot as a cell in a paper spreadsheet, a financial
+modeling tool popular enough to make visi-calc the first business
+killer app for microcomputers.
+
+as a child i watched my father toil at home for hours over paper
+spreadsheets with pencil and slide rule. after he changed one value,
+he had to propagate that change to other cells by first remembering
+which other ones included the changed cell in their computation.
+then he had to do the calculations for those, erase, enter...
+and then repeating that process to propagate those changes in a
+cascade across the paper.
+
+visi-calc let my father take the formula he had in mind and
+put it in (declare it to) the electronic spreadsheet. then visi-calc
+could do the tedious work: recalculating, knowing what to recalculate,
+and knowing in what order to recalculate.
+
+cells do for programmers what electronic spreadsheets did for my father.
+without cells, clos slots are like cells of a paper spreadsheet.
+a single key-down event can cause a cascade of change throughout an
+application. the programmer has to arrange for it all to happen,
+all in the right order: delete any selected text, insert
+the new character, re-wrap the text, update the undo mechanism, revisit
+the menu statuses ("cut" is no longer enabled), update the scroll bars,
+possibly scroll the window, flag the file as unsaved...
+
+with cells, the programmer looks at program state differently. one
+asks, "how could i compute, at any point of runtime, a value for
+a given slot of an arbitrary instance, based only on other runtime state
+(other slots of other instances)." great fun, by the way, as well as
+enforcing good programming practices like encapsulation.
+
+an example will help. consider indeed the state of the "cut" menu item.
+in some applications, programmers have a dozen places in their code
+where they tend to the status of the cut menu item. one might be:
+
+(defun do-clear (edit-structure)
+ (when (selected-range edit-structure)
+
+
+
+ (menu-item-enable *edit-cut* nil)
+ (menu-item-enable *edit-copy* nil)
+ (menu-item-enable *edit-clear* nil)))
+
+other programmers wait until the user clicks on the edit menu,
+then decide just-in-time from program state whether the cut item
+should be enabled:
+
+(defmethod prep-for-display ((m edit-menu))
+
+ (when (typep (focus *app*) 'text-edit-widget)
+ (menu-item-enable (find :cut (items m) :key #'item-name)
+ (not (null (selected-range (focus *app*)))))))
+
+this latter programmer is ready for cells, because they
+have already shifted from imperative to declarative thinking;
+they have learned to write code that works based not on what
+has happened lately, but instead only on the current program
+state (however it got that way).
+
+the cell programmer writes:
+
+(make-instance 'menu-item
+ :name :cut
+ :label "cut"
+ :cmd-key +control-x+
+ :actor #'do-cut
+ :enabled (c? (when (typep (focus *app*) 'text-edit-widget)
+ (not (null (selected-range (focus *app*)))))))
+
+...and now they can forget the menu item exists as they work
+on the rest of the application. the menu-item enabled status
+will stay current (correct) as the selected-range changes
+and as the focus itself changes as the user moves from field
+to field.
+
+that covers the spirit of cells. now let's look at the syntax
+and mechanics, with examples you can execute once you have
+loaded the cells package. see the read-me.txt file in the
+root directory into which the cello software was unzipped.
+
+we'll model a falling stone, where the distance fallen is half
+the product of the acceleration (due to gravity) and the
+square of the time falling.
+
+|#
+
+(in-package :cells)
+
+(defmodel stone ()
+ ((accel :cell t :initarg :accel :initform 0 :accessor accel)
+ (time-elapsed :cell t :initarg :time-elapsed
+ :initform (c-in 0)
+ :accessor time-elapsed)
+ (distance :cell t :initarg :distance :initform 0 :accessor distance))
+ (:default-initargs
+ :distance (c? (/ (* (accel self)
+ (expt (time-elapsed self) 2))
+ 2))))
+
+(defobserver accel ((self stone) new old old-bound-p)
+ (trc "observer sees accel" :new new :old old :oldp old-bound-p)) ;; TRC provides print diagnostics
+
+(defobserver time-elapsed ((self stone)) ;; short form (I'm lazy)
+ (trc "observer sees time-elapsed" :new new-value :old old-value :oldp old-value-boundp))
+
+(defobserver distance ((self stone))
+ (format t "~&observer sees distance fallen: ~d feet" new-value))
+
+
+#|
+let's look at non-standard syntax found in the forms above,
+in the order in which they appear:
+
+ (defmodel ...
+
+defmodel is just a defclass wrapper which also sets up plumbing for cells.
+
+ ... :cell t ...
+
+without this option, a model instance slot cannot be powered
+by a cell (and cell slot access overhead is avoided).
+
+with this option, one can specify what kind of cell
+is to be defined: ephemeral, delta or t (normal). we'll leave
+those esoteric cell slot types for another tutorial and just
+specify t to get normal cells (the ones used 99% of the time).
+
+ time-elapsed ... :initform (c-in 0)...
+
+(c-in ) allows the cellular slot (or "cell", for short)
+to be setf'ed. these are inputs to the dataflow,
+which usually flows from c? to c? but has to start somewhere.
+since modern interactve applications are event-driven, in
+real-world cello apps most cv dataflow inputs are slots closely
+corresponding to some system value, such as the position slots
+of a cell-powered mouse class. moving on...
+
+a naked value such as the 32 supplied for accel cannot be changed; a
+runtime error results from any such attempt. this makes cells faster,
+because some plumbing can be skipped: no dependency gets recorded between
+the distance traveled and the acceleration. on the other hand, a more
+elaborate model might have the acceleration varying according to the distance
+between the stone and earth (in which case we get into an advance
+topic for another day, namely how to handle circularity.)
+
+next: (:default-initargs
+ :distance (c? (/ (* (accel self)
+ (expt (time-elapsed self) 2))
+ 2)
+
+c? associates a rule with a cellular slot (or "cell", for short). any
+read operation on another cell (directly or during a function call)
+establishes a dependency of distance on that cell -- unless that cell
+can never change. why would a cell not be able to change?
+
+cell internals enforce a rule that a cell with a naked value (ie, not wrapped
+in cv or c?) cannot be changed by client code (ok, (setf slot-value) is a backdoor).
+cell internals enforce this, simply to make possible the optimization
+of leaving off the overhead of recording a pointless dependency.
+
+next: (defobserver...
+
+here is the signature for the defobserver macro:
+
+ (defmacro defobserver (slotname (&optional (self-arg 'self)
+ (new-varg 'new-value)
+ (oldvarg 'old-value)
+ (oldvargboundp 'old-value-boundp))
+ &body observer-body) ....)
+
+defobserver defines a generic method with method-combination progn,
+which one can specialize on any of the four
+parameters. the method gets called when the slot value changes, and during
+initial processing by shared-initialize (part of make-instance).
+
+shared-initialize brings a new model instance to life, including calling
+any observers defined for cellular slots.
+
+now evaluate the following:
+
+|#
+
+#+evaluatethis
+
+(progn
+ (cells-reset)
+ (defparameter *s2* (make-instance 'stone
+ :accel 32 ;; (constant) feet per second per second
+ :time-elapsed (c-in 0))))
+
+#|
+
+...and observe:
+0> observer sees accel :new 32 :old nil :oldp nil
+0> observer sees time-elapsed :new 0 :old nil :oldp nil
+observer sees distance fallen: 0 feet
+
+
+getting back to the output shown above, why observer output on a new instance? we want
+any new instance to come fully to life. that means
+evaluating every rule so the dependencies get established, and
+propagating cell values outside the model (by calling the observer
+methods) to make sure the model and outside world (if only the
+system display) are consistent.
+
+;-----------------------------------------------------------
+now let's get moving:
+
+|#
+
+#+evaluatethis
+
+(setf (time-elapsed *s2*) 1)
+
+#|
+...and observe:
+0> observer sees time-elapsed :new 1 :old 0 :oldp t
+observer sees distance fallen: 16 feet
+
+behind the scenes:
+- the slot value time-elapsed got changed from 0 to 1
+- the time-elapsed observer was called
+- dependents on time-elapsed (here just distance) were recalculated
+- go to the first step, this time for the distance slot
+
+;-----------------------------------------------------------
+to see some optimizations at work, set the cell time-elapsed to
+the same value it already has:
+|#
+
+#+evaluatethis
+
+(setf (time-elapsed *s2*) 1)
+
+#| observe:
+nothing, since the slot-value did not in fact change.
+
+;-----------------------------------------------------------
+to test the enforcement of the cell stricture against
+modifying cells holding naked values:
+|#
+
+#+evaluatethis
+
+(let ((*c-debug* t))
+ (handler-case
+ (setf (accel *s2*) 10)
+ (t (error)
+ (cells-reset) ;; clear a *stop* flag used to bring down a runaway model :)
+ (trc "error is" error)
+ error)))
+
+#| observe:
+c-setting-debug > constant accel in stone may not be altered..init to (c-in nil)
+0> error is #
+
+Without turning on *c-debug* one just gets the runtime error, not the explanation to standard output.
+
+;-----------------------------------------------------------
+nor may ruled cells be modified arbitrarily:
+|#
+
+#+evaluatethis
+
+(let ((*c-debug* t))
+ (handler-case
+ (setf (distance *s2*) 42)
+ (t (error)
+ (cells-reset)
+ (trc "error is" error)
+ error)))
+
+#| observe:
+c-setting-debug > ruled distance in stone may not be setf'ed
+0> error is #
+
+;-----------------------------------------------------------
+aside from c?, cv, and defobserver, another thing you will see
+in cello code is how complex views are constructed using
+the family class and its slot kids. every model-object has a
+parent slot, which gets used along with a family's kids slot to
+form simple trees navigable up and down.
+
+model-objects also have slots for md-name and value (don't
+worry camelcase-haters, that is a declining feature of my code).
+md-name lets the family trees we build be treated as namespaces.
+value just turns out to be very handy for a lot of things. for
+example, a check-box instance needs some place to indicate its
+boolean state.
+
+now let's see family in action, using code from the handbook of
+silly examples. all i want to get across is that a lot happens
+when one changes the kids slot. it happens automatically, and
+it happens transparently, following the dataflow implicit in the
+rules we write, and the side-effects we specify via observer functions.
+
+the silly example below just shows the summer (that which sums) getting
+a new value as the kids change, along with some observer output. in real-world
+applications, where kids represent gui elements often dependent on
+each other, vastly more can transpire before a simple push into a kids
+slot has run its course.
+
+evaluate:
+|#
+
+(defmodel summer (family)
+ ()
+ (:default-initargs
+ :kids (c-in nil) ;; or we cannot add any addend kids later
+ :value (c? (trc "val rule runs")
+ (reduce #'+ (kids self)
+ :initial-value 0
+ :key #'value))))
+
+(defobserver .value ((self summer))
+ (trc "the sum of the values of the kids is" new-value))
+
+(defobserver .kids ((self summer))
+ (trc "the values of the kids are" (mapcar #'value new-value)))
+
+;-----------------------------------------------------------
+; now just evaluate each of the following forms one by one,
+; checking results after each to see what is going on
+;
+#+evaluatethis
+
+(defparameter *f1* (make-instance 'summer))
+
+#|
+observe:
+0> the sum of the values of the kids is 0
+0> the values of the kids are nil
+
+;----------------------------------------------------------|#
+
+#+evaluatethis
+
+(push (make-instance 'model
+ :fm-parent *f1*
+ :value 1) (kids *f1*))
+
+#| observe:
+0> the values of the kids are (1)
+0> the sum of the values of the kids is 1
+
+;----------------------------------------------------------|#
+
+#+evaluatethis
+
+(push (make-instance 'model
+ :fm-parent *f1*
+ :value 2) (kids *f1*))
+
+#| observe:
+0> the values of the kids are (2 1)
+0> the sum of the values of the kids is 3
+
+;----------------------------------------------------------|#
+
+#+evaluatethis
+
+(setf (kids *f1*) nil)
+
+#| observe:
+0> the values of the kids are nil
+0> the sum of the values of the kids is 0
+
+now before closing, it occurs to me you'll need a little
+introduction to the semantics of ^slot-x macros generated
+by the defmodel macro. here is another way to define our stone:
+
+|#
+
+#+evaluatethis
+
+(setq *s2* (make-instance 'stone
+ :accel 2
+ :time-elapsed (c-in 3)
+ :distance (c? (+ (^accel) (^time-elapsed)))))
+
+#| in the olden days of cells, when they were called
+semaphors, the only way to establish a dependency
+was to use some form like:
+
+ (^some-slot some-thing)
+
+that is no longer necessary. now any dynamic access:
+
+(1) during evaluation of a form wrapped in (c?...)
+(2) to a cell, direct or inside some function
+(3) using accessors named in the defmodel form (not slot-value)
+
+...establishes a dependency. so why still have the ^slot macros?
+
+one neat thing about the ^slot macros is that the default
+argument is self, an anaphor set up by c? and its ilk, so
+one can make many rules a little easier to follow by simply
+coding (^slot). another is convenient specification of
+synapses on dependencies, a more advanced topic we can
+ignore a while.
+
+
+|#
Added: dependencies/trunk/cells/doc/cell-doc.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/doc/cell-doc.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,181 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+#|
+
+Deep thoughts: Where a program implements a model using interesting, long-lived state (such
+as the position of other players on a virtual soccer field in a game program), some state will
+be computed off of other such state. Not everything is raw input. eg, a player might
+have set himself a task such as "tackle opponent" based on a higher-level computation
+of what is going on in the game, and then "current task" is both computed yet long-lived.
+
+Spread throughout the application will be code here and code there
+which makes an interesting computation using other program state ("given what I can see,
+which player if any has the ball") and decides
+to do something, which may be (a) to act outside the program such as cause some component
+to be redrawn (say, to manifest its new color, in this case if a debugging hack uses
+the game display to show which player the algorithm has settled on) or (b) to cache the
+observation as a guide to other algorithms. My current task "tackle opponent" controls
+inter alia the player's choices on which way to turn and how fast to run in order
+to close on the opponent.
+
+Whenever a program receives an input, such as the mouse position or a keystroke or
+a message over a socket connection, some computations need to be repeated. In a
+multi-player game an external server will be deciding the position of the ball, and
+when that changes my program must rethink a lot of things which were decided based
+on the old position of the ball.
+
+Cells's job is to make sure that last bit goes smoothly, which we will define now.
+
+Suppose the system has reached the stable, valid state reached after
+autoinitialization of the initial model population...we'll worry about initialization
+ later. I like to think of a change to a variable such as the window's width as
+a /data pulse/, or /pulse/ for short. If we enumerate these pulses sequentially,
+we can state the Prime Directive of Cells as:
+
+ take a system gets from pulse n to n+1 smoothly.
+
+To handle concurrency, we can instead stamp pulses with the time. Then we can speak
+of time T and T+1, which will be time stamps such that no pulse known to the system
+has a time stamp between T and T+1. (Where we have concurrency and network latency,
+some regulating scheme will have to be found to make sure everyone has had a chance
+to "share" before T+1 is decided, given T and a new set of pulses. Let's duck that
+for now and assume a single thread in which each pulse also moves T to T+1.) Now
+we can restate the Cells manifesto:
+
+ take a system from time T to time T+1 smoothly
+
+Your next question should be, what does "smoothly" mean? First, some formal definitions.
+
+Let's call the slot changed by the triggering pulse X, as in "X marks the spot" where
+the system perturbation began. X might be the mouse position as fed to the application
+by the operating system.
+
+Now let's talk of Cells being "at" some time Tn or other. Time starts at T0. The application
+makes its first model instances and brings that cluster to life, sweeping the cluster
+evaluating ruled cells. Eventually they have all been computed, and we are at T1. After this
+everything is Tn or Tn+1.
+
+-- When a pulse Pn+1 occurs, it takes the system from Tn to Tn+1.
+
+Now suppose P is a change to slot X, the mouse position of some "system" instance we
+are using to model the application environment.
+
+-- We say slot X is now "at" time Tn+1, because it trivially reflects the value of Pn+1
+
+If another cell happens to have used X in its most recent calculation, it needs to be
+recalculated. Once it is recalculated, we say it too has reached Tn+1. And if any Cell
+did not involve in its calculation X, directly or indirectly through some other cell,
+then we also think of it as being at time T+1. It is current with pulse Pn+1 because
+Pn+1 changes nothing of relevance to it.
+
+With those definitions in mind, here are the qualities of a smooth
+transition from T to T+1:
+
+(1) Completeness: everyone gets to Tn+1: every internal calculation affected directly or
+indirectly by X will be recalculated.
+
+(1a) Completeness: any and only those Cs which actually change in value getting from Cn to Cn+1
+will have that change echoed.
+
+(2) Efficiency: only those calculations will execute. There is no reason to run a rule
+if nothing affecting its outcome has changed.
+
+(2a) Efficiency: a calculation is affected by a transition of some cell to Tn+1
+iff Cn+1 is different from Cn. ie, if X actually changes and some cell A which uses
+it dutifully recalculates but comes up with the same result (it might involve a min or
+max function), then some other cell B which uses A does not need to be recalculated.
+
+(3) Simplicity: calculations will run only once (no re-entrance). More efficient as well.
+This may seem obvious, but certain engineering attempts have resulted in reentrance.
+But then one has to worry about backtracking. The idea is to make
+programming easier, so we won't ask developers to worry about re-entrance. Not
+that we are encouraging side-effects in Cell rules. Anyway....
+
+(4) Consistency: no rule when it runs will access any cell not already at T+1.
+
+(5) Consistency II: akin to the first, no echo of n+1 will employ any data not at Tn+1.
+
+(6) Completeness II: Tn+2 does not happen until the transition to Tn+1 satisfies
+the above requirements.
+
+If we timestamp every Cell as it moves from Cn to Cn+1, it all just works if we
+move Tn to Tn+1 and follow the above requirements.
+
+First, Tn+1 was reached by X itself receiving pulse N+1 and becoming Xn+1.
+
+Rule 2 requires us to determine if pulse N+1 actually change X. In the case of
+a window being resized only vertically, the reshape event will include a "new"
+value for width which is the same as the old.
+
+If X turns out not to have changed, we do not move time to Tn+1. Efficiencies 2 and 2a.
+
+But if X has changed, we now have Tn+1 and X reaches Xn+1 trivially.
+
+Now rule 1 requires us to recalculate all of X's users, and if one of
+those changes, likewise notify their users. Eventually everyone gets notified, so
+we look good on Rule 1.
+
+But now we have a problem. What if A and B are users of X, but A also uses C which uses B?
+A's rule, when it runs, needs to see Cn+1 to satisfy rule 4. We cannot just run the rule
+for C because we do not know until B gets calculated whether /it/ will change. We know
+X has changed, but maybe B will come up with the same answer as before. In which case,
+by the definitions above, C is already Cn+1 and recalculating it would be a waste.
+
+The solution is a little tricky: descend the "used" links from C looking for X. When
+we come to a terminus (a c-variable which is not X), we flag that as being at n+1 and
+return nil. If at any ruled node all useds return nil, we flag the ruled cell as
+being at n+1 and return nil.
+
+But where we get to X, we return T. Where a ruled node gets T back from any used Cell
+it kicks off its own calculation, returning T iff it changes. But before returning it
+echos. Should that echo involve some user-level read of some cell which is at Cn,
+accessor processing will include these safeguards which check to see if any used value
+is at Tn+1 and recalculate "just in time". This means we need a special variable which
+indicates when data pulse propagation is underway:
+
+ (let ((*propagating* (setf *time* (get-internal-real-time))))....
+
+That way if *propagating* is false there is no need to do anything but return valid
+values.
+
+Anyway, it looks as if echo requirements can be satisfied, and that completes the
+picture. But we have a problem. If some cell H (for high up in the dependency graph)
+uses both A and C, it is possible for X to tell A to recalculate, which will lead
+to A asking C to recalculate, which will do so and tell H to recalculate, which will
+ask A for its current value. Deadlock, and again this cannot be detected via lookahead
+because H's rule may not branch to A until just this pulse.
+
+The trick is that all we need from C when it gets accessed is its value. yes, we can tell
+now that H must be recalculated at some point, but A has not gone after H and will not
+so recalculating H can wait. If A /does/ go after H the above framework will see to
+it that H gets recalculated. But in this case H can wait (but not be forgotten).
+
+So we simply add H to a fifo queue of deferred dependencies to be revisited before
+Tn+1 can be considered attained.
+
+
+
+|#
+
Added: dependencies/trunk/cells/doc/cells-overview.pdf
==============================================================================
Binary files (empty file) and dependencies/trunk/cells/doc/cells-overview.pdf Tue Jan 26 15:20:07 2010 differ
Added: dependencies/trunk/cells/doc/hw.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/doc/hw.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,72 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+
+(in-package :cells)
+
+(defmodel computer ()
+ ((hear :cell :ephemeral :accessor hear :initform (c-in nil))
+ (salutation :initarg :salutation :accessor salutation :initform "hello")
+ (response :initform nil :initarg :response
+ :unchanged-if ?string= :accessor response)))
+
+(def-c-output response ()
+ (when new-value
+ (format t "~&hear: ~a~%respond: ~a" (hear self) new-value)))
+
+(defun hello-world ()
+ (cell-reset)
+ (let ((system (make-instance 'computer
+ :response (c? (let ((r (case (hear self)
+ (:knock-knock "who's there?")
+ (:world (concatenate 'string
+ (salutation self)
+ ", "
+ (string (hear self))))
+ ((nil) ""))))
+ (if (string= r .cache)
+ (format nil "i said, \"~a\"" r)
+ r))))))
+ (format t "~&to-be initialization complete")
+ (setf (hear system) :knock-knock)
+ (setf (hear system) :knock-knock)
+ (setf (hear system) :world)
+ (setf (salutation system) "hiya")
+ (values)))
+
+#+(or)
+(hello-world)
+
+#| output
+
+hear: nil
+respond:
+hear: knock-knock
+respond: who's there?
+hear: knock-knock
+respond: i said, "who's there?"
+hear: world
+respond: hello, world
+
+|#
+
Added: dependencies/trunk/cells/doc/motor-control.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/doc/motor-control.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,157 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells -*-
+;;;
+;;; Copyright ? 2004 by Bill Clementson
+;;;
+;;; Reprinted, reformatted, and modestly revised by permission.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+#|
+
+Experimenting with Cells
+----------------------------
+Thursday, September 11, 2003
+
+Kenny Tilton has been talking about his Cells implementation on comp.lang.lisp for some time
+but I've only just had a look at it over the past few evenings. It's actually pretty neat.
+Kenny describes Cells as, conceptually, analogous to a spreadsheet cell (e.g. -- something
+in which you can put a value or a formula and have it updated automatically based on changes
+in other "cell" values). Another way of saying this might be that Cells allows you to define
+classes whose slots can be dynamically (and automatically) updated and for which standard
+observers can be defined that react to changes in those slots.
+
+Hmmm, maybe an example works best. Here's one that's a variation on one of the examples
+included in the latest distribution. I'll create a "motor" object that reacts to changes
+in the motor's operating temperature. If the temperature exceeds 100 degrees, the motor will
+need to be shut off. If it is shut off, the flow from the fuel pump will also need to be
+closed (otherwise, we get a big pool of fuel on the floor).
+
+So, by using Cells in this example, the following will be demonstrated:
+
+ * Create slots whose values vary based on a formula. The formula can be defined at
+ either class definition time or at object instantiation time.
+
+ * Dynamically (and automatically) update dependent slot variables (maintaining consistency
+ between dependent class attributes).
+
+ * Create Observers that react to changes in slot values to handle "external"
+ actions (e.g. - GUI updates, external API calls, etc.).
+
+ * Automatically filter slot changes so that we only update dependent slots
+ when the right granularity of change occurs.
+
+First, define the motor class (Note: defmodel is a macro that wraps a class
+definition and several method definitions):
+|#
+
+(in-package :cells)
+
+(defmodel motor ()
+ ((status :initarg :status :accessor status :initform nil)
+ (fuel-pump :initarg :fuel-pump :accessor fuel-pump
+ :initform (c? (ecase (^status) (:on :open) (:off :closed))))
+ (temp :initarg :temp :accessor temp :initform (c-in 0))))
+
+#+test
+(progn
+ (cells-reset)
+ (setf (status (make-instance 'motor :status :on)) 42))
+
+#|
+
+Note that "status" is a cell with no initial value or formula, "fuel-pump" is
+a cell that has a formula that depends on the value of "status" (the ^status notation
+is shorthand to refer to a slot in the same instance), and "temp" is initialized to zero.
+
+Next, define observers (this is an optional step) using a Cells macro.
+These observers act on a change in a slot's value. They don't actually update
+any dependent slots (this is done automatically by Cells and the programmer
+doesn't have to explicitly call the slot updates), they just provide a mechanism
+for the programmer to handle outside dependencies. In this example, we're just
+printing a message; however, in a real program, we would be calling out to something
+like an Allen Bradley controller to turn the motor and fuel pump on/off.
+
+|#
+
+(defobserver status ((self motor))
+ (trc "motor status changing from" old-value :to new-value))
+
+(defobserver fuel-pump ((self motor))
+ (trc "motor fuel-pump changing from" old-value :to new-value))
+
+(defobserver temp ((self motor))
+ (trc "motor temperature changing from" old-value :to new-value))
+
+#|
+
+Then, create an instance of the motor. Note that we programmatically assign
+a formula to the "status" slot. The formula states that when the temperature
+rises above 100 degrees, we change the status to "off". Since the temperature may
+fluctuate around 100 degrees a bit before it moves decisively one way or
+the other (and we don't want the motor to start turning off and on as we get
+minor temperature fluctuations around the 100 degree mark), we use another
+Cells feature ("Synapses" allow for pre-defined filters to be applied to a
+slot's value before it is used to update other slots) to filter the temperatures
+for small variations. Note that the formula is being assigned to the "status"
+slot at instantiation time as this gives us the ability to create different
+formulas for different types of motors without subclassing "motor".
+
+|#
+
+#+evaluatethis
+
+(defparameter *motor1*
+ (make-instance 'motor
+ :status (c? (if (< (f-sensitivity :tmp (0.05) (^temp)) 100)
+ :on :off))))
+
+#|
+
+This alone produces the following results as the Cells engine gets the motor
+instance fully active, which requires getting the real-world motor
+in synch with the CLOS instance:
+
+0> motor status changing from | NIL | :TO :ON
+0> motor fuel-pump changing from | NIL | :TO :OPEN
+0> motor temperature changing from | NIL | :TO 0
+
+Then we test the operation of the motor by changing the motor's
+temperature (starting at 99 degrees and increasing it by 1 degree +/- a small random variation).
+
+|#
+
+#+evaluatethis
+
+(dotimes (x 2)
+ (dotimes (y 10)
+ (let ((newtemp (+ 99 x (random 0.07) -.02)))
+ (setf (temp *motor1*) newtemp))))
+
+#|
+
+This produces the following results, which will vary from run to run because of
+the use of a random amount to simulate real-world variability:
+
+0> motor temperature changing from NIL :TO 0
+0> motor temperature changing from 0 :TO 98.99401
+0> motor temperature changing from 98.99401 :TO 99.01954
+[snipped 8 intermediate readings]
+0> motor temperature changing from 99.00016 :TO 100.00181
+0> motor status changing from :ON :TO :OFF
+0> motor fuel-pump changing from :OPEN :TO :CLOSED
+0> motor temperature changing from 100.00181 :TO 100.0177
+0> motor temperature changing from 100.0177 :TO 99.98742
+0> motor temperature changing from 99.98742 :TO 99.99313
+[snipped 6 intermediate readings]
+
+Notice how the fsensitivity synapse prevents minor fluctuations around 100 degrees
+from causing the motor to start turning itself on and off in rapid succession,
+possibly causing it to flood or fail in some way.
+
+|#
\ No newline at end of file
Added: dependencies/trunk/cells/family-values.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/family-values.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,96 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(family-values family-values-sorted
+ sort-index sort-direction sort-predicate sort-key
+ ^sort-index ^sort-direction ^sort-predicate ^sort-key)))
+
+(defmodel family-values (family)
+ (
+ (kv-collector :initarg :kv-collector
+ :initform #'identity
+ :reader kv-collector)
+
+ (kid-values :initform (c? (when (kv-collector self)
+ (funcall (kv-collector self) (^value))))
+ :accessor kid-values
+ :initarg :kid-values)
+
+ (kv-key :initform #'identity
+ :initarg :kv-key
+ :reader kv-key)
+
+ (kv-key-test :initform #'equal
+ :initarg :kv-key-test
+ :reader kv-key-test)
+
+ (kid-factory :initform #'identity
+ :initarg :kid-factory
+ :reader kid-factory)
+
+ (.kids :initform (c? (c-assert (listp (kid-values self)))
+ (let ((new-kids (mapcan (lambda (kid-value)
+ (list (or (find kid-value .cache
+ :key (kv-key self)
+ :test (kv-key-test self))
+ (trc nil "family-values forced to make new kid"
+ self .cache kid-value)
+ (funcall (kid-factory self) self kid-value))))
+ (^kid-values))))
+ (nconc (mapcan (lambda (old-kid)
+ (unless (find old-kid new-kids)
+ (when (fv-kid-keep self old-kid)
+ (list old-kid))))
+ .cache)
+ new-kids)))
+ :accessor kids
+ :initarg :kids)))
+
+(defmethod fv-kid-keep (family old-kid)
+ (declare (ignorable family old-kid))
+ nil)
+
+(defmodel family-values-sorted (family-values)
+ ((sorted-kids :initarg :sorted-kids :accessor sorted-kids
+ :initform nil)
+ (sort-map :initform (c-in nil) :initarg :sort-map :accessor sort-map)
+ (.kids :initform (c? (c-assert (listp (kid-values self)))
+ (mapsort (^sort-map)
+ (the-kids
+ (mapcar (lambda (kid-value)
+ (trc "making kid" kid-value)
+ (or (find kid-value .cache :key (kv-key self) :test (kv-key-test self))
+ (trc nil "family-values forced to make new kid" self .cache kid-value)
+ (funcall (kid-factory self) self kid-value)))
+ (^kid-values)))))
+ :accessor kids
+ :initarg :kids)))
+
+(defun mapsort (map data)
+ ;;(trc "mapsort map" map)
+ (if map
+ (stable-sort data #'< :key (lambda (datum) (or (position datum map)
+ ;(trc "mapsort datum not in map" datum)
+ (1+ (length data)))))
+ data))
+
+(defobserver sorted-kids ()
+ (setf (sort-map self) new-value)) ;; cellular trick to avoid cyclicity
\ No newline at end of file
Added: dependencies/trunk/cells/family.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/family.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,264 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+ (export '(model value family dbg .pa
+ kids kid1 ^k1 kid2 ^k2 last-kid ^k-last perishable)))
+
+(defmodel model ()
+ ((.md-name :cell nil :initform nil :initarg :md-name :accessor md-name)
+ (.fm-parent :cell nil :initform nil :initarg :fm-parent :accessor fm-parent)
+ (.dbg-par :cell nil :initform nil)
+ (.value :initform nil :accessor value :initarg :value)
+ (register? :cell nil :initform nil :initarg :register? :reader register?)
+ (zdbg :initform nil :accessor dbg :initarg :dbg)))
+
+(defmethod not-to-be :around ((self model))
+ (setf (slot-value self '.dbg-par) (fm-parent self)) ;; before it gets zapped
+ (call-next-method))
+
+(defmethod initialize-instance :after ((self model) &key)
+ (when (register? self)
+ (fm-register self)))
+
+(defmethod print-cell-object ((md model))
+ (or (md-name md) :md?))
+
+(defmethod fm-parent (other)
+ (declare (ignore other))
+ nil)
+
+(defmethod (setf fm-parent) (new-value other)
+ (declare (ignore other))
+ new-value)
+
+(defmethod print-object ((self model) s)
+ #+shhh (format s "~a" (type-of self))
+ (format s "~a~a" (if (mdead self) "DEAD!" "")
+ (or (md-name self) (type-of self))))
+
+(define-symbol-macro .parent (fm-parent self))
+(define-symbol-macro .pa (fm-parent self))
+
+(defmethod md-name (other)
+ (trc "yep other md-name" other (type-of other))
+ other)
+
+(defmethod md-name ((nada null))
+ (unless (c-stopped)
+ (c-stop :md-name-on-null)
+ (break "md-name called on nil")))
+
+(defmethod md-name ((sym symbol)) sym)
+
+(defmethod shared-initialize :around ((self model) slotnames &rest initargs &key fm-parent)
+ (declare (ignorable initargs slotnames fm-parent))
+
+ (call-next-method)
+
+ (when (slot-boundp self '.md-name)
+ (unless (md-name self)
+ (setf (md-name self) (gentemp (string (c-class-name (class-of self)))))))
+
+ (when (and (slot-boundp self '.fm-parent)
+ (fm-parent self)
+ (zerop (adopt-ct self)))
+ (md-be-adopted self)))
+
+(defmodel perishable ()
+ ((expiration :initform nil :accessor expiration :initarg :expiration)))
+
+(defobserver expiration ()
+ (when new-value
+ (not-to-be self)))
+
+(defvar *parent* nil)
+
+(defmodel family (model)
+ ((.kid-slots :cell nil
+ :initform nil
+ :accessor kid-slots
+ :initarg :kid-slots)
+ (.kids :initform (c-in nil) ;; most useful
+ :owning t
+ :accessor kids
+ :initarg :kids)
+ (registry? :cell nil
+ :initform nil
+ :initarg :registry?
+ :accessor registry?)
+ (registry :cell nil
+ :initform nil
+ :accessor registry)))
+
+#+test
+(let ((c (find-class 'family)))
+ (mop::finalize-inheritance c)
+ (class-precedence-list c))
+
+(defmacro the-kids (&rest kids)
+ `(let ((*parent* self))
+ (packed-flat! , at kids)))
+
+(defmacro s-sib-no () `(position self (kids .parent)))
+
+(defmacro gpar ()
+ `(fm-grandparent self))
+
+(defmacro nearest (self-form type)
+ (let ((self (gensym)))
+ `(bwhen (,self ,self-form)
+ (if (typep ,self ',type) ,self (upper ,self ,type)))))
+
+(defun kid1 (self) (car (kids self)))
+
+(export! first-born-p)
+(defun first-born-p (self)
+ (eq self (kid1 .parent)))
+
+(defun kid2 (self) (cadr (kids self)))
+(defmacro ^k1 () `(kid1 self))
+(defmacro ^k2 () `(kid2 self))
+
+(defun last-kid (self) (last1 (kids self)))
+(defmacro ^k-last () `(last-kid self))
+
+;; /// redundancy in following
+
+(defmacro psib (&optional (self-form 'self))
+ (let ((self (gensym)))
+ `(bwhen (,self ,self-form)
+ (find-prior ,self (kids (fm-parent ,self))))))
+
+(defmacro nsib (&optional (self-form 'self))
+ (let ((self (gensym)))
+ `(bwhen (,self ,self-form)
+ (cadr (member ,self (kids (fm-parent ,self)))))))
+
+(defun prior-sib (self)
+ (let ((kid (gensym)))
+ `(let ((,kid ,self))
+ (find-prior ,kid (kids (fm-parent ,kid))))))
+
+(defun md-be-adopted (self &aux (fm-parent (fm-parent self)) (selftype (type-of self)))
+ (c-assert self)
+ (c-assert fm-parent)
+ (c-assert (typep fm-parent 'family))
+
+ (trc nil "md be adopted >" :kid self (adopt-ct self) :by fm-parent)
+
+ (when (plusp (adopt-ct self))
+ (c-break "2nd adopt ~a, by ~a" self fm-parent))
+
+ (incf (adopt-ct self))
+ (trc nil "getting adopted" self :by fm-parent)
+ (bwhen (kid-slots-fn (kid-slots (fm-parent self)))
+ (dolist (ks-def (funcall kid-slots-fn self) self)
+ (let ((slot-name (ks-name ks-def)))
+ (trc nil "got ksdef " slot-name (ks-if-missing ks-def))
+ (when (md-slot-cell-type selftype slot-name)
+ (trc nil "got cell type " slot-name )
+ (when (or (not (ks-if-missing ks-def))
+ (and (null (c-slot-value self slot-name))
+ (null (md-slot-cell self slot-name))))
+ (trc nil "ks missing ok " slot-name)
+ (multiple-value-bind (c-or-value suppressp)
+ (funcall (ks-rule ks-def) self)
+ (unless suppressp
+ (trc nil "md-install-cell " slot-name c-or-value)
+ (md-install-cell self slot-name c-or-value)))))))))
+
+(defobserver .kids ((self family) new-kids old-kids)
+ (c-assert (listp new-kids) () "New kids value for ~a not listp: ~a ~a" self (type-of new-kids) new-kids)
+ (c-assert (listp old-kids))
+ (c-assert (not (member nil old-kids)))
+ (c-assert (not (member nil new-kids)))
+ (bwhen (sample (find-if-not 'fm-parent new-kids))
+ (c-break "New as of Cells3: parent must be supplied to make-instance of ~a kid ~a"
+ (type-of sample) sample))
+ (trc nil ".kids output > entry" new-kids (mapcar 'fm-parent new-kids)))
+
+(defmethod kids ((other model-object)) nil)
+
+
+
+;------------------ kid slotting ----------------------------
+;
+(defstruct (kid-slotdef
+ (:conc-name nil))
+ ks-name
+ ks-rule
+ (ks-if-missing t))
+
+(defmacro mk-kid-slot ((ks-name &key if-missing) ks-rule)
+ `(make-kid-slotdef
+ :ks-name ',ks-name
+ :ks-rule (lambda (self)
+ (declare (ignorable self))
+ ,ks-rule)
+ :ks-if-missing ,if-missing))
+
+(defmacro def-kid-slots (&rest slot-defs)
+ `(lambda (self)
+ (declare (ignorable self))
+ (list , at slot-defs)))
+
+; --- registry "namespacing" ---
+
+(defmethod registry? (other) (declare (ignore other)) nil)
+
+(defmethod initialize-instance :after ((self family) &key)
+ (when (registry? self)
+ (setf (registry self) (make-hash-table :test 'eq))))
+
+(defmethod fm-register (self &optional (guest self))
+ (assert self)
+ (if (registry? self)
+ (progn
+ ;(trc "fm-registering" (md-name guest) :with self)
+ (setf (gethash (md-name guest) (registry self)) guest))
+ (fm-register (fm-parent self) guest)))
+
+(defmethod fm-check-out (self &optional (guest self))
+ (assert self () "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent))
+ (if (registry? self)
+ (remhash (md-name guest) (registry self))
+ (bif (p (fm-parent self))
+ (fm-check-out p guest)
+ (break "oops ~a ~a ~a" self (fm-parent self) (slot-value self '.fm-parent)))))
+
+(defmethod fm-find-registered (id self &optional (must-find? self must-find?-supplied?))
+ (or (if (registry? self)
+ (gethash id (registry self))
+ (bwhen (p (fm-parent self))
+ (fm-find-registered id p must-find?)))
+ (when (and must-find? (not must-find?-supplied?))
+ (break "fm-find-registered failed seeking ~a starting search at node ~a" id self))))
+
+(export! rg? rg!)
+
+(defmacro rg? (id)
+ `(fm-find-registered ,id self nil))
+
+(defmacro rg! (id)
+ `(fm-find-registered ,id self))
+
+
+
\ No newline at end of file
Added: dependencies/trunk/cells/fm-utilities.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/fm-utilities.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,735 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+$Header: /project/cells/cvsroot/cells/fm-utilities.lisp,v 1.22 2008-10-12 01:21:07 ktilton Exp $
+|#
+
+
+(in-package :cells)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export
+ '(;; Family member creation
+ make-part
+ mk-part
+ mk-part-spec
+ upper
+ u^
+ container
+ container-typed
+
+ ;; Family member finding
+ fm-descendant-typed
+ fm-ascendant-typed
+ fm-kid-named
+ fm-descendant-named
+ fm-ascendant-named
+ fm-ascendant-some
+ fm-ascendant-if
+ fm-descendant-if
+ fm-descendant-common
+ fm-collect-if
+ fm-collect-some
+ fm-value-dictionary
+ fm-max
+ fm-traverse
+ fm-traverse-bf
+ fm-ordered-p
+ sub-nodes
+ fm-ps-parent
+ with-like-fm-parts
+ do-like-fm-parts
+ true-that
+ fm-do-up
+ fm-gather
+ fm-find-all
+ fm-find-next
+ fm-find-next-within
+ fm-find-prior
+ fm-find-prior-within
+ fm-find-last-if
+ fm-prior-sib
+ fm-next-sib-if
+ fm-next-sib
+ ^fm-next-sib
+ fm-find-if
+
+ ;; Family ordering
+ fm-kid-add
+ fm-kid-insert-last
+ fm-kid-insert-first
+ fm-kid-insert
+ fm-kid-remove
+ fm-quiesce-all
+ fm-kid-replace
+
+ ;; Family high-order ops
+ fm-min-kid
+ fm-max-kid
+ fm-other
+ fmv
+ fm-otherx
+ fm-other-v
+ fm-otherv?
+ fm-other?
+ fm-other!
+ fm^
+ fm?
+ fm!
+ fm!v
+ fm-other?!
+ fm-collect
+ fm-map
+ fm-mapc
+ fm-pos
+ fm-count-named
+ fm-top
+ fm-first-above
+ fm-nearest-if
+ fm-includes
+ fm-ancestor-p
+ fm-kid-containing
+ fm-ascendant-p
+ fm-find-one
+ fm-find-kid
+ fm-kid-typed
+
+ ;; Other family stuff
+ make-name
+ name-root
+ name-subscript
+ kid-no
+
+ ;; Debug flags
+ *fmdbg*
+
+ )))
+
+(defparameter *fmdbg* nil)
+
+(defun make-part (partname part-class &rest initargs)
+ ;;(trc "make-part > name class" partname partclass)
+ (when part-class ;;a little programmer friendliness
+ (apply #'make-instance part-class (append initargs (list :md-name partname)))))
+
+(defmacro mk-part (md-name (md-class) &rest initargs)
+ `(make-part ',md-name ',md-class , at initargs
+ :fm-parent (progn (assert self) self)))
+
+(defmethod make-part-spec ((part-class symbol))
+ (make-part part-class part-class))
+
+(defmethod make-part-spec ((part model))
+ part)
+
+
+(defmacro upper (self &optional (type t))
+ `(container-typed ,self ',type))
+
+(defmacro u^ (type)
+ `(upper self ,type))
+
+(defmethod container (self) (fm-parent self))
+
+;;;(defmethod container-typed ((self model-object) type)
+;;; (let ((parent (container self))) ;; fm- or ps-parent
+;;; (cond
+;;; ((null parent) nil)
+;;; ((typep parent type) parent)
+;;; (t (container-typed parent type)))))
+
+(defmethod container-typed ((self model-object) type)
+ (let ((parent (fm-parent self))) ;; fm- or ps-parent
+ (cond
+ ((null parent) nil)
+ ((typep parent type) parent)
+ (t (container-typed parent type)))))
+
+(defun fm-descendant-typed (self type)
+ (when self
+ (or (find-if (lambda (k) (typep k type)) (kids self))
+ (some (lambda (k)
+ (fm-descendant-typed k type)) (kids self)))))
+
+(defun fm-kid-named (self name)
+ (find name (^kids) :key 'md-name))
+
+(defun fm-descendant-named (parent name &key (must-find t))
+ (fm-find-one parent name :must-find must-find :global-search nil))
+
+(defun fm-ascendant-named (parent name)
+ (when parent
+ (or (when (eql (md-name parent) name)
+ parent)
+ (fm-ascendant-named (fm-parent parent) name))))
+
+(defun fm-ascendant-typed (parent name)
+ (when parent
+ (or (when (typep parent name)
+ parent)
+ (fm-ascendant-typed (fm-parent parent) name))))
+
+(defun fm-ascendant-some (parent some-function)
+ (when (and parent some-function)
+ (or (funcall some-function parent)
+ (fm-ascendant-some (fm-parent parent) some-function))))
+
+(defun fm-ascendant-if (self test)
+ (when (and self test)
+ (or (when (funcall test self)
+ self)
+ (fm-ascendant-if .parent test))))
+
+(defun fm-descendant-if (self test)
+ (when (and self test)
+ (or (when (funcall test self)
+ self)
+ (loop for k in (^kids)
+ thereis (fm-descendant-if k test)))))
+
+(defun fm-ascendant-common (d1 d2)
+ (fm-ascendant-some d1 (lambda (node)
+ (when (fm-includes node d2)
+ node))))
+
+(defun fm-collect-if (tree test &optional skip-top dependently)
+ (let (collection)
+ (fm-traverse tree (lambda (node)
+ (unless (and skip-top (eq node tree))
+ (when (funcall test node)
+ (push node collection))))
+ :with-dependency dependently)
+ (nreverse collection)))
+
+(defun fm-collect-some (tree test &optional skip-top dependently)
+ (let (collection)
+ (fm-traverse tree (lambda (node)
+ (unless (and skip-top (eq node tree))
+ (bwhen (s (funcall test node))
+ (push s collection))))
+ :with-dependency dependently)
+ (nreverse collection)))
+
+(defun fm-value-dictionary (tree value-fn &optional include-top)
+ (let (collection)
+ (fm-traverse tree
+ (lambda (node)
+ (when (or include-top (not (eq node tree)))
+ (bwhen (v (funcall value-fn node))
+ (push (cons (md-name node) v) collection)))))
+ (nreverse collection)))
+
+(defun fm-max (tree key)
+ (let (max)
+ (fm-traverse tree (lambda (node)
+ (if max
+ (setf max (max max (funcall key node)))
+ (setf max (funcall key node)))))
+ max))
+
+
+(defun fm-traverse (family applied-fn &key skip-node skip-tree global-search opaque with-dependency)
+ ;;(when *fmdbg* (trc "fm-traverse" family skipTree skipNode global-search))
+
+ (when family
+ (labels ((tv-family (fm)
+ (etypecase fm
+ (cons (loop for md in fm do (tv-family md)))
+ (model-object
+ (unless (eql fm skip-tree)
+ (let ((outcome (and (not (eql skip-node fm)) ;; skipnode new 990310 kt
+ (funcall applied-fn fm))))
+ (unless (and outcome opaque)
+ (dolist (kid (kids fm))
+ (tv-family kid))
+ ;(tv-family (mdValue fm))
+ )))))))
+ (flet ((tv ()
+ (tv-family family)
+ (when global-search
+ (fm-traverse (fm-parent family) applied-fn
+ :global-search t
+ :skip-tree family
+ :skip-node skip-node
+ :with-dependency t)))) ;; t actually just defaults to outermost call
+ (if with-dependency
+ (tv)
+ (without-c-dependency (tv))))))
+ (values))
+
+(defun fm-traverse-bf (family applied-fn &optional (cq (make-fifo-queue)))
+ (when family
+ (flet ((process-node (fm)
+ (funcall applied-fn fm)
+ (when (kids fm)
+ (fifo-add cq (kids fm)))))
+ (process-node family)
+ (loop for x = (fifo-pop cq)
+ while x
+ do (mapcar #'process-node x)))))
+
+#+test-bf
+(progn
+ (defmd bftree (family)
+ (depth 0 :cell nil)
+ (id (c? (klin self)))
+ :kids (c? (when (< (depth self) 4)
+ (loop repeat (1+ (depth self))
+ collecting (make-kid 'bftree :depth (1+ (depth self)))))))
+
+ (defun klin (self)
+ (when self
+ (if .parent
+ (cons (kid-no self) (klin .parent))
+ (list 0))))
+
+ (defun test-bf ()
+ (let ((self (make-instance 'bftree)))
+ (fm-traverse-bf self
+ (lambda (node)
+ (print (id node)))))))
+
+(defun fm-ordered-p (n1 n2 &aux (top (fm-ascendant-common n1 n2)))
+ (assert top)
+ (fm-traverse top (lambda (n)
+ (cond
+ ((eq n n1)(return-from fm-ordered-p t))
+ ((eq n n2)(return-from fm-ordered-p nil))))))
+
+
+(defmethod sub-nodes (other)
+ (declare (ignore other)))
+
+(defmethod sub-nodes ((self family))
+ (kids self))
+
+(defmethod fm-ps-parent ((self model-object))
+ (fm-parent self))
+
+(defmacro with-like-fm-parts ((parts-var (self like-class)) &body body)
+ `(let (,parts-var)
+ (fm-traverse ,self (lambda (node)
+ ;;(trc "with like sees node" node (type-of node) ',likeclass)
+ (when (typep node ',like-class)
+ (push node ,parts-var)))
+ :skip-node ,self
+ :opaque t)
+ (setf ,parts-var (nreverse ,parts-var))
+ (progn , at body)))
+
+(defmacro do-like-fm-parts ((part-var (self like-class) &optional return-var) &body body)
+ `(progn
+ (fm-traverse ,self (lambda (,part-var)
+ (when (typep ,part-var ',like-class)
+ , at body))
+ :skip-node ,self
+ :opaque t)
+ ,return-var)
+ )
+
+;;
+;; family member finding
+;;
+
+
+#|
+ (defun fm-member-named (kidname kids)
+ (member kidname kids :key #'md-name))
+ |#
+
+(defun true-that (that) (declare (ignore that)) t)
+;;
+;; eventually fm-find-all needs a better name (as does fm-collect) and they
+;; should be modified to go through 'gather', which should be the real fm-find-all
+;;
+
+(defun fm-do-up (self &optional (fn 'identity))
+ (when self
+ (funcall fn self)
+ (if .parent (fm-do-up .parent fn) self))
+ (values))
+
+(defun fm-gather (family &key (test #'true-that))
+ (packed-flat!
+ (cons (when (funcall test family) family)
+ (mapcar (lambda (fm)
+ (fm-gather fm :test test))
+ (kids family)))))
+
+(defun fm-find-all (family md-name &key (must-find t) (global-search t))
+ (let ((matches (catch 'fm-find-all
+ (with-dynamic-fn
+ (traveller (family)
+ (with-dynamic-fn
+ (filter (kid) (eql md-name (md-name kid)))
+ (let ((matches (remove-if-not filter (kids family))))
+ (when matches
+ (throw 'fm-find-all matches)))))
+ (fm-traverse family traveller :global-search global-search)))))
+ (when (and must-find (null matches))
+ (setf *stop* t)
+ (fm-traverse family (lambda (node)
+ (trc "known node" (md-name node))) :global-search global-search)
+ (break "fm-find-all > *stop*ping...did not find ~a ~a ~a" family md-name global-search)
+ ;; (error 'fm-not-found (list md-name family global-search))
+ )
+ matches))
+
+(defun fm-find-next (fm test-fn)
+ (fm-find-next-within fm test-fn))
+
+(defun fm-find-next-within (fm test-fn &optional upperbound &aux (fm-parent (unless (eql upperbound fm)
+ (fm-parent fm))))
+ (let ((sibs (and fm-parent (rest (member fm (kids fm-parent))))))
+ (or (dolist (s sibs)
+ (let ((winner (fm-find-if s test-fn)))
+ (when winner (return winner))))
+ (if fm-parent
+ (fm-find-next-within fm-parent test-fn upperbound)
+ (fm-find-if fm test-fn)))))
+
+(defun fm-find-prior (fm test-fn)
+ (fm-find-prior-within fm test-fn))
+
+(defun fm-find-prior-within (fm test-fn &optional upperbound &aux (fm-parent (unless (eql upperbound fm)
+ (fm-parent fm))))
+ (let ((sibs (and fm-parent (kids fm-parent))))
+ (or (loop with next-ok
+ for s on sibs
+ for last-ok = nil then (or next-ok last-ok)
+ when (eql fm (first s)) do (loop-finish)
+ finally (return last-ok)
+ do (setf next-ok (fm-find-last-if (car s) test-fn)))
+ (if fm-parent
+ (fm-find-prior-within fm-parent test-fn upperbound)
+ (fm-find-last-if fm test-fn)))))
+
+ (defun fm-find-last-if (family test-fn)
+ (let ((last))
+ (or (and (kids family)
+ (dolist (k (kids family) last)
+ (setf last (or (fm-find-last-if k test-fn) last))))
+ (when (funcall test-fn family)
+ family))))
+
+(defun fm-prior-sib (self &optional (test-fn #'true-that))
+ "Find nearest preceding sibling passing TEST-FN"
+ (chk self 'psib)
+ (let ((kids (kids (fm-parent self))))
+ (find-if test-fn kids :end (position self kids) :from-end t)))
+
+(defun fm-next-sib-if (self test-fn)
+ (some test-fn (cdr (member self (kids (fm-parent self))))))
+
+(defun fm-next-sib (self)
+ (car (cdr (member self (kids (fm-parent self))))))
+
+(defmacro ^fm-next-sib (&optional (self 'self))
+ (let ((s (gensym)))
+ `(let ((,s ,self))
+ (car (cdr (member ,s (kids (fm-parent ,s))))))))
+
+(defun find-prior (self sibs &key (test #'true-that))
+ (c-assert (member self sibs) () "find-prior of ~a does not find it in sibs arg ~a" self sibs)
+ (unless (eql self (car sibs))
+ (labels
+ ((fpsib (rsibs &aux (psib (car rsibs)))
+ (c-assert rsibs () "find-prior > fpsib > self ~s not found to prior off" self)
+ (if (eql self (cadr rsibs))
+ (when (funcall test psib) psib)
+ (or (fpsib (cdr rsibs))
+ (when (funcall test psib) psib)))))
+ (fpsib sibs))))
+
+(defun fm-find-if (family test-fn &key skip-top-p) ;; 99-03 kt why is thsi depth-first?
+ (c-assert test-fn)
+ (when family
+ (or (dolist (b (sub-nodes family))
+ (let ((match (fm-find-if b test-fn)))
+ (when match (return match))))
+ (when (and (not skip-top-p)
+ (funcall test-fn family))
+ family))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;;;
+;;;; family ordering
+;;;;
+(defun fm-kid-add (fm-parent kid &optional before)
+ (c-assert (or (null (fm-parent kid)) (eql fm-parent (fm-parent kid))))
+ (c-assert (typep fm-parent 'family))
+ (setf (fm-parent kid) fm-parent)
+ (fm-kid-insert kid before))
+
+(defun fm-kid-insert-last (goal &aux (fm-parent (fm-parent goal)))
+ (setf (kids fm-parent) (nconc (kids fm-parent) (list goal))))
+
+(defun fm-kid-insert-first (goal &aux (fm-parent (fm-parent goal)))
+ (setf (kids fm-parent) (cons goal (kids fm-parent))))
+
+(defun fm-kid-insert (kid &optional before &aux (da-kids (kids (fm-parent kid))))
+ (c-assert (or (null before) (eql (fm-parent kid) (fm-parent before))))
+ (setf (kids (fm-parent kid))
+ (if before
+ (if (eql before (car da-kids))
+ (cons kid da-kids)
+ (let ((cell (member before da-kids)))
+ (rplaca cell kid)
+ (rplacd cell (cons before (cdr cell)))
+ (cons (car da-kids) (rest da-kids))))
+ (if da-kids
+ (progn
+ (rplacd (last da-kids) (cons kid nil))
+ (cons (car da-kids) (rest da-kids)))
+ (cons kid da-kids)))))
+
+(defun fm-kid-remove (kid &key (quiesce t) &aux (parent (fm-parent kid)))
+ (when quiesce
+ (fm-quiesce-all kid))
+ (when parent
+ (setf (kids parent) (remove kid (kids parent)))
+ ;; (setf (fm-parent kid) nil) gratuitous housekeeping caused ensuing focus output
+ ;; image-invalidate to fail since no access to containing window via fm-parent chain
+ ))
+
+(defun fm-quiesce-all (md)
+ (md-quiesce md)
+ (dolist (kid (kids md))
+ (fm-quiesce-all kid)))
+
+(defun fm-kid-replace (old-kid new-kid &aux (fm-parent (fm-parent old-kid)))
+ (c-assert (member old-kid (kids fm-parent)) ()
+ "~&oldkid ~s not amongst kids of its fm-parent ~s"
+ old-kid fm-parent)
+ (when fm-parent ;; silly test given above assert--which is right?
+ (c-assert (typep fm-parent 'family))
+ (setf (fm-parent new-kid) fm-parent)
+ (setf (kids fm-parent) (substitute new-kid old-kid (kids fm-parent)))
+ ;;(rplaca (member oldkid (kids fm-parent)) newkid)
+ new-kid))
+
+;----------------------------------------------------------
+;;
+;; h i g h - o r d e r f a m i l y o p s
+;;
+;; currently not in use...someday?
+;;
+
+
+(defun fm-min-kid (self slot-name)
+ (or (loop for k in (^kids)
+ minimizing (funcall slot-name k))
+ 0))
+(defun fm-max-kid (self slot-name)
+ (or (loop for k in (^kids)
+ maximizing (funcall slot-name k))
+ 0))
+
+(defmacro fm-other (md-name &key (starting 'self) skip-tree (test '#'true-that))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :skip-tree ,skip-tree
+ :global-search t
+ :test ,test))
+
+(defmacro fmv (name)
+ `(value (fm-other ,name)))
+
+(defmacro fm-otherx (md-name &key (starting 'self) skip-tree)
+ (if (eql starting 'self)
+ `(or (fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :skip-tree ,skip-tree
+ :global-search t))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :skip-tree ,skip-tree
+ :global-search t)))
+
+(defun fm-other-v (md-name starting &optional (global-search t))
+ (fm-find-one starting md-name
+ :must-find nil
+ :global-search global-search))
+
+(defmacro fm-otherv? (md-name &optional (starting 'self) (global-search t))
+ `(fm-other-v ,md-name ,starting ,global-search))
+
+(defmacro fm-other? (md-name &optional (starting 'self) (global-search t))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find nil
+ :global-search ,global-search))
+
+(defun fm-other! (starting md-name &optional (global-search t))
+ (fm-find-one starting md-name
+ :must-find t
+ :global-search global-search))
+
+(defmacro fm^ (md-name &key (skip-tree 'self) (must-find t))
+ `(without-c-dependency
+ (fm-find-one (fm-parent self) ,md-name
+ :skip-tree ,skip-tree
+ :must-find ,must-find
+ :global-search t)))
+
+
+(export! fm^v)
+(defmacro fm^v (id)
+ `(value (fm^ ,id)))
+
+(defmacro fm? (md-name &optional (starting 'self) (global-search t))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find nil
+ :global-search ,global-search))
+
+(defmacro fm! (md-name &optional (starting 'self))
+ `(without-c-dependency
+ (fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find t
+ :global-search nil)))
+
+(defmacro fm!v (id)
+ `(value (fm! ,id)))
+
+(defmacro fm-other?! (md-name &optional (starting 'self))
+ `(fm-find-one ,starting ,(if (consp md-name)
+ `(list ',(car md-name) ,(cadr md-name))
+ `',md-name)
+ :must-find nil
+ :global-search nil))
+
+(defmacro fm-collect (md-name &key (must-find t))
+ `(fm-find-all self ',md-name :must-find ,must-find)) ;deliberate capture
+
+(defmacro fm-map (fn md-name)
+ `(mapcar ,fn (fm-find-all self ',md-name))) ;deliberate capture
+
+(defmacro fm-mapc (fn md-name)
+ `(mapc ,fn (fm-find-all self ',md-name))) ;deliberate capture
+
+(defun fm-pos (goal &aux (fm-parent (fm-parent goal)))
+ (when fm-parent
+ (or (position goal (kids fm-parent))
+ (length (kids fm-parent))))) ;; ?!!
+
+(defmacro fm-count-named (family md-name &key (global-search t))
+ `(length (fm-find-all ,family ,md-name
+ :must-find nil
+ :global-search ,global-search)))
+;---------------------------------------------------------------
+(defun fm-top (fm &optional (test #'true-that) &aux (fm-parent (fm-parent fm)))
+ (cond ((null fm-parent) fm)
+ ((not (funcall test fm-parent)) fm)
+ (t (fm-top fm-parent test))))
+
+(defun fm-first-above (fm &key (test #'true-that) &aux (fm-parent (fm-parent fm)))
+ (cond ((null fm-parent) nil)
+ ((funcall test fm-parent) fm-parent)
+ (t (fm-first-above fm-parent :test test))))
+
+(defun fm-nearest-if (test fm)
+ (when fm
+ (if (funcall test fm)
+ fm
+ (fm-nearest-if test (fm-parent fm)))))
+
+(defun fm-includes (fm sought)
+ (fm-ancestor-p fm sought))
+
+(defun fm-ancestor-p (fm sought)
+ (c-assert fm)
+ (when sought
+ (or (eql fm sought)
+ (fm-includes fm (fm-parent sought)))))
+
+(defun fm-kid-containing (fm-parent descendant)
+ (with-dynamic-fn (finder (node) (not (eql fm-parent node)))
+ (fm-top descendant finder)))
+
+;;; above looks confused, let's try again
+
+(defun fm-ascendant-p (older younger)
+ (cond
+ ((null (fm-parent younger)) nil)
+ ((eq older (fm-parent younger)) t)
+ (t (fm-ascendant-p older (fm-parent younger)))))
+
+(defun make-name (root &optional subscript)
+ (if subscript (list root subscript) root))
+
+(defun name-root (md-name)
+ (if (atom md-name) md-name (car md-name)))
+
+(defun name-subscript (md-name)
+ (when (consp md-name) (cadr md-name)))
+
+(defun fm-find-one (family md-name &key (must-find t)
+ (global-search t) skip-tree (test #'true-that)
+ &aux diag)
+ (count-it :fm-find-one)
+ (flet ((matcher (fm)
+ (when diag
+ (trc nil
+ "fm-find-one matcher sees name" (md-name fm) :ofthing (type-of fm) :seeking md-name global-search))
+ (when (and (eql (name-root md-name)(md-name fm))
+ (or (null (name-subscript md-name))
+ (eql (name-subscript md-name) (fm-pos fm)))
+ (progn
+ (when diag
+ (trc "fm-find-one testing" fm))
+ (funcall test fm)))
+ (throw 'fm-find-one fm))))
+ #-lispworks (declare (dynamic-extent matcher))
+ (trc nil "fm-find-one> entry " md-name family)
+ (let ((match (catch 'fm-find-one
+ (fm-traverse family #'matcher
+ :skip-tree skip-tree
+ :global-search global-search))))
+ (when (and must-find (null match))
+ (trc "fm-find-one > erroring fm-not-found, in family: " family :seeking md-name :global? global-search)
+ (setq diag t must-find nil)
+ (fm-traverse family #'matcher
+ :skip-tree skip-tree
+ :global-search global-search)
+ (c-break "fm-find-one > *stop*ping...did not find ~a ~a ~a" family md-name global-search)
+ )
+ match)))
+
+(defun fm-find-kid (self name)
+ (find name (kids self) :key #'md-name))
+
+(defun fm-kid-typed (self type)
+ (c-assert self)
+ (find type (kids self) :key #'type-of))
+
+(defun kid-no (self)
+ (unless (typep self 'model-object)
+ (break "not a model object ~a" self))
+ (when (and self (fm-parent self))
+ (c-assert (member self (kids (fm-parent self))))
+ (position self (kids (fm-parent self)))))
Added: dependencies/trunk/cells/gui-geometry/coordinate-xform.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/coordinate-xform.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,287 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :gui-geometry)
+
+(defconstant *reference-dpi* 1440)
+
+(let (
+ (logical-dpi 96) ;;1440)
+ ; This is cello's internal dots per inch. This value is germane only if size references are unqualified by a function call.
+ ; Size references should always be qualified, as in (:pts 6), except when specifying pen widths.
+ ; (Pen widths may pose a special case -- we may need to match screen pens to print pens.)
+
+ (scan-resolution 300)
+ ; This is the desired scan resolution, and the assumed resolution of all scans.
+ ; Hypothetically, a scanner not capable of scanning at 300 dpi could make a big hash of this scheme.
+ ; Rather than even pretend to support multiple resolutions within a study, for now we'll enforce 300 across the board.
+ ; Dependencies on this spec can be identified by searching on scan-resolution.
+
+ (logical-screen-resolution 96)
+ ; This is the internal logical screen resolution, which does _not_ have to equal the current LOGPIXELSX (LOGPIXELSY) value
+ ; reported by GetDeviceCaps. The original thought was that we could use this to rescale _all_ drawing on the fly. Now that
+ ; idea is being superseded by targetRes, but this functions (1) as a tacit targetRes for the outer window and (2) as a magic
+ ; number to complicate debugging [we need to root out a few references in .bmp drawing, I think].
+
+ ;;(printer-resolution 600) ; /// improve #'cs-printer-resolution to bypass this.
+
+ ;;(emf-resolution 600)
+
+ )
+
+ (declare (ignorable logical-dpi scan-resolution logical-screen-resolution printer-resolution))
+
+ ; Notice the somewhat nonstandard naming convention:
+ ; #'uInches takes logical inches and returns logical units (DPI)
+ ; so, for instance, if logical-dpi = 1440, then (uInches 0.5) = 720.
+ (defun u-round (number &optional (divisor 1))
+ (multiple-value-bind (quotient remainder)
+ (round number divisor)
+ (declare (ignorable remainder))
+ ;(assert (zerop remainder))
+ ;(assert (zerop (mod quotient 15))) ;96ths
+ quotient))
+
+
+ (defun udots (dots dpi)
+ (u-round (* dots logical-dpi) dpi)) ;only the first value will be used.
+
+ (defun uinches (logical-inches)
+ (u-round (* logical-inches logical-dpi))) ;only the first value will be used.
+
+ (defun uin (logical-inches)
+ (uinches logical-inches))
+
+ (defun upoints (logical-points)
+ (udots logical-points 72))
+
+ (defun upts (logical-points)
+ (upoints logical-points))
+
+ (defun u96ths (logical-96ths)
+ (udots logical-96ths 96))
+
+ (defun u8ths (logical-8ths)
+ (udots logical-8ths 8))
+
+ (defun u16ths (logical-16ths)
+ (udots logical-16ths 16))
+
+ (defun u32nds (logical-32nds)
+ (udots logical-32nds 32))
+
+ (defun u120ths (logical-120ths)
+ (udots logical-120ths 120))
+
+ (defun cs-logical-dpi ()
+ logical-dpi)
+
+ (defsetf cs-logical-dpi cs-logical-dpi-setf)
+
+ (defun cs-logical-dpi-setf (new-value)
+ (setf logical-dpi new-value))
+
+ (defun cs-scan-resolution ()
+ scan-resolution)
+
+ (defun cs-logical-screen-resolution ()
+ logical-screen-resolution)
+
+ )
+
+
+
+
+(defmethod u-cvt ((nn number) (units (eql :96ths)) )
+ (u96ths nn))
+
+(defmethod u-cvt ((nn number) (units (eql :8ths)) )
+ (u8ths nn))
+
+(defmethod u-cvt ((nn number) (units (eql :16ths)) )
+ (u16ths nn))
+
+(defmethod u-cvt ((nn number) (units (eql :32nds)) )
+ (u32nds nn))
+
+(defmethod u-cvt ((nn number) (units (eql :inches)) )
+ (uinches nn))
+
+(defmethod u-cvt ((nn number) (units (eql :points)) )
+ (upoints nn))
+
+(defmethod u-cvt (other units)
+ (declare (ignore units))
+ other)
+
+(defmethod u-cvt ((nns cons) units)
+ (cons (u-cvt (car nns) units)
+ (u-cvt (cdr nns) units)))
+
+(defmacro u-cvt! (nn units)
+ `(u-cvt ,nn ,units))
+
+(defun uv2 (x y u-key) (apply #'mkv2 (u-cvt (list x y) u-key)))
+
+;-----------------
+
+(defun os-logical-screen-dpi ()
+ (break "need (win:GetDeviceCaps (device-context (screen *cg-system*)) win:LOGPIXELSX))"))
+
+#+no(defun browser-target-resolution ()
+ (target-resolution (find-window :clinisys)))
+
+; set to 96 because the code is trying to do rect-frames for the header before the window is init'ed.
+
+(let ((current-target-resolution 96)) ;initialize when main window is created
+
+ (defun set-current-target-resolution (resolution)
+ #+shh(trc "setting current-target-resolution to" resolution)
+ (setf current-target-resolution resolution))
+
+ (defun cs-current-target-resolution ()
+ current-target-resolution)
+
+ (defun cs-target-res ()
+ current-target-resolution)
+
+ (defmacro with-target-resolution ((new-resolution) &rest body)
+ (let ((old-resolution (gensym))
+ )
+ `(let ((,old-resolution (cs-current-target-resolution))
+ )
+ (prog2
+ (set-current-target-resolution ,new-resolution)
+ (progn , at body)
+ (set-current-target-resolution ,old-resolution)
+ ))))
+ )
+
+
+;converts screen pixels to logical pixels given the current target resolution OR OPTIONAL OTHER RES
+(defun scr2log (dots &optional (target-res (cs-target-res)))
+ (round (* dots (cs-logical-dpi))
+ target-res))
+
+(defun log2scr (logv &optional (target-res (cs-target-res)))
+ (floor-round (* logv target-res )
+ (cs-logical-dpi)))
+
+(defun cs-archos-dpi ()
+ (cs-logical-dpi))
+
+(defun floor-round (x &optional (divisor 1))
+ (ceiling (- (/ x divisor) 1/2)))
+
+;converts logical pixels to screen pixels given the current target resolution OR OPTIONAL OTHER RES
+(defun logical-to-screen-vector (dots &optional target-res)
+ (let ((convert-res (or target-res (cs-target-res))))
+ (floor-round (* dots convert-res) (cs-logical-dpi))))
+
+(defun logical-to-screen-point (point &optional target-res)
+ (mkv2
+ (log2scr (v2-h point) target-res)
+ (log2scr (v2-v point) target-res)))
+
+(defun screen-to-logical-v2 (point &optional target-res)
+ (mkv2
+ (scr2log (v2-h point) target-res)
+ (scr2log (v2-v point) target-res)))
+
+(defun nr-screen-to-logical (logical-rect screen-rect &optional target-res)
+ (nr-make logical-rect
+ (scr2log (r-left screen-rect) target-res)
+ (scr2log (r-top screen-rect) target-res)
+ (scr2log (r-right screen-rect) target-res)
+ (scr2log (r-bottom screen-rect) target-res)))
+
+; logical-to-target is a more sensible name throughout
+
+(defun logical-to-target-vector (dots &optional target-res)
+ (log2scr dots target-res))
+;--------------------------------------------------------------------------------------------
+
+(defun r-logical-to-screen (logical-rect &optional target-res)
+ (count-it :r-logical-to-screen)
+ (nr-logical-to-screen (mkr 0 0 0 0) logical-rect target-res))
+
+(defun nr-logical-to-screen (screen-rect logical-rect &optional target-res)
+ (nr-make screen-rect
+ (log2scr (r-left logical-rect) target-res)
+ (log2scr (r-top logical-rect) target-res)
+ (log2scr (r-right logical-rect) target-res)
+ (log2scr (r-bottom logical-rect) target-res)))
+
+;------------------------------------------------------------------------------------------------
+
+;;;(defun set-scaling (window)
+;;; #+shh(trc "targetResolution" (targetRes window))
+;;;
+;;; (set-current-target-resolution (cs-logical-screen-resolution)) ;here and below, we'll probably make scalable
+;;; ;(set-current-target-resolution (cs-logical-dpi))
+;;; (let ((dc (device-context window))
+;;; (display-dpi (cs-logical-screen-resolution)) ;... and use (targetRes window)
+;;; (logical-dpi (cs-logical-dpi)))
+;;; (os-SetMapMode dc win:MM_ISOTROPIC)
+;;; (os-SetWindowExtEx dc logical-dpi logical-dpi ct:hnull)
+;;; (os-SetViewportExtEx dc display-dpi display-dpi ct:hnull)))
+
+
+(defun move-v2-x-y (v2 x y)
+ (incf (v2-h v2) x)
+ (incf (v2-v v2) y)
+ v2)
+
+(defmethod ncanvas-to-screen-point (self point)
+ (ncanvas-to-screen-point (fm-parent self)
+ (move-v2-x-y point (px self) (py self))))
+
+(defmethod res-to-res ((amount number) from-res to-res)
+ (if to-res
+ (round (* amount from-res) to-res)
+ from-res))
+
+(defmethod res-to-res ((point v2) from-res to-res)
+ (nres-to-res (copy-v2 point) from-res to-res))
+
+#+no-2e-h
+(defmethod nres-to-res ((point v2) from-res to-res)
+ (setf (v2-h point) (res-to-res (v2-h point) from-res to-res))
+ (setf (v2-v point) (res-to-res (v2-v point) from-res to-res))
+ point)
+
+(defmethod res-to-res ((box rect) from-res to-res)
+ (count-it :res-to-res)
+ (nres-to-res (nr-copy (mkr 0 0 0 0) box) from-res to-res))
+
+(defmethod nres-to-res :around (geo-thing from-res (to-res null))
+ (declare (ignore from-res))
+ geo-thing)
+
+(defmethod nres-to-res ((box rect) from-res to-res)
+ (setf (r-left box) (res-to-res (r-left box) from-res to-res))
+ (setf (r-top box) (res-to-res (r-top box) from-res to-res))
+ (setf (r-right box) (res-to-res (r-right box) from-res to-res))
+ (setf (r-bottom box) (res-to-res (r-bottom box) from-res to-res))
+ box)
+
+(defun canvas-to-screen-box (self box)
+ (count-it :canvas-to-screen-box)
+ (nr-make-from-corners
+ (mkr 0 0 0 0)
+ (ncanvas-to-screen-point self (r-top-left box))
+ (ncanvas-to-screen-point self (r-bottom-right box))))
+
Added: dependencies/trunk/cells/gui-geometry/defpackage.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/defpackage.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,53 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(defpackage #:gui-geometry
+ (:nicknames #:geo)
+ (:use #:common-lisp #:excl #:utils-kt #:cells)
+ (:export #:geometer #:geo-zero-tl #:geo-inline #:a-stack #:a-row
+ #:px #:py #:ll #:lt #:lr #:lb #:pl #:pt #:pr #:pb
+ #:^px #:^py #:^ll #:^lt #:^lr #:^lb #:^lb-height
+ #:^fill-parent-down
+ #:u96ths #:udots #:uinches #:uin #:upoints #:upts #:u8ths #:u16ths #:u32nds
+ #:mkr #:v2-nmove #:l-height #:mkv2 #:^offset-within #:inset-lr #:v2-v #:v2-h
+ #:r-bounds #:l-box
+ #:lb
+ #:cs-target-res
+ #:nr-make
+ #:r-contains
+ #:collapsed
+ #:g-box
+ #:v2-in-rect-ratio
+ #:v2-xlate #:v2-in-rect #:v2-add #:v2-subtract
+ #:log2scr
+ #:^lr-width
+ #:px-maintain-pr
+ #:outset
+ #:py-maintain-pb
+ #:cs-logical-dpi
+ #:px-maintain-pl #:py-maintain-pt
+ #:scr2log
+ #:inset-width #:inset-height
+ #:res-to-res
+ #:logical-to-screen-point
+ #:nres-to-res
+ #:cs-logical-screen-resolution
+ #:outl
+ #:with-r-bounds #:r-inset
+ #:ncopy-rect
+ #:l
+ #:r-height #:r-width #:r-top #:r-right #:r-bottom #:r-left
+ #:l-width ))
Added: dependencies/trunk/cells/gui-geometry/geo-data-structures.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/geo-data-structures.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,342 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :gui-geometry)
+
+(eval-now!
+ (export '(v2 mkv2 v2=)))
+;-----------------------------
+
+(defstruct v2
+ (h 0 ) ;; horizontal coordinate
+ (v 0 ) ;; vertical coordinate
+ )
+
+(defmethod print-object ((self v2) s)
+ (format s "~a|~a" (v2-h self)(v2-v self)))
+
+(defun mkv2 (h v) (make-v2 :h h :v v))
+
+(defun v2= (a b)
+ (and a b
+ (= (v2-h a)(v2-h b))
+ (= (v2-v a)(v2-v b))))
+
+(defun v2-add (p1 p2-or-x &optional y-or-p2-or-x-is-p2)
+ (if y-or-p2-or-x-is-p2
+ (make-v2 :h (+ (v2-h p1) p2-or-x)
+ :v (+ (v2-v p1) y-or-p2-or-x-is-p2))
+ (make-v2 :h (+ (v2-h p1) (v2-h p2-or-x))
+ :v (+ (v2-v p1) (v2-v p2-or-x)))))
+
+(defun v2-subtract (p1 p2-or-x &optional y-or-p2-or-x-is-p2)
+ (if y-or-p2-or-x-is-p2
+ (make-v2 :h (- (v2-h p1) p2-or-x)
+ :v (- (v2-v p1) y-or-p2-or-x-is-p2))
+ (make-v2 :h (- (v2-h p1) (v2-h p2-or-x))
+ :v (- (v2-v p1) (v2-v p2-or-x)))))
+
+(defun v2-nmove (p1 x &optional y)
+ (if y
+ (progn
+ (incf (v2-h p1) x)
+ (incf (v2-v p1) y))
+ (v2-nmove p1 (v2-h x)(v2-v x)))
+ p1)
+
+(defun v2-in-rect (v2 r)
+ (mkv2 (min (r-right r) (max (r-left r) (v2-h v2)))
+ (min (r-top r) (max (r-bottom r) (v2-v v2)))))
+
+(defun v2-in-rect-ratio (v2 r)
+ (assert (<= (r-left r) (v2-h v2) (r-right r)))
+ (assert (<= (r-bottom r) (v2-v v2) (r-top r)))
+ (mkv2 (div-safe (- (v2-h v2) (r-left r)) (r-width r))
+ (div-safe (- (v2-v v2) (r-bottom r)) (r-height r))))
+
+(defun div-safe (n d &optional (zero-div-return-value 1))
+ (if (zerop d) zero-div-return-value (/ n d)))
+
+(defmethod c-value-incf (c (base v2) (delta number))
+ (declare (ignore c))
+ (mkv2 (+ (v2-h base) delta)
+ (+ (v2-v base) delta)))
+
+(defmethod c-value-incf (c (base v2) (delta v2))
+ (declare (ignore c))
+ (v2-add base delta))
+
+; synapse support
+;
+(defmethod delta-diff ((new v2) (old v2) (subtypename (eql 'v2)))
+ (v2-subtract new old))
+
+(defmethod delta-identity ((dispatcher number) (subtypename (eql 'v2)))
+ (mkv2 0 0))
+
+(defun long-v2 (long-hv)
+ (c-assert (numberp long-hv))
+ (multiple-value-bind (fv fh)
+ (floor long-hv 65536)
+ (mkv2 fh fv)))
+
+(defun long-x (long-hv)
+ (c-assert (numberp long-hv))
+ (mod long-hv 65536))
+
+(defun long-y (long-hv)
+ (c-assert (numberp long-hv))
+ (floor long-hv 65536))
+
+(defun v2-long (v2)
+ (c-assert (typep v2 'v2))
+ (xy-long (v2-h v2) (v2-v v2)))
+
+(defun xy-long (x y)
+ (+ (* 65536 y) x))
+
+(defun v2-to-vector (v2)
+ (vector (v2-h v2) (v2-v v2)))
+
+(defun v2-negative (v2)
+ (c-assert (typep v2 'v2))
+ (mkv2 (- (v2-h v2)) (- (v2-v v2))))
+
+(defun vector-v2 (vc) (mkv2 (elt vc 0) (elt vc 1)))
+
+(defmethod delta-exceeds ((d1 v2) (d2 v2) (subtypename (eql 'v2)))
+ (c-assert (and (typep d1 'v2) (typep d2 'v2)))
+ (> (v2-distance-to d1) (v2-distance-to d2)))
+
+(defun v2-distance (from to)
+ (sqrt (+ (expt (v2-dv from to) 2)
+ (expt (v2-dh from to) 2))))
+
+(defun v2-area (v2)
+ "Treat point as length & width and calc area"
+ (abs (* (v2-h v2)(v2-v v2))))
+
+(defun v2-dh (p1 p2)
+ (- (v2-h p2) (v2-h p1)))
+
+(defun v2-dv (p1 p2)
+ (- (v2-v p2) (v2-v p1)))
+
+(defun v2-angle-between (from to)
+ (atan (v2-dv from to) (v2-dh from to)))
+
+(defun v2-distance-to (to)
+ (sqrt (+ (expt (v2-h to) 2)
+ (expt (v2-v to) 2))))
+;-------------------------------------------------
+
+(export! rect)
+(defstruct (rect (:conc-name r-))
+ (left 0 )
+ (top 0 )
+ (right 0 )
+ (bottom 0 ))
+
+(defmethod print-object ((self rect) s)
+ (format s "(rect (~a,~a) (~a,~a))" (r-left self)(r-top self)(r-right self)(r-bottom self)))
+
+(defun r-top-left (r)
+ (mkv2 (r-left r) (r-top r)))
+
+(export! r-center)
+
+(defun r-center (r)
+ (mkv2 (/ (+ (r-left r)(r-right r)) 2)
+ (/ (+ (r-top r)(r-bottom r)) 2)))
+
+(defun r-bottom-right (r)
+ (mkv2 (r-bottom r) (r-right r)))
+
+(defun mkr (left top right bottom)
+ (count-it :mkrect)
+ (make-rect :left left :top top :right right :bottom bottom))
+
+(defun nr-make (r left top right bottom)
+ (setf (r-left r) left (r-top r) top (r-right r) right (r-bottom r) bottom)
+ r)
+
+(defmacro with-r-bounds ((lv tv rv bv) r-form &body body)
+ (let ((r (gensym)))
+ `(let* ((,r ,r-form)
+ (,lv (r-left ,r))
+ (,tv (r-top ,r))
+ (,rv (r-right ,r))
+ (,bv (r-bottom ,r)))
+ , at body)))
+
+(defun ncopy-rect (old &optional new)
+ (if new
+ (progn
+ (setf (r-left new)(r-left old)
+ (r-top new)(r-top old)
+ (r-right new)(r-right old)
+ (r-bottom new)(r-bottom old))
+ new)
+ (copy-rect old)))
+
+(defun r-inset (r in &optional (destr (mkr 0 0 0 0)))
+ (nr-make destr
+ (+ (r-left r) in)
+ (+ (r-top r) (downs in))
+ (- (r-right r) in)
+ (+ (r-bottom r) (ups in))))
+
+(defun nr-make-from-corners (r tl br)
+ (nr-make r (v2-h tl)(v2-v tl)(v2-h br)(v2-v br)))
+
+(defun nr-copy (r copied-r)
+ (setf (r-left r) (r-left copied-r)
+ (r-top r) (r-top copied-r)
+ (r-right r) (r-right copied-r)
+ (r-bottom r) (r-bottom copied-r))
+ r)
+
+(defun r-contains (r v2)
+ (and (<= (r-left r)(v2-h v2)(r-right r))
+ (<= (r-top r)(v2-v v2)(r-bottom r))))
+
+(defun nr-intersect (r sr)
+ (let ((r-min-v (min (r-top r) (r-bottom r)))
+ (r-max-v (max (r-top r) (r-bottom r)))
+ (r-min-h (min (r-left r) (r-right r)))
+ (r-max-h (max (r-left r) (r-right r)))
+ ;
+ (sr-min-v (min (r-top sr) (r-bottom sr)))
+ (sr-max-v (max (r-top sr) (r-bottom sr)))
+ (sr-min-h (min (r-left sr) (r-right sr)))
+ (sr-max-h (max (r-left sr) (r-right sr)))
+ )
+ (let ((min-v (max r-min-v sr-min-v))
+ (max-v (min r-max-v sr-max-v))
+ (min-h (max r-min-h sr-min-h))
+ (max-h (min r-max-h sr-max-h)))
+ (when (or (>= min-v max-v)(>= min-h max-h))
+ (setf min-h 0 min-v 0 max-h 0 max-v 0))
+ (nr-make r min-h min-v max-h max-v))))
+
+(defun nr-union (r sr) ;; unlike other code, this is assuming opengl's up==plus, and proper rectangles
+ (nr-make r (min (r-left r) (r-left sr))
+ (max (r-top r) (r-top sr))
+ (max (r-right r) (r-right sr))
+ (min (r-bottom r) (r-bottom sr))))
+
+(defun nr-move-to (r h v)
+ (setf (r-left r) h
+ (r-top r) (+ v (r-width r))
+ (r-right r) (+ h (r-width r))
+ (r-bottom r) (+ v (r-height r))))
+
+
+(defun nr-scale (r factor)
+ (nr-make r
+ (round (* (r-left r) factor))
+ (round (* (r-top r) factor))
+ (round (* (r-right r) factor))
+ (round (* (r-bottom r) factor))))
+
+(defun r-empty (r)
+ (or (zerop (r-width r))
+ (zerop (r-height r))))
+
+(defun r-width (r) (abs (- (r-right r)(r-left r))))
+(defun r-height (r) (abs (- (r-top r)(r-bottom r))))
+(defun r-area (r) (* (r-width r)(r-height r)))
+
+(defun nr-offset (r dh dv)
+;;; (declare (optimize (speed 3) (safety 0) (debug 0)))
+ ;; (declare (type fixnum dh dv))
+ (incf (r-left r) dh)
+ (incf (r-right r) dh)
+ (incf (r-top r) dv)
+ (incf (r-bottom r) dv)
+ r)
+
+(defun nr-outset (box dh &optional (dv dh))
+;;; (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (declare (type fixnum dh dv))
+ (decf (r-left box) dh)
+ (incf (r-right box) dh)
+ (decf (r-top box) dv)
+ (incf (r-bottom box) dv)
+ box)
+
+(defun r-bounds (box)
+ (list (r-left box)(r-top box)(r-right box)(r-bottom box)))
+
+(defun pt-in-bounds (point bounds-left bounds-top bounds-right boundsbottom)
+;;; (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (declare (type fixnum bounds-left bounds-top bounds-right boundsbottom))
+ (and (<= bounds-left (progn (v2-h point)) bounds-right)
+ (<= bounds-top (progn (v2-v point)) boundsbottom)))
+
+
+(defun r-in-bounds (box bounds-left bounds-top bounds-right boundsbottom)
+;;; (declare (optimize (speed 3) (safety 0) (debug 0)))
+ (declare (type fixnum bounds-left bounds-top bounds-right boundsbottom))
+ (and (<= bounds-left (progn (r-left box)) (progn (r-right box)) bounds-right)
+ (<= bounds-top (progn (r-top box)) (progn (r-bottom box)) boundsbottom)))
+
+(defun r-unitize (object-r unit-r &aux (ww (r-width unit-r))(wh (r-height unit-r)))
+ (flet ((cf (i) (coerce i 'float)))
+ (mkr (cf (/ (- (r-left object-r)(r-left unit-r)) ww))
+ (cf (/ (- (r-top unit-r)(r-top object-r)) wh))
+ (cf (/ (- (r-right object-r)(r-left unit-r)) ww))
+ (cf (/ (- (r-top unit-r)(r-bottom object-r)) wh)))))
+
+(defun r-scale (r x y)
+ (mkr (* (r-left r) x)
+ (* (r-top r) y)
+ (* (r-right r) x)
+ (* (r-bottom r) x)))
+
+(defun r-analog (this1 that1 this2)
+ (mkr (* (r-left this2) (/ (r-left that1)(r-left this1)))
+ (* (r-top this2) (/ (r-top that1)(r-top this1)))
+ (* (r-right this2) (/ (r-right that1)(r-right this1)))
+ (* (r-bottom this2) (/ (r-bottom that1)(r-bottom this1)))))
+
+
+;;; --- Up / Down variability management ---
+
+(eval-now!
+ (export '(*up-is-positive* ups ups-more ups-most downs downs-most downs-more)))
+
+(defparameter *up-is-positive* t
+ "You should set this to NIL for most GUIs, but not OpenGl")
+
+(defun ups (&rest values)
+ (apply (if *up-is-positive* '+ '-) values))
+
+(defun ups-more (&rest values)
+ (apply (if *up-is-positive* '> '<) values))
+
+(defun ups-most (&rest values)
+ (apply (if *up-is-positive* 'max 'min) values))
+
+(defun downs (&rest values)
+ (apply (if *up-is-positive* '- '+) values))
+
+(defun downs-most (&rest values)
+ (apply (if *up-is-positive* 'min 'max) values))
+
+(defun downs-more (&rest values)
+ (apply (if *up-is-positive* '< '>) values))
+
Added: dependencies/trunk/cells/gui-geometry/geo-family.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/geo-family.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,171 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :gui-geometry)
+
+(export! geo-inline-lazy ^px-self-centered justify py-maintain-pt
+ ^prior-sib-pb spacing lr-maintain-pr orientation)
+
+;--------------- geo-inline -----------------------------
+;
+(defmodel geo-inline (geo-zero-tl)
+ ((orientation :initarg :orientation :initform nil :accessor orientation
+ :documentation ":vertical (for a column) or :horizontal (row)")
+ (justify :initarg :justify :accessor justify
+ :initform (c? (ecase (orientation self)
+ (:vertical :left)
+ (:horizontal :top))))
+ (spacing :initarg :spacing :initform 0 :accessor spacing))
+ (:default-initargs
+ :lr (c? (if (^collapsed)
+ (^lr-width 0)
+ (+ (^outset)
+ (ecase (orientation self)
+ (:vertical (loop for k in (^kids)
+ maximizing (l-width k)))
+ (:horizontal (bif (lk (last1 (^kids)))
+ (pr lk) 0))))))
+ :lb (c? (if (^collapsed)
+ (^lb-height 0)
+ (+ (- (^outset))
+ (ecase (orientation self)
+ (:vertical (loop for k in (^kids)
+ unless (collapsed k)
+ minimizing (pb k)))
+ (:horizontal (downs (loop for k in (^kids)
+ maximizing (l-height k))))))))
+ :kid-slots (lambda (self)
+ (ecase (orientation .parent)
+ (:vertical (list
+ (mk-kid-slot (px :if-missing t)
+ (c? (^px-self-centered (justify .parent))))
+ (mk-kid-slot (py)
+ (c? (py-maintain-pt
+ (^prior-sib-pb self (spacing .parent)))))))
+ (:horizontal (list
+ (mk-kid-slot (py :if-missing t)
+ (c? (py-self-centered self (justify .parent))))
+ (mk-kid-slot (px :if-missing t)
+ (c? (px-maintain-pl
+ (^prior-sib-pr self (spacing .parent)))))))))
+ ))
+
+(defmodel geo-inline-lazy (geo-zero-tl)
+ ((orientation :initarg :orientation :initform nil :accessor orientation
+ :documentation ":vertical (for a column) or :horizontal (row)")
+ (justify :initarg :justify :accessor justify
+ :initform (c_? (ecase (orientation self)
+ (:vertical :left)
+ (:horizontal :top))))
+ (spacing :initarg :spacing :initform 0 :accessor spacing))
+ (:default-initargs
+ :lr (c_? (+ (^outset)
+ (ecase (orientation self)
+ (:vertical (loop for k in (^kids)
+ maximizing (l-width k)))
+ (:horizontal (bif (lk (last1 (^kids)))
+ (pr lk) 0)))))
+ :lb (c_? (+ (- (^outset))
+ (ecase (orientation self)
+ (:vertical (bif (lk (last1 (^kids)))
+ (pb lk) 0))
+ (:horizontal (downs (loop for k in (^kids)
+ maximizing (l-height k)))))))
+ :kid-slots (lambda (self)
+ (ecase (orientation .parent)
+ (:vertical (list
+ (mk-kid-slot (px :if-missing t)
+ (c_? (^px-self-centered (justify .parent))))
+ (mk-kid-slot (py)
+ (c_? (eko (nil "py" self (^lt) (l-height self)(psib))
+ (py-maintain-pt
+ (eko (nil "psib-pb")
+ (^prior-sib-pb self (spacing .parent)))))))))
+ (:horizontal (list
+ (mk-kid-slot (py :if-missing t)
+ (c_? (py-self-centered self (justify .parent))))
+ (mk-kid-slot (px)
+ (c_? (px-maintain-pl
+ (^prior-sib-pr self (spacing .parent)))))))))))
+
+
+
+(defun ^prior-sib-pb (self &optional (spacing 0)) ;; just keeping with -pt variant till both converted to defun
+ (bif (psib (find-prior self (kids .parent)
+ :test (lambda (sib)
+ (not (collapsed sib)))))
+ (eko (nil "^prior-sib-pb spc pb-psib -lt" (- (abs spacing)) (pb psib) (- (^lt)))
+ (+ (- (abs spacing)) ;; force spacing to minus(= down for OpenGL)
+ (pb psib)))
+ 0))
+
+(defun centered-h? ()
+ (c? (px-maintain-pl (round (- (inset-width .parent) (l-width self)) 2))))
+
+(defun centered-v? ()
+ (c? (py-maintain-pt (round (- (l-height .parent) (l-height self)) -2))))
+
+;--------------- geo.row.flow ----------------------------
+(export! geo-row-flow fixed-col-width ^fixed-col-width ^spacing-hz spacing-hz
+ max-per-row ^max-per-row)
+
+(defmd geo-row-flow (geo-inline)
+ (spacing-hz 0)
+ (spacing-vt 0)
+ (aligned :cell nil)
+ fixed-col-width
+ max-per-row
+ (row-flow-layout
+ (c? (loop with max-pb = 0 and pl = 0 and pt = 0
+ for k in (^kids)
+ for kn upfrom 0
+ for kw = (or (^fixed-col-width) (l-width k))
+ for kpr = (+ pl kw)
+ when (unless (= pl 0)
+ (if (^max-per-row)
+ (zerop (mod kn (^max-per-row)))
+ (> kpr (- (l-width self) (outset self)))))
+ do
+ (when (> kpr (- (l-width self) (outset self)))
+ (trc nil "LR overflow break" kpr :gt (- (l-width self) (outset self))))
+ (when (zerop (mod kn (^max-per-row)))
+ (trc nil "max/row break" kn (^max-per-row) (mod kn (^max-per-row))))
+ (setf pl 0
+ pt (+ max-pb (downs (^spacing-vt))))
+
+ collect (cons (+ pl (case (justify self)
+ (:center (/ (- kw (l-width k)) 2))
+ (:right (- kw (l-width k)))
+ (otherwise 0))) pt) into pxys
+ do (incf pl (+ kw (^spacing-hz)))
+ (setf max-pb (min max-pb (+ pt (downs (l-height k)))))
+ finally (return (cons max-pb pxys)))))
+ :lb (c? (+ (bif (xys (^row-flow-layout))
+ (car xys) 0)
+ (downs (outset self))))
+ :kid-slots (lambda (self)
+ (declare (ignore self))
+ (list
+ (mk-kid-slot (px)
+ (c? (px-maintain-pl (car (nth (kid-no self) (cdr (row-flow-layout .parent)))))))
+ (mk-kid-slot (py)
+ (c? (py-maintain-pt (cdr (nth (kid-no self) (cdr (row-flow-layout .parent))))))))))
+
+
+
+
+
+
Added: dependencies/trunk/cells/gui-geometry/geo-macros.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/geo-macros.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,142 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package #:gui-geometry)
+
+(defmacro ^offset-within (inner outer)
+ (let ((offset-h (gensym)) (offset-v (gensym)) (from (gensym)))
+ `(let ((,offset-h 0)
+ (,offset-v 0))
+ (do ((,from ,inner (fm-parent ,from)))
+ ((or (null ,from)
+ (eql ,from ,outer))
+ ;
+ (mkv2 ,offset-h ,offset-v))
+
+ (incf ,offset-h (px ,from))
+ (incf ,offset-v (py ,from))))))
+
+(defmacro ^ll-width (width)
+ `(- (lr self) ,width))
+
+(defmacro ^lr-width (width)
+ `(+ (ll self) ,width))
+
+(defmacro ^lt-height (height)
+ `(- (lb self) ,height))
+
+(defmacro ^lb-height (height)
+ `(+ (lt self) ,height))
+
+(defmacro ll-maintain-pL (pl)
+ `(- ,pL (^px)))
+
+(defmacro lr-maintain-pr (pr)
+ `(- ,pr (^px)))
+
+(defmacro ^fill-right (upperType &optional (padding 0))
+ `(call-^fillRight self (upper self ,upperType) ,padding))
+
+;recalc local top based on pT and offset
+(defmacro lt-maintain-pT (pT)
+ `(- ,pT (^py)))
+
+;recalc local bottom based on pB and offset
+(defmacro lb-maintain-pB (pB)
+ `(- ,pB (^py)))
+
+;------------------------------------
+; recalc offset based on p and local
+;
+
+(defmacro px-maintain-pL (pL)
+ (let ((lL (gensym)))
+ `(- ,pL (let ((,lL (^lL)))
+ (c-assert ,lL () "^px-maintain-pL sees nil lL for ~a" self)
+ ,lL))))
+
+(defmacro px-maintain-pR (pR)
+ `(- ,pR (^lR)))
+
+(defmacro py-maintain-pT (pT)
+ `(- ,pT (^lT)))
+
+(defmacro py-maintain-pB (pB)
+ `(- ,pB (^lB)))
+
+(export! centered-h? centered-v? lb-maintain-pB)
+
+(defmacro ^fill-down (upper-type &optional (padding 0))
+ (let ((filled (gensym)))
+ `(let ((,filled (upper self ,upper-type)))
+ #+shhh (trc "^fillDown sees filledLR less offH"
+ (lb ,filled)
+ ,padding
+ (v2-v (offset-within self ,filled)))
+ (- (lb ,filled)
+ ,padding
+ (v2-v (offset-within self ,filled))))))
+
+(defmacro ^lbmax? (&optional (padding 0))
+ `(c? (lb-maintain-pb (- (inset-lb .parent)
+ ,padding))))
+
+(defmacro ^lrmax? (&optional (padding 0))
+ `(c? (lr-maintain-pr (- (inset-lr .parent)
+ ,padding))))
+
+; "...return the sib's pL [if ,alignment is :left] or pR, plus optional spacing"
+
+(defmacro ^prior-sib-pr (self &optional (spacing 0) alignment)
+ (let ((kid (gensym))
+ (psib (gensym)))
+ `(let* ((,kid ,self)
+ (,psib (find-prior ,kid (kids (fm-parent ,kid)) :test (lambda (k) (not (collapsed k))))))
+ (if ,psib
+ (case ,alignment
+ (:left (+ ,spacing (pl ,psib)))
+ (otherwise (+ ,spacing (pr ,psib))))
+ 0))))
+
+(defmacro ^px-stay-right-of (other &key (by '0))
+ `(px-maintain-pl (+ (pr (fm-other ,other)) ,by)))
+
+; in use; adjust offset to maintain pL based on ,justify
+(defmacro ^px-self-centered (justify)
+ `(px-maintain-pl
+ (ecase ,justify
+ (:left 0)
+ (:center (floor (- (inset-width .parent) (l-width self)) 2))
+ (:right (- (inset-lr .parent) (l-width self))))))
+
+(defmacro ^fill-parent-right (&optional (inset 0))
+ `(lr-maintain-pr (- (inset-lr .parent) ,inset)))
+
+(defmacro ^fill-parent-down ()
+ `(lb-maintain-pb (inset-lb .parent)))
+
+(defmacro ^prior-sib-pt (self &optional (spacing 0))
+ (let ((kid (gensym))
+ (psib (gensym)))
+ `(let* ((,kid ,self)
+ (,psib (find-prior ,kid (kids (fm-parent ,kid)))))
+ ;(trc "^priorSib-pb > kid, sib" ,kid ,pSib)
+ (if ,psib
+ (+ (- (abs ,spacing)) (pt ,psib))
+ 0))))
+
+
+
Added: dependencies/trunk/cells/gui-geometry/geometer.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/geometer.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,241 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: gui-geometry; -*-
+#|
+
+Copyright (C) 2004 by Kenneth William Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package #:gui-geometry)
+
+(eval-now!
+ (export '(outset ^outset mkv2 g-offset g-offset-h g-offset-v collapsed ^collapsed inset ^inset)))
+
+(defmd geometer ()
+ px py ll lt lr lb
+ collapsed
+ (inset (mkv2 0 0) :unchanged-if 'v2=)
+ (outset 0)
+ (w-box (mkr 0 0 0 0) :cell nil :accessor w-box
+ :documentation "bbox in window coordinate system"))
+
+(defmethod collapsed (other)
+ (declare (ignore other))
+ nil)
+
+;;-------- Zero-zero Top Left ----------------------------
+;;
+(defmodel geo-zero-tl (family)
+ ()
+ (:default-initargs
+ :ll (c? (- (outset self)))
+ :lt (c? (+ (outset self)))
+ :lr (c? (geo-kid-wrap self 'pr))
+ :lb (c? (geo-kid-wrap self 'pb))
+ :kid-slots (def-kid-slots
+ (mk-kid-slot (px :if-missing t)
+ (c? (px-maintain-pl 0)))
+ (mk-kid-slot (py :if-missing t)
+ (c? (py-maintain-pt 0))))))
+
+(export! geo-kid-sized)
+(defmodel geo-kid-sized (family)
+ ()
+ (:default-initargs
+ :ll (c? (geo-kid-wrap self 'pl))
+ :lt (c? (geo-kid-wrap self 'pt))
+ :lr (c? (geo-kid-wrap self 'pr))
+ :lb (c? (geo-kid-wrap self 'pb))))
+
+(defun l-box (geo)
+ (count-it :l-box)
+ (mkr (ll geo) (lt geo) (lr geo) (lb geo)))
+
+;---------- gOffset -------------------
+
+(export! offset-within inset-lb)
+;
+(defun offset-within (inner outer &optional dbg)
+ (declare (ignorable dbg))
+ (trc nil "offset-within inner outer" inner outer)
+ (do (
+ (offset-h 0 (progn
+ (trc nil "offset-within delta-h, from" from (px from))
+ (incf offset-h (px from))))
+ (offset-v 0 (incf offset-v (py from)))
+ (from inner (fm-parent from)))
+ ((or (null from)
+ (null outer)
+ (eql from outer)) (eko (nil "offset-within returns")
+ (mkv2 offset-h offset-v)))))
+
+(defun offset-within2 (inner outer)
+ (do (
+ (offset-h 0 (incf offset-h (px from)))
+ (offset-v 0 (incf offset-v (py from)))
+ (from inner (fm-parent from)))
+ ((or (null from)
+ (null outer)
+ (eql from outer)) (mkv2 offset-h offset-v))
+ ;(trc "inner outer" inner outer)
+ ))
+
+
+
+;----------- OfKids -----------------------
+;
+
+(defun v2-in-subframe (super h v sub)
+ (if (eql super sub) ;; bingo
+ (values h v)
+ (dolist (kid (kids super))
+ (multiple-value-bind (subh sub-v)
+ (v2-in-subframe kid h v sub)
+ (when subh
+ (return-from v2-in-subframe (values (- subh (px kid))
+ (- sub-v (py kid)))))))))
+(defun mk-gr (geo)
+ (c-assert geo)
+ (count-it :mk-gr)
+ (let ((g-offset (g-offset geo))) ;; /// wastes a v2
+ (nr-offset (mkr (ll geo) (lt geo) (lr geo) (lb geo)) (v2-h g-offset) (v2-v g-offset))))
+
+;sum pXYs up the family tree ;gave an odd result for cursor display....
+
+(defun v2-xlate (outer inner outer-v2)
+ (if (eq outer inner)
+ outer-v2
+ (v2-xlate outer (fm-parent inner)
+ (v2-subtract outer-v2
+ (mkv2 (px inner) (py inner))))))
+
+(defun v2-xlate-out (inner outer inner-v2)
+ (if (eq outer inner)
+ inner-v2
+ (v2-xlate (fm-parent inner) outer
+ (v2-add inner-v2
+ (mkv2 (px inner) (py inner))))))
+
+(defun v2-xlate-between (from-v2 from to)
+ (cond
+ ((fm-includes from to)(v2-xlate from to from-v2))
+ ((fm-includes to from)(v2-xlate-out from to from-v2))
+ (t (break "time to extend v2-xlate-between"))))
+
+(export! h-xlate v-xlate v2-xlate-between)
+
+(defun h-xlate (outer inner outer-h)
+ (if (eql outer inner)
+ outer-h
+ (h-xlate outer (fm-parent inner)
+ (- outer-h (px inner)))))
+
+(defun v-xlate (outer inner outer-v)
+ (if (eql outer inner)
+ outer-v
+ (v-xlate outer (fm-parent inner)
+ (- outer-v (py inner)))))
+
+(defmethod g-offset (self &optional (accum-h 0) (accum-v 0) within)
+ (declare (ignorable self within))
+ (mkv2 accum-h accum-v))
+
+(defun g-offset-h (geo)
+ (v2-h (g-offset geo)))
+
+(defun g-offset-v (geo)
+ (v2-v (g-offset geo)))
+
+(defun g-box (geo)
+ (count-it :g-box)
+ (if (c-stopped)
+ (trc "gbox sees stop" geo)
+ (progn
+ (c-assert geo)
+ (let* ((g-offset (g-offset geo))
+ (oh (v2-h g-offset)))
+ (c-assert (typep g-offset 'v2))
+ (c-assert (numberp oh))
+ (c-assert (numberp (lr geo)))
+ (let ((r (nr-offset
+ (nr-make (w-box geo) (ll geo) (lt geo) (lr geo) (lb geo))
+ oh (v2-v g-offset))))
+ (c-assert (numberp (r-left r)))
+ (c-assert (numberp (r-top r)))
+ (c-assert (numberp (r-right r)))
+ (c-assert (numberp (r-bottom r)))
+ r)))))
+
+;____________________________________________
+
+(defun pl (self) (+ (px self) (ll self)))
+(defun pr (self)
+ (c-assert (px self))
+ (c-assert (lr self))
+ (+ (px self) (lr self)))
+(defun pt (self) (+ (py self) (lt self)))
+(defun pb (self)
+ (c-assert (lb self))
+ (c-assert (py self))
+ (+ (py self) (lb self)))
+
+(defun pxy (self)
+ (mkv2 (px self) (py self)))
+
+;--------------------------------------------------------
+
+
+(defun l-width (i)
+ (c-assert (lr i))
+ (c-assert (ll i))
+ (- (lr i) (ll i)))
+
+(defun l-height (i)
+ (abs (- (lb i) (lt i))))
+
+;;-----------------------------------------------
+
+(defun inset-width (self)
+ (- (l-width self) (outset self) (outset self)))
+
+(defun inset-lr (self)
+ (- (lr self) (outset self)))
+
+(defun inset-lb (self)
+ (+ (lb self) (outset self)))
+
+(defun inset-lt (self)
+ (downs (lt self) (outset self)))
+
+(defun inset-height (self)
+ (- (l-height self) (outset self) (outset self)))
+
+;---------------------------------
+
+;----------------------------------
+
+(export! geo-kid-wrap inset-lt)
+
+(defun geo-kid-wrap (self bound)
+ (funcall (ecase bound ((pl pb) '-)((pr pt) '+))
+ (funcall (ecase bound
+ ((pl pb) 'fm-min-kid)
+ ((pr pt) 'fm-max-kid)) self bound)
+ (outset self)))
+
+; in use; same idea for pT
+(defun py-self-centered (self justify)
+ (py-maintain-pt
+ (ecase justify
+ (:top 0)
+ (:center (floor (- (inset-height .parent) (l-height self)) -2))
+ (:bottom (downs (- (inset-height .parent) (l-height self)))))))
+
Added: dependencies/trunk/cells/gui-geometry/gui-geometry.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/gui-geometry.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,15 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+
+(asdf:defsystem :gui-geometry
+ :author "Kenny Tilton "
+ :maintainer "Kenny Tilton "
+ :licence "Lisp LGPL"
+ :depends-on (:cells)
+ :serial t
+ :components
+ ((:file "defpackage")
+ (:file "geo-macros")
+ (:file "geo-data-structures")
+ (:file "coordinate-xform")
+ (:file "geometer")
+ (:file "geo-family")))
Added: dependencies/trunk/cells/gui-geometry/gui-geometry.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/gui-geometry/gui-geometry.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,88 @@
+;; -*- lisp-version: "8.0 [Windows] (Jan 29, 2007 18:02)"; cg: "1.81"; -*-
+
+(in-package :cg-user)
+
+(defpackage :COMMON-GRAPHICS-USER)
+
+(define-project :name :gui-geometry
+ :modules (list (make-instance 'module :name "defpackage.lisp")
+ (make-instance 'module :name "geo-macros.lisp")
+ (make-instance 'module :name
+ "geo-data-structures.lisp")
+ (make-instance 'module :name "coordinate-xform.lisp")
+ (make-instance 'module :name "geometer.lisp")
+ (make-instance 'module :name "geo-family.lisp"))
+ :projects (list (make-instance 'project-module :name
+ "..\\..\\Cells\\cells"))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :common-graphics-user
+ :main-form nil
+ :compilation-unit t
+ :verbose nil
+ :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane
+ :cg.bitmap-pane.clipboard :cg.bitmap-stream
+ :cg.button :cg.caret :cg.check-box :cg.choice-list
+ :cg.choose-printer :cg.clipboard
+ :cg.clipboard-stack :cg.clipboard.pixmap
+ :cg.color-dialog :cg.combo-box :cg.common-control
+ :cg.comtab :cg.cursor-pixmap :cg.curve
+ :cg.dialog-item :cg.directory-dialog
+ :cg.directory-dialog-os :cg.drag-and-drop
+ :cg.drag-and-drop-image :cg.drawable
+ :cg.drawable.clipboard :cg.dropping-outline
+ :cg.edit-in-place :cg.editable-text
+ :cg.file-dialog :cg.fill-texture
+ :cg.find-string-dialog :cg.font-dialog
+ :cg.gesture-emulation :cg.get-pixmap
+ :cg.get-position :cg.graphics-context
+ :cg.grid-widget :cg.grid-widget.drag-and-drop
+ :cg.group-box :cg.header-control :cg.hotspot
+ :cg.html-dialog :cg.html-widget :cg.icon
+ :cg.icon-pixmap :cg.ie :cg.item-list
+ :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu
+ :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget
+ :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip
+ :cg.message-dialog :cg.multi-line-editable-text
+ :cg.multi-line-lisp-text :cg.multi-picture-button
+ :cg.multi-picture-button.drag-and-drop
+ :cg.multi-picture-button.tooltip :cg.ocx
+ :cg.os-widget :cg.os-window :cg.outline
+ :cg.outline.drag-and-drop
+ :cg.outline.edit-in-place :cg.palette
+ :cg.paren-matching :cg.picture-widget
+ :cg.picture-widget.palette :cg.pixmap
+ :cg.pixmap-widget :cg.pixmap.file-io
+ :cg.pixmap.printing :cg.pixmap.rotate :cg.printing
+ :cg.progress-indicator :cg.project-window
+ :cg.property :cg.radio-button :cg.rich-edit
+ :cg.rich-edit-pane :cg.rich-edit-pane.clipboard
+ :cg.rich-edit-pane.printing :cg.sample-file-menu
+ :cg.scaling-stream :cg.scroll-bar
+ :cg.scroll-bar-mixin :cg.selected-object
+ :cg.shortcut-menu :cg.static-text :cg.status-bar
+ :cg.string-dialog :cg.tab-control
+ :cg.template-string :cg.text-edit-pane
+ :cg.text-edit-pane.file-io :cg.text-edit-pane.mark
+ :cg.text-or-combo :cg.text-widget :cg.timer
+ :cg.toggling-widget :cg.toolbar :cg.tooltip
+ :cg.trackbar :cg.tray :cg.up-down-control
+ :cg.utility-dialog :cg.web-browser
+ :cg.web-browser.dde :cg.wrap-string
+ :cg.yes-no-list :cg.yes-no-string :dde)
+ :splash-file-module (make-instance 'build-module :name "")
+ :icon-file-module (make-instance 'build-module :name "")
+ :include-flags '(:top-level :debugger)
+ :build-flags '(:allow-runtime-debug :purify)
+ :autoload-warning t
+ :full-recompile-for-runtime-conditionalizations nil
+ :default-command-line-arguments "+M +t \"Console for Debugging\""
+ :additional-build-lisp-image-arguments '(:read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :on-initialization 'default-init-function
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/initialize.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/initialize.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,63 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(eval-when (compile eval load)
+ (export '(c-envalue)))
+
+(defstruct (c-envaluer (:conc-name nil))
+ envalue-rule)
+
+(defmethod awaken-cell (c)
+ (declare (ignorable c)))
+
+(defmethod awaken-cell ((c cell))
+ (assert (c-inputp c))
+ ;
+ ; nothing to calculate, but every cellular slot should be output
+ ;
+ (trc nil "awaken cell observing" c)
+ (when (> *data-pulse-id* (c-pulse-observed c))
+ (setf (c-pulse-observed c) *data-pulse-id*)
+ (slot-value-observe (c-slot-name c) (c-model c) (c-value c) nil nil c)
+ (ephemeral-reset c)))
+
+(defmethod awaken-cell ((c c-ruled))
+ (let (*depender*)
+ (calculate-and-set c :fn-awaken-cell nil)))
+
+#+cormanlisp ; satisfy CormanCL bug
+(defmethod awaken-cell ((c c-dependent))
+ (let (*depender*)
+ (trc nil "awaken-cell c-dependent clearing *depender*" c)
+ (calculate-and-set c :fn-awaken-cell nil)))
+
+(defmethod awaken-cell ((c c-drifter))
+ ;
+ ; drifters *begin* valid, so the derived version's test for unbounditude
+ ; would keep (drift) rule ever from being evaluated. correct solution
+ ; (for another day) is to separate awakening (ie, linking to independent
+ ; cs) from evaluation, tho also evaluating if necessary during
+ ; awakening, because awakening's other role is to get an instance up to speed
+ ; at once upon instantiation
+ ;
+ (calculate-and-set c :fn-awaken-cell nil)
+ (cond ((c-validp c) (c-value c))
+ ((c-unboundp c) nil)
+ (t "illegal state!!!")))
Added: dependencies/trunk/cells/integrity.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/integrity.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,234 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(define-constant *ufb-opcodes* '(:tell-dependents
+ :awaken
+ :client
+ :ephemeral-reset
+ :change))
+
+(defmacro with-integrity ((&optional opcode defer-info debug) &rest body)
+ (declare (ignorable debug))
+ (when opcode
+ (assert (find opcode *ufb-opcodes*) ()
+ "Invalid opcode for with-integrity: ~a. Allowed values: ~a" opcode *ufb-opcodes*))
+ `(call-with-integrity ,opcode ,defer-info
+ (lambda (opcode defer-info)
+ (declare (ignorable opcode defer-info))
+ ;;; ,(when debug
+ ;;; `(trc "integrity action entry" opcode defer-info ',body))
+ ;;; (when *c-debug*
+ ;;; (when (eq opcode :change)
+ ;;; (trc "-------w/integ :change go--------------->:" defer-info)))
+ , at body)
+ nil
+ #+noway (when *c-debug* ',body)))
+
+(export! with-cc)
+
+(defmacro with-cc (id &body body)
+ `(with-integrity (:change ,id)
+ , at body))
+
+(defun integrity-managed-p ()
+ *within-integrity*)
+
+(defun call-with-integrity (opcode defer-info action code)
+ (declare (ignorable code))
+ (when *stop*
+ (return-from call-with-integrity))
+ (if *within-integrity*
+ (if opcode
+ (prog1
+ :deferred-to-ufb-1 ; SETF is supposed to return the value being installed
+ ; in the place, but if the SETF is deferred we return
+ ; something that will help someone who tries to use
+ ; the setf'ed value figure out what is going on:
+ (ufb-add opcode (cons defer-info action)))
+
+ ; thus by not supplying an opcode one can get something
+ ; executed immediately, potentially breaking data integrity
+ ; but signifying by having coded the with-integrity macro
+ ; that one is aware of this. If you read this comment.
+ (funcall action opcode defer-info))
+
+ (flet ((go-go ()
+ (let ((*within-integrity* t)
+ *unfinished-business*
+ *defer-changes*)
+ (trc nil "initiating new UFB!!!!!!!!!!!!" opcode defer-info)
+ ;(when *c-debug* (assert (boundp '*istack*)))
+ (when (or (zerop *data-pulse-id*)
+ (eq opcode :change))
+ (eko (nil "!!! New pulse, event" *data-pulse-id* defer-info)
+ (data-pulse-next (cons opcode defer-info))))
+ (prog1
+ (funcall action opcode defer-info)
+ (setf *finbiz-id* 0)
+ (finish-business)))))
+ (if nil ;; *c-debug*
+ (let ((*istack* (list (list opcode defer-info)
+ (list :trigger code)
+ (list :start-dp *data-pulse-id*))))
+ (trc "*istack* bound")
+ (handler-case
+ (go-go)
+ (xcell (c)
+ (if (functionp *c-debug*)
+ (funcall *c-debug* c (nreverse *istack*))
+ (loop for f in (nreverse *istack*)
+ do (format t "~&istk> ~(~a~) " f)
+ finally (describe c)
+ (break "integ backtrace: see listener for deets")))))
+ (trc "*istack* unbinding"))
+ (go-go)))))
+
+(defun ufb-queue (opcode)
+ (cdr (assoc opcode *unfinished-business*)))
+
+(defun ufb-queue-ensure (opcode)
+ (or (ufb-queue opcode)
+ (cdr (car (push (cons opcode (make-fifo-queue)) *unfinished-business*)))))
+
+(defparameter *no-tell* nil)
+
+(defun ufb-add (opcode continuation)
+ #+trythis (when (and *no-tell* (eq opcode :tell-dependents))
+ (break "truly queueing tell under no-tell"))
+ (trc nil "ufb-add deferring" opcode (when (eql opcode :client)(car continuation)))
+ (fifo-add (ufb-queue-ensure opcode) continuation))
+
+(defun just-do-it (op-or-q &optional (op-code op-or-q) ;; [mb]
+ &aux (q (if (keywordp op-or-q)
+ (ufb-queue op-or-q)
+ op-or-q)))
+ (declare (ignorable op-code))
+ (trc nil "----------------------------just do it doing---------------------" op-or-q)
+ (loop for (defer-info . task) = (fifo-pop q)
+ while task
+ do (trc nil "unfin task is" opcode task)
+ #+chill (when *c-debug*
+ (push (list op-code defer-info) *istack*))
+ (funcall task op-or-q defer-info)))
+
+(defun finish-business ()
+ (when *stop* (return-from finish-business))
+ (incf *finbiz-id*)
+ (tagbody
+ tell-dependents
+ (just-do-it :tell-dependents)
+ ;
+ ; while the next step looks separate from the prior, they are closely bound.
+ ; during :tell-dependents, any number of new model instances can be spawned.
+ ; as they are spawned, shared-initialize queues them for awakening, which
+ ; you will recall forces the calculation of ruled cells and observer notification
+ ; for all cell slots. These latter may enqueue :change or :client tasks, in which
+ ; case note that they become appended to :change or :client tasks enqueued
+ ; during :tell-dependents. How come? Because the birth itself of model instances during
+ ; a datapulse is considered part of that datapulse, so we do want tasks enqueued
+ ; during their awakening to be handled along with those enqueued by cells of
+ ; existing model instances.
+ ;
+ #-its-alive!
+ (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
+ (trcx fin-business uqp)
+ (dolist (b (fifo-data (ufb-queue :tell-dependents)))
+ (trc "unhandled :tell-dependents" (car b) (c-callers (car b))))
+ (break "unexpected 1> ufb needs to tell dependnents after telling dependents"))
+ (let ((*no-tell* t))
+ (just-do-it :awaken) ;--- md-awaken new instances ---
+ )
+ ;
+ ; OLD THINKING, preserved for the record, but NO LONGER TRUE:
+ ; we do not go back to check for a need to :tell-dependents because (a) the original propagation
+ ; and processing of the :tell-dependents queue is a full propagation; no rule can ask for a cell that
+ ; then decides it needs to recompute and possibly propagate; and (b) the only rules forced awake during
+ ; awakening need that precisely because no one asked for their values, so there can be no dependents
+ ; to "tell". I think. :) So...
+ ; END OF OLD THINKING
+ ;
+ ; We now allow :awaken to change things so more dependents need to be told. The problem is the implicit
+ ; dependence on the /life/ of a model whenever there is a dependence on any /cell/ of that model.
+ ; md-quiesce currently just flags such slots as uncurrent -- maybe /that/ should change and those should
+ ; recalculate at once -- and then an /observer/ can run and ask for a new value from such an uncurrent cell,
+ ; which now knows it must recalculate. And that recalculation of course can and likely will come up with a new value
+ ; and perforce need to tell its dependents. So...
+ ;
+ ; I /could/ explore something other than the "uncurrent" kludge, but NCTM 2007 is coming up and
+ ; to be honest the idea of not allowing nested tells was enforcing a /guess/ that that should not
+ ; arise, and there was not even any perceived integrity whole being closed, it was just a gratuitous
+ ; QA trick, and indeed for a long time many nested tells were avoidable. But the case of the quiesced
+ ; dependent reverses the arrow and puts the burden on the prosecution to prove nested tells are a problem.
+
+ (bwhen (uqp (fifo-peek (ufb-queue :tell-dependents)))
+ #+xxx (trc "retelling dependenst, one new one being" uqp)
+ (go tell-dependents))
+
+ ;--- process client queue ------------------------------
+ ;
+ (when *stop* (return-from finish-business))
+
+ handle-clients
+ (bwhen (clientq (ufb-queue :client))
+ (if *client-queue-handler*
+ (funcall *client-queue-handler* clientq) ;; might be empty/not exist, so handlers must check
+ (just-do-it clientq :client))
+ (when (fifo-peek (ufb-queue :client))
+ #+shhh (ukt::fifo-browse (ufb-queue :client) (lambda (entry)
+ (trc "surprise client" entry)))
+ (go handle-clients)))
+ ;--- now we can reset ephemerals --------------------
+ ;
+ ; one might be wondering when the observers got notified. That happens right during
+ ; slot.value.assume, via c-propagate.
+ ;
+ ; Nice historical note: by accident, in the deep-cells test to exercise the new behavior
+ ; of cells3, I coded an ephemeral cell and initialized it to non-nil, hitting a runtime
+ ; error (now gone) saying I had no idea what a non-nil ephemeral would mean. That had been
+ ; my conclusion when the idea occurred to me the first time, so I stuck in an assertion
+ ; to warn off callers.
+ ;
+ ; But the new
+ ; datachange progression defined by Cells3 had already forced me to manage ephemeral resets
+ ; more predictably (something in the test suite failed). By the time I got the runtime
+ ; error on deep-cells I was able to confidently take out the error and just let the thing
+ ; run. deep-cells looks to behave just right, but maybe a tougher test will present a problem?
+ ;
+ (just-do-it :ephemeral-reset)
+
+ ;--- do deferred state changes -----------------------
+ ;
+ (bwhen (task-info (fifo-pop (ufb-queue :change)))
+ (trc nil "!!! finbiz --- CHANGE ---- (first of)" (fifo-length (ufb-queue :change)))
+ (destructuring-bind (defer-info . task-fn) task-info
+ #+xxx (trc "fbz: dfrd chg" defer-info (fifo-length (ufb-queue :change)))
+ (data-pulse-next (list :finbiz defer-info))
+ (funcall task-fn :change defer-info)
+ ;
+ ; to finish this state change we could recursively call (finish-business), but
+ ; a goto let's us not use the stack. Someday I envision code that keeps on
+ ; setf-ing, polling the OS for events, in which case we cannot very well use
+ ; recursion. But as a debugger someone might want to change the next form
+ ; to (finish-business) if they are having trouble with a chain of setf's and
+ ; want to inspect the history on the stack.
+ ;
+ (go tell-dependents)))))
+
+
Added: dependencies/trunk/cells/link.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/link.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,152 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(defun record-caller (used)
+ (when (c-optimized-away-p used) ;; 2005-05-21 removed slow type check that used is cell
+ (trc nil "depender not being recorded because used optimized away" *depender* (c-value used) :used used)
+ (return-from record-caller nil))
+ #+shhh (trc *depender* "record-caller depender entry: used=" used :caller *depender*)
+ (assert *depender*)
+ #+shhh (trc used "record-caller caller entry: used=" (qci used)
+ :caller *depender*)
+
+ (multiple-value-bind (used-pos useds-len)
+ (loop with u-pos
+ for known in (cd-useds *depender*)
+ counting known into length
+ when (eq used known)
+ do
+ (count-it :known-used)
+ (setf u-pos length)
+ finally (return (values (when u-pos (- length u-pos)) length)))
+
+ (when (null used-pos)
+ (trc nil "c-link > new caller,used " *depender* used)
+ (count-it :new-used)
+ (setf used-pos useds-len)
+ (push used (cd-useds *depender*))
+ (caller-ensure used *depender*) ;; 060604 experiment was in unlink
+ )
+ (let ((cd-usage (cd-usage *depender*)))
+ (when (>= used-pos (array-dimension cd-usage 0))
+ (setf cd-usage
+ (setf (cd-usage *depender*)
+ (adjust-array (cd-usage *depender*)
+ (+ used-pos 16)
+ :initial-element 0))))
+ (setf (sbit cd-usage used-pos) 1))
+ #+nonportable
+ (handler-case
+ (setf (sbit (cd-usage *depender*) used-pos) 1)
+ (type-error (error)
+ (declare (ignorable error))
+ (setf (cd-usage *depender*)
+ (adjust-array (cd-usage *depender*) (+ used-pos 16) :initial-element 0))
+ (setf (sbit (cd-usage *depender*) used-pos) 1))))
+ used)
+
+
+;--- unlink unused --------------------------------
+
+(defun c-unlink-unused (c &aux (usage (cd-usage c))
+ (usage-size (array-dimension (cd-usage c) 0))
+ (dbg nil))
+ (declare (ignorable dbg usage-size))
+ (when (cd-useds c)
+ (let (rev-pos)
+ (labels ((nail-unused (useds)
+ (flet ((handle-used (rpos)
+ (if (or (>= rpos usage-size)
+ (zerop (sbit usage rpos)))
+ (progn
+ (count-it :unlink-unused)
+ (trc nil "c-unlink-unused" c :dropping-used (car useds))
+ (c-unlink-caller (car useds) c)
+ (rplaca useds nil))
+ (progn
+ ;; moved into record-caller 060604 (caller-ensure (car useds) c)
+ )
+ )))
+ (if (cdr useds)
+ (progn
+ (nail-unused (cdr useds))
+ (handle-used (incf rev-pos)))
+ (handle-used (setf rev-pos 0))))))
+ (trc nil "cd-useds length" (length (cd-useds c)) c)
+ (nail-unused (cd-useds c))
+ (setf (cd-useds c) (delete nil (cd-useds c)))
+ (trc nil "useds of" c :now (mapcar 'qci (cd-useds c)))))))
+
+(defun c-caller-path-exists-p (from-used to-caller)
+ (count-it :caller-path-exists-p)
+ (or (find to-caller (c-callers from-used))
+ (find-if (lambda (from-used-caller)
+ (c-caller-path-exists-p from-used-caller to-caller))
+ (c-callers from-used))))
+
+; ---------------------------------------------
+
+(defun cd-usage-clear-all (c)
+ (setf (cd-usage c) (blank-usage-mask))
+ #+wowo (loop with mask = (cd-usage c)
+ for n fixnum below (array-dimension mask 0)
+ do (setf (sbit mask n) 0)
+ finally (return mask))
+ )
+
+
+;--- unlink from used ----------------------
+
+(defmethod c-unlink-from-used ((caller c-dependent))
+ (dolist (used (cd-useds caller))
+ (trc nil "unlinking from used" caller used)
+ (c-unlink-caller used caller))
+ ;; shouldn't be necessary (setf (cd-useds caller) nil)
+ )
+
+(defmethod c-unlink-from-used (other)
+ (declare (ignore other)))
+
+;----------------------------------------------------------
+
+(defun c-unlink-caller (used caller)
+ (trc nil "(1) caller unlinking from (2) used" caller used)
+ (caller-drop used caller)
+ (c-unlink-used caller used))
+
+(defun c-unlink-used (caller used)
+ (setf (cd-useds caller) (remove used (cd-useds caller))))
+
+;----------------- link debugging ---------------------
+
+(defun dump-callers (c &optional (depth 0))
+ (format t "~&~v,4t~s" depth c)
+ (dolist (caller (c-callers c))
+ (dump-callers caller (+ 1 depth))))
+
+(defun dump-useds (c &optional (depth 0))
+ ;(c.trc "dump-useds> entry " c (+ 1 depth))
+ (when (zerop depth)
+ (format t "x~&"))
+ (format t "~&|usd> ~v,8t~s" depth c)
+ (when (typep c 'c-ruled)
+ ;(c.trc "its ruled" c)
+ (dolist (used (cd-useds c))
+ (dump-useds used (+ 1 depth)))))
Added: dependencies/trunk/cells/load.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/load.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,7 @@
+(require 'asdf)
+(push "/home/alessio/libs/lisp/cells/" asdf:*central-registry*)
+(push "/home/alessio/libs/lisp/cells/utils-kt/" asdf:*central-registry*)
+(asdf:oos 'asdf:load-op :cells)
+
+(push "/home/alessio/libs/lisp/cells/cells-test/" asdf:*central-registry*)
+(asdf:oos 'asdf:load-op :cells-test)
Added: dependencies/trunk/cells/md-slot-value.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/md-slot-value.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,407 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(defparameter *ide-app-hard-to-kill* t)
+
+(defun md-slot-value (self slot-name &aux (c (md-slot-cell self slot-name)))
+ (when (and (not *not-to-be*) (mdead self))
+ ;#-its-alive!
+ (unless *stop*
+ (trc nil "md-slot-value passed dead self:" self :asked4slot slot-name :cell c)
+ ;#-sbcl (inspect self)
+ ;(setf *stop* t)
+ ;(break "md-slot-value sees dead ~a" self)
+ )
+ (return-from md-slot-value (slot-value self slot-name))) ;; we can dream
+ (tagbody
+ retry
+ (when *stop*
+ (if *ide-app-hard-to-kill*
+ (progn
+ (princ #\.)
+ (princ "stopped")
+ (return-from md-slot-value))
+ (restart-case
+ (error "Cells is stopped due to a prior error.")
+ (continue ()
+ :report "Return a slot value of nil."
+ (return-from md-slot-value nil))
+ (reset-cells ()
+ :report "Reset cells and retry getting the slot value."
+ (cells-reset)
+ (go retry))))))
+
+ ;; (count-it :md-slot-value slot-name)
+ (if c
+ (cell-read c)
+ (values (slot-value self slot-name) nil)))
+
+(defun cell-read (c)
+ (assert (typep c 'cell))
+ (prog1
+ (with-integrity ()
+ (ensure-value-is-current c :c-read nil))
+ (when *depender*
+ (record-caller c))))
+
+(defun chk (s &optional (key 'anon))
+ (when (mdead s)
+ (break "model ~a is dead at ~a" s key)))
+
+(defvar *trc-ensure* nil)
+
+(defun qci (c)
+ (when c
+ (cons (md-name (c-model c)) (c-slot-name c))))
+
+
+(defun ensure-value-is-current (c debug-id ensurer)
+ ;
+ ; ensurer can be used cell propagating to callers, or an existing caller who wants to make sure
+ ; dependencies are up-to-date before deciding if it itself is up-to-date
+ ;
+ (declare (ignorable debug-id ensurer))
+ ;(count-it! :ensure.value-is-current)
+ ;(trc "evic entry" (qci c))
+ (wtrcx (:on? nil) ("evic>" (qci c) debug-id (qci ensurer))
+ ;(count-it! :ensure.value-is-current )
+ #+chill
+ (when ensurer ; (trcp c)
+ (count-it! :ensure.value-is-current (c-slot-name c) (md-name (c-model c))(c-slot-name ensurer) (md-name (c-model ensurer))))
+ #+chill
+ (when (and *c-debug* (trcp c)
+ (> *data-pulse-id* 650))
+ (bgo ens-high))
+
+ (trc nil ; c ;; (and *c-debug* (> *data-pulse-id* 495)(trcp c))
+ "ensure.value-is-current > entry1" debug-id (qci c) :st (c-state c) :vst (c-value-state c)
+ :my/the-pulse (c-pulse c) *data-pulse-id*
+ :current (c-currentp c) :valid (c-validp c))
+
+ #+nahhh
+ (when ensurer
+ (trc (and *c-debug* (> *data-pulse-id* 495)(trcp c))
+ "ensure.value-is-current > entry2"
+ :ensurer (qci ensurer)))
+
+ (when *not-to-be*
+ (when (c-unboundp c)
+ (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c)))
+ (return-from ensure-value-is-current
+ (when (c-validp c) ;; probably accomplishes nothing
+ (c-value c))))
+
+ (when (and (not (symbolp (c-model c))) ;; damn, just here because of playing around with global vars and cells
+ (eq :eternal-rest (md-state (c-model c))))
+ (break "model ~a of cell ~a is dead" (c-model c) c))
+
+ (cond
+ ((c-currentp c)
+ (count-it! :ensvc-is-indeed-currentp)
+ (trc nil "EVIC yep: c-currentp" c)
+ ) ;; used to follow c-inputp, but I am toying with letting ephemerals (inputs) fall obsolete
+ ;; and then get reset here (ie, ((c-input-p c) (ephemeral-reset c))). ie, do not assume inputs are never obsolete
+ ;;
+ ((and (c-inputp c)
+ (c-validp c) ;; a c?n (ruled-then-input) cell will not be valid at first
+ (not (and (typep c 'c-dependent)
+ (eq (cd-optimize c) :when-value-t)
+ (null (c-value c)))))
+ (trc nil "evic: cool: inputp" (qci c)))
+
+ ((or (bwhen (nv (not (c-validp c)))
+ (count-it! :ens-val-not-valid)
+ (trc nil "not c-validp, gonna run regardless!!!!!!" c)
+ nv)
+ ;;
+ ;; new for 2006-09-21: a cell ended up checking slots of a dead instance, which would have been
+ ;; refreshed when checked, but was going to be checked last because it was the first used, useds
+ ;; being simply pushed onto a list as they come up. We may need fancier handling of dead instance/cells
+ ;; still being encountered by consulting the prior useds list, but checking now in same order as
+ ;; accessed seems Deeply Correct (and fixed the immediate problem nicely, always a Good Sign).
+ ;;
+ (labels ((check-reversed (useds)
+ (when useds
+ (or (check-reversed (cdr useds))
+ (let ((used (car useds)))
+ (ensure-value-is-current used :nested c)
+ #+slow (trc nil "comparing pulses (ensurer, used, used-changed): " c debug-id used (c-pulse-last-changed used))
+ (when (> (c-pulse-last-changed used)(c-pulse c))
+ (count-it! :ens-val-someused-newer)
+ (trc nil "used changed and newer !!!!######!!!!!! used" (qci used) :oldpulse (c-pulse used)
+ :lastchg (c-pulse-last-changed used))
+ #+shhh (when (trcp c)
+ (describe used))
+ t))))))
+ (assert (typep c 'c-dependent))
+ (check-reversed (cd-useds c))))
+ (trc nil "kicking off calc-set of!!!!" (c-state c) (c-validp c) (qci c) :vstate (c-value-state c)
+ :stamped (c-pulse c) :current-pulse *data-pulse-id*)
+ (calculate-and-set c :evic ensurer)
+ (trc nil "kicked off calc-set of!!!!" (c-state c) (c-validp c) (qci c) :vstate (c-value-state c)
+ :stamped (c-pulse c) :current-pulse *data-pulse-id*))
+
+ ((mdead (c-value c))
+ (trc nil "ensure.value-is-current> trying recalc of ~a with current but dead value ~a" c (c-value c))
+ (let ((new-v (calculate-and-set c :evic-mdead ensurer)))
+ (trc nil "ensure.value-is-current> GOT new value ~a to replace dead!!" new-v)
+ new-v))
+
+ (t (trc nil "ensure.current decided current, updating pulse" (c-slot-name c) debug-id)
+ (c-pulse-update c :valid-uninfluenced)))
+
+ (when (c-unboundp c)
+ (error 'unbound-cell :cell c :instance (c-model c) :name (c-slot-name c)))
+
+ (bwhen (v (c-value c))
+ (if (mdead v)
+ (progn
+ #-its-alive!
+ (progn
+ (format t "~&on pulse ~a ensure.value still got and still not returning ~a dead value ~a" *data-pulse-id* c v)
+ (inspect v))
+ nil)
+ v))))
+
+
+(defun calculate-and-set (c dbgid dbgdata)
+ (declare (ignorable dbgid dbgdata)) ;; just there for inspection of the stack during debugging
+ (flet ((body ()
+ (when (c-stopped)
+ (princ #\.)
+ (return-from calculate-and-set))
+
+ #-its-alive!
+ (bwhen (x (find c *call-stack*)) ;; circularity
+ (unless nil ;; *stop*
+ (let ()
+ (inspect c)
+ (trc "calculating cell:" c (cr-code c))
+ (trc "appears-in-call-stack (newest first): " (length *call-stack*))
+ (loop for caller in (copy-list *call-stack*)
+ for n below (length *call-stack*)
+ do (trc "caller> " caller #+shhh (cr-code caller))
+ when (eq caller c) do (loop-finish))))
+ (setf *stop* t)
+ (c-break ;; break is problem when testing cells on some CLs
+ "cell ~a midst askers (see above)" c)
+ (error 'asker-midst-askers :cell c))
+
+ (multiple-value-bind (raw-value propagation-code)
+ (calculate-and-link c)
+
+ (when (and *c-debug* (typep raw-value 'cell))
+ (c-break "new value for cell ~s is itself a cell: ~s. probably nested (c? ... (c? ))"
+ c raw-value))
+
+ (unless (c-optimized-away-p c)
+ ; this check for optimized-away-p arose because a rule using without-c-dependency
+ ; can be re-entered unnoticed since that clears *call-stack*. If re-entered, a subsequent
+ ; re-exit will be of an optimized away cell, which we need not sv-assume on... a better
+ ; fix might be a less cutesy way of doing without-c-dependency, and I think anyway
+ ; it would be good to lose the re-entrance.
+ (md-slot-value-assume c raw-value propagation-code)))))
+ (if (trcp c) ;; *dbg*
+ (wtrc (0 100 "calcnset" c) (body))
+ (body))))
+
+(defun calculate-and-link (c)
+ (let ((*call-stack* (cons c *call-stack*))
+ (*depender* c)
+ (*defer-changes* t))
+ (assert (typep c 'c-ruled))
+ (trc nil "calculate-and-link" c)
+ (cd-usage-clear-all c)
+ (multiple-value-prog1
+ (funcall (cr-rule c) c)
+ (c-unlink-unused c))))
+
+
+;-------------------------------------------------------------
+
+(defun md-slot-makunbound (self slot-name
+ &aux (c (md-slot-cell self slot-name)))
+ (unless c
+ (c-break ":md-slot-makunbound > cellular slot ~a of ~a cannot be unbound unless initialized as inputp"
+ slot-name self))
+
+ (when (c-unboundp c)
+ (return-from md-slot-makunbound nil))
+
+ (when *within-integrity* ;; 2006-02 oops, bad name
+ (c-break "md-slot-makunbound of ~a must be deffered by wrapping code in with-integrity" c))
+
+ ;
+ ; Big change here for Cells III: before, only the propagation was deferred. Man that seems
+ ; wrong. So now the full makunbound processing gets deferred. Less controversially,
+ ; by contrast the without-c-dependency wrapped everything, and while that is harmless,
+ ; it is also unnecessary and could confuse people trying to follow the logic.
+ ;
+ (let ((causation *causation*))
+ (with-integrity (:change c)
+ (let ((*causation* causation))
+ ; --- cell & slot maintenance ---
+ (let ((prior-value (c-value c)))
+ (setf (c-value-state c) :unbound
+ (c-value c) nil
+ (c-state c) :awake)
+ (bd-slot-makunbound self slot-name)
+ ;
+ ; --- data flow propagation -----------
+ ;
+ (without-c-dependency
+ (c-propagate c prior-value t)))))))
+
+;;; --- setf md.slot.value --------------------------------------------------------
+;;;
+
+(defun (setf md-slot-value) (new-value self slot-name
+ &aux (c (md-slot-cell self slot-name)))
+ #+shhh (when *within-integrity*
+ (trc "mdsetf>" self (type-of self) slot-name :new new-value))
+ (when *c-debug*
+ (c-setting-debug self slot-name c new-value))
+
+ (unless c
+ (c-break "cellular slot ~a of ~a cannot be SETFed because it is not
+mediated by a Cell with :inputp t. To achieve this, the initial value ~s -- whether
+supplied as an :initform, :default-initarg, or at make-instance time via
+an :initarg -- should be wrapped in either macro C-IN or C-INPUT.
+In brief, initialize ~0@*~a to (c-in ~2@*~s) instead of plain ~:*~s"
+ slot-name self (slot-value self slot-name)))
+
+ (cond
+ ((find (c-lazy c) '(:once-asked :always t))
+ (md-slot-value-assume c new-value nil))
+
+ (*defer-changes*
+ (c-break "SETF of ~a must be deferred by wrapping code in WITH-INTEGRITY" c))
+
+ (t
+ (with-integrity (:change slot-name)
+ (md-slot-value-assume c new-value nil))))
+
+ ;; new-value
+ ;; above line commented out 2006-05-01. It seems to me we want the value assumed by the slot
+ ;; not the value setf'ed (on rare occasions they diverge, or at least used to for delta slots)
+ ;; anyway, if they no longer diverge the question of which to return is moot
+ )
+
+(defun md-slot-value-assume (c raw-value propagation-code)
+ (assert c)
+ (trc nil "md-slot-value-assume entry" (qci c)(c-state c))
+ (without-c-dependency
+ (let ((prior-state (c-value-state c))
+ (prior-value (c-value c))
+ (absorbed-value (c-absorb-value c raw-value)))
+
+ (c-pulse-update c :slotv-assume)
+
+ ; --- head off unchanged; this got moved earlier on 2006-06-10 ---
+ (when (and (not (eq propagation-code :propagate))
+ (find prior-state '(:valid :uncurrent))
+ (c-no-news c absorbed-value prior-value))
+ (setf (c-value-state c) :valid) ;; new for 2008-07-15
+ (trc nil "(setf md-slot-value) > early no news" propagation-code prior-state prior-value absorbed-value)
+ (count-it :nonews)
+ (return-from md-slot-value-assume absorbed-value))
+
+ ; --- slot maintenance ---
+
+ (unless (c-synaptic c)
+ (md-slot-value-store (c-model c) (c-slot-name c) absorbed-value))
+
+ ; --- cell maintenance ---
+ (setf
+ (c-value c) absorbed-value
+ (c-value-state c) :valid
+ (c-state c) :awake)
+
+ (case (and (typep c 'c-dependent)
+ (cd-optimize c))
+ ((t) (c-optimize-away?! c)) ;;; put optimize test here to avoid needless linking
+ (:when-value-t (when (c-value c)
+ (c-unlink-from-used c))))
+
+ ; --- data flow propagation -----------
+ (unless (eq propagation-code :no-propagate)
+ (trc nil "md-slot-value-assume flagging as changed: prior state, value:" prior-state prior-value )
+ (c-propagate c prior-value (cache-state-bound-p prior-state))) ;; until 06-02-13 was (not (eq prior-state :unbound))
+ (trc nil "exiting md-slot-val-assume" (c-state c) (c-value-state c))
+ absorbed-value)))
+
+(defun cache-bound-p (c)
+ (cache-state-bound-p (c-value-state c)))
+
+(defun cache-state-bound-p (value-state)
+ (or (eq value-state :valid)
+ (eq value-state :uncurrent)))
+
+;---------- optimizing away cells whose dependents all turn out to be constant ----------------
+;
+
+(defun flushed? (c)
+ (rassoc c (cells-flushed (c-model c))))
+
+(defun c-optimize-away?! (c)
+ #+shhh (trc nil "c-optimize-away?! entry" (c-state c) c)
+ (when (and (typep c 'c-dependent)
+ (null (cd-useds c))
+ (cd-optimize c)
+ (not (c-optimized-away-p c)) ;; c-streams (FNYI) may come this way repeatedly even if optimized away
+ (c-validp c) ;; /// when would this not be the case? and who cares?
+ (not (c-synaptic c)) ;; no slot to cache invariant result, so they have to stay around)
+ (not (c-inputp c)) ;; yes, dependent cells can be inputp
+ )
+ ;; (when (trcp c) (break "go optimizing ~a" c))
+
+ (when (trcp c)
+ (trc "optimizing away" c (c-state c) (rassoc c (cells (c-model c)))(rassoc c (cells-flushed (c-model c))))
+ )
+
+ (count-it :c-optimized)
+
+ (setf (c-state c) :optimized-away)
+
+ (let ((entry (rassoc c (cells (c-model c)))))
+ (unless entry
+ (describe c)
+ (bwhen (fe (rassoc c (cells-flushed (c-model c))))
+ (trc "got in flushed thoi!" fe)))
+ (c-assert entry)
+ ;(trc (eq (c-slot-name c) 'cgtk::id) "c-optimize-away?! moving cell to flushed list" c)
+ (setf (cells (c-model c)) (delete entry (cells (c-model c))))
+ #-its-alive! (push entry (cells-flushed (c-model c)))
+ )
+
+ (dolist (caller (c-callers c) )
+ ;
+ ; example: on window shutdown with a tool-tip displayed, the tool-tip generator got
+ ; kicked off and asked about the value of a dead instance. That returns nil, and
+ ; there was no other dependency, so the Cell then decided to optimize itself away.
+ ; of course, before that time it had a normal value on which other things depended,
+ ; so we ended up here. where there used to be a break.
+ ;
+ (setf (cd-useds caller) (delete c (cd-useds caller)))
+ ;;; (trc "nested opti" c caller)
+ (c-optimize-away?! caller) ;; rare but it happens when rule says (or .cache ...)
+ )))
+
+
Added: dependencies/trunk/cells/md-utilities.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/md-utilities.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,245 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(defun md-awake (self) (eql :awake (md-state self)))
+
+(defun fm-grandparent (md)
+ (fm-parent (fm-parent md)))
+
+
+(defmethod md-release (other)
+ (declare (ignorable other)))
+
+(export! mdead)
+;___________________ birth / death__________________________________
+
+(defgeneric mdead (self)
+ (:method ((self model-object))
+ (unless *not-to-be* ;; weird
+ (eq :eternal-rest (md-state self))))
+
+ (:method (self)
+ (declare (ignore self))
+ nil))
+
+
+
+(defgeneric not-to-be (self)
+ (:method (other)
+ (declare (ignore other)))
+ (:method ((self cons))
+ (not-to-be (car self))
+ (not-to-be (cdr self)))
+ (:method ((self array))
+ (loop for s across self
+ do (not-to-be s)))
+ (:method ((self hash-table))
+ (maphash (lambda (k v)
+ (declare (ignorable k))
+ (not-to-be v)) self))
+
+ (:method ((self model-object))
+ (setf (md-census-count self) -1)
+ (md-quiesce self))
+
+ (:method :before ((self model-object))
+ (loop for slot-name in (md-owning-slots self)
+ do (not-to-be (slot-value self slot-name))))
+
+ (:method :around ((self model-object))
+ (declare (ignorable self))
+ (let ((*not-to-be* t)
+ (dbg nil))
+
+ (flet ((gok ()
+ (if (eq (md-state self) :eternal-rest)
+ (trc nil "n2be already dead" self)
+ (progn
+ (call-next-method)
+ (setf (fm-parent self) nil
+ (md-state self) :eternal-rest)
+;;; (bif (a (assoc (type-of self) *awake-ct*))
+;;; (decf (cdr a))
+;;; (break "no awake for" (type-of self) *awake-ct*))
+;;; (setf *awake* (delete self *awake*))
+ (md-map-cells self nil
+ (lambda (c)
+ (c-assert (eq :quiesced (c-state c)) ()
+ "Cell ~a of dead model ~a not quiesced. Was not-to-be shadowed by
+ a primary method? Use :before instead." c self))) ;; fails if user obstructs not.to-be with primary method (use :before etc)
+
+ ))))
+ (if (not dbg)
+ (gok)
+ (wtrc (0 100 "not.to-be nailing" self (when (typep self 'family)
+ (mapcar 'type-of (slot-value self '.kids))))
+ (gok)
+ (when dbg (trc "finished nailing" self))))))))
+
+
+
+(defun md-quiesce (self)
+ (trc nil "md-quiesce nailing cells" self (type-of self))
+ (md-map-cells self nil (lambda (c)
+ (trc nil "quiescing" c)
+ (c-assert (not (find c *call-stack*)))
+ (c-quiesce c)))
+ (when (register? self)
+ (fm-check-out self)))
+
+(defun c-quiesce (c)
+ (typecase c
+ (cell
+ (trc nil "c-quiesce unlinking" c)
+ (c-unlink-from-used c)
+ (dolist (caller (c-callers c))
+ (setf (c-value-state caller) :uncurrent)
+ (trc nil "c-quiesce totlalaly unlinking caller and making uncurrent" .dpid :q c :caller caller)
+ (c-unlink-caller c caller))
+ (setf (c-state c) :quiesced) ;; 20061024 for debugging for now, might break some code tho
+ )))
+
+(defparameter *to-be-dbg* nil)
+
+(defmacro make-kid (class &rest initargs)
+ `(make-instance ,class
+ , at initargs
+ :fm-parent (progn (assert self) self)))
+
+(defvar *c-d-d*)
+(defvar *max-d-d*)
+
+(defparameter *model-pop* nil)
+
+(export! md-census-start md-census-report md-census-count)
+
+(defun md-census-start ()
+ (setf *model-pop* (make-hash-table :test 'eq)))
+
+(defun (setf md-census-count) (delta self)
+ (when *model-pop*
+ (incf (gethash (type-of self) *model-pop* 0) delta)))
+
+(defun md-census-report ()
+ (when *model-pop*
+ (loop for (ct . type)
+ in (sort (let (raw)
+ (maphash (lambda (k v)
+ (push (cons v k) raw))
+ *model-pop*)
+ raw) '< :key 'car)
+ unless (zerop ct)
+ do (trc "pop" ct type))))
+
+#+test
+(md-census-report)
+
+#+test
+(md-census-count)
+
+(defun md-census-count (&optional type)
+ (when *model-pop*
+ (if type
+ (gethash type *model-pop* 0)
+ (loop for v being the hash-values of *model-pop*
+ summing v))))
+
+
+(defun count-model (self &key count-cells &aux (ccc 0))
+
+ (setf *c-d-d* (make-hash-table :test 'eq) *max-d-d* 0)
+ (let ((*counted* (make-hash-table :test 'eq :size 5000)))
+ (with-metrics (t nil "cells statistics for" self)
+ (labels ((cc (self from)
+ (unless (gethash self *counted*)
+ (setf (gethash self *counted*) t)
+ (typecase self
+ (cons (cc (car self) from)
+ (cc (cdr self) from))
+ #+nahhhh (mathx::box (count-it! :mathx-box-struct)
+ (cc (mathx::bx-mx self) from))
+ (model
+ (when (zerop (mod (incf ccc) 100))
+ (trc "cc" (md-name self) (type-of self)))
+ (count-it! :thing)
+ (count-it! :thing (type-of self))
+ #+nahhhh (when (typep self 'mathx::problem)
+ (count-it! :thing-from (type-of self) (type-of from)))
+ (when count-cells
+ (loop for (nil . c) in (cells self)
+ do (count-it! :live-cell)
+ ;(count-it! :live-cell id)
+ (when (c-lazy c)
+ (count-it! :lazy)
+ (count-it! :lazy (c-value-state c)))
+ (typecase c
+ (c-dependent
+ (count-it! :dependent-cell)
+ #+chill (loop repeat (length (c-useds c))
+ do (count-it! :cell-useds)
+ (count-it! :dep-depth (c-depend-depth c))))
+ (otherwise (if (c-inputp c)
+ (progn
+ (count-it! :c-input-altogether)
+ ;(count-it! :c-input id)
+ )
+ (count-it! :c-unknown))))
+
+ (loop repeat (length (c-callers c))
+ do (count-it! :cell-callers)))
+
+ (loop repeat (length (cells-flushed self))
+ do (count-it! :flushed-cell #+toomuchinfo id)))
+
+ (loop for slot in (md-owning-slots self) do
+ (loop for k in (let ((sv (SLOT-VALUE self slot)))
+ (if (listp sv) sv (list sv)))
+ do (cc k self)))
+ #+nahhh
+ (progn
+ (when (typep self 'mathx::mx-optr)
+ (cc (mathx::opnds self) from))
+ (when (typep self 'mathx::math-expression)
+ (count-it! :math-expression))))
+ (otherwise
+ (count-it (type-of self)))))))
+ (cc self nil)))))
+
+(defun c-depend-depth (ctop)
+ (if (null (c-useds ctop))
+ 0
+ (or (gethash ctop *c-d-d*)
+ (labels ((cdd (c &optional (depth 1) chain)
+ (when (and (not (c-useds c))
+ (> depth *max-d-d*))
+ (setf *max-d-d* depth)
+ (trc "new dd champ from user" depth :down-to c)
+ (when (= depth 41)
+ (trc "end at" (c-slot-name c) :of (type-of (c-model c)))
+ (loop for c in chain do
+ (trc "called by" (c-slot-name c) :of (type-of (c-model c))))))
+ (setf (gethash c *c-d-d*)
+ ;(break "c-depend-depth ~a" c)
+ (progn
+ ;(trc "dd" c)
+ (1+ (loop for u in (c-useds c)
+ maximizing (cdd u (1+ depth) (cons c chain))))))))
+ (cdd ctop)))))
+
\ No newline at end of file
Added: dependencies/trunk/cells/model-object.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/model-object.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,331 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+;;; --- model-object ----------------------
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(md-name fm-parent .parent )))
+
+(defclass model-object ()
+ ((.md-state :initform :nascent :accessor md-state) ; [nil | :nascent | :alive | :doomed]
+ (.awaken-on-init-p :initform nil :initarg :awaken-on-init-p :accessor awaken-on-init-p)
+ (.cells :initform nil :accessor cells)
+ (.cells-flushed :initform nil :accessor cells-flushed
+ :documentation "cells supplied but un-whenned or optimized-away")
+ (adopt-ct :initform 0 :accessor adopt-ct)))
+
+(defmethod register? ((self model-object)))
+
+(defmethod md-state ((self symbol))
+ :alive)
+;;; --- md obj initialization ------------------
+
+(defmethod shared-initialize :after ((self model-object) slotnames
+ &rest initargs &key fm-parent)
+ (declare (ignorable initargs slotnames fm-parent))
+ (setf (md-census-count self) 1) ;; bad idea if we get into reinitializing
+ ;
+ ; for convenience and transparency of mechanism we allow client code
+ ; to intialize a slot to a cell, but we want the slot to hold the functional
+ ; value, partly for ease of inspection, partly for performance, mostly
+ ; because sometimes we are a slave to other libraries, such as a persistence
+ ; library that does interesting things automatically based on the slot value.
+ ;
+ ; here we shuttle cells out of the slots and into a per-instance dictionary of cells,
+ ; as well as tell the cells what slot and instance they are mediating.
+ ;
+
+ (when (slot-boundp self '.md-state)
+ (loop for esd in (class-slots (class-of self))
+ for sn = (slot-definition-name esd)
+ for sv = (when (slot-boundp self sn)
+ (slot-value self sn))
+ ;; do (print (list (type-of self) sn sv (typep sv 'cell)))
+ when (typep sv 'cell)
+ do (if (md-slot-cell-type (type-of self) sn)
+ (md-install-cell self sn sv)
+ (when *c-debug*
+ (break "warning: cell ~a offered for non-cellular model/slot ~a/~a" sv sn (type-of self)))))
+ ;
+ ; queue up for awakening
+ ;
+ (if (awaken-on-init-p self)
+ (md-awaken self)
+ (with-integrity (:awaken self)
+ (md-awaken self)))
+ ))
+
+(defun md-install-cell (self slot-name c &aux (c-isa-cell (typep c 'cell)))
+ ;
+ ; iff cell, init and move into dictionary
+ ;
+ (when c-isa-cell
+ (count-it :md-install-cell)
+ (setf
+ (c-model c) self
+ (c-slot-name c) slot-name
+ (md-slot-cell self slot-name) c))
+ ;
+ ; now have the slot really be the slot
+ ;
+ (if c-isa-cell
+ (if (c-unboundp c)
+ (bd-slot-makunbound self slot-name)
+ (if self
+ (setf (slot-value self slot-name)
+ (when (c-inputp c) (c-value c)))
+ (setf (symbol-value slot-name)
+ (when (c-inputp c) (c-value c)))))
+ ;; note that in this else branch "c" is a misnomer since
+ ;; the value is not actually a cell
+ (if self
+ (setf (slot-value self slot-name) c)
+ (setf (symbol-value slot-name) c))))
+
+
+;;; --- awaken --------
+;
+; -- do initial evaluation of all ruled slots
+; -- call observers of all slots
+
+
+
+(export! md-awake-ct md-awake-ct-ct)
+(defun md-awake-ct ()
+ *awake-ct*)
+
+(defun md-awake-ct-ct ()
+ (reduce '+ *awake-ct* :key 'cdr))
+
+
+(defmethod md-awaken :around ((self model-object))
+ (when (eql :nascent (md-state self))
+ #+nahh (bif (a (assoc (type-of self) *awake-ct*))
+ (incf (cdr a))
+ (push (cons (type-of self) 1) *awake-ct*))
+ ;(trc "awake" (type-of self))
+ #+chya (push self *awake*)
+ (call-next-method))
+ self)
+
+#+test
+(md-slot-cell-type 'cgtk::label 'cgtk::container)
+
+(defmethod md-awaken ((self model-object))
+ ;
+ ; --- debug stuff
+ ;
+ (when *stop*
+ (princ #\.)
+ (return-from md-awaken))
+ (trc nil "md-awaken entry" self (md-state self))
+ (c-assert (eql :nascent (md-state self)))
+ (count-it :md-awaken)
+ ;(count-it 'mdawaken (type-of self))
+
+ ; ---
+
+ (setf (md-state self) :awakening)
+
+ (dolist (esd (class-slots (class-of self)))
+ (bwhen (sct (md-slot-cell-type (type-of self) (slot-definition-name esd)))
+ (let* ((slot-name (slot-definition-name esd))
+ (c (md-slot-cell self slot-name)))
+ (when *c-debug*
+ (bwhen (sv (and (slot-boundp self slot-name)
+ (slot-value self slot-name)))
+ (when (typep sv 'cell)
+ (c-break "md-awaken ~a found cell ~a in slot ~a" self sv esd))))
+
+ (cond
+ ((not c)
+ ;; all slots must hit any change handlers as instances come into existence to get
+ ;; models fully connected to the outside world they are controlling. that
+ ;; happens in awaken-cell for slots in fact mediated by cells, but as an
+ ;; optimization we allow raw literal values to be specified for a slot, in
+ ;; which case heroic measures are needed to get the slot to the change handler
+ ;;
+ ;; next is an indirect and brittle way to determine that a slot has already been output,
+ ;; but I think anything better creates a run-time hit.
+ ;;
+ ;; until 2007-10 (unless (cdr (assoc slot-name (cells-flushed self))) ;; make sure not flushed
+ ;; but first I worried about it being slow keeping the flushed list /and/ searching, then
+ ;; I wondered why a flushed cell should not be observed, constant cells are. So Just Observe It
+
+ (let ((flushed (md-slot-cell-flushed self slot-name)))
+ (when (or (null flushed) ;; constant, ie, never any cell provided for this slot
+ (> *data-pulse-id* (c-pulse-observed flushed))) ;; unfrickinlikely
+ (when flushed
+ (setf (c-pulse-observed flushed) *data-pulse-id*)) ;; probably unnecessary
+ (slot-value-observe slot-name self (bd-slot-value self slot-name) nil nil flushed))))
+
+ ((find (c-lazy c) '(:until-asked :always t))
+ (trc nil "md-awaken deferring c-awaken since lazy"
+ self esd))
+
+ ((eq :nascent (c-state c))
+ (c-assert (c-model c) () "c-awaken sees uninstalled cell" c)
+ (c-assert (eq :nascent (c-state c)))
+ (trc nil "c-awaken > awakening" c)
+ (count-it :c-awaken)
+
+ (setf (c-state c) :awake)
+ (awaken-cell c))))))
+
+ (setf (md-state self) :awake)
+ self)
+
+;;; --- utilities, accessors, etc --------------------------------------
+
+(defmethod c-slot-value ((self model-object) slot)
+ (slot-value self slot))
+
+(defmethod md-slot-cell (self slot-name)
+ (if self
+ (cdr (assoc slot-name (cells self)))
+ (get slot-name 'cell)))
+
+(defmethod md-slot-cell-flushed (self slot-name)
+ (if self
+ (cdr (assoc slot-name (cells-flushed self)))
+ (get slot-name 'cell)))
+
+#+test
+(get 'cgtk::label :cell-types)
+
+(defun md-slot-cell-type (class-name slot-name)
+ (assert class-name)
+ (if (eq class-name 'null)
+ (get slot-name :cell-type)
+ (bif (entry (assoc slot-name (get class-name :cell-types)))
+ (cdr entry)
+ (dolist (super (class-precedence-list (find-class class-name))
+ (setf (md-slot-cell-type class-name slot-name) nil))
+ (bwhen (entry (assoc slot-name (get (c-class-name super) :cell-types)))
+ (return-from md-slot-cell-type
+ (setf (md-slot-cell-type class-name slot-name) (cdr entry))))))))
+
+(defun (setf md-slot-cell-type) (new-type class-name slot-name)
+ (assert class-name)
+ (if (eq class-name 'null) ;; not def-c-variable
+ (setf (get slot-name :cell-type) new-type)
+ (let ((entry (assoc slot-name (get class-name :cell-types))))
+ (if entry
+ (prog1
+ (setf (cdr entry) new-type)
+ (loop for c in (class-direct-subclasses (find-class class-name))
+ do (setf (md-slot-cell-type (class-name c) slot-name) new-type)))
+ (cdar (push (cons slot-name new-type) (get class-name :cell-types)))))))
+
+#+test
+(md-slot-owning? 'm-index '.value)
+
+(defun md-slot-owning? (class-name slot-name)
+ (assert class-name)
+ (if (eq class-name 'null)
+ (get slot-name :owning) ;; might be wrong -- support for specials is unfinished w.i.p.
+ (bif (entry (assoc slot-name (get class-name :direct-ownings)))
+ (cdr entry)
+ (bif (entry (assoc slot-name (get class-name :indirect-ownings)))
+ (cdr entry)
+ (cdar
+ (push (cons slot-name
+ (cdr (loop for super in (cdr (class-precedence-list (find-class class-name)))
+ thereis (assoc slot-name (get (c-class-name super) :direct-ownings)))))
+ (get class-name :indirect-ownings)))))))
+
+(defun (setf md-slot-owning-direct?) (value class-name slot-name)
+ (assert class-name)
+ (if (eq class-name 'null) ;; global variables
+ (setf (get slot-name :owning) value)
+ (progn
+ (bif (entry (assoc slot-name (get class-name :direct-ownings)))
+ (setf (cdr entry) value)
+ (push (cons slot-name value) (get class-name :direct-ownings)))
+ ; -- propagate to derivatives ...
+ (labels ((clear-subclass-ownings (c)
+ (loop for sub-c in (class-direct-subclasses c)
+ for sub-c-name = (c-class-name sub-c)
+ do (setf (get sub-c-name :indirect-ownings)
+ (delete slot-name (get sub-c-name :indirect-ownings) :key 'car)) ;; forces redecide
+ (setf (get sub-c-name :model-ownings) nil) ;; too much forcing full recalc like this?
+ (clear-subclass-ownings sub-c))))
+ (clear-subclass-ownings (find-class class-name))))))
+
+(defun md-owning-slots (self &aux (st (type-of self)))
+ (or (get st :model-ownings)
+ (setf (get st :model-ownings)
+ (loop for s in (class-slots (class-of self))
+ for sn = (slot-definition-name s)
+ when (and (md-slot-cell-type st sn)
+ (md-slot-owning? st sn))
+ collect sn))))
+
+#+test
+(md-slot-owning? 'cells::family '.kids)
+
+(defun md-slot-value-store (self slot-name new-value)
+ (trc nil "md-slot-value-store" self slot-name new-value)
+ (if self
+ (setf (slot-value self slot-name) new-value)
+ (setf (symbol-value slot-name) new-value)))
+
+;----------------- navigation: slot <> initarg <> esd <> cell -----------------
+
+#+cmu
+(defmethod c-class-name ((class pcl::standard-class))
+ (pcl::class-name class))
+
+(defmethod c-class-name (other) (declare (ignore other)) nil)
+
+;; why not #-cmu?
+(defmethod c-class-name ((class standard-class))
+ (class-name class))
+
+(defmethod cell-when (other) (declare (ignorable other)) nil)
+
+(defun (setf md-slot-cell) (new-cell self slot-name)
+ (if self ;; not on def-c-variables
+ (bif (entry (assoc slot-name (cells self)))
+ ; this next branch guessed it would only occur during kid-slotting,
+ ; before any dependency-ing could have happened, but a math-editor
+ ; is silently switching between implied-multiplication and mixed numbers
+ ; while they type and it
+ (progn
+ (trc nil "second cell same slot:" slot-name :old entry :new new-cell)
+ (let ((old (cdr entry))) ;; s/b being supplanted by kid-slotter
+ (declare (ignorable old))
+ (c-assert (null (c-callers old)))
+ (when (typep entry 'c-dependent)
+ (c-assert (null (cd-useds old))))
+ (trc nil "replacing in model .cells" old new-cell self)
+ (rplacd entry new-cell)))
+ (progn
+ (trc nil "adding to model .cells" new-cell self)
+ (push (cons slot-name new-cell)
+ (cells self))))
+ (setf (get slot-name 'cell) new-cell)))
+
+(defun md-map-cells (self type celldo)
+ (map type (lambda (cell-entry)
+ (bwhen (cell (cdr cell-entry))
+ (unless (listp cell)
+ (funcall celldo cell))))
+ (cells self)))
Added: dependencies/trunk/cells/propagate.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/propagate.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,291 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+;----------------- change detection ---------------------------------
+
+(defun c-no-news (c new-value old-value)
+ ;;; (trc nil "c-no-news > checking news between" newvalue oldvalue)
+ (bif (test (c-unchanged-test (c-model c) (c-slot-name c)))
+ (funcall test new-value old-value)
+ (eql new-value old-value)))
+
+(defmacro def-c-unchanged-test ((class slotname) &body test)
+ `(defmethod c-unchanged-test ((self ,class) (slotname (eql ',slotname)))
+ , at test))
+
+(defmethod c-unchanged-test (self slotname)
+ (declare (ignore self slotname))
+ nil)
+
+; --- data pulse (change ID) management -------------------------------------
+
+(defparameter *one-pulse?* nil)
+
+(defun data-pulse-next (pulse-info)
+ (declare (ignorable pulse-info))
+ (unless *one-pulse?*
+ ;(trc "dp-next> " (1+ *data-pulse-id*) pulse-info)
+ #+chill (when *c-debug*
+ (push (list :data-pulse-next pulse-info) *istack*))
+ (incf *data-pulse-id*)))
+
+(defun c-currentp (c)
+ (eql (c-pulse c) *data-pulse-id*))
+
+(defun c-pulse-update (c key)
+ (declare (ignorable key))
+ (unless (find key '(:valid-uninfluenced))
+ (trc nil "!!!!!!! c-pulse-update updating !!!!!!!!!!" *data-pulse-id* c key :prior-pulse (c-pulse c)))
+ (assert (>= *data-pulse-id* (c-pulse c)) ()
+ "Current DP ~a not GE pulse ~a of cell ~a" *data-pulse-id* (c-pulse c) c)
+ (setf (c-pulse c) *data-pulse-id*))
+
+;--------------- propagate ----------------------------
+; n.b. the cell argument may have been optimized away,
+; though it is still receiving final processing here.
+
+(defparameter *per-cell-handler* nil)
+
+(defun c-propagate (c prior-value prior-value-supplied)
+ (when *one-pulse?*
+ (when *per-cell-handler*
+ (funcall *per-cell-handler* c prior-value prior-value-supplied)
+ (return-from c-propagate)))
+
+ (count-it :cpropagate)
+ (setf (c-pulse-last-changed c) *data-pulse-id*)
+
+ (when prior-value
+ (assert prior-value-supplied () "How can prior-value-supplied be nil if prior-value is not?!! ~a" c))
+ (let (*depender* *call-stack* ;; I think both need clearing, cuz we are neither depending nor calling when we prop to callers
+ (*c-prop-depth* (1+ *c-prop-depth*))
+ (*defer-changes* t))
+ (trc nil "c.propagate clearing *depender*" c)
+
+ ;------ debug stuff ---------
+ ;
+ (when *stop*
+ (princ #\.)(princ #\!)
+ (return-from c-propagate))
+ (trc nil "c.propagate> !!!!!!! propping" c (c-value c) :caller-ct (length (c-callers c)))
+ #+slow (trc nil "c.propagate> !!!! new value" (c-value c) :prior-value prior-value :caller-ct (length (c-callers c)) c)
+ (when *c-debug*
+ (when (> *c-prop-depth* 250)
+ (trc nil "c.propagate deep" *c-prop-depth* (c-model c) (c-slot-name c) #+nah c))
+ (when (> *c-prop-depth* 300)
+ (c-break "c.propagate looping ~c" c)))
+
+ ; --- manifest new value as needed ---
+ ;
+ ; 20061030 Trying not.to.be first because doomed instances may be interested in callers
+ ; who will decide to propagate. If a family instance kids slot is changing, a doomed kid
+ ; will be out of the kids but not yet quiesced. If the propagation to this rule asks the kid
+ ; to look at its siblings (say a view instance being deleted from a stack who looks to the psib
+ ; pb to decide its own pt), the doomed kid will still have a parent but not be in its kids slot
+ ; when it goes looking for a sibling relative to its position.
+ ;
+ (when (and prior-value-supplied
+ prior-value
+ (md-slot-owning? (type-of (c-model c)) (c-slot-name c)))
+ (trc nil "c.propagate> contemplating lost" (qci c))
+ (flet ((listify (x) (if (listp x) x (list x))))
+ (bif (lost (set-difference (listify prior-value) (listify (c-value c))))
+ (progn
+ (trc nil "prop nailing owned!!!!!!!!!!!" (qci c) :lost (length lost)) ;; :leaving (c-value c))
+ (loop for l in lost
+ when (numberp l)
+ do (break "got num ~a" (list l (type-of (c-model c))(c-slot-name c)
+ (md-slot-owning? (type-of (c-model c)) (c-slot-name c)))))
+ (mapcar 'not-to-be lost))
+ (trc nil "no owned lost!!!!!"))))
+
+ ; propagation to callers jumps back in front of client slot-value-observe handling in cells3
+ ; because model adopting (once done by the kids change handler) can now be done in
+ ; shared-initialize (since one is now forced to supply the parent to make-instance).
+ ;
+ ; we wnat it here to support (eventually) state change rollback. change handlers are
+ ; expected to have side-effects, so we want to propagate fully and be sure no rule
+ ; wants a rollback before starting with the side effects.
+ ;
+ (progn ;; unless (member (c-lazy c) '(t :always :once-asked)) ;; 2006-09-26 still fuzzy on this
+ (c-propagate-to-callers c))
+
+ (trc nil "c.propagate observing" c)
+
+ ; this next assertion is just to see if we can ever come this way twice. If so, just
+ ; make it a condition on whether to observe
+ (when t ; breaks algebra (> *data-pulse-id* (c-pulse-observed c))
+ (setf (c-pulse-observed c) *data-pulse-id*)
+ (slot-value-observe (c-slot-name c) (c-model c)
+ (c-value c) prior-value prior-value-supplied c))
+
+
+ ;
+ ; with propagation done, ephemerals can be reset. we also do this in c-awaken, so
+ ; let the fn decide if C really is ephemeral. Note that it might be possible to leave
+ ; this out and use the datapulse to identify obsolete ephemerals and clear them
+ ; when read. That would avoid ever making again bug I had in which I had the reset inside slot-value-observe,
+ ; thinking that that always followed propagation to callers. It would also make
+ ; debugging easier in that I could find the last ephemeral value in the inspector.
+ ; would this be bad for persistent CLOS, in which a DB would think there was still a link
+ ; between two records until the value actually got cleared?
+ ;
+ (ephemeral-reset c)))
+
+; --- slot change -----------------------------------------------------------
+
+(defmacro defobserver (slotname &rest args &aux (aroundp (eq :around (first args))))
+ (when aroundp (setf args (cdr args)))
+ (when (find slotname '(value kids))
+ (break "d: did you mean .value or .kids when you coded ~a?" slotname))
+ (destructuring-bind ((&optional (self-arg 'self) (new-varg 'new-value)
+ (oldvarg 'old-value) (oldvargboundp 'old-value-boundp) (cell-arg 'c))
+ &body output-body) args
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf (get ',slotname :output-defined) t))
+ ,(if (eql (last1 output-body) :test)
+ (let ((temp1 (gensym))
+ (loc-self (gensym)))
+ `(defmethod slot-value-observe #-(or cormanlisp) ,(if aroundp :around 'progn)
+ ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg)
+ (let ((,temp1 (bump-output-count ,slotname))
+ (,loc-self ,(if (listp self-arg)
+ (car self-arg)
+ self-arg)))
+ (when (and ,oldvargboundp ,oldvarg)
+ (format t "~&output ~d (~a ~a) old: ~a" ,temp1 ',slotname ,loc-self ,oldvarg ,cell-arg))
+ (format t "~&output ~d (~a ~a) new: ~a" ,temp1 ',slotname ,loc-self ,new-varg ,cell-arg))))
+ `(defmethod slot-value-observe
+ #-(or cormanlisp) ,(if aroundp :around 'progn)
+ ((slotname (eql ',slotname)) ,self-arg ,new-varg ,oldvarg ,oldvargboundp ,cell-arg)
+ (declare (ignorable
+ ,@(flet ((arg-name (arg-spec)
+ (etypecase arg-spec
+ (list (car arg-spec))
+ (atom arg-spec))))
+ (list (arg-name self-arg)(arg-name new-varg)
+ (arg-name oldvarg)(arg-name oldvargboundp) (arg-name cell-arg)))))
+ , at output-body)))))
+
+(defmacro bump-output-count (slotname) ;; pure test func
+ `(if (get ',slotname :outputs)
+ (incf (get ',slotname :outputs))
+ (setf (get ',slotname :outputs) 1)))
+
+; --- recalculate dependents ----------------------------------------------------
+
+
+(defmacro cll-outer (val &body body)
+ `(let ((outer-val ,val))
+ , at body))
+
+(defmacro cll-inner (expr)
+ `(,expr outer-val))
+
+(export! cll-outer cll-inner)
+
+(defun c-propagate-to-callers (c)
+ ;
+ ; We must defer propagation to callers because of an edge case in which:
+ ; - X tells A to recalculate
+ ; - A asks B for its current value
+ ; - B must recalculate because it too uses X
+ ; - if B propagates to its callers after recalculating instead of deferring it
+ ; - B might tell H to reclaculate, where H decides this time to use A
+ ; - but A is in the midst of recalculating, and cannot complete until B returns.
+ ; but B is busy eagerly propagating. "This time" is important because it means
+ ; there is no way one can reliably be sure H will not ask for A
+ ;
+ (when (find-if-not (lambda (caller)
+ (and (c-lazy caller) ;; slight optimization
+ (member (c-lazy caller) '(t :always :once-asked))))
+ (c-callers c))
+ (let ((causation (cons c *causation*))) ;; in case deferred
+ #+slow (trc nil "c.propagate-to-callers > queueing notifying callers" (c-callers c))
+ (with-integrity (:tell-dependents c)
+ (assert (null *call-stack*))
+ (assert (null *depender*))
+ ;
+ (if (mdead (c-model c))
+ (trc nil "WHOAA!!!! dead by time :tell-deps dispatched; bailing" c)
+ (let ((*causation* causation))
+ (trc nil "c.propagate-to-callers > actually notifying callers of" c (c-callers c))
+ #+c-debug (dolist (caller (c-callers c))
+ (assert (find c (cd-useds caller)) () "test 1 failed ~a ~a" c caller))
+ #+c-debug (dolist (caller (copy-list (c-callers c))) ;; following code may modify c-callers list...
+ (trc nil "PRE-prop-CHECK " c :caller caller (c-state caller) (c-lazy caller))
+ (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
+ (member (c-lazy caller) '(t :always :once-asked)))
+ (assert (find c (cd-useds caller))() "Precheck Caller ~a of ~a does not have it as used" caller c)
+ ))
+ (dolist (caller (c-callers c))
+ (trc nil "propagating to caller iterates" c :caller caller (c-state caller) (c-lazy caller))
+ (block do-a-caller
+ (unless (or (eq (c-state caller) :quiesced) ;; ..so watch for quiesced
+ (member (c-lazy caller) '(t :always :once-asked)))
+ (unless (find c (cd-useds caller))
+ (trc "WHOA!!!! Bailing on Known caller:" caller :does-not-in-its-used c)
+ (return-from do-a-caller))
+ #+slow (trc nil "propagating to caller is used" c :caller caller (c-currentp c))
+ (let ((*trc-ensure* (trcp c)))
+ ;
+ ; we just calculate-and-set at the first level of dependency because
+ ; we do not need to check the next level (as ensure-value-is-current does)
+ ; because we already know /this/ notifying dependency has changed, so yeah,
+ ; any first-level cell /has to/ recalculate. (As for ensuring other dependents
+ ; of the first level guy are current, that happens automatically anyway JIT on
+ ; any read.) This is a minor efficiency enhancement since ensure-value-is-current would
+ ; very quickly decide it has to re-run, but maybe it makes the logic clearer.
+ ;
+ ;(ensure-value-is-current caller :prop-from c) <-- next was this, but see above change reason
+ ;
+ (unless (c-currentp caller) ; happens if I changed when caller used me in current pulse
+ (calculate-and-set caller :propagate c))))))))))))
+
+(defparameter *the-unpropagated* nil)
+
+(defmacro with-one-datapulse ((&key (per-cell nil per-cell?) (finally nil finally?)) &body body)
+ `(call-with-one-datapulse (lambda () , at body)
+ ,@(when per-cell? `(:per-cell (lambda (c prior-value prior-value-boundp)
+ (declare (ignorable c prior-value prior-value-boundp))
+ ,per-cell)))
+ ,@(when finally? `(:finally (lambda (cs) (declare (ignorable cs)) ,finally)))))
+
+(defun call-with-one-datapulse
+ (f &key
+ (per-cell (lambda (c prior-value prior-value?)
+ (unless (find c *the-unpropagated* :key 'car)
+ (pushnew (list c prior-value prior-value?) *the-unpropagated*))))
+ (finally (lambda (cs)
+ (print `(finally sees ,*data-pulse-id* ,cs))
+ ;(trace c-propagate ensure-value-is-current)
+ (loop for (c prior-value prior-value?) in (nreverse cs) do
+ (c-propagate c prior-value prior-value?)))))
+ (assert (not *one-pulse?*))
+ (data-pulse-next :client-prop)
+ (trc "call-with-one-datapulse bumps pulse" *data-pulse-id*)
+ (funcall finally
+ (let ((*one-pulse?* t)
+ (*per-cell-handler* per-cell)
+ (*the-unpropagated* nil))
+ (funcall f)
+ *the-unpropagated*)))
+
Added: dependencies/trunk/cells/slot-utilities.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/slot-utilities.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,97 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(defun c-setting-debug (self slot-name c new-value)
+ (declare (ignorable new-value))
+ (cond
+ ((null c)
+ (format t "c-setting-debug > constant ~a in ~a may not be altered..init to (c-in nil)"
+ slot-name self)
+
+ (c-break "setting-const-cell")
+ (error "setting-const-cell"))
+ ((c-inputp c))
+ (t
+ (let ((self (c-model c))
+ (slot-name (c-slot-name c)))
+ ;(trc "c-setting-debug sees" c newvalue self slot-name)
+ (when (and c (not (and slot-name self)))
+ ;; cv-test handles errors, so don't set *stop* (c-stop)
+ (c-break "unadopted ~a for self ~a spec ~a" c self slot-name)
+ (error 'c-unadopted :cell c))
+ #+whocares (typecase c
+ (c-dependent
+ ;(trc "setting c-dependent" c newvalue)
+ (format t "c-setting-debug > ruled ~a in ~a may not be setf'ed"
+ (c-slot-name c) self)
+
+ (c-break "setting-ruled-cell")
+ (error "setting-ruled-cell"))
+ )))))
+
+(defun c-absorb-value (c value)
+ (typecase c
+ (c-drifter-absolute (c-value-incf c value 0)) ;; strange but true
+ (c-drifter (c-value-incf c (c-value c) value))
+ (t value)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(c-value-incf)))
+
+(defmethod c-value-incf (c (envaluer c-envaluer) delta)
+ (c-assert (c-model c))
+ (c-value-incf c (funcall (envalue-rule envaluer) c)
+ delta))
+
+(defmethod c-value-incf (c (base number) delta)
+ (declare (ignore c))
+ (if delta
+ (+ base delta)
+ base))
+
+
+;----------------------------------------------------------------------
+
+(defun bd-slot-value (self slot-name)
+ (slot-value self slot-name))
+
+(defun (setf bd-slot-value) (new-value self slot-name)
+ (setf (slot-value self slot-name) new-value))
+
+(defun bd-bound-slot-value (self slot-name caller-id)
+ (declare (ignorable caller-id))
+ (when (bd-slot-boundp self slot-name)
+ (bd-slot-value self slot-name)))
+
+(defun bd-slot-boundp (self slot-name)
+ (slot-boundp self slot-name))
+
+(defun bd-slot-makunbound (self slot-name)
+ (if slot-name ;; not in def-c-variable
+ (slot-makunbound self slot-name)
+ (makunbound self)))
+
+#| sample incf
+(defmethod c-value-incf ((base fpoint) delta)
+ (declare (ignore model))
+ (if delta
+ (fp-add base delta)
+ base))
+|#
Added: dependencies/trunk/cells/synapse-types.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/synapse-types.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,152 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(export! f-find)
+
+(defmacro f-find (synapse-id sought where)
+ `(call-f-find ,synapse-id ,sought ,where))
+
+(defun call-f-find (synapse-id sought where)
+ (with-synapse synapse-id ()
+ (bif (k (progn
+ (find sought where)))
+ (values k :propagate)
+ (values nil :no-propagate))))
+
+(defmacro f-sensitivity (synapse-id (sensitivity &optional subtypename) &body body)
+ `(call-f-sensitivity ,synapse-id ,sensitivity ,subtypename (lambda () , at body)))
+
+(defun call-f-sensitivity (synapse-id sensitivity subtypename body-fn)
+ (with-synapse synapse-id (prior-fire-value)
+ (let ((new-value (funcall body-fn)))
+ ;(trc "f-sensitivity fire-p decides new" new-value :from-prior prior-fire-value :sensi sensitivity)
+ (let ((prop-code (if (or (xor prior-fire-value new-value)
+ (eko (nil "sens fire-p decides" new-value prior-fire-value sensitivity)
+ (delta-greater-or-equal
+ (delta-abs (delta-diff new-value prior-fire-value subtypename)
+ subtypename)
+ (delta-abs sensitivity subtypename)
+ subtypename)))
+ :propagate
+ :no-propagate)))
+ (values (if (eq prop-code :propagate)
+ (progn
+ (trc nil "sense prior fire value now" new-value)
+ (setf prior-fire-value new-value))
+ new-value) prop-code)))))
+
+(defmacro f-delta (synapse-id (&key sensitivity (type 'number)) &body body)
+ `(call-f-delta ,synapse-id ,sensitivity ',type (lambda () , at body)))
+
+(defun call-f-delta (synapse-id sensitivity type body-fn)
+ (with-synapse synapse-id (last-relay-basis last-bound-p delta-cum)
+ (let* ((new-basis (funcall body-fn))
+ (threshold sensitivity)
+ (tdelta (delta-diff new-basis
+ (if last-bound-p
+ last-relay-basis
+ (delta-identity new-basis type))
+ type)))
+ (trc nil "tdelta, threshhold" tdelta threshold)
+ (setf delta-cum tdelta)
+ (let ((propagation-code
+ (when threshold
+ (if (delta-exceeds tdelta threshold type)
+ (progn
+ (setf last-bound-p t)
+ (setf last-relay-basis new-basis)
+ :propagate)
+ :no-propagate))))
+ (trc nil "f-delta returns values" delta-cum propagation-code)
+ (values delta-cum propagation-code)))))
+
+(defmacro f-plusp (key &rest body)
+ `(with-synapse ,key (prior-fire-value)
+ (let ((new-basis (progn , at body)))
+ (values new-basis (if (xor prior-fire-value (plusp new-basis))
+ (progn
+ (setf prior-fire-value (plusp new-basis))
+ :propagate)
+ :no-propagate)))))
+
+(defmacro f-zerop (key &rest body)
+ `(with-synapse ,key (prior-fire-value)
+ (let ((new-basis (progn , at body)))
+ (values new-basis (if (xor prior-fire-value (zerop new-basis))
+ (progn
+ (setf prior-fire-value (zerop new-basis))
+ :propagate)
+ :no-propagate)))))
+
+
+
+;;;(defun f-delta-list (&key (test #'true))
+;;; (with-synapse (prior-list)
+;;; :fire-p (lambda (syn new-list)
+;;; (declare (ignorable syn))
+;;; (or (find-if (lambda (new)
+;;; ;--- gaining one? ----
+;;; (and (not (member new prior-list))
+;;; (funcall test new)))
+;;; new-list)
+;;; (find-if (lambda (old)
+;;; ;--- losing one? ----
+;;; (not (member old new-list))) ;; all olds have passed test, so skip test here
+;;; prior-list)))
+;;;
+;;; :fire-value (lambda (syn new-list)
+;;; (declare (ignorable syn))
+;;; ;/// excess consing on long lists
+;;; (setf prior-list (remove-if-not test new-list)))))
+
+;;;(defun f-find-once (finder-fn)
+;;; (mk-synapse (bingo bingobound)
+;;;
+;;; :fire-p (lambda (syn new-list)
+;;; (declare (ignorable syn))
+;;; (unless bingo ;; once found, yer done
+;;; (setf bingobound t
+;;; bingo (find-if finder-fn new-list))))
+;;;
+;;; :fire-value (lambda (syn new-list)
+;;; (declare (ignorable syn))
+;;; (or bingo
+;;; (and (not bingobound) ;; don't bother if fire? already looked
+;;; (find-if finder-fn new-list))))))
+
+;;;(defun fdifferent ()
+;;; (mk-synapse (prior-object)
+;;; :fire-p (lambda (syn new-object)
+;;; (declare (ignorable syn))
+;;; (trc nil "fDiff: prior,new" (not (eql new-object prior-object))
+;;; prior-object new-object)
+;;; (not (eql new-object prior-object)))
+;;;
+;;; :fire-value (lambda (syn new-object)
+;;; (declare (ignorable syn))
+;;; (unless (eql new-object prior-object)
+;;; (setf prior-object new-object)))
+;;; ))
+
+
+;;;(defun f-boolean (&optional (sensitivity 't))
+;;; (f-delta :sensitivity sensitivity :type 'boolean))
+
+
Added: dependencies/trunk/cells/synapse.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/synapse.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,89 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(mk-synapse f-delta f-sensitivity f-plusp f-zerop fdifferent with-synapse)))
+
+(defmacro with-synapse (synapse-id (&rest closure-vars) &body body)
+ (let ((syn-id (gensym)))
+ `(let* ((,syn-id ,synapse-id)
+ (synapse (or (find ,syn-id (cd-useds *depender*) :key 'c-slot-name)
+ (let ((new-syn
+ (let (, at closure-vars)
+ (make-c-dependent
+ :model (c-model *depender*)
+ :slot-name ,syn-id
+ :code ',body
+ :synaptic t
+ :rule (c-lambda , at body)))))
+ (record-caller new-syn)
+ new-syn))))
+ (prog1
+ (multiple-value-bind (v p)
+ (with-integrity ()
+ (ensure-value-is-current synapse :synapse *depender*))
+ (values v p))
+ (record-caller synapse)))))
+
+
+;__________________________________________________________________________________
+;
+
+(defmethod delta-exceeds (bool-delta sensitivity (subtypename (eql 'boolean)))
+ (unless (eql bool-delta :unchanged)
+ (or (eq sensitivity t)
+ (eq sensitivity bool-delta))))
+
+(defmethod delta-diff ((new number) (old number) subtypename)
+ (declare (ignore subtypename))
+ (- new old))
+
+(defmethod delta-identity ((dispatcher number) subtypename)
+ (declare (ignore subtypename))
+ 0)
+
+(defmethod delta-abs ((n number) subtypename)
+ (declare (ignore subtypename))
+ (abs n))
+
+(defmethod delta-exceeds ((d1 number) (d2 number) subtypename)
+ (declare (ignore subtypename))
+ (> d1 d2))
+
+(defmethod delta-greater-or-equal ((d1 number) (d2 number) subtypename)
+ (declare (ignore subtypename))
+ (>= d1 d2))
+
+;_________________________________________________________________________________
+;
+(defmethod delta-diff (new old (subtypename (eql 'boolean)))
+ (if new
+ (if old
+ :unchanged
+ :on)
+ (if old
+ :off
+ :unchanged)))
+
+
+(defmethod delta-identity (dispatcher (subtypename (eql 'boolean)))
+ (declare (ignore dispatcher))
+ :unchanged)
+
Added: dependencies/trunk/cells/test-cc.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test-cc.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,40 @@
+(in-package :cells)
+
+(defmd tcc ()
+ (tccversion 1)
+ (tcc-a (c-in nil))
+ (tcc-2a (c-in nil)))
+
+(defobserver tcc-a ()
+ (case (^tccversion)
+ (1 (when new-value
+ (with-cc :tcc-a-obs
+ (setf (tcc-2a self) (* 2 new-value))
+ (with-cc :aha!2
+ (assert (eql (tcc-2a self) (* 2 new-value))
+ () "one")
+ (trc "one happy")))
+ (with-cc :aha!
+ (assert (eql (tcc-2a self) (* 2 new-value))
+ () "two"))))
+ (2 (when new-value
+ (with-cc :tcc-a-obs
+ (setf (tcc-2a self) (* 2 new-value))
+ (with-cc :aha!2
+ (assert (eql (tcc-2a self) (* 2 new-value))
+ () "one")
+ (trc "one happy")))))))
+
+
+(defun test-with-cc ()
+ (let ((self (make-instance 'tcc
+ :tccversion 2 ;:tcc-2a
+ )))
+ (trcx cool 42)
+ (setf (tcc-a self) 42)
+ (assert (and (numberp (tcc-2a self))
+ (= (tcc-2a self) 84)))))
+
+#+test
+(test-with-cc)
+
Added: dependencies/trunk/cells/test-cycle.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test-cycle.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,77 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+
+(defmodel m-cyc ()
+ ((m-cyc-a :initform (c-in nil) :initarg :m-cyc-a :accessor m-cyc-a)
+ (m-cyc-b :initform (c-in nil) :initarg :m-cyc-b :accessor m-cyc-b)))
+
+(def-c-output m-cyc-a ()
+ (print `(output m-cyc-a ,self ,new-value ,old-value))
+ (setf (m-cyc-b self) new-value))
+
+(def-c-output m-cyc-b ()
+ (print `(output m-cyc-b ,self ,new-value ,old-value))
+ (setf (m-cyc-a self) new-value))
+
+(defun m-cyc () ;;def-cell-test m-cyc
+ (let ((m (make-be 'm-cyc)))
+ (print `(start ,(m-cyc-a m)))
+ (setf (m-cyc-a m) 42)
+ (assert (= (m-cyc-a m) 42))
+ (assert (= (m-cyc-b m) 42))))
+
+#+(or)
+(m-cyc)
+
+(defmodel m-cyc2 ()
+ ((m-cyc2-a :initform (c-in 0) :initarg :m-cyc2-a :accessor m-cyc2-a)
+ (m-cyc2-b :initform (c? (1+ (^m-cyc2-a)))
+ :initarg :m-cyc2-b :accessor m-cyc2-b)))
+
+(def-c-output m-cyc2-a ()
+ (print `(output m-cyc2-a ,self ,new-value ,old-value))
+ #+(or) (when (< new-value 45)
+ (setf (m-cyc2-b self) (1+ new-value))))
+
+(def-c-output m-cyc2-b ()
+ (print `(output m-cyc2-b ,self ,new-value ,old-value))
+ (when (< new-value 45)
+ (setf (m-cyc2-a self) (1+ new-value))))
+
+(def-cell-test m-cyc2
+ (cell-reset)
+ (let ((m (make-be 'm-cyc2)))
+ (print '(start))
+ (setf (m-cyc2-a m) 42)
+ (describe m)
+ (assert (= (m-cyc2-a m) 44))
+ (assert (= (m-cyc2-b m) 45))
+ ))
+
+#+(or)
+(m-cyc2)
+
+
Added: dependencies/trunk/cells/test-ephemeral.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test-ephemeral.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,57 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+(defmodel m-ephem ()
+ ((m-ephem-a :cell :ephemeral :initform nil :initarg :m-ephem-a :accessor m-ephem-a)
+ (m-test-a :cell nil :initform nil :initarg :m-test-a :accessor m-test-a)
+ (m-ephem-b :cell :ephemeral :initform nil :initarg :m-ephem-b :accessor m-ephem-b)
+ (m-test-b :cell nil :initform nil :initarg :m-test-b :accessor m-test-b)))
+
+(def-c-output m-ephem-a ()
+ (setf (m-test-a self) new-value))
+
+(def-c-output m-ephem-b ()
+ (setf (m-test-b self) new-value))
+
+(def-cell-test m-ephem
+ (let ((m (make-be 'm-ephem :m-ephem-a (c-in nil) :m-ephem-b (c? (* 2 (or (^m-ephem-a) 0))))))
+ (ct-assert (null (slot-value m 'm-ephem-a)))
+ (ct-assert (null (m-ephem-a m)))
+ (ct-assert (null (m-test-a m)))
+ (ct-assert (null (slot-value m 'm-ephem-b)))
+ (ct-assert (null (m-ephem-b m)))
+ (ct-assert (zerop (m-test-b m)))
+ (setf (m-ephem-a m) 3)
+ (ct-assert (null (slot-value m 'm-ephem-a)))
+ (ct-assert (null (m-ephem-a m)))
+ (ct-assert (eql 3 (m-test-a m)))
+ ;
+ (ct-assert (null (slot-value m 'm-ephem-b)))
+ (ct-assert (null (m-ephem-b m)))
+ (ct-assert (eql 6 (m-test-b m)))
+ ))
+
+
+
Added: dependencies/trunk/cells/test-propagation.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test-propagation.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,45 @@
+(in-package :cells)
+
+(defmd tcp ()
+ (left (c-in 0))
+ (top (c-in 0))
+ (right (c-in 0))
+ (bottom (c-in 0))
+ (area (c? (trc "area running")
+ (* (- (^right)(^left))
+ (- (^top)(^bottom))))))
+
+(defobserver area ()
+ (TRC "new area" new-value old-value old-value-boundp :pulse *data-pulse-id*))
+
+(defobserver bottom ()
+ (TRC "new bottom" new-value old-value old-value-boundp :pulse *data-pulse-id*)
+ (with-integrity (:change 'bottom-tells-left)
+ (setf (^left) new-value)))
+
+(defobserver left ()
+ (TRC "new left" new-value old-value old-value-boundp :pulse *data-pulse-id*))
+
+(defun tcprop ()
+ (untrace)
+ (ukt:test-prep)
+ (LET ((box (make-instance 'tcp)))
+ (trc "changing top to 10" *data-pulse-id*)
+ (setf (top box) 10)
+ (trc "not changing top" *data-pulse-id*)
+ (setf (top box) 10)
+ (trc "changing right to 10" *data-pulse-id*)
+ (setf (right box) 10)
+ (trc "not changing right" *data-pulse-id*)
+ (setf (right box) 10)
+ (trc "changing bottom to -1" *data-pulse-id*)
+ (decf (bottom box))
+ (with-one-datapulse ()
+ (loop repeat 5 do
+ (trc "changing bottom by -1" *data-pulse-id*)
+ (decf (bottom box))))))
+
+
+
+
+
Added: dependencies/trunk/cells/test-synapse.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test-synapse.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,102 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(in-package :cells)
+
+
+(defmodel m-syn ()
+ ((m-syn-a :initform nil :initarg :m-syn-a :accessor m-syn-a)
+ (m-syn-b :initform nil :initarg :m-syn-b :accessor m-syn-b)
+ (m-syn-factor :initform nil :initarg :m-syn-factor :accessor m-syn-factor)
+ (m-sens :initform nil :initarg :m-sens :accessor m-sens)
+ (m-plus :initform nil :initarg :m-plus :accessor m-plus)
+ ))
+
+(def-c-output m-syn-b ()
+ (print `(output m-syn-b ,self ,new-value ,old-value)))
+
+
+
+(def-cell-test m-syn
+ (progn (cell-reset)
+ (let* ((delta-ct 0)
+ (sens-ct 0)
+ (plus-ct 0)
+ (m (make-be 'm-syn
+ :m-syn-a (c-in 0)
+ :m-syn-b (c? (incf delta-ct)
+ (trc nil "syn-b rule firing!!!!!!!!!!!!!!" delta-ct)
+ (eko (nil "syn-b rule returning")
+ (f-delta :syna-1 (:sensitivity 2)
+ (^m-syn-a))))
+ :m-syn-factor (c-in 1)
+ :m-sens (c? (incf sens-ct)
+ (trc nil "m-sens rule firing ~d !!!!!!!!!!!!!!" sens-ct)
+ (* (^m-syn-factor)
+ (f-sensitivity :sensa (3) (^m-syn-a))))
+ :m-plus (c? (incf plus-ct)
+ (trc nil "m-plus rule firing!!!!!!!!!!!!!!" plus-ct)
+ (f-plusp :syna-2 (- 2 (^m-syn-a)))))))
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (= 1 sens-ct))
+ (ct-assert (= 1 plus-ct))
+ (ct-assert (= 0 (m-sens m)))
+ (trc "make-be complete. about to incf m-syn-a")
+ (incf (m-syn-a m))
+ (ct-assert (= 1 delta-ct))
+ (ct-assert (= 1 sens-ct))
+ (ct-assert (= 1 plus-ct))
+ (ct-assert (= 0 (m-sens m)))
+ (trc "about to incf m-syn-a 2")
+ (incf (m-syn-a m) 2)
+ (trc nil "syn-b now" (m-syn-b m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 2 sens-ct))
+ (ct-assert (= 2 plus-ct))
+
+ (ct-assert (= 3 (m-sens m)))
+ (trc "about to incf m-syn-a")
+ (incf (m-syn-a m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 2 sens-ct))
+ (trc "about to incf m-syn-factor")
+ (incf (m-syn-factor m))
+ (ct-assert (= 3 sens-ct))
+ (ct-assert (= (m-sens m) (* (m-syn-factor m) (m-syn-a m))))
+ (trc "about to incf m-syn-a xxx")
+ (incf (m-syn-a m))
+ (ct-assert (= 2 delta-ct))
+ (ct-assert (= 3 sens-ct))
+ (trc "about to incf m-syn-a yyyy")
+ (incf (m-syn-a m))
+ (ct-assert (= 3 delta-ct))
+ (ct-assert (= 4 sens-ct))
+ (ct-assert (= 2 plus-ct))
+ (describe m)
+ (print '(start)))))
+
+(Def-c-output m-syn-a ()
+ (trc "!!! M-SYN-A now =" new-value))
+
+#+(or)
+(m-syn)
+
Added: dependencies/trunk/cells/test.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/test.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,228 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+#| Synapse Cell Unification Notes
+
+- start by making Cells synapse-y
+
+- make sure outputs show right old and new values
+- make sure outputs fire when they should
+
+- wow: test the Cells II dictates: no output callback sees stale data, no rule
+sees stale data, etc etc
+
+- test a lot of different synapses
+
+- make sure they fire when they should, and do not when they should not
+
+- make sure they survive an evaluation by the caller which does not branch to
+them (ie, does not access them)
+
+- make sure they optimize away
+
+- test with forms which access multiple other cells
+
+- look at direct alteration of a caller
+
+- does SETF honor not propagating, as well as a c-ruled after re-calcing
+
+- do diff unchanged tests such as string-equal work
+
+|#
+
+#| do list
+
+-- can we lose the special handling of the .kids slot?
+
+-- test drifters (and can they be handled without creating a special
+subclass for them?)
+
+|#
+
+(eval-when (compile load)
+ (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))))
+
+(in-package :cells)
+
+(defvar *cell-tests* nil)
+
+
+#+go
+(test-cells)
+
+(defun test-cells ()
+ (loop for test in (reverse *cell-tests*)
+ do (cell-test-init test)
+ (funcall test)))
+
+(defun cell-test-init (name)
+ (print (make-string 40 :initial-element #\!))
+ (print `(starting test ,name))
+ (print (make-string 40 :initial-element #\!))
+ (cell-reset))
+
+(defmacro def-cell-test (name &rest body)
+ `(progn
+ (pushnew ',name *cell-tests*)
+ (defun ,name ()
+ (cell-reset)
+ , at body)))
+
+(defmacro ct-assert (form &rest stuff)
+ `(progn
+ (print `(attempting ,',form))
+ (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff))))
+
+;; test huge number of useds by one rule
+
+(defmodel m-index (family)
+ ()
+ (:default-initargs
+ :value (c? (bwhen (ks (^kids))
+ (apply '+ (mapcar 'value ks))))))
+
+(def-cell-test many-useds
+ (let ((i (make-instance 'm-index)))
+ (loop for n below 100
+ do (push (make-instance 'model
+ :value (c-in n))
+ (kids i)))
+ (trc "index total" (value i))))
+
+(defmodel m-null ()
+ ((aa :initform nil :cell nil :initarg :aa :accessor aa)))
+
+(def-cell-test m-null
+ (let ((m (make-be 'm-null :aa 42)))
+ (ct-assert (= 42 (aa m)))
+ (ct-assert (= 21 (decf (aa m) 21)))
+ :okay-m-null))
+
+(defmodel m-solo ()
+ ((m-solo-a :initform nil :initarg :m-solo-a :accessor m-solo-a)
+ (m-solo-b :initform nil :initarg :m-solo-b :accessor m-solo-b)))
+
+(def-cell-test m-solo
+ (let ((m (make-be 'm-solo
+ :m-solo-a (c-in 42)
+ :m-solo-b (c? (* 2 (^m-solo-a))))))
+ (ct-assert (= 42 (m-solo-a m)))
+ (ct-assert (= 84 (m-solo-b m)))
+ (decf (m-solo-a m))
+ (ct-assert (= 41 (m-solo-a m)))
+ (ct-assert (= 82 (m-solo-b m)))
+ :okay-m-null))
+
+(defmodel m-var ()
+ ((m-var-a :initform nil :initarg :m-var-a :accessor m-var-a)
+ (m-var-b :initform nil :initarg :m-var-b :accessor m-var-b)))
+
+(def-c-output m-var-b ()
+ (print `(output m-var-b ,self ,new-value ,old-value)))
+
+(def-cell-test m-var
+ (let ((m (make-be 'm-var :m-var-a (c-in 42) :m-var-b 1951)))
+ (ct-assert (= 42 (m-var-a m)))
+ (ct-assert (= 21 (decf (m-var-a m) 21)))
+ (ct-assert (= 21 (m-var-a m)))
+ :okay-m-var))
+
+(defmodel m-var-output ()
+ ((cbb :initform nil :initarg :cbb :accessor cbb)
+ (aa :cell nil :initform nil :initarg :aa :accessor aa)))
+
+(def-c-output cbb ()
+ (trc "output cbb" self)
+ (setf (aa self) (- new-value (if old-value-boundp
+ old-value 0))))
+
+(def-cell-test m-var-output
+ (let ((m (make-be 'm-var-output :cbb (c-in 42))))
+ (ct-assert (eql 42 (cbb m)))
+ (ct-assert (eql 42 (aa m)))
+ (ct-assert (eql 27 (decf (cbb m) 15)))
+ (ct-assert (eql 27 (cbb m)))
+ (ct-assert (eql -15 (aa m)))
+ (list :okay-m-var (aa m))))
+
+(defmodel m-var-linearize-setf ()
+ ((ccc :initform nil :initarg :ccc :accessor ccc)
+ (ddd :initform nil :initarg :ddd :accessor ddd)))
+
+(def-c-output ccc ()
+ (with-deference
+ (setf (ddd self) (- new-value (if old-value-boundp
+ old-value 0)))))
+
+(def-cell-test m-var-linearize-setf
+ (let ((m (make-be 'm-var-linearize-setf
+ :ccc (c-in 42)
+ :ddd (c-in 1951))))
+
+ (ct-assert (= 42 (ccc m)))
+ (ct-assert (= 42 (ddd m)))
+ (ct-assert (= 27 (decf (ccc m) 15)))
+ (ct-assert (= 27 (ccc m)))
+ (ct-assert (= -15 (ddd m)))
+ :okay-m-var))
+
+;;; -------------------------------------------------------
+
+(defmodel m-ruled ()
+ ((eee :initform nil :initarg :eee :accessor eee)
+ (fff :initform (c? (floor (^ccc) 2)) :initarg :fff :accessor fff)))
+
+(def-c-output eee ()
+ (print `(output> eee ,new-value old ,old-value)))
+
+(def-c-output fff ()
+ (print `(output> eee ,new-value old ,old-value)))
+
+(def-cell-test m-ruled
+ (let ((m (make-be 'm-ruled
+ :eee (c-in 42)
+ :fff (c? (floor (^eee) 2)))))
+ (trc "___Initial TOBE done____________________")
+ (print `(pulse ,*data-pulse-id*))
+ (ct-assert (= 42 (eee m)))
+ (ct-assert (= 21 (fff m)))
+ (ct-assert (= 36 (decf (eee m) 6)))
+ (print `(pulse ,*data-pulse-id*))
+ (ct-assert (= 36 (eee m)))
+ (ct-assert (= 18 (fff m)) m)
+ :okay-m-ruled))
+
+(defmodel m-worst-case ()
+ ((wc-x :accessor wc-x :initform (c-input () 2))
+ (wc-a :accessor wc-a :initform (c? (when (oddp (wc-x self))
+ (wc-c self))))
+ (wc-c :accessor wc-c :initform (c? (evenp (wc-x self))))
+ (wc-h :accessor wc-h :initform (c? (or (wc-c self)(wc-a self))))))
+
+(def-cell-test m-worst-case
+ (let ((m (make-be 'm-worst-case)))
+ (trc "___Initial TOBE done____________________")
+ (ct-assert (eql t (wc-c m)))
+ (ct-assert (eql nil (wc-a m)))
+ (ct-assert (eql t (wc-h m)))
+ (ct-assert (eql 3 (incf (wc-x m))))))
+
Added: dependencies/trunk/cells/trc-eko.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/trc-eko.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,170 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ The Newly Cells-aware TRC trace and EKO value echo facilities
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+;----------- trc -------------------------------------------
+(defparameter *last-trc* (get-internal-real-time))
+(defparameter *trcdepth* 0)
+
+(defun trcdepth-reset ()
+ (setf *trcdepth* 0))
+
+(defmacro trc (tgt-form &rest os)
+ (if (eql tgt-form 'nil)
+ '(progn)
+ (if (stringp tgt-form)
+ `(without-c-dependency
+ (call-trc t ,tgt-form , at os))
+ (let ((tgt (gensym)))
+ ;(break "slowww? ~a" tgt-form)
+ `(without-c-dependency
+ (bif (,tgt ,tgt-form)
+ (if (trcp ,tgt)
+ (progn
+ (assert (stringp ,(car os)) () "trc with test expected string second, got ~a" ,(car os))
+ (call-trc t , at os)) ;;,(car os) ,tgt ,@(cdr os)))
+ (progn
+ ;(trc "trcfailed")
+ (count-it :trcfailed)))
+ (count-it :tgtnileval)))))))
+
+(defun call-trc (stream s &rest os)
+ ;(break)
+ (if #+cormanlisp nil #-cormanlisp (and (boundp '*trcdepth*)
+ *trcdepth*)
+ (format stream "~&~v,,,'.<~d~>> " (mod *trcdepth* 100) *trcdepth*)
+ (format stream "~&"))
+ ;;(format stream " ~a " (round (- (get-internal-real-time) *last-trc*) 10))
+ (setf *last-trc* (get-internal-real-time))
+ (format stream "~a" s)
+ (let (pkwp)
+ (dolist (o os)
+ (format stream (if pkwp " ~(~s~)" " ~(~s~)") o) ;; save, used to insert divider, trcx dont like
+ (setf pkwp (keywordp o))))
+ (force-output stream)
+ (values))
+
+(export! brk brkx .bgo bgo)
+
+(define-symbol-macro .bgo
+ #+gimme-a-break (break "go")
+ #-gimme-a-break nil)
+
+(defmacro bgo (msg)
+ (declare (ignorable msg))
+ #+gimme-a-break `(break "BGO ~a" ',msg)
+ #-gimme-a-break `(progn))
+
+(defmacro brkx (msg)
+ (declare (ignorable msg))
+ #+gimme-a-break `(break "At ~a: OK?" ',msg)
+ #-gimme-a-break `(progn))
+
+(defmacro trcx (tgt-form &rest os)
+ (if (eql tgt-form 'nil)
+ '(progn)
+ `(without-c-dependency
+ (call-trc t ,(format nil "TX> ~(~s~)" tgt-form)
+ ,@(loop for obj in (or os (list tgt-form))
+ nconcing (list (intern (format nil "~a" obj) :keyword) obj))))))
+
+(defun call-trc-to-string (fmt$ &rest fmt-args)
+ (let ((o$ (make-array '(0) :element-type 'base-char
+ :fill-pointer 0 :adjustable t)))
+ (with-output-to-string (os-stream o$)
+ (apply 'call-trc os-stream fmt$ fmt-args))
+ o$))
+
+#+findtrcevalnils
+(defmethod trcp :around (other)
+ (unless (call-next-method other)(break)))
+
+(defmethod trcp (other)
+ (eq other t))
+
+(defmethod trcp (($ string))
+ t)
+
+(defun trcdepth-incf ()
+ (incf *trcdepth*))
+
+(defun trcdepth-decf ()
+ (format t "decrementing trc depth ~d" *trcdepth*)
+ (decf *trcdepth*))
+
+(defmacro wtrc ((&optional (min 1) (max 50) &rest banner) &body body )
+ `(let ((*trcdepth* (if *trcdepth*
+ (1+ *trcdepth*)
+ 0)))
+ ,(when banner `(when (>= *trcdepth* ,min)
+ (if (< *trcdepth* ,max)
+ (trc , at banner)
+ (progn
+ (break "excess trace notttt!!! ~d" *trcdepth*) ;; , at banner)
+ nil))))
+ (when (< *trcdepth* ,max)
+ , at body)))
+
+(defmacro wtrcx ((&key (min 1) (max 50) (on? t))(&rest banner) &body body )
+ `(let ((*trcdepth* (if *trcdepth*
+ (1+ *trcdepth*)
+ 0)))
+ ,(when banner `(when (and ,on? (>= *trcdepth* ,min))
+ (if (< *trcdepth* ,max)
+ (trc , at banner)
+ (progn
+ (break "excess trace notttt!!! ~d" *trcdepth*) ;; , at banner)
+ nil))))
+ (when (< *trcdepth* ,max)
+ , at body)))
+
+(defmacro wnotrc ((&optional (min 1) (max 50) &rest banner) &body body )
+ (declare (ignore min max banner))
+ `(progn , at body))
+
+;------ eko --------------------------------------
+
+(defmacro eko ((&rest trcargs) &rest body)
+ (let ((result (gensym)))
+ `(let ((,result , at body))
+ ,(if (stringp (car trcargs))
+ `(trc ,(car trcargs) :=> ,result ,@(cdr trcargs))
+ `(trc ,(car trcargs) ,(cadr trcargs) :=> ,result ,@(cddr trcargs)))
+ ,result)))
+
+(defmacro ekx (ekx-id &rest body)
+ (let ((result (gensym)))
+ `(let ((,result (, at body)))
+ (trc ,(string-downcase (symbol-name ekx-id)) :=> ,result)
+ ,result)))
+
+(defmacro eko-if ((&rest trcargs) &rest body)
+ (let ((result (gensym)))
+ `(let ((,result , at body))
+ (when ,result
+ (trc ,(car trcargs) :res ,result ,@(cdr trcargs)))
+ ,result)))
+
+(defmacro ek (label &rest body)
+ (let ((result (gensym)))
+ `(let ((,result (, at body)))
+ (when ,label
+ (trc ,label ,result))
+ ,result)))
+
Added: dependencies/trunk/cells/tutorial/01-lesson.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/01-lesson.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,40 @@
+(defmacro cells::ct-assert (form &rest stuff)
+ `(progn
+ (print `(attempting ,',form))
+ (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff))))
+
+(defpackage #:tu-selfinit (:use :cl :cells))
+
+;;
+;; We will keep making new packages so we can incrementally develop the
+;; same class without newer versions stomping on earlier versions (by
+;; being in the same package and effectively redefining earlier versions).
+;;
+(in-package #:tu-selfinit)
+
+(defmodel rectangle ()
+ ((len :initarg :len :accessor len
+ :initform (c? (* 2 (width self))))
+ (width :initarg :width :initform nil :accessor width))
+ (:default-initargs
+ :width (c? (/ (len self) 2))))
+
+#+test
+(cells::ct-assert (eql 21 (width (make-instance 'rectangle :len 42))))
+
+;;; The first thing we see is that we are not creating something new, we are
+;;; merely /extending/ CLOS. defmodel works like defclass in all ways, except for
+;;; extensions to provide the behavior of Cells. We see both :initform
+;;; and :default-initarg used to provide rules for a slot. We also see
+;;; the initarg :len used to override the default initform.
+;;;
+;;; By extending defclass we (a) retain its expressiveness, and (b) produce
+;;; something hopefully easier to learn by developers already familiar with CLOS.
+;;;
+;;; The first extension we see is that the len initform refers to the
+;;; Smalltalk-like anaphoric variable self, to which will be bound
+;;; the rectangle instance being initialized. Normally an initform is evaluated
+;;; without being able to see the instance, and any initialization requiring
+;;; that must be done in the class initializer.
+
+
Added: dependencies/trunk/cells/tutorial/01a-dataflow.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/01a-dataflow.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,17 @@
+(defpackage #:tu-dataflow (:use :cl :cells))
+(in-package #:tu-dataflow)
+
+(defmodel rectangle ()
+ ((len :initarg :len :accessor len
+ :initform (c? (* 2 (width self))))
+ (width :initarg :width :initform nil :accessor width))
+ (:default-initargs
+ :width (c? (/ (len self) 2))))
+
+#+test
+(let ((r (make-instance 'rectangle :len (c-in 42))))
+ (cells::ct-assert (eql 21 (width r)))
+ (cells::ct-assert (= 1000 (setf (len r) 1000))) ;; make sure we did not break SETF, which must return the value set
+ (cells::ct-assert (eql 500 (width r)))) ;; make sure new value propagated
+
+
Added: dependencies/trunk/cells/tutorial/01b-change-handling.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/01b-change-handling.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,36 @@
+#| There is the fun part: automatic state management. Not only can a slot get its value from
+a self-aware rule, but that value will stay current with other values as they change.
+
+But often changes to a value must be reflected outside the automatic dataflow model. See next.
+
+|#
+
+(defpackage #:tu-change-handling (:use :cl :cells))
+(in-package #:tu-change-handling)
+
+(defmodel rectangle ()
+ ((len :initarg :len :accessor len
+ :initform (c? (* 2 (width self))))
+ (width :initarg :width :initform nil :accessor width))
+ (:default-initargs
+ :width (c? (/ (len self) 2))))
+
+(defvar *gui-told*)
+
+(defobserver len ((self rectangle) new-value old-value old-value-bound-p)
+ ;; Where rectangle is a GUI element, we need to tell the GUI framework
+ ;; to update this area of the screen
+ (setf *gui-told* t)
+ (print (list "tell GUI about" self new-value old-value old-value-bound-p)))
+
+#+test
+(let* ((*gui-told* nil)
+ (r (make-instance 'rectangle :len (c-in 42))))
+ (cells::ct-assert *gui-told*)
+ (setf *gui-told* nil)
+ (cells::ct-assert (eql 21 (width r)))
+
+ (cells::ct-assert (= 1000 (setf (len r) 1000)))
+ (cells::ct-assert *gui-told*)
+ (cells::ct-assert (eql 500 (width r))))
+
Added: dependencies/trunk/cells/tutorial/01c-cascade.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/01c-cascade.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,94 @@
+#|
+
+Now we have automatic state management (including change propagation)
+outside the Cells model as well as in. Now lets look at cascading change
+by adding another level of computation, so A->B->C.
+
+In this case: len->area->brightness
+Also: len->width->area->brightness
+
+That leads to some complications I will discuss, but no assertions here
+enforce correct behavior in re those complications. Soon. :)
+
+|#
+
+(defpackage #:tu-depth (:use :cl :cells))
+(in-package #:tu-depth)
+
+(defmacro start-finish (key rule)
+ `(progn
+ (print (list :start ,key))
+ (prog1
+ (progn ,rule)
+ (print (list :finish ,key)))))
+
+(defmodel rectangle ()
+ ((lumens :initform 1000000 :reader lumens)
+ (len :initarg :len :accessor len
+ :initform (c? (start-finish :len
+ (* 2 (width self)))))
+ (area :initarg :area :accessor area
+ :initform (c? (start-finish :area
+ (* (len self)(width self)))))
+ (width :initarg :width :accessor width
+ :initform (c? (start-finish :width
+ (floor (len self) 2))))
+ (brightness :reader brightness
+ :initform (c? (start-finish :brightness
+ (/ (^lumens) (^area)))))
+ ))
+
+#+test
+(let ((r (make-instance 'rectangle :len (c-in 100))))
+ (cells::ct-assert (eql 50 (width r)))
+ (cells::ct-assert (eql 5000 (area r)))
+ (cells::ct-assert (eql 200 (brightness r)))
+ (cells::ct-assert (= 1000 (setf (len r) 1000)))
+ (cells::ct-assert (eql 500000 (area r)))
+ (cells::ct-assert (eql 2 (brightness r))))
+
+#| --- discussion ----------------------------
+
+The output in Cells is:
+
+(:START :AREA)
+(:START :WIDTH)
+(:finish :WIDTH)
+(:finish :AREA)
+(:START :BRIGHTNESS)
+(:finish :BRIGHTNESS)
+(CELTK::ATTEMPTING (EQL 50 (WIDTH R)))
+(CELTK::ATTEMPTING (EQL 5000 (AREA R)))
+(CELTK::ATTEMPTING (EQL 200 (BRIGHTNESS R)))
+(CELTK::ATTEMPTING (= 1000 (SETF (LEN R) 1000)))
+0> c-propagate-to-users > notifying users of | [i :=[24]LEN/#] | (AREA WIDTH)
+
+Notice here that the LEN cell is about to tell both the width and area to recalculate,
+since area depends (of course) on len and (rather artificially) width also derives
+from LEN.
+
+ie, This example has accidentally deviated into more complexity than intended. But we are
+approaching these issues anyay, so I will leave it for now. We can always break it up
+later.
+
+Let's continue:
+
+(:START :WIDTH)
+(:finish :WIDTH)
+(:START :AREA)
+(:finish :AREA)
+
+Fine, now here comes the challenge. Width is also going to tell area to recalculate:
+
+0> c-propagate-to-users > notifying users of | [? :=[24]WIDTH/#] | (AREA)
+0> c-propagate-to-users > notifying users of | [? :=[24]AREA/#] | (BRIGHTNESS)
+
+Correct: Area does not actually run its rule since it already did so when notified by LEN,
+ but it does propagate to brightness.
+
+(:START :BRIGHTNESS)
+(:finish :BRIGHTNESS)
+(CELTK::ATTEMPTING (EQL 500000 (AREA R)))
+(CELTK::ATTEMPTING (EQL 2 (BRIGHTNESS R)))
+
+|#
\ No newline at end of file
Added: dependencies/trunk/cells/tutorial/02-lesson.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/02-lesson.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,63 @@
+#| A->B->C works. For efficiency, let's have propagation stop if some rule
+computes the same value as last time.
+|#
+
+(defpackage #:tu-smart-propagation (:use :cl :cells :utils-kt :tu-cells))
+(in-package #:tu-smart-propagation)
+
+
+;;; -----------------------------------------------
+
+(defmodel rectangle ()
+ ((padded-width :initarg :padded-width :accessor padded-width
+ :initform (c? (compute-log :padded-width)
+ (+ 10 (width self))))
+ (len :initarg :len :accessor len
+ :initform (c? (compute-log :len)
+ (* 2 (width self))))
+ (width :initarg :width :accessor width
+ :initform (c? (compute-log :width)
+ (floor (len self) 2)))))
+
+(defobserver width ()
+ (assert (not (eql new-value old-value)))
+ (TRC "observing width" new-value old-value)
+ (compute-log :width-observer))
+
+(defobserver len ()
+ (compute-log :len-observer))
+
+#+test
+(let* ((r (progn
+ (CELLS-RESET)
+ (clear-computed)
+ (make-instance 'rectangle :len (c-in 42)))))
+ (cells::ct-assert (eql 21 (width r)))
+
+ ;; first check that setting an input cell does not
+ ;; propagate needlessly...
+
+ (clear-computed)
+ (verify-not-computed :len-observer :width :width-observer :padded-width)
+ (setf (len r) 42) ;; n.b. same as existing value, no change
+ (cells::ct-assert (eql 21 (width r))) ;; floor truncates
+ (verify-not-computed :len-observer :width :width-observer :padded-width)
+
+ ;; now check that intermediate computations, when unchanged
+ ;; from the preceding computation, does not propagate needlessly...
+
+ (clear-computed)
+ (setf (len r) 43)
+ (cells::ct-assert (eql 21 (width r))) ;; floor truncates
+ (verify-computed :len-observer :width)
+ (verify-not-computed :width-observer :padded-width)
+
+ #| Ok, so the engine runs the width rule, sees that it computes
+the same value as before, so does not invoke either the width
+observer or recalculation of are. Very efficient. The sanity check
+reconfirms that the engine does do that work when necessary.
+|#
+
+ (clear-computed)
+ (setf (len r) 44)
+ (verify-computed :len-observer :width :width-observer :padded-width))
Added: dependencies/trunk/cells/tutorial/03-ephemeral.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/03-ephemeral.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,85 @@
+
+
+(defpackage #:tu-ephemeral (:use :cl :utils-kt :cells :tu-cells))
+(in-package #:tu-ephemeral)
+
+
+#|
+
+Events present a problem for spreadsheet models. Suppose we have a clicked rule for a button
+which says:
+
+ :clicked (c? (point-in-rect
+ (screen-location (mouse-event *window*))
+ (bounding-box self)))
+
+Now suppose we get a mouse-event outside the bounding box of widget X, and then in the
+next application event something happens that makes the bounding box grow such that it
+includes the location of the old mouse event. We need the mouse-event not to be there any more,
+because, well, events are events. It is relevant only in the moment of its creation and propagation.
+
+Note, btw, that this must happen not as bang-bang:
+
+ (setf (mouse-event *window*) (get-next-event)
+ (setf (mouse-event *window*) nil)
+
+...because observers can kick off state change, and anyway SETF has interesting Cell semantics,
+including observers firing. So setf-nil is a kludge, better that the Cells engine acknowledge that
+events are different and accomodate them by silently reverting an event to nil as soon as it finishes
+propagating.
+
+Finally, so far this has worked out well as a slot attribute as defined at the class level, not
+instance by instance, by specifying :cell :ephemeral
+
+|#
+
+(defmodel rectangle ()
+ ((click :cell :ephemeral :initform (c-in nil) :accessor click)
+ (bbox :initarg :bbox :initform (c-in nil) :accessor bbox)
+ (clicked :cell :ephemeral :accessor clicked
+ :initform (c? (point-in-rect (^click)(^bbox))))))
+
+(defun point-in-rect (p r)
+ (when (and p r)
+ (destructuring-bind (x y) p
+ (destructuring-bind (l top r b) r
+ (and (<= l x r)
+ (<= b y top))))))
+
+(defobserver click ((self rectangle) new-value old-value old-value-bound-p)
+ (when new-value
+ (with-integrity (:change)
+ (TRC "setting bbox!!!")
+ (setf (bbox self) (list -1000 1000 1000 -1000)))))
+
+(defobserver clicked ((self rectangle) new-value old-value old-value-bound-p)
+ (when new-value
+ (TRC "clicked!!!!" self new-value)
+ (compute-log :clicked)))
+
+#+test
+(progn
+ (cells-reset)
+ (let* ((starting-bbox (list 10 10 20 20))
+ (r (make-instance 'rectangle
+ :bbox (c-in (list 10 10 20 20)))))
+ (clear-computed)
+ (setf (click r) (list 0 0))
+ (assert (and (not (point-in-rect (list 0 0) starting-bbox))
+ (point-in-rect (list 0 0)(bbox r))
+ (verify-not-computed :clicked)))))
+
+#|
+The assertion demonstrates... well, it is complicated. Point 0-0 is
+in the current bbox, but the system correctly determines that it
+was not clicked. The click event at 0-0 happened when the bbox
+was elsewhwer. When the bbox moved, the Cells engine had already cleared
+the "ephemeral" click.
+
+Note that now we have less transparency: if one wants to perturb the data model
+from with an observer of some ongoing perturbation, one needs to arrange for
+that nested perturbation to wait until the ongoing one completes. That
+explains the "with-integrity" macro.
+
+|#
+
\ No newline at end of file
Added: dependencies/trunk/cells/tutorial/04-formula-once-then-input.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/04-formula-once-then-input.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,48 @@
+
+
+(defpackage #:tu-rule-once-then-input (:use :cl :utils-kt :cells :tu-cells))
+(in-package #:tu-rule-once-then-input)
+
+
+#|
+
+Often in interactive applications one needs to do interesting things to come up
+with an initial value for a field which then is to be edited by a user, or
+for some other reason regularly fed as a C-INPUT.
+
+|#
+
+(defvar *db-entry*)
+
+(defun get-age (id)
+ (bwhen (props (cdr (assoc id *db-entry* :test 'string=)))
+ (getf props :age)))
+
+(defmodel kenny-view ()
+ ((age :accessor age :initform (c-formula (:inputp t)
+ (- (get-age "555-55-5555")
+ (^grecian-formula-amt))))
+ (grecian-formula-amt :accessor grecian-formula-amt
+ :initform (c-in 5))))
+
+(defobserver age ((self kenny-view))
+ (setf (getf (cdr (assoc "555-55-5555" *db-entry* :test 'string=)) :age) new-value))
+
+#+test
+(let ((*db-entry* (copy-list '(("555-55-5555" . (:name "ken" :age 54))
+ ("666-66-6666" . (:name "satan" :age most-positive-fixnum))))))
+ (cells-reset)
+ (let ((kv (make-instance 'kenny-view)))
+ (print `(:age-init ,(age kv)))
+ (assert (= 49 (age kv)))
+
+ (incf (grecian-formula-amt kv) 10) ;; try looking younger
+ (assert (= 15 (grecian-formula-amt kv)))
+
+ (assert (= 49 (age kv))) ;; unchanged -- the age rule is gone
+
+ (print `(:happy-birthday ,(incf (age kv))))
+ (assert (= 50 (age kv)(get-age "555-55-5555")))
+ ;
+ ; just showin' off...
+ (assert (= 51 (1+ (age kv))(incf (age kv))(get-age "555-55-5555")))))
\ No newline at end of file
Added: dependencies/trunk/cells/tutorial/test.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/test.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,52 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+;;;
+;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
+;;;
+;;; Permission is hereby granted, free of charge, to any person obtaining a copy
+;;; of this software and associated documentation files (the "Software"), to deal
+;;; in the Software without restriction, including without limitation the rights
+;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+;;; copies of the Software, and to permit persons to whom the Software is furnished
+;;; to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be included in
+;;; all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
+;;; IN THE SOFTWARE.
+
+(eval-when (compile load)
+ (proclaim '(optimize (speed 2) (safety 3) (space 1) (debug 3))))
+
+(defpackage #:tu-cells
+ (:use :cl :utils-kt)
+ (:export #:clear-computed #:verify-computed #:verify-not-computed #:compute-log))
+
+(in-package :tu-cells)
+
+(defmacro ct-assert (form &rest stuff)
+ `(progn
+ (print `(attempting ,',form))
+ (assert ,form () "Error with ~a >> ~a" ',form (list , at stuff))))
+
+(defvar *computed*)
+(defun clear-computed ()
+ (setf *computed* nil))
+
+(defun compute-log (&rest keys)
+ (loop for k in keys
+ do (pushnew k *computed*)))
+
+(defun verify-computed (&rest keys)
+ (loop for k in keys
+ do (assert (find k *computed*)() "Unable verify ~a computed: ~a" k *computed*)))
+
+(defun verify-not-computed (&rest keys)
+ (loop for k in keys
+ do (assert (not (find k *computed*)) () "Unable verify ~a NOT computed: ~a" k *computed*)
+ finally (return t)))
\ No newline at end of file
Added: dependencies/trunk/cells/tutorial/tutorial.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/tutorial/tutorial.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,95 @@
+;; -*- lisp-version: "8.0 [Windows] (May 22, 2006 0:51)"; cg: "1.81"; -*-
+
+(in-package :cg-user)
+
+(defpackage :TU-CELLS)
+
+(define-project :name :tutorial
+ :modules (list (make-instance 'module :name "test.lisp")
+ (make-instance 'module :name "01-lesson.lisp")
+ (make-instance 'module :name "01a-dataflow.lisp")
+ (make-instance 'module :name
+ "01b-change-handling.lisp")
+ (make-instance 'module :name "01c-cascade.lisp")
+ (make-instance 'module :name "02-lesson.lisp")
+ (make-instance 'module :name "03-ephemeral.lisp")
+ (make-instance 'module :name
+ "04-formula-once-then-input.lisp")
+ (make-instance 'module :name "05-class-cell.lisp")
+ (make-instance 'module :name
+ "..\\gotchas\\lost-ephemeral-init.lisp")
+ (make-instance 'module :name "chat-cells.lisp")
+ (make-instance 'module :name "df-interference.lisp"))
+ :projects (list (make-instance 'project-module :name "..\\cells"))
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :tu-cells
+ :main-form nil
+ :compilation-unit t
+ :verbose nil
+ :runtime-modules '(:cg-dde-utils :cg.base :cg.bitmap-pane
+ :cg.bitmap-pane.clipboard :cg.bitmap-stream
+ :cg.button :cg.caret :cg.check-box :cg.choice-list
+ :cg.choose-printer :cg.clipboard
+ :cg.clipboard-stack :cg.clipboard.pixmap
+ :cg.color-dialog :cg.combo-box :cg.common-control
+ :cg.comtab :cg.cursor-pixmap :cg.curve
+ :cg.dialog-item :cg.directory-dialog
+ :cg.directory-dialog-os :cg.drag-and-drop
+ :cg.drag-and-drop-image :cg.drawable
+ :cg.drawable.clipboard :cg.dropping-outline
+ :cg.edit-in-place :cg.editable-text
+ :cg.file-dialog :cg.fill-texture
+ :cg.find-string-dialog :cg.font-dialog
+ :cg.gesture-emulation :cg.get-pixmap
+ :cg.get-position :cg.graphics-context
+ :cg.grid-widget :cg.grid-widget.drag-and-drop
+ :cg.group-box :cg.header-control :cg.hotspot
+ :cg.html-dialog :cg.html-widget :cg.icon
+ :cg.icon-pixmap :cg.ie :cg.item-list
+ :cg.keyboard-shortcuts :cg.lamp :cg.lettered-menu
+ :cg.lisp-edit-pane :cg.lisp-text :cg.lisp-widget
+ :cg.list-view :cg.mci :cg.menu :cg.menu.tooltip
+ :cg.message-dialog :cg.multi-line-editable-text
+ :cg.multi-line-lisp-text :cg.multi-picture-button
+ :cg.multi-picture-button.drag-and-drop
+ :cg.multi-picture-button.tooltip :cg.ocx
+ :cg.os-widget :cg.os-window :cg.outline
+ :cg.outline.drag-and-drop
+ :cg.outline.edit-in-place :cg.palette
+ :cg.paren-matching :cg.picture-widget
+ :cg.picture-widget.palette :cg.pixmap
+ :cg.pixmap-widget :cg.pixmap.file-io
+ :cg.pixmap.printing :cg.pixmap.rotate :cg.printing
+ :cg.progress-indicator :cg.project-window
+ :cg.property :cg.radio-button :cg.rich-edit
+ :cg.rich-edit-pane :cg.rich-edit-pane.clipboard
+ :cg.rich-edit-pane.printing :cg.sample-file-menu
+ :cg.scaling-stream :cg.scroll-bar
+ :cg.scroll-bar-mixin :cg.selected-object
+ :cg.shortcut-menu :cg.static-text :cg.status-bar
+ :cg.string-dialog :cg.tab-control
+ :cg.template-string :cg.text-edit-pane
+ :cg.text-edit-pane.file-io :cg.text-edit-pane.mark
+ :cg.text-or-combo :cg.text-widget :cg.timer
+ :cg.toggling-widget :cg.toolbar :cg.tooltip
+ :cg.trackbar :cg.tray :cg.up-down-control
+ :cg.utility-dialog :cg.web-browser
+ :cg.web-browser.dde :cg.wrap-string
+ :cg.yes-no-list :cg.yes-no-string :dde)
+ :splash-file-module (make-instance 'build-module :name "")
+ :icon-file-module (make-instance 'build-module :name "")
+ :include-flags '(:top-level :debugger)
+ :build-flags '(:allow-runtime-debug :purify)
+ :autoload-warning t
+ :full-recompile-for-runtime-conditionalizations nil
+ :default-command-line-arguments "+M +t \"Console for Debugging\""
+ :additional-build-lisp-image-arguments '(:read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :on-initialization 'tu-cells::tu-chat-2
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/utils-kt/core.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/core.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,74 @@
+#|
+
+ Utils-kt core
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :utils-kt)
+
+
+
+(defmacro with-gensyms ((&rest symbols) &body body)
+ `(let ,(loop for sym in symbols
+ collecting `(,sym (gensym ,(string sym))))
+ , at body))
+
+(defmacro eval-now! (&body body)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ , at body))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defmacro export! (&rest symbols)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export ',symbols))))
+
+(eval-now!
+ (defmacro define-constant (name value &optional docstring)
+ "Define a constant properly. If NAME is unbound, DEFCONSTANT
+it to VALUE. If it is already bound, and it is EQUAL to VALUE,
+reuse the SYMBOL-VALUE of NAME. Otherwise, DEFCONSTANT it again,
+resulting in implementation-specific behavior."
+ `(defconstant ,name
+ (if (not (boundp ',name))
+ ,value
+ (let ((value ,value))
+ (if (equal value (symbol-value ',name))
+ (symbol-value ',name)
+ value)))
+ ,@(when docstring (list docstring)))))
+
+(defun test-setup (&optional drib)
+ #+(and allegro ide (or (not its-alive!) debugging-alive!))
+ (ide.base::find-new-prompt-command
+ (cg.base::find-window :listener-frame))
+ (when drib
+ (dribble (merge-pathnames
+ (make-pathname :name drib :type "TXT")
+ (project-path)))))
+
+(export! test-setup test-prep test-init)
+(export! project-path)
+(defun project-path ()
+ #+(and allegro ide (not its-alive!))
+ (excl:path-pathname (ide.base::project-file ide.base:*current-project*))
+ )
+
+#+test
+(test-setup)
+
+(defun test-prep (&optional drib)
+ (test-setup drib))
+
+(defun test-init (&optional drib)
+ (test-setup drib))
\ No newline at end of file
Added: dependencies/trunk/cells/utils-kt/datetime.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/datetime.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,205 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cello; -*-
+#|
+
+ Utils-kt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+
+(in-package :utils-kt)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(os-tickcount time-of-day now hour-min-of-day
+ time-in-zone dd-mmm-yy mmm-dd-yyyy)))
+
+(defun os-tickcount ()
+ (cl:get-internal-real-time))
+
+(defun now ()
+ (/ (get-internal-real-time)
+ internal-time-units-per-second))
+
+(defun time-of-day (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~A:~2,,,'0 at A:~2,,,'0 at A" hours minutes seconds)))
+
+(defun hour-min-of-day (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~2,,,'0 at A:~2,,,'0 at A" hours minutes)))
+
+(defun time-in-zone (inzone &optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylightsavingsp this-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable this-zone day-of-week daylightsavingsp))
+ (encode-universal-time seconds minutes hours date month year (- inzone (if daylightsavingsp 1 0)))))
+
+(defun dd-mmm-yy (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~A-~A-~2,,,'0 at A" date (month-abbreviation month)
+ (mod year 100))))
+
+(defun mmm-dd-yyyy (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~A ~A, ~A" (month-abbreviation month)
+ date year)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(month-abbreviation weekday-abbreviation week-time
+ mdyy-yymd u-time u-date)))
+
+(defun month-abbreviation (month)
+ (elt '("Jan" "Feb" "Mar" "Apr" "May" "June"
+ "July" "Aug" "Sept" "Oct" "Nov" "Dec") (1- month)))
+
+(defun weekday-abbreviation (day)
+ (elt '("Mon" "Tue" "Wed" "Thur" "Fri" "Sat" "Sun") day))
+
+(defun week-time (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~A ~A ~A, ~A ~a:~2,'0d ~a"
+ (weekday-abbreviation day-of-week)
+ (month-abbreviation month)
+
+ date
+ year
+ (if (= 12 hours) hours (mod hours 12)) ; JP 010911 since (mod 12 12) = 0, treat 12 as a special case.
+ minutes (if (>= hours 12) "PM" "AM"))))
+
+
+(defun mdyy-yymd (d)
+ (assert (eql 8 (length d)))
+ (conc$ (right$ d 4) (left$ d 4)))
+
+(defun u-time (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~2,d:~2,'0d ~a"
+ ;; /// time-zone, really Naggum's stuff
+ (mod hours 12) minutes
+ (if (>= hours 12) "PM" "AM"))))
+
+(defun u-date (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~A-~A-~A"
+ date
+ (elt '("Jan" "Feb" "Mar" "Apr" "May" "June"
+ "July" "Aug" "Sept" "Oct" "Nov" "Dec") (1- month))
+ year
+ )))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(u-day multiple-value-bind m/d/y mm/dd yyyy-mm-dd)))
+
+(defun u-day (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (elt '("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday") day-of-week)))
+
+(defun u-day3 (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (elt '("Mon" "Tue" "Wed" "Thu" "Fri" "Sat" "Sun") day-of-week)))
+
+(defun m/d/y (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~2,,,'0 at A/~2,,,'0 at A/~2,,,'0 at A" month date (mod year 100))))
+
+(defun mm/dd (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~2,,,'0 at A/~2,,,'0 at A" month date)))
+
+(defun yyyy-mm-dd (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~4,,,'0 at A~2,,,'0 at A~2,,,'0 at A"
+ year month date)))
+
+(eval-now!
+ (export '(ymdhmsh)))
+
+(defun ymdhmsh (&optional (i-time (get-universal-time)))
+ (multiple-value-bind
+ (seconds minutes hours date month year day-of-week daylight-saving-time-p time-zone)
+ (decode-universal-time i-time)
+ (declare (ignorable seconds minutes hours date
+ month year day-of-week
+ daylight-saving-time-p time-zone))
+ (format nil "~4,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A:~2,,,'0 at A"
+ year month date hours minutes seconds (floor (* 10 (mod (now) 1.0))))))
+
+(defun hyphenated-time-string ()
+ (substitute #\- #\: (ymdhmsh)))
+
+#+test
+(hyphenated-time-string)
+
+#+test
+(ymdhmsh)
\ No newline at end of file
Added: dependencies/trunk/cells/utils-kt/debug.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/debug.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,150 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
+;;;
+#|
+
+ Utils-kt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+
+(in-package :utils-kt)
+
+
+(defvar *count* nil)
+(defvar *counting* nil)
+(defvar *dbg*)
+(defvar *stop* nil)
+
+(defun utils-kt-reset ()
+ (clock-off :ukt-reset)
+ (setf *count* nil
+ *stop* nil
+ *dbg* nil)
+
+ (print "----------UTILSRESET----------------------------------"))
+
+;------------- counting ---------------------------
+
+(defmacro with-counts ((onp &rest msg) &body body)
+ `(if ,onp
+ (let ((*counting* (cons t *counting*)))
+ (prog2
+ (count-clear nil , at msg)
+ (progn , at body)
+ (show-count t , at msg)))
+ (progn , at body)))
+
+(defun count-of (key)
+ (cdr (assoc key *count* :key 'car)))
+
+(defun count-clear (announce &rest msg)
+ (declare (ignorable msg))
+ (when announce (format t "~&count-clear > ~a" msg))
+ (setf *count* nil))
+
+(defmacro count-it (&rest keys)
+ (declare (ignorable keys))
+ #+nahhh
+ `(progn)
+ `(when (car *counting*)
+ (call-count-it , at keys)))
+
+(export! count-it!)
+(defmacro count-it! (&rest keys)
+ (declare (ignorable keys))
+ #+(and its-alive! (not debugging-alive!))
+ `(progn)
+ #-(and its-alive! (not debugging-alive!))
+ `(when (car *counting*)
+ (call-count-it , at keys)))
+
+(defun call-count-it (&rest keys)
+ (declare (ignorable keys))
+ #+nahh (when (find (car keys) '(:trcfailed :TGTNILEVAL))
+ (break "clean up time ~a" keys))
+ (let ((entry (assoc keys *count* :test #'equal)))
+ (if entry
+ (setf (cdr entry) (1+ (cdr entry)))
+ (push (cons keys 1) *count*))))
+
+(defun show-count (clearp &rest msg &aux announced)
+
+ (let ((res (sort (copy-list *count*) (lambda (v1 v2)
+ (let ((v1$ (symbol-name (caar v1)))
+ (v2$ (symbol-name (caar v2))))
+ (if (string= v1$ v2$)
+ (< (cdr v1) (cdr v2))
+ (string< v1$ v2$))))))
+ )
+ (loop for entry in res
+ for occs = (cdr entry)
+ when (plusp occs)
+ sum occs into running
+ and do (unless announced
+ (setf announced t)
+ (format t "~&Counts after: clearp ~a, length ~d: ~s" clearp (length *count*) msg))
+ (format t "~&~4d ... ~2d ... ~(~{~a ~}~)" running occs (car entry))))
+ (when clearp (count-clear announced "show-count" )))
+
+;-------------------- timex ---------------------------------
+
+(export! timex)
+
+(defmacro timex ((onp &rest trcargs) &body body)
+ `(if ,onp
+ (prog2
+ (format t "~&Starting timing run of ~{ ~a~}" (list , at trcargs))
+ (time (progn , at body))
+ (format t "~&Above timing was of ~{ ~a~}" (list , at trcargs)))
+ (progn , at body)))
+
+#+save
+(defun dbg-time-report (cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes)
+ (format t "~&cpu-gc-user ~a" cpu-gc-user)
+ (format t "~&cpu-gc-sys ~a" cpu-gc-sys)
+ (format t "~&cpu-tot-user ~a" cpu-tot-user)
+ (format t "~&cpu-tot-sys ~a" cpu-tot-sys)
+ (format t "~& ~a" (- cpu-tot-user cpu-gc-user))
+ (format t "~& ~a" (- cpu-tot-sys cpu-gc-sys))
+ (format t "~&conses ~a" conses)
+ (format t "~&other-bytes ~a" other-bytes)
+ (format t "~&static-bytes ~a" static-bytes)
+ (excl::time-report cpu-gc-user cpu-gc-sys cpu-tot-user cpu-tot-sys real-time conses other-bytes static-bytes))
+
+;---------------- Metrics -------------------
+
+(defmacro with-metrics ((countp timep &rest trcargs) form-measured &body postlude)
+ `(with-counts (,countp , at trcargs)
+ (timex (,timep , at trcargs)
+ ,form-measured)
+ , at postlude))
+
+(defvar *clock*)
+
+(export! clock clock-0 clock-off)
+
+(defun clock-off (key)
+ (when (boundp '*clock*)
+ (print (list :clock-off key))
+ (makunbound '*clock*)))
+
+(defun clock-0 (key &aux (now (get-internal-real-time)))
+ (setf *clock* (cons now now))
+ (print (list :clock-initialized-by key)))
+
+(defun clock (&rest keys &aux (now (get-internal-real-time)))
+ (when (boundp '*clock*)
+ (print (list* :clock (- now (cdr *clock*)) :tot (- now (car *clock*)) :at keys))
+ (setf (cdr *clock*) now)))
+
Added: dependencies/trunk/cells/utils-kt/defpackage.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/defpackage.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,61 @@
+#|
+
+ Utils-kt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+
+(in-package :cl-user)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf *features* (remove :its-alive! *features*)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf *features* (pushnew :gimme-a-break *features*)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (setf *features* (remove :debugging-alive! *features*)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;;; #+(and its-alive! (not debugging-alive!))
+ ;;; (proclaim '(optimize (speed 3) (safety 1) (space 1) (debug 0)))
+ ;;; #-(and its-alive! (not debugging-alive!))
+ (proclaim '(optimize (speed 2) (safety 1) (space 1) (debug 3))))
+
+(defpackage :utils-kt
+ (:nicknames #:ukt)
+ (:use #:common-lisp
+ #+(or allegro lispworks clisp) #:clos
+ #+cmu #:mop
+ #+sbcl #:sb-mop
+ #+openmcl-partial-mop #:openmcl-mop
+ #+(and mcl (not openmcl-partial-mop)) #:ccl)
+ (:export
+ #:export!
+ #:utils-kt-reset
+ #:count-it #:count-of #:with-counts
+ #:wdbg #:maptimes #:bwhen #:bif #:xor
+ #:with-dynamic-fn #:last1 #:packed-flat! #:with-metrics
+ #:shortc
+ #:intern$
+ #:define-constant #:*count* #:*stop*
+ #:*dbg*
+ #:with-gensyms
+ #:make-fifo-queue #:fifo-queue #:fifo-add #:fifo-delete
+ #:fifo-empty #:fifo-pop #:fifo-clear
+ #:fifo-map #:fifo-peek #:fifo-data #:with-fifo-map #:fifo-length
+
+ #-(or lispworks mcl) #:true
+ #+(and mcl (not openmcl-partial-mop)) #:class-slots
+ ))
Added: dependencies/trunk/cells/utils-kt/detritus.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/detritus.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,230 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
+#|
+
+ Utils-kt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+
+(in-package :utils-kt)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(eval-now! export! assocd rassoca class-proto brk)))
+
+(defmacro wdbg (&body body)
+ `(let ((*dbg* t))
+ , at body))
+
+(defun assocd (x y) (cdr (assoc x y)))
+(defun rassoca (x y) (car (assoc x y)))
+
+(defun class-proto (c)
+ (let ((cc (find-class c)))
+ (when cc
+ (finalize-inheritance cc))
+ (mop::class-prototype cc)))
+
+
+(defun brk (&rest args)
+ #+its-alive! (apply 'error args)
+ #-its-alive! (progn
+ ;;(setf *ctk-dbg* t)
+ (apply 'break args)))
+
+(defun find-after (x l)
+ (bIf (xm (member x l))
+ (cadr xm)
+ (brk "find-after ~a not member of ~a" x l)))
+
+(defun find-before (x l)
+ (loop with prior = nil
+ for i in l
+ if (eql i x)
+ return prior
+ else do (setf prior i)
+ finally (brk "find-before ~a not member of ~a" x l)))
+
+(defun list-insert-after (list after new )
+ (let* ((new-list (copy-list list))
+ (m (member after new-list)))
+ (rplacd m (cons new (cdr m)))
+ new-list))
+
+#+(and mcl (not openmcl-partial-mop))
+(defun class-slots (c)
+ (nconc (copy-list (class-class-slots c))
+ (copy-list (class-instance-slots c))))
+
+
+#-(or lispworks mcl)
+(progn
+ (defun true (it) (declare (ignore it)) t)
+ (defun false (it) (declare (ignore it))))
+
+(defun xor (c1 c2)
+ (if c1 (not c2) c2))
+
+(export! collect collect-if find-after find-before list-insert-after)
+
+(defun collect (x list &key (key 'identity) (test 'eql))
+ (loop for i in list
+ when (funcall test x (funcall key i))
+ collect i))
+
+(defun collect-if (test list)
+ (remove-if-not test list))
+
+;;; --- FIFO Queue -----------------------------
+
+(defun make-fifo-queue (&rest init-data)
+ (let ((q (cons nil nil)))
+ (prog1 q
+ (loop for id in init-data
+ do (fifo-add q id)))))
+
+(deftype fifo-queue () 'cons)
+
+(defun fifo-data (q) (car q))
+(defun fifo-clear (q) (rplaca q nil))
+(defun fifo-empty (q) (not (fifo-data q)))
+(defun fifo-length (q) (length (fifo-data q)))
+(defun fifo-peek (q) (car (fifo-data q)))
+
+(defun fifo-browse (q fn)
+ (map nil fn (fifo-data q)))
+
+(defun fifo-add (q new)
+ (if (car q)
+ (let ((last (cdr q))
+ (newlast (list new)))
+ (rplacd last newlast)
+ (rplacd q newlast))
+ (let ((newlist (list new)))
+ (rplaca q newlist)
+ (rplacd q newlist))))
+
+(defun fifo-delete (q dead)
+ (let ((c (member dead (fifo-data q))))
+ (assert c)
+ (rplaca q (delete dead (fifo-data q)))
+ (when (eq c (cdr q))
+ (rplacd q (last (fifo-data q))))))
+
+(defun fifo-pop (q)
+ (unless (fifo-empty q)
+ (prog1
+ (fifo-peek q)
+ (rplaca q (cdar q)))))
+
+(defun fifo-map (q fn)
+ (loop until (fifo-empty q)
+ do (funcall fn (fifo-pop q))))
+
+(defmacro with-fifo-map ((pop-var q) &body body)
+ (let ((qc (gensym)))
+ `(loop with ,qc = ,q
+ while (not (fifo-empty ,qc))
+ do (let ((,pop-var (fifo-pop ,qc)))
+ , at body))))
+
+#+(or)
+(let ((*print-circle* t))
+ (let ((q (make-fifo-queue)))
+ (loop for n below 3
+ do (fifo-add q n))
+ (fifo-delete q 1)
+ (loop until (fifo-empty q)
+ do (print (fifo-pop q)))))
+
+#+test
+(line-count "/openair" t 10 t)
+
+#+allegro
+(defun line-count (path &optional show-files (max-depth most-positive-fixnum) no-semis (depth 0))
+ (cond
+ ((excl:file-directory-p path)
+ (if (>= depth max-depth)
+ (progn
+ (format t "~&~v,8t~a dir too deep:" depth (pathname-directory path))
+ 0)
+ (progn
+ (when show-files
+ (format t "~&~v,8t~a counts:" depth (pathname-directory path)))
+ (let ((directory-lines
+ (loop for file in (directory path :directories-are-files nil)
+ for lines = (line-count file show-files max-depth no-semis (1+ depth))
+ when (and show-files (plusp lines))
+ do (bwhen (fname (pathname-name file))
+ (format t "~&~v,8t~a ~,40t~d" (1+ depth) fname lines))
+ summing lines)))
+ (unless (zerop directory-lines)
+ (format t "~&~v,8t~a ~,50t~d" depth (pathname-directory path) directory-lines))
+ directory-lines))))
+
+ ((find (pathname-type path) '("cl" "lisp" "c" "h" "java")
+ :test 'string-equal)
+ (source-line-count path no-semis))
+ (t 0)))
+
+(defun source-line-count (path no-semis)
+ (with-open-file (s path)
+ (loop with block-rem = 0
+ for line = (read-line s nil nil)
+ for trim = (when line (string-trim '(#\space #\tab) line))
+ while line
+ when (> (length trim) 1)
+ do (cond
+ ((string= "#|" (subseq trim 0 2))(incf block-rem))
+ ((string= "|#" (subseq trim 0 2))(decf block-rem)))
+ unless (or (string= trim "")
+ (and no-semis (or (plusp block-rem)
+ (char= #\; (schar trim 0)))))
+ count 1)))
+
+#+(or)
+(line-count (make-pathname
+ :device "c"
+ :directory `(:absolute "0algcount" ))
+ nil 5 t)
+
+#+(or)
+(loop for d1 in '("cl-s3" "kpax" "puri-1.5.1" "s-base64" "s-http-client" "s-http-server" "s-sysdeps" "s-utils" "s-xml")
+ summing (line-count (make-pathname
+ :device "c"
+ :directory `(:absolute "0Algebra" "1-devtools" ,d1))))
+
+
+(export! tree-includes tree-traverse tree-intersect)
+
+(defun tree-includes (sought tree &key (test 'eql))
+ (typecase tree
+ (null)
+ (atom (funcall test sought tree))
+ (cons (or (tree-includes sought (car tree) :test test)
+ (tree-includes sought (cdr tree) :test test)))))
+
+(defun tree-traverse (tree fn)
+ (typecase tree
+ (null)
+ (atom (funcall fn tree))
+ (cons (tree-traverse (car tree) fn)
+ (tree-traverse (cdr tree) fn)))
+ (values))
+
+(defun tree-intersect (t1 t2 &key (test 'eql))
+ (tree-traverse t1
+ (lambda (t1-node)
+ (when (tree-includes t1-node t2 :test test)
+ (return-from tree-intersect t1-node)))))
+
Added: dependencies/trunk/cells/utils-kt/flow-control.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/flow-control.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,254 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
+#|
+
+ Utils-kt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+
+(in-package :utils-kt)
+
+(defun last1 (thing)
+ (car (last thing)))
+
+(defun max-if (&rest values)
+ (loop for x in values when x maximize x))
+
+(defun min-max-of (v1 v2)
+ (values (min-if v1 v2) (max-if v1 v2)))
+
+(defun min-if (v1 v2)
+ (if v1 (if v2 (min v1 v2) v1) v2))
+
+(export! list-flatten! tree-flatten list-insertf subseq-contiguous-p pair-off)
+
+(defun list-flatten! (&rest list)
+ (if (consp list)
+ (let (head work visited)
+ (labels ((link (cell)
+ ;;(format t "~&Link > cons: ~s . ~s" (car cell) (cdr cell))
+ (when (and (consp cell)
+ (member cell visited))
+ (break "list-flatten! detects infinite list: cell ~a, visited ~a" cell visited))
+ (push cell visited)
+
+ (when cell
+ (if (consp (car cell))
+ (link (car cell))
+ (progn
+ (setf head (or head cell))
+ (when work
+ (rplacd work cell))
+ (setf work cell)))
+ (link (rest cell)))))
+ (link list))
+ head)
+ list))
+
+(defun tree-flatten (tree)
+ (list-flatten! (copy-tree tree)))
+
+(export! push-end)
+(defmacro push-end (item place )
+ `(setf ,place (nconc ,place (list ,item))))
+
+(defun pair-off (list &optional (test 'eql))
+ (loop with pairs and copy = (copy-list list)
+ while (cdr copy)
+ do (let ((pair (find (car copy) (cdr copy) :test test)))
+ (if pair
+ (progn
+ (push-end (cons (car copy) pair) pairs)
+ (setf copy (delete pair (cdr copy) :count 1)))
+ (setf copy (cdr copy))))
+ finally (return pairs)))
+
+(defun packed-flat! (&rest u-nameit)
+ (delete nil (list-flatten! u-nameit)))
+
+(defmacro with-dynamic-fn ((fn-name (&rest fn-args) &body fn-body) &body body)
+ `(let ((,fn-name (lambda ,fn-args , at fn-body)))
+ (declare (dynamic-extent ,fn-name))
+ , at body))
+
+(defmacro list-insertf (place item &key after)
+ (let ((list (gensym))
+ (afterv (gensym))
+ (afters (gensym)))
+ `(let* ((,list ,place)
+ (,afterv ,after)
+ (,afters (when ,afterv (member ,after ,list))))
+ (assert (or (null ,afterv) ,afters) () "list-insertf after ~a not in list ~a" ,afterv ,list)
+ (setf ,place
+ (if ,afterv
+ (append (ldiff ,list ,afters)
+ (list ,afterv)
+ (list ,item)
+ (cdr ,afters))
+ (append ,list (list ,item)))))))
+
+(defun intern$ (&rest strings)
+ (intern (apply #'concatenate 'string strings)))
+
+#-allegro
+(defmacro until (test &body body)
+ `(loop (when ,test (return)) , at body))
+
+#-allegro
+(defmacro while (test &body body)
+ `(loop (unless ,test (return)) , at body))
+
+(defmacro bwhen ((bindvar boundform) &body body)
+ `(let ((,bindvar ,boundform))
+ (when ,bindvar
+ , at body)))
+
+(defmacro b-when (bindvar boundform &body body)
+ `(let ((,bindvar ,boundform))
+ (when ,bindvar
+ , at body)))
+
+(defmacro bif ((bindvar boundform) yup &optional nope)
+ `(let ((,bindvar ,boundform))
+ (if ,bindvar
+ ,yup
+ ,nope)))
+
+(defmacro b-if (bindvar boundform yup &optional nope)
+ `(let ((,bindvar ,boundform))
+ (if ,bindvar
+ ,yup
+ ,nope)))
+
+(defmacro b1 ((bindvar boundform) &body body)
+ `(let ((,bindvar ,boundform))
+ , at body))
+
+(defmacro maptimes ((nvar count) &body body)
+ `(loop for ,nvar below ,count
+ collecting (progn , at body)))
+
+(export! b1 maphash* hashtable-assoc -1?1 -1?1 prime? b-if b-when)
+
+(defun maphash* (f h)
+ (loop for k being the hash-keys of h
+ using (hash-value v)
+ collecting (funcall f k v)))
+
+(defun hashtable-assoc (h)
+ (maphash* (lambda (k v) (cons k v)) h))
+
+(define-symbol-macro -1?1 (expt -1 (random 2)))
+
+(defun -1?1 (x) (* -1?1 x))
+
+(defun prime? (n)
+ (when (> n 1)
+ (cond
+ ((= 2 n) t)
+ ((evenp n) (values nil 2))
+ (t (loop for d upfrom 3 by 2 to (sqrt n)
+ when (zerop (mod n d)) do (return-from prime? (values nil d))
+ finally (return t))))))
+
+
+
+; --- cloucell support for struct access of slots ------------------------
+
+(eval-when (:compile-toplevel :execute :load-toplevel)
+ (export '(cc-defstruct instance-slots)))
+
+(defmacro cc-defstruct (header &rest slots)
+ (let (name conc-name (cache (gensym)))
+ (if (consp header)
+ (destructuring-bind (hname &rest options)
+ header
+ (setf name hname)
+ (setf conc-name (bif (conc-option (find :conc-name options :key #'car))
+ (unless (eql (second conc-option) 'nil)
+ (second conc-option))
+ (intern (concatenate 'string
+ (symbol-name hname)
+ "-")))))
+ (progn
+ (setf name header)
+ (setf conc-name (intern (concatenate 'string
+ (symbol-name header) "-")))))
+
+ (let ((cc-info (mapcar (lambda (s)
+ (let ((sn (if (consp s)
+ (car s) s)))
+ (cons sn
+ (intern (concatenate 'string
+ (when conc-name (symbol-name conc-name))
+ (symbol-name sn))))))
+ slots)))
+ `(progn
+ (defstruct ,header , at slots)
+ (let (,cache)
+ (defmethod instance-slots ((self ,name))
+ (or ,cache (setf ,cache (append (call-next-method) ',cc-info)))))
+ ))))
+
+(defmethod instance-slots (self)
+ (class-slots (class-of self))) ;; acl has this for structs
+
+;;; ---- without-repeating ----------------------------------------------
+
+;; Returns a function that generates an elements from ALL each time it
+;; is called. When a certain element is generated it will take at
+;; least DECENT-INTERVAL calls before it is generated again.
+;;
+;; note: order of ALL is important for first few calls, could be fixed
+
+(defun without-repeating-generator (decent-interval all)
+ (let ((len (length all))
+ (head (let ((v (shuffle all)))
+ (nconc v v))))
+ (lambda ()
+ ;(print (list "without-repeating-generator sees len all =" len :decent-interval decent-interval))
+ (if (< len 2)
+ (car all)
+ (prog2
+ (rotatef (car head)
+ (car (nthcdr (random (- len decent-interval))
+ head)))
+ (car head)
+ (setf head (cdr head)))))))
+
+(defun shuffle (list &key (test 'identity))
+ (if (cdr list)
+ (loop thereis
+ (funcall test
+ (mapcar 'cdr
+ (sort (loop for e in list collecting (cons (random most-positive-fixnum) e))
+ '< :key 'car))))
+ (copy-list list)))
+
+(export! without-repeating shuffle)
+
+(defparameter *without-repeating-generators* nil)
+
+(defun reset-without-repeating ()
+ (if *without-repeating-generators*
+ (clrhash *without-repeating-generators*)
+ (setf *without-repeating-generators* (make-hash-table :test 'equalp))))
+
+(defun without-repeating (key all &optional (decent-interval (floor (length all) 2)))
+ (funcall (or (gethash key *without-repeating-generators*)
+ (progn
+ ;(print (list "without-repeating makes new gen" key :all-len (length all) :int decent-interval))
+ (setf (gethash key *without-repeating-generators*)
+ (without-repeating-generator decent-interval all))))))
+
Added: dependencies/trunk/cells/utils-kt/quad.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/quad.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,199 @@
+
+#|
+
+From: Erik Naggum (erik at naggum.no)
+Subject: Re: XML->sexpr ideas
+Newsgroups: comp.lang.lisp
+Date: 2004-01-19 04:24:43 PST
+
+* Kenny Tilton
+| Of course it is easy enough for me to come up with a sexpr format off
+| the top of my head, but I seem to recall someone (Erik? Tim? Other?)
+| saying they had done some work on a formal approach to an alternative
+| to XML/HTML/whatever.
+|
+| True that? If so, I am all ears.
+
+ Really? You are? Maybe I didn't survive 2003 and this is some Hell
+ where people have to do eternal penance, and now I get to do SGML all
+ over again.
+
+ Much processing of SGML-like data appears to be stream-like and will
+ therefore appear to be equivalent to an in-order traversal of a tree,
+ which can therefore be represented with cons cells while the traverser
+ maintains its own backward links elsewhere, but this is misleading.
+
+ The amount of work and memory required to maintain the proper backward
+ links and to make the right decisions is found in real applications to
+ balloon and to cause random hacks; the query languages reflect this
+ complexity. Ease of access to the parent element is crucial to the
+ decision-making process, so if one wants to use a simple list to keep
+ track of this, the most natural thing is to create a list of the
+ element type, the parent, and the contents, such that each element has
+ the form (type parent . contents), but this has the annoying property
+ that moving from a particular element to the next can only be done by
+ remembering the position of the current element in a list, just as one
+ cannot move to the next element in a list unless you keep the cons
+ cell around. However, the whole point of this exercise is to be able
+ to keep only one pointer around. So the contents of an element must
+ have the form (type parent contents . tail) if it has element contents
+ or simply a list of objects, or just the object if simple enough.
+
+ Example: 123 would thus be represented by (foo nil "123"),
+ 123456 by (foo nil "123" bar nil "456"), and
+ 123456 by #1=(zot nil (foo #1# "123"
+ bar #1# "456")).
+
+ Navigation inside this kind of structure is easy: When the contents in
+ CADDR is exhausted, the CDDDR is the next element, or if NIL, we have
+ exhausted the contents of the parent and move up to the CADR and look
+ for its next element, etc. All the important edges of the containers
+ that make up the *ML document are easily detectible and the operations
+ that are usually found at the edges are normally tied to the element
+ type (or as modified by its parents), are easily computable. However,
+ using a list for this is cumbersome, so I cooked up the ?quad?. The
+ ?quad? is devoid of any intrinsic meaning because it is intended to be
+ a general data structure, so I looked for the best meaningless names
+ for the slots/accessors, and decided on QAR, QBR, QCR, and QDR. The
+ quad points to the element type (like the operator in a sexpr) in the
+ QAR, the parent (or back) quad in the QBR, the contents of the element
+ in the QCR, and the usual pointer to the next quad in the QDR.
+
+ Since the intent with this model is to ?load? SGML/XML/SALT documents
+ into memory, one important issue is how to represent long stretches of
+ character content or binary content. The quad can easily be used to
+ represent a (sequence of) entity fragments, with the source in QAR,
+ the start position in QBR, and the end position in QCR, thereby using
+ a minimum of memory for the contents. Since very large documents are
+ intended to be loaded into memory, this property is central to the
+ ability to search only selected elements for their contents -- most
+ searching processors today parse the entire entity structure and do
+ very little to maintain the parsed element structure.
+
+ Speaking of memory, one simple and efficient way to implement the quad
+ on systems that lack the ability to add native types without overhead,
+ is to use a two-dimensional array with a second dimension of 4 and let
+ quad pointers be integers, which is friendly to garbage collection and
+ is unambiguous when the quad is used in the way explained above.
+
+ Maybe I'll talk about SALT some other day.
+
+--
+Erik Naggum | Oslo, Norway
+
+Act from reason, and failure makes you rethink and study harder.
+Act from faith, and failure makes you blame someone and push harder.
+
+|#
+
+(in-package :ukt)
+
+;;;(defstruct (juad jar jbr jcr jdr)
+
+
+
+(defun qar (q) (car q))
+(defun (setf qar) (v q) (setf (car q) v))
+
+(defun qbr (q) (cadr q))
+(defun (setf qbr) (v q) (setf (cadr q) v))
+
+(defun qcr (q) (caddr q))
+(defun (setf qcr) (v q) (setf (caddr q) v))
+
+(defun qdr (q) (cdddr q))
+(defun (setf qdr) (v q) (setf (cdddr q) v))
+
+(defun sub-quads (q)
+ (loop for childq on (qcr q) by #'qdr
+ collecting childq))
+
+(defun sub-quads-do (q fn)
+ (loop for childq on (qcr q) by #'qdr
+ do (funcall fn childq)))
+
+(defun quad-traverse (q fn &optional (depth 0))
+ (funcall fn q depth)
+ (sub-quads-do q
+ (lambda (subq)
+ (quad-traverse subq fn (1+ depth)))))
+
+(defun quad (operator parent contents next)
+ (list operator parent contents next))
+
+(defun quad* (operator parent contents next)
+ (list operator parent contents next))
+
+(defun qups (q)
+ (loop for up = (qbr q) then (qbr up)
+ unless up do (loop-finish)
+ collecting up))
+
+(defun quad-tree (q)
+ (list* (qar q)
+ (loop for childq on (qcr q) by #'qdr
+ while childq
+ collecting (quad-tree childq))))
+
+(defun tree-quad (tree &optional parent)
+ (let* ((q (quad (car tree) parent nil nil))
+ (kids (loop for k in (cdr tree)
+ collecting (tree-quad k q))))
+ (loop for (k n) on kids
+ do (setf (qdr k) n))
+ (setf (qcr q) (car kids))
+ q))
+
+#+test
+(test-qt)
+
+(defun test-qt ()
+ (print (quad-tree #1='(zot nil (foo #1# ("123" "abc")
+ . #2=(bar #1# (ding #2# "456"
+ dong #2# "789")))))))
+
+(print #1='(zot nil (foo #1# ("123" "abc")
+ . #2=(bar #1# (ding #2# "456"
+ dong #2# "789")))))
+#+xxxx
+(test-tq)
+
+(defun test-tq ()
+ (let ((*print-circle* t)
+ (tree '(zot (foo ("123")) (bar (ding) (dong)))))
+ (assert (equal tree (quad-tree (tree-quad tree))))))
+
+(defun testq ()
+ (let ((*print-circle* t))
+ (let ((q #1='(zot nil (foo #1# ("123" "abc")
+ . #2=(bar #1# (ding #2# "456"
+ dong #2# "789"))))))
+ (print '(traverse showing each type and data preceded by its depth))
+
+ (quad-traverse q (lambda (q depth)
+ (print (list depth (qar q)(qcr q)))))
+ (print `(listify same ,(quad-tree q))))
+ (let ((q #2='(zot nil (ding #2# "456"
+ dong #2# "789"))))
+ (print '(traverse showing each "car" and itd parentage preceded by its depth))
+ (print '(of data (zot (ding (dong)))))
+ (quad-traverse q (lambda (q depth)
+ (print (list depth (qar q)
+ (mapcar 'qar (qups q)))))))))
+
+;;;(defun tree-quad (tree)
+
+
+(defun testq2 ()
+ (let ((*print-circle* t))
+ (let ((q #2='(zot nil (ding #2# "456"
+ dong #2# "789"))))
+ (print '(traverse showing each "car" and itd parentage preceded by its depth))
+ (print '(of data (zot (ding (dong)))))
+ (quad-traverse q (lambda (q depth)
+ (print (list depth (qar q)
+ (mapcar 'qar (qups q)))))))))
+
+
+
+
\ No newline at end of file
Added: dependencies/trunk/cells/utils-kt/split-sequence.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/split-sequence.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,223 @@
+;;;; SPLIT-SEQUENCE
+;;;
+;;; This code was based on Arthur Lemmens' in
+;;; ;
+;;;
+;;; changes include:
+;;;
+;;; * altering the behaviour of the :from-end keyword argument to
+;;; return the subsequences in original order, for consistency with
+;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
+;;; affects the answer if :count is less than the number of
+;;; subsequences, by analogy with the above-referenced functions).
+;;;
+;;; * changing the :maximum keyword argument to :count, by analogy
+;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
+;;;
+;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
+;;; than SPLIT.
+;;;
+;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
+;;;
+;;; * The second return value is now an index rather than a copy of a
+;;; portion of the sequence; this index is the `right' one to feed to
+;;; CL:SUBSEQ for continued processing.
+
+;;; There's a certain amount of code duplication here, which is kept
+;;; to illustrate the relationship between the SPLIT-SEQUENCE
+;;; functions and the CL:POSITION functions.
+
+;;; Examples:
+;;;
+;;; * (split-sequence #\; "a;;b;c")
+;;; -> ("a" "" "b" "c"), 6
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t)
+;;; -> ("a" "" "b" "c"), 0
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1)
+;;; -> ("c"), 4
+;;;
+;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)
+;;; -> ("a" "b" "c"), 6
+;;;
+;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("" "" "r" "c" "d" "" "r" ""), 11
+;;;
+;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("ab" "a" "a" "ab" "a"), 11
+;;;
+;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)
+;;; -> ("oo" "bar" "b"), 9
+
+;; cl-utilities note: the license of this file is unclear, and I don't
+;; even know whom to contact to clarify it. If anybody objects to my
+;; assumption that it is public domain, please contact me so I can do
+;; something about it. Previously I required the split-sequence
+ ; package as a dependency, but that was so unwieldy that it was *the*
+;; sore spot sticking out in the design of cl-utilities. -Peter Scott
+
+(in-package :utils-kt)
+
+(export! split-sequence)
+
+(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil)
+ (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by delimiter.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (let ((len (length seq))
+ (other-keys (nconc (when test-supplied
+ (list :test test))
+ (when test-not-supplied
+ (list :test-not test-not))
+ (when key-supplied
+ (list :key key)))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position delimiter seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position delimiter seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by items satisfying
+predicate.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (let ((len (length seq))
+ (other-keys (when key-supplied
+ (list :key key))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position-if predicate seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position-if predicate seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by items satisfying
+(CL:COMPLEMENT predicate).
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular,
+the behaviour of :from-end is possibly different from other versions
+of this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped." ; Emacs syntax highlighting is broken, and this helps: "
+ (let ((len (length seq))
+ (other-keys (when key-supplied
+ (list :key key))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position-if-not predicate seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position-if-not predicate seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+
+
+(pushnew :split-sequence *features*)
Added: dependencies/trunk/cells/utils-kt/strings.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/strings.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,221 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: utils-kt; -*-
+#|
+
+ Utils-kt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+
+(in-package :utils-kt)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (export '(case$ strloc$ make$ space$ char$ conc-list$ conc$
+ left$ mid$ seg$ right$ insert$ remove$
+ trim$ trunc$ abbrev$ empty$ find$ num$
+ normalize$ down$ lower$ up$ upper$ equal$
+ min$ numeric$ alpha$ assoc$ member$ starts$
+ +return$+ +lf$+ case-string-equal)))
+
+(defmacro case$ (string-form &rest cases)
+ (let ((v$ (gensym))
+ (default (or (find 'otherwise cases :key #'car)
+ (find 'otherwise cases :key #'car))))
+ (when default
+ (setf cases (delete default cases)))
+ `(let ((,v$ ,string-form))
+ (cond
+ ,@(mapcar (lambda (case-forms)
+ `((string-equal ,v$ ,(car case-forms)) ,@(rest case-forms)))
+ cases)
+ (t ,@(or (cdr default) `(nil)))))))
+
+(defmacro case-string-equal (string-form &rest cases)
+ (let ((v$ (gensym))
+ (default (or (find 'otherwise cases :key #'car)
+ (find 'otherwise cases :key #'car))))
+ (when default
+ (setf cases (delete default cases)))
+ `(let ((,v$ ,string-form))
+ (cond
+ ,@(mapcar (lambda (case-forms)
+ `((string-equal ,v$ ,(string (car case-forms))) ,@(rest case-forms)))
+ cases)
+ (t ,@(or (cdr default) `(nil)))))))
+
+;--------
+
+(defmethod shortc (other)
+ (declare (ignorable other))
+ (concatenate 'string "noshortc" (symbol-name (class-name (class-of other)))))
+
+(defmethod longc (other) (shortc other))
+
+(defmethod shortc ((nada null)) nil)
+(defmethod shortc ((many list))
+ (if (consp (cdr many))
+ (mapcar #'shortc many)
+ (conc$ (shortc (car many)) " " (shortc (cdr many)))))
+(defmethod shortc ((self string)) self)
+(defmethod shortc ((self symbol)) (string self))
+(defmethod shortc ((self number)) (num$ self))
+(defmethod shortc ((self character)) (string self))
+
+;-----------------------
+
+(defun strloc$ (substr str)
+ (when (and substr str (not (string= substr "")))
+ (search substr str)))
+
+(defun make$ (&optional (size 0) (char #\space))
+ (make-string size :initial-element (etypecase char
+ (character char)
+ (number (code-char char)))))
+(defun basic$ ()
+ (make-array 0 :element-type 'character :adjustable t :fill-pointer 0))
+
+(defun space$ (size)
+ (make$ size))
+
+(defun char$ (char)
+ (make$ 1 char))
+
+(defun conc-list$ (ss)
+ (when ss
+ (reduce (lambda (s1 s2) (concatenate 'string s1 s2)) ss)))
+
+(defun conc$ (&rest ss)
+ (with-output-to-string (stream)
+ (dolist (s ss)
+ (when s
+ (princ (shortc s) stream)))))
+
+(defun left$ (s n)
+ (subseq s 0 (max (min n (length s)) 0)))
+
+(export! cc$)
+(defun cc$ (code) (string (code-char code)))
+
+(defun mid$ (s offset length)
+ (let* ((slen (length s))
+ (start (min slen (max offset 0)))
+ (end (max start (min (+ offset length) slen))))
+ (subseq s start end)))
+
+(defun seg$ (s offset end)
+ (let* ((slen (length s))
+ (start (min slen (max offset 0)))
+ (end (max start (min end slen))))
+ (subseq s start end)))
+
+(defun right$ (s n)
+ (subseq s (min n (length s))))
+
+(defun insert$ (s c &optional (offset (length s)))
+ (conc$ (subseq s 0 offset)
+ (string c)
+ (subseq s offset)))
+
+(defun remove$ (s offset)
+ (conc$ (subseq s 0 (1- offset))
+ (subseq s offset)))
+
+(defun trim$ (s)
+ (assert (or (null s) (stringp s)))
+ (string-trim '(#\space) s))
+
+(defun trunc$ (s char)
+ (let ((pos (position char s)))
+ (if pos
+ (subseq s 0 pos)
+ s)))
+
+(defun abbrev$ (long$ max)
+ (if (<= (length long$) max)
+ long$
+ (conc$ (left$ long$ (- max 3)) "...")))
+
+(defmethod empty ((nada null)) t)
+(defmethod empty ((c cons))
+ (and (empty (car c))
+ (empty (cdr c))))
+(defmethod empty ((s string)) (empty$ s))
+(defmethod empty (other) (declare (ignorable other)) nil)
+
+(defun empty$ (s)
+ (or (null s)
+ (if (stringp s)
+ (string-equal "" (trim$ s))
+ #+(or) (format t "empty$> sees non-string ~a" (type-of s)))))
+
+(defmacro find$ (it where &rest args)
+ `(find ,it ,where , at args :test #'string-equal))
+
+(defmethod num$ ((n number))
+ (format nil "~d" n))
+
+(defmethod num$ (n)
+ (format nil "~d" n))
+
+(defun normalize$ (s)
+ (down$ s))
+
+(defun down$ (s)
+ (etypecase s
+ (null "")
+ (string (string-downcase s))
+ (number (format nil "~a" s))
+ (symbol (string-downcase (symbol-name s)))
+ (cons (format nil "~{~(~a~)~^ ~}" s))))
+
+(defun lower$ (s)
+ (string-downcase s))
+
+(defun up$ (s)
+ (string-upcase s))
+
+(defun upper$ (s)
+ (string-upcase s))
+
+(defun equal$ (s1 s2)
+ (if (empty$ s1)
+ (empty$ s2)
+ (when s2
+ (string-equal s1 s2))))
+
+(defun min$ (&rest ss)
+ (cond
+ ((null ss) nil)
+ ((null (cdr ss)) (car ss))
+ (t (let ((rmin$ (apply #'min$ (cdr ss))))
+ (if (string< (car ss) rmin$)
+ (car ss) rmin$)))))
+
+(defun numeric$ (s &optional trimmed)
+ (every (lambda (c) (digit-char-p c)) (if trimmed (trim$ s) s)))
+
+(defun alpha$ (s)
+ (every (lambda (c) (alpha-char-p c)) s))
+
+(defmacro assoc$ (item alist &rest kws)
+ `(assoc ,item ,alist :test #'equal , at kws))
+
+(defmacro member$ (item list &rest kws)
+ `(member ,item ,list :test #'string= , at kws))
+
+(defun starts$ (a b)
+ (bwhen (s (search b a))
+ (zerop s)))
+
+(defparameter *return$* (conc$ (char$ #\return) (char$ #\linefeed)))
+(defparameter *lf$* (string #\linefeed))
Added: dependencies/trunk/cells/utils-kt/utils-kt.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/utils-kt.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,30 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+;(declaim (optimize (debug 2) (speed 1) (safety 1) (compilation-speed 1)))
+(declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0)))
+
+;;;(operate 'load-op :asdf-aclproj)
+;;;(use-package :asdf-aclproj)
+
+#+(or allegro lispworks cmu mcl clisp cormanlisp sbcl scl abcl)
+
+(asdf:defsystem :utils-kt
+ :name "utils-kt"
+ :author "Kenny Tilton "
+ :version "2007-12-02"
+ :maintainer "Kenny Tilton "
+ :licence "MIT Style"
+ :description "Kenny's Utilities"
+ :long-description "Low-level utilities used by all of Kenny's projects"
+ :components ((:file "defpackage")
+ (:file "core" :depends-on ("defpackage"))
+ (:file "debug" :depends-on ("core"))
+ (:file "flow-control" :depends-on ("core" "debug"))
+ (:file "detritus" :depends-on ("core" "debug"))
+ (:file "strings" :depends-on ("core" "debug"))
+ (:file "datetime" :depends-on ("core" "debug"))
+ (:file "split-sequence" :depends-on ("core" "debug"))))
+
+(defmethod perform ((o load-op) (c (eql (find-system :utils-kt))))
+ ; (pushnew "CELLS" *modules* :test #'string=)
+ (pushnew :utils-kt *features*))
Added: dependencies/trunk/cells/utils-kt/utils-kt.lpr
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/utils-kt/utils-kt.lpr Tue Jan 26 15:20:07 2010
@@ -0,0 +1,39 @@
+;; -*- lisp-version: "8.1 [Windows] (Oct 11, 2008 17:00)"; cg: "1.103.2.10"; -*-
+
+(in-package :cg-user)
+
+(define-project :name :utils-kt
+ :modules (list (make-instance 'module :name "defpackage.lisp")
+ (make-instance 'module :name "core.lisp")
+ (make-instance 'module :name "debug.lisp")
+ (make-instance 'module :name "flow-control.lisp")
+ (make-instance 'module :name "detritus.lisp")
+ (make-instance 'module :name "strings.lisp")
+ (make-instance 'module :name "datetime.lisp")
+ (make-instance 'module :name "split-sequence.lisp"))
+ :projects nil
+ :libraries nil
+ :distributed-files nil
+ :internally-loaded-files nil
+ :project-package-name :common-lisp
+ :main-form nil
+ :compilation-unit t
+ :verbose nil
+ :runtime-modules nil
+ :splash-file-module (make-instance 'build-module :name "")
+ :icon-file-module (make-instance 'build-module :name "")
+ :include-flags (list :local-name-info)
+ :build-flags (list :allow-debug :purify)
+ :autoload-warning t
+ :full-recompile-for-runtime-conditionalizations nil
+ :include-manifest-file-for-visual-styles t
+ :default-command-line-arguments "+cx +t \"Initializing\""
+ :additional-build-lisp-image-arguments (list :read-init-files nil)
+ :old-space-size 256000
+ :new-space-size 6144
+ :runtime-build-option :standard
+ :build-number 0
+ :on-initialization 'default-init-function
+ :on-restart 'do-default-restart)
+
+;; End of Project Definition
Added: dependencies/trunk/cells/variables.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cells/variables.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,118 @@
+;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cells; -*-
+#|
+
+ Cells -- Automatic Dataflow Managememnt
+
+Copyright (C) 1995, 2006 by Kenneth Tilton
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the Lisp Lesser GNU Public License
+ (http://opensource.franz.com/preamble.html), known as the LLGPL.
+
+This library is distributed WITHOUT ANY WARRANTY; without even
+the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
+
+See the Lisp Lesser GNU Public License for more details.
+
+|#
+
+(in-package :cells)
+
+(defun c-variable-accessor (symbol)
+ (assert (symbolp symbol))
+ (c-variable-reader symbol))
+
+(defun (setf c-variable-accessor) (value symbol)
+ (assert (symbolp symbol))
+ (c-variable-writer value symbol))
+
+(defun c-variable-reader (symbol)
+ (assert (symbolp symbol))
+ (assert (get symbol 'cell))
+ (cell-read (get symbol 'cell)))
+
+(defun c-variable-writer (value symbol)
+ (assert (symbolp symbol))
+ (setf (md-slot-value nil symbol) value)
+ (setf (symbol-value symbol) value))
+
+(export! def-c-variable)
+
+(defmacro def-c-variable (v-name cell &key ephemeral owning unchanged-if)
+ (declare (ignore unchanged-if))
+ (let ((c 'whathef)) ;;(gensym)))
+ `(progn
+ (eval-when (:compile-toplevel :load-toplevel)
+ (define-symbol-macro ,v-name (c-variable-accessor ',v-name))
+ (setf (md-slot-cell-type 'null ',v-name) (when ,ephemeral :ephemeral))
+ (when ,owning
+ (setf (md-slot-owning 'null ',v-name) t)))
+ (eval-when (:load-toplevel)
+ (let ((,c ,cell))
+ (md-install-cell nil ',v-name ,c)
+ (awaken-cell ,c)))
+ ',v-name)))
+
+
+(defobserver *kenny* ()
+ (trcx kenny-obs new-value old-value old-value-boundp))
+
+#+test
+(def-c-variable *kenny* (c-in nil))
+
+
+#+test
+(defmd kenny-watcher ()
+ (twice (c? (bwhen (k *kenny*)
+ (* 2 k)))))
+
+(defobserver twice ()
+ (trc "twice kenny is:" new-value self old-value old-value-boundp))
+
+#+test-ephem
+(progn
+ (cells-reset)
+ (let ((tvw (make-instance 'kenny-watcher)))
+ (trcx twice-read (twice tvw))
+ (setf *c-debug* nil)
+ (setf *kenny* 42)
+ (setf *kenny* 42)
+ (trcx post-setf-kenny *kenny*)
+ (trcx print-twice (twice tvw))
+ ))
+
+#+test
+(let ((*kenny* 13)) (print *kenny*))
+
+#+test
+(let ((c (c-in 42)))
+ (md-install-cell '*test-c-variable* '*test-c-variable* c)
+ (awaken-cell c)
+ (let ((tvw (make-instance 'test-var-watcher)))
+ (trcx twice-read (twice tvw))
+ (setf *test-c-variable* 69)
+ (trcx print-testvar *test-c-variable*)
+ (trcx print-twice (twice tvw))
+ (unless (eql (twice tvw) 138)
+ (inspect (md-slot-cell tvw 'twice))
+ (inspect c)
+ ))
+ )
+
+#+test2
+(let ((tvw (make-instance 'test-var-watcher :twice (c-in 42))))
+ (let ((c (c? (trcx joggggggggging!!!!!!!!!!!!!!!)
+ (floor (twice tvw) 2))))
+ (md-install-cell '*test-c-variable* '*test-c-variable* c)
+ (awaken-cell c)
+ (trcx print-testvar *test-c-variable*)
+ (trcx twice-read (twice tvw))
+ (setf (twice tvw) 138)
+ (trcx print-twice (twice tvw))
+ (trcx print-testvar *test-c-variable*)
+ (unless (eql *test-c-variable* 69)
+ (inspect (md-slot-cell tvw 'twice))
+ (inspect c)
+ ))
+ )
+
Added: dependencies/trunk/cl-utilities-1.2.4/README
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/README Tue Jan 26 15:20:07 2010
@@ -0,0 +1,59 @@
+CL-UTILITIES Collection
+=======================
+
+On Cliki.net , there
+is a collection of Common Lisp Utilities, things that everybody writes
+since they're not part of the official standard. There are some very
+useful things there; the only problems are that they aren't
+implemented as well as you'd like (some aren't implemented at all) and
+they aren't conveniently packaged and maintained. It takes quite a bit
+of work to carefully implement utilities for common use, commented
+and documented, with error checking placed everywhere some dumb user
+might make a mistake.
+
+The CLRFI process is a lot better thought out,
+and will probably produce better standards than informal discussion on
+a Wiki, but it has one problem: at the time of this writing, it's not
+doing anything yet. Until the CLRFI process gets going, I think that a
+high-quality collection of the informal standards on Cliki is a
+valuable thing to have. It's here, and it's called cl-utilities.
+
+The home page is .
+
+Documentation
+-------------
+
+Right now, documentation is at
+. There are a few
+differences, though:
+
+* The READ-DELIMITED function takes :start and :end keyword args.
+* A WITH-GENSYMS function is provided for compatibility.
+* COPY-ARRAY is not called SHALLOW-COPY-ARRAY.
+* The ONCE-ONLY macro is included.
+
+Installation
+------------
+
+To install cl-utilities, you'll need to do one of two things:
+
+* Download cl-utilities into a place where asdf can find it, then
+ load it via asdf. You will also need to get the split-sequence
+ package, which cl-utilities depends on.
+
+-or-
+
+* Use asdf-install: (asdf-install:install :cl-utilities)
+
+Feedback
+--------
+
+The current maintainer is Peter Scott. If you have questions, bugs,
+comments, or contributions, please send them to the cl-utilities-devel
+mailing list, .
+
+License
+-------
+
+The code in cl-utilities is in the public domain. Do whatever you want
+with it.
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/cl-utilities.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/cl-utilities.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,33 @@
+;; -*- Lisp -*-
+
+(defpackage #:cl-utilities-system
+ (:use #:common-lisp #:asdf))
+
+(in-package #:cl-utilities-system)
+
+(defsystem cl-utilities
+ :author "Maintained by Peter Scott"
+ :components ((:file "package")
+ (:file "split-sequence" :depends-on ("package"))
+ (:file "extremum" :depends-on ("package"
+ "with-unique-names"
+ "once-only"))
+ (:file "read-delimited" :depends-on ("package"))
+ (:file "expt-mod" :depends-on ("package"))
+ (:file "with-unique-names" :depends-on ("package"))
+ (:file "collecting" :depends-on ("package"
+ "with-unique-names"
+ "compose"))
+ (:file "once-only" :depends-on ("package"))
+ (:file "rotate-byte" :depends-on ("package"))
+ (:file "copy-array" :depends-on ("package"))
+ (:file "compose" :depends-on ("package"))))
+
+;; Sometimes we can accelerate byte rotation on SBCL by using the
+;; SB-ROTATE-BYTE extension. This loads it.
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (handler-case (progn
+ (require :sb-rotate-byte)
+ (pushnew :sbcl-uses-sb-rotate-byte *features*))
+ (error () (delete :sbcl-uses-sb-rotate-byte *features*))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/collecting.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/collecting.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,84 @@
+;; Opinions differ on how a collection macro should work. There are
+;; two major points for discussion: multiple collection variables and
+;; implementation method.
+;;
+;; There are two main ways of implementing collection: sticking
+;; successive elements onto the end of the list with tail-collection,
+;; and using the PUSH/NREVERSE idiom. Tail-collection is usually
+;; faster, except on CLISP, where PUSH/NREVERSE is a little faster.
+;;
+;; The COLLECTING macro only allows collection into one list, and you
+;; can't nest them to get the same effect as multiple collection since
+;; it always uses the COLLECT function. If you want to collect into
+;; multiple lists, use the WITH-COLLECT macro.
+
+(in-package :cl-utilities)
+
+;; This should only be called inside of COLLECTING macros, but we
+;; define it here to provide an informative error message and to make
+;; it easier for SLIME (et al.) to get documentation for the COLLECT
+;; function when it's used in the COLLECTING macro.
+(defun collect (thing)
+ "Collect THING in the context established by the COLLECTING macro"
+ (error "Can't collect ~S outside the context of the COLLECTING macro"
+ thing))
+
+(defmacro collecting (&body body)
+ "Collect things into a list forwards. Within the body of this macro,
+the COLLECT function will collect its argument into the list returned
+by COLLECTING."
+ (with-unique-names (collector tail)
+ `(let (,collector ,tail)
+ (labels ((collect (thing)
+ (if ,collector
+ (setf (cdr ,tail)
+ (setf ,tail (list thing)))
+ (setf ,collector
+ (setf ,tail (list thing))))))
+ , at body)
+ ,collector)))
+
+(defmacro with-collectors ((&rest collectors) &body body)
+ "Collect some things into lists forwards. The names in COLLECTORS
+are defined as local functions which each collect into a separate
+list. Returns as many values as there are collectors, in the order
+they were given."
+ (%with-collectors-check-collectors collectors)
+ (let ((gensyms-alist (%with-collectors-gensyms-alist collectors)))
+ `(let ,(loop for collector in collectors
+ for tail = (cdr (assoc collector gensyms-alist))
+ nconc (list collector tail))
+ (labels ,(loop for collector in collectors
+ for tail = (cdr (assoc collector gensyms-alist))
+ collect `(,collector (thing)
+ (if ,collector
+ (setf (cdr ,tail)
+ (setf ,tail (list thing)))
+ (setf ,collector
+ (setf ,tail (list thing))))))
+ , at body)
+ (values , at collectors))))
+
+(defun %with-collectors-check-collectors (collectors)
+ "Check that all of the COLLECTORS are symbols. If not, raise an error."
+ (let ((bad-collector (find-if-not #'symbolp collectors)))
+ (when bad-collector
+ (error 'type-error
+ :datum bad-collector
+ :expected-type 'symbol))))
+
+(defun %with-collectors-gensyms-alist (collectors)
+ "Return an alist mapping the symbols in COLLECTORS to gensyms"
+ (mapcar #'cons collectors
+ (mapcar (compose #'gensym
+ #'(lambda (x)
+ (format nil "~A-TAIL-" x)))
+ collectors)))
+
+;; Some test code which would be too hard to move to the test suite.
+#+nil (with-collectors (one-through-nine abc)
+ (mapcar #'abc '(a b c))
+ (dotimes (x 10)
+ (one-through-nine x)
+ (print one-through-nine))
+ (terpri) (terpri))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/compose.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/compose.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,51 @@
+;; This version of COMPOSE can only handle functions which take one
+;; value and return one value. There are other ways of writing
+;; COMPOSE, but this is the most commonly used.
+
+(in-package :cl-utilities)
+
+;; This is really slow and conses a lot. Fortunately we can speed it
+;; up immensely with a compiler macro.
+(defun compose (&rest functions)
+ "Compose FUNCTIONS right-associatively, returning a function"
+ #'(lambda (x)
+ (reduce #'funcall functions
+ :initial-value x
+ :from-end t)))
+
+;; Here's some benchmarking code that compares various methods of
+;; doing the same thing. If the first method, using COMPOSE, is
+;; notably slower than the rest, the compiler macro probably isn't
+;; being run.
+#+nil
+(labels ((2* (x) (* 2 x)))
+ (macrolet ((repeat ((x) &body body)
+ (with-unique-names (counter)
+ `(dotimes (,counter ,x)
+ (declare (type (integer 0 ,x) ,counter)
+ (ignorable ,counter))
+ , at body))))
+ ;; Make sure the compiler macro gets run
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (time (repeat (30000000) (funcall (compose #'1+ #'2* #'1+) 6)))
+ (time (repeat (30000000) (funcall (lambda (x) (1+ (2* (1+ x)))) 6)))
+ (time (repeat (30000000)
+ (funcall (lambda (x)
+ (funcall #'1+ (funcall #'2* (funcall #'1+ x))))
+ 6)))))
+
+;; Converts calls to COMPOSE to lambda forms with everything written
+;; out and some things written as direct function calls.
+;; Example: (compose #'1+ #'2* #'1+) => (LAMBDA (X) (1+ (2* (1+ X))))
+(define-compiler-macro compose (&rest functions)
+ (labels ((sharp-quoted-p (x)
+ (and (listp x)
+ (eql (first x) 'function)
+ (symbolp (second x)))))
+ `(lambda (x) ,(reduce #'(lambda (fun arg)
+ (if (sharp-quoted-p fun)
+ (list (second fun) arg)
+ (list 'funcall fun arg)))
+ functions
+ :initial-value 'x
+ :from-end t))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/copy-array.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/copy-array.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,29 @@
+(in-package :cl-utilities)
+
+(defun copy-array (array &key (undisplace nil))
+ "Shallow copies the contents of any array into another array with
+equivalent properties. If array is displaced, then this function will
+normally create another displaced array with similar properties,
+unless UNDISPLACE is non-NIL, in which case the contents of the array
+will be copied into a completely new, not displaced, array."
+ (declare (type array array))
+ (let ((copy (%make-array-with-same-properties array undisplace)))
+ (unless (array-displacement copy)
+ (dotimes (n (array-total-size copy))
+ (setf (row-major-aref copy n) (row-major-aref array n))))
+ copy))
+
+(defun %make-array-with-same-properties (array undisplace)
+ "Make an array with the same properties (size, adjustability, etc.)
+as another array, optionally undisplacing the array."
+ (apply #'make-array
+ (list* (array-dimensions array)
+ :element-type (array-element-type array)
+ :adjustable (adjustable-array-p array)
+ :fill-pointer (when (array-has-fill-pointer-p array)
+ (fill-pointer array))
+ (multiple-value-bind (displacement offset)
+ (array-displacement array)
+ (when (and displacement (not undisplace))
+ (list :displaced-to displacement
+ :displaced-index-offset offset))))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/doc/collecting.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/collecting.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,78 @@
+
+
+
+ Macro COLLECTING, WITH-COLLECTORS
+
+
+
+
+
collector---a symbol which will have a collection function bound to it.
+
+
result---a collected list.
+
+
+
Description:
+
+collecting collects things into a list. Within the
+body of this macro, the collect function will collect its
+argument into result.
+
+
with-collectors collects some things into lists. The
+collector names are defined as local functions which each
+collect into a separate list. Returns as many values as there are
+collectors, in the order they were given.
+
+
Exceptional situations:
+
+
+
If the collector names are not all symbols, a
+type-error will be signalled.
+
+
Opinions differ on how a collection macro should work. There are
+two major points for discussion: multiple collection variables and
+implementation method.
+
+
There are two main ways of implementing collection: sticking
+successive elements onto the end of the list with tail-collection, or
+using the PUSH/NREVERSE idiom. Tail-collection is usually faster,
+except on CLISP, where PUSH/NREVERSE is a little faster because it's
+implemented in C which is always faster than Lisp bytecode.
+
+
The collecting macro only allows collection into one list,
+and you can't nest them to get the same effect as multiple collection
+since it always uses the collect function. If you want to
+collect into multiple lists, use the with-collect macro.
Composes its arguments into a single composite function. All its
+arguments are assumed to designate functions which take one argument
+and return one argument.
+
+
(funcall (compose f g) 42) is equivalent to (f (g
+42)). Composition is right-associative.
+
+
Examples:
+
+
+;; Just to illustrate order of operations
+(defun 2* (x) (* 2 x))
+
+
+(funcall (compose #'1+ #'1+) 1) => 3
+(funcall (compose '1+ '2*) 5) => 11
+(funcall (compose #'1+ '2* '1+) 6) => 15
+
+
+
Notes:
+
If you're dealing with multiple arguments and return values, the
+same concept can be used. Here is some code that could be useful:
+
+
+
+undisplace---a generalized boolean. The default is false.
+
+new-array---an array.
+
+
+
Description:
+
+
Shallow copies the contents of array into another array with
+equivalent properties. If array is displaced, then this
+function will normally create another displaced array with similar
+properties, unless undisplace is true, in which case the
+contents of array will be copied into a completely new, not
+displaced, array.
+expt-mod returns n raised to the exponent power,
+modulo divisor. (expt-mod n exponent divisor) is
+equivalent to (mod (expt n exponent) divisor).
+
+
+
Exceptional situations:
+
+
+
The exceptional situations are the same as those for (mod (expt
+n exponent) divisor).
+
+
Notes:
+
+
One might wonder why we shouldn't simply write (mod (expt n
+exponent) divisor). This function exists because the naïve
+way of evaluating (mod (expt n exponent) divisor) produces a
+gigantic intermediate result, which kills performance in applications
+which use this operation heavily. The operation can be done much more
+efficiently. Usually the compiler does this optimization
+automatically, producing very fast code. However, we can't
+depend on this behavior if we want to produce code that is
+guaranteed not to perform abysmally on some Lisp implementations.
+
+
Therefore cl-utilities provides a standard interface to this
+composite operation which uses mediocre code by default. Specific
+implementations can usually do much better, but some do much
+worse. We can get the best of both by simply using the same interface
+and doing read-time conditionalization within cl-utilities to get
+better performance on compilers like SBCL and Allegro CL which
+optimize this operation.
+
+
extremumsequence predicate &key key (start 0) end => morally-smallest-element
+
extremasequence predicate &key key (start 0) end => morally-smallest-elements
+
n-most-extremen sequence predicate &key key (start 0) end => n-smallest-elements
+
+
Arguments and Values:
+
+sequence---a proper sequence.
+
+predicate---a designator for a function of two
+arguments that returns a generalized boolean.
+
+key---a designator for a function of one
+argument, or nil.
+
+start, end---bounding index designators of sequence. The
+defaults for start and end are 0 and nil, respectively.
+
+morally-smallest-element---the element of sequence that
+would appear first if the sequence were ordered according to sort
+using predicate and key
+
+
morally-smallest-elements---the identical elements of
+sequence that would appear first if the sequence were ordered
+according to sort
+using predicate and key. If predicate states that
+neither of two objects is before the other, they are considered
+identical.
+
+n---a positive integer
+
+n-smallest-elements---the n elements of sequence that
+would appear first if the sequence were ordered according to sort
+using predicate and key
+
+
+
Description:
+
+extremum returns the element of sequence that would
+appear first if the subsequence of sequence specified by
+start and end were ordered according to sort
+using predicate and key.
+
+
+
extremum determines the relationship between two elements
+by giving keys extracted from the elements to the
+predicate. The first argument to the predicate function
+is the part of one element of sequence extracted by the
+key function (if supplied); the second argument is the part of
+another element of sequence extracted by the key
+function (if supplied). Predicate should return true if
+and only if the first argument is strictly less than the second (in
+some appropriate sense). If the first argument is greater than or
+equal to the second (in the appropriate sense), then the
+predicate should return false.
+
+
The argument to the key function is the sequence
+element. The return value of the key function becomes an
+argument to predicate. If key is not supplied or
+nil, the sequence element itself is used. There is no
+guarantee on the number of times the key will be called.
+
+
If the key and predicate always return, then the
+operation will always terminate. This is guaranteed even if the
+predicate does not really consistently represent a total order
+(in which case the answer may be wrong). If the key
+consistently returns meaningful keys, and the predicate does
+reflect some total ordering criterion on those keys, then the answer
+will be right
+
+
The predicate is assumed to consider two elements x
+and y to be equal if (funcall predicate
+xy) and (funcall
+predicateyx)
+are both false.
+
+
+
The return value of (extremum predicate sequence :key key)
+can be defined as (elt (sort
+predicate (subseq sequence start end) :key key) 0) except when
+sequence is empty (see Exceptional Situations), but may use
+faster (less asymptotically complex) algorithms to find this answer.
+
+
extrema is similar to extremum, but it returns a list
+of values. There can be more than one extremum, as determined by
+predicate, and with extremum the choice of which
+extremum to return is arbitrary. extrema returns all the
+possible values which predicate determines to be equal.
+
+
n-most-extreme returns a list of n values without
+testing for equality. It orders sequence in the same way as
+extremum and extrema, then returns the first n
+elements of the sorted sequence.
+
+
+
Exceptional situations:
+
+
+
If sequence is empty, then the error no-extremum is
+signalled. Invoking the continue restart will cause
+extremum to return nil.
+
+
+
Should be prepared to signal an error of type type-error if
+sequence is not a proper sequence.
+
+
If there are fewer than n values in the part of
+sequence that n-most-extreme may operate on, it returns
+all the values it can in sorted order and signals the warning
+n-most-extreme-not-enough-elements. This warning stores the
+given values for n and the relevant subsequence, and they may
+be accessed with n-most-extreme-not-enough-elements-n and
+n-most-extreme-not-enough-elements-subsequence, respectively.
+
+
Implementation notes:
+
+
There are two implementations of this function included in
+cl-utilities, which should only concern you if you want to squeeze out
+more efficiency, since the versions perform differently on different
+inputs.
+
+
The function extremum-fastkey is used exactly like
+extremum, but it calls key fewer times. If key is
+fast, extremum-fastkey is slower than regular extremum,
+but if key is hard to compute you can get significant gains in
+speed. The extremum-fastkey function is more complicated than
+extremum, and therefore may be more likely to contain
+bugs. That said, it doesn't seem buggy.
+
+
Don't worry about the performance of passing #'identity as
+key. This is optimized by a compiler macro.
Everybody writes some utilities because they're not part of the
+standard but they're so broadly useful. This results in a lot of wheel
+reinvention, and most reinventions are not as good as they should
+be. The cl-utilities project is an actively maintained collection of
+some of these utilities, with high-quality public-domain
+implementations and decent documentation.
+
+
+
+Public domain, maintained by Peter Scott. For more information, see
+the home page.
+
+
+
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/doc/once-only.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/doc/once-only.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,40 @@
+
+
+
+ Macro ONCE-ONLY
+
+
+
+
+
Meant to be used in macro code, once-only guards against
+multiple evaluation of its arguments in macroexpansion code. Any
+concise description would be far too vague to grasp, but this
+thread on comp.lang.lisp does a decent job of explaining what
+once-only does.
+
+
Notes:
+
+
The description here is frustratingly non-descriptive, and I
+apologize for that. If you understand once-only and can give a
+better explanation, I would be very grateful—not to mention
+completely awed.
+
+
read-delimitedsequence stream &key start end delimiter test key => position, delimited-p
+
+
Arguments and Values:
+
+
sequence---a sequence.
+
+
stream---an input stream.
+
start, end---bounding index designators of
+sequence. The defaults for start and end are 0
+and nil, respectively.
+
+
delimiter---a character. It defaults to #\newline.
+
test---a designator for a function of two
+arguments that returns a generalized boolean.
+
+
key---a designator for a function of one
+argument, or nil.
+
position---an integer greater than or equal to zero,
+and less than or equal to the length of the sequence.
+
+
delimited-p---the result of the last invokation of test
+
+
Description:
+
+
Destructively modifies sequence by replacing
+elements of sequencebounded by start and
+end with elements read from stream.
+
+
Test is called with the actual read character, converted
+by applying key to it, as the first and delimiter as the
+second argument.
+
+
If a character is read for which (funcall test (funcall
+keychar) delimiter) is non-nil,
+read-delimited terminates the copying even before reaching
+end of file or the end of the bounding
+designator.
+
+
read-delimited returns the index of the first
+element of sequence that was not updated as the first
+and the result of the last invokation of test as the second
+value.
+
+
Sequence is destructively modified by copying successive
+elements into it from stream. If the end of file
+for stream is reached before copying all elements of the
+subsequence, then the extra elements near the end of
+sequence are not updated.
+
+
Exceptional situations:
+
+
If start and/or end are out of bounds, or if
+start > end, then a
+read-delimited-bounds-error error is signalled. This error is
+passed the values of start, end, and sequence,
+which can be read with read-delimited-bounds-error-start,
+read-delimited-bounds-error-end, and
+read-delimited-bounds-error-sequence,
+respectively.
+
+
Implementation notes:
+
+
This is one of the more complex utilities, and the amount of
+argument checking needed to do it properly is daunting. An amazing 76%
+of the code is spent on making sure that the bounds are valid and in
+order, and on what to do if they aren't. Once you remove all that, the
+actual function which does all the work is quite simple, and unlikely
+to contain bugs.
+
+
The design of this function makes it a little annoying to use, but
+it is more efficient. If you need something more high-level, this
+could be built on top of read-delimited fairly easily.
Rotates a field of bits within integer; specifically, returns an
+integer that contains the bits of integer rotated count times
+leftwards within the byte specified by bytespec, and elsewhere
+contains the bits of integer.
SBCL provides the sb-rotate-byte extension to do this
+efficiently. On SBCL, cl-utilities uses this extension
+automatically. On other implementations, portable Common Lisp code is
+used instead.
+
+
split-sequencedelimiter sequence &key count remove-empty-subseqs from-end start end test test-not key => list, index
+
split-sequence-ifpredicate sequence &key count remove-empty-subseqs from-end start end key => list, index
+
+
split-sequence-if-notpredicate sequence &key count remove-empty-subseqs from-end start end key => list, index
+
+
Arguments and Values:
+
+
delimiter---an object.
+
+
predicate---a designator for a function of one argument that returns a generalized boolean.
+
sequence---a proper sequence.
+
+
count---an integer or nil. The default is nil.
+
remove-empty-subseqs---a generalized boolean. The default is false.
+
+
from-end---a generalized boolean. The default is false.
+
start, end---bounding index designators of sequence. The defaults for start and end are 0 and nil, respectively.
+
+
test---a designator for a function of two arguments that returns a generalized boolean.
+
test-not---a designator for a function of two arguments that returns a generalized boolean.
+
+
key---a designator for a function of one argument, or nil.
+
list---a proper sequence.
+
+
index---an integer greater than or equal to zero, and less than or equal to the length of the sequence.
+
+
Description:
+
+
Splits sequence into a list of subsequences delimited by objects satisfying the test.
+
+
+
List is a list of sequences of the same kind as sequence that has elements consisting of subsequences of sequence that were delimited in the argument by elements satisfying the test. Index is an index into sequence indicating the unprocessed region, suitable as an argument to subseq to continue processing in the same manner if desired.
+
+
+
The count argument, if supplied, limits the number of subsequences in the first return value; if more than count delimited subsequences exist in sequence, the count leftmost delimited subsequences will be in order in the first return value, and the second return value will be the index into sequence at which processing stopped.
+
+
If from-end is non-null, sequence is conceptually processed from right to left, accumulating the subsequences in reverse order; from-end only makes a difference in the case of a non-null count argument. In the presence of from-end, the count rightmost delimited subsequences will be in the order that they are in sequence in the first return value, and the second is the index indicating the end of the unprocessed region.
+
+
+
The start and end keyword arguments permit a certain subsequence of the sequence to be processed without the need for a copying stage; their use is conceptually equivalent to partitioning the subsequence delimited by start and end, only without the need for copying.
+
+
If remove-empty-subseqs is null (the default), then empty subsequences will be included in the result.
+
+
+
In all cases, the subsequences in the first return value will be in the order that they appeared in sequence.
+
+
This code was written various people, and the license is
+unknown. Since multiple people worked on it collaboratively and none
+of them seem interested in keeping their intellectual property rights
+to it, I'll assume that it is in the public domain (since the process
+that produced it seems like the very essence of public domain). If
+this is incorrect, please contact
+me so we can get it straightened out.
+
+
The implementation itself is mature and well tested, and it is
+widely used. The code should be fast enough for most people, but be
+warned: it was written with vectors in mind, with list manipulation as
+an afterthought. It does a lot of things that are quick on vectors but
+slow on lists, and this can result in many orders of magnitude
+slowdown in list benchmarks versus code written for lists. If this is
+a problem for you, it should be straightforward to write your own,
+such as the (more limited, not API compatible) example function given
+by Szymon in this
+mailing list post:
+
+
+(defun split-list-if (test list &aux (start list) (end list))
+ (loop while (and end (setq start (member-if-not test end)))
+ collect (ldiff start (setq end (member-if test start)))))
+
+
+
If this is an issue for enough people, I could optimize the code
+and fix this problem. I'm reluctant to do that, however, since the
+code works and is tested. It's usually more important to be correct
+and non-buggy than to be fast, and I have been known to introduce
+bugs.
This is an extension of the classic macro with-gensyms. In
+fact, cl-utilities also exports with-gensyms, and it can be
+used as usual. The exported with-gensyms is actually just an
+alias for with-unique-names which gives a warning at
+compile-time if the extensions of with-unique-names are used.
+
+
You are encouraged to use with-unique-names instead of
+with-gensyms because it is a little more flexible and because
+it tells what is going on rather than how it works. This is a somewhat
+controversial point, so go ahead and use whichever you like if you
+have an opinion on it. But if you're a newbie who honestly doesn't
+care, please use with-unique-names.
+
+
Manual Index
+
+
+
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/expt-mod.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/expt-mod.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,38 @@
+(in-package :cl-utilities)
+
+;; This is portable Common Lisp, but implementation-specific code may
+;; improve performance considerably.
+(defun expt-mod (n exponent modulus)
+ "As (mod (expt n exponent) modulus), but more efficient."
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ ;; It's much faster on SBCL and ACL to use the simple method, and
+ ;; trust the compiler to optimize it. This may be the case on other
+ ;; Lisp implementations as well.
+ #+(or sbcl allegro) (mod (expt n exponent) modulus)
+ #-(or sbcl allegro)
+ (if (some (complement #'integerp) (list n exponent modulus))
+ (mod (expt n exponent) modulus)
+ (loop with result = 1
+ for i of-type fixnum from 0 below (integer-length exponent)
+ for sqr = n then (mod (* sqr sqr) modulus)
+ when (logbitp i exponent) do
+ (setf result (mod (* result sqr) modulus))
+ finally (return result))))
+
+;; If the compiler is going to expand compiler macros, we should
+;; directly inline the simple expansion; this lets the compiler do all
+;; sorts of fancy optimizations based on type information that
+;; wouldn't be used to optimize the normal EXPT-MOD function.
+#+(or sbcl allegro)
+(define-compiler-macro expt-mod (n exponent modulus)
+ `(mod (expt ,n ,exponent) ,modulus))
+
+
+;; Here's some benchmarking code that may be useful. I probably
+;; completely wasted my time declaring ITERATIONS to be a fixnum.
+#+nil
+(defun test (&optional (iterations 50000000))
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1))
+ (fixnum iterations))
+ (time (loop repeat iterations do (mod (expt 12 34) 235)))
+ (time (loop repeat iterations do (expt-mod 12 34 235))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/extremum.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/extremum.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,167 @@
+(in-package :cl-utilities)
+
+(define-condition no-extremum (error) ()
+ (:report "Cannot find extremum of empty sequence")
+ (:documentation "Raised when EXTREMUM is called on an empty
+sequence, since there is no morally smallest element"))
+
+(defun comparator (test &optional (key #'identity))
+ "Comparison operator: auxilliary function used by EXTREMUM"
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (lambda (a b) (if (funcall test
+ (funcall key a)
+ (funcall key b))
+ a
+ b)))
+
+;; This optimizes the case where KEY is #'identity
+(define-compiler-macro comparator (&whole whole test
+ &optional (key #'identity))
+ (if (eql key #'identity)
+ `(lambda (a b)
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (if (funcall ,test a b) a b))
+ whole))
+
+;; The normal way of testing the if length of a proper sequence equals
+;; zero is to just use (zerop (length sequence)). And, while some
+;; implementations may optimize this, it's probably a good idea to
+;; just write an optimized version and use it. This method can speed
+;; up list length testing.
+(defun zero-length-p (sequence)
+ "Is the length of SEQUENCE equal to zero?"
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (or (null sequence)
+ (when (vectorp sequence)
+ (zerop (length sequence)))))
+
+(declaim (inline zero-length-p))
+
+;; Checks the length of the subsequence of SEQUENCE specified by START
+;; and END, and if it's 0 then a NO-EXTREMUM error is signalled. This
+;; should only be used in EXTREMUM functions.
+(defmacro with-check-length ((sequence start end) &body body)
+ (once-only (sequence start end)
+ `(if (or (zero-length-p ,sequence)
+ (>= ,start (or ,end (length ,sequence))))
+ (restart-case (error 'no-extremum)
+ (continue ()
+ :report "Return NIL instead"
+ nil))
+ (progn , at body))))
+
+;; This is an extended version which takes START and END keyword
+;; arguments. Any spec-compliant use of EXTREMUM will also work with
+;; this extended version.
+(defun extremum (sequence predicate
+ &key (key #'identity) (start 0) end)
+ "Returns the element of SEQUENCE that would appear first if the
+sequence were ordered according to SORT using PREDICATE and KEY using
+an unstable sorting algorithm. See http://www.cliki.net/EXTREMUM for
+the full specification."
+ (with-check-length (sequence start end)
+ (reduce (comparator predicate key) sequence
+ :start start :end end)))
+
+;; This optimizes the case where KEY is #'identity
+(define-compiler-macro extremum (&whole whole sequence predicate
+ &key (key #'identity) (start 0) end)
+ (if (eql key #'identity)
+ (once-only (sequence predicate start end)
+ `(with-check-length (,sequence ,start ,end)
+ (locally (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (reduce (comparator ,predicate) ,sequence
+ :start ,start :end ,end))))
+ whole))
+
+;; This is an "optimized" version which calls KEY less. REDUCE is
+;; already so optimized that this will actually be slower unless KEY
+;; is expensive. And on CLISP, of course, the regular version will be
+;; much faster since built-in functions are ridiculously faster than
+;; ones implemented in Lisp. Be warned, this isn't as carefully tested
+;; as regular EXTREMUM and there's more that could go wrong.
+(defun extremum-fastkey (sequence predicate
+ &key (key #'identity) (start 0) end)
+ "EXTREMUM implemented so that it calls KEY less. This is only faster
+if the KEY function is so slow that calling it less often would be a
+significant improvement; ordinarily it's slower."
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ (with-check-length (sequence start end)
+ (let* ((smallest (elt sequence 0))
+ (smallest-key (funcall key smallest))
+ (current-index 0)
+ (real-end (or end (1- most-positive-fixnum))))
+ (declare (type (integer 0) current-index real-end start)
+ (fixnum current-index real-end start))
+ (map nil #'(lambda (x)
+ (when (<= start current-index real-end)
+ (let ((x-key (funcall key x)))
+ (when (funcall predicate
+ x-key
+ smallest-key)
+ (setf smallest x)
+ (setf smallest-key x-key))))
+ (incf current-index))
+ sequence)
+ smallest)))
+
+;; EXTREMA and N-MOST-EXTREME are based on code and ideas from Tobias
+;; C. Rittweiler. They deal with the cases in which you are not
+;; looking for a single extreme element, but for the extreme identical
+;; elements or the N most extreme elements.
+
+(defun extrema (sequence predicate &key (key #'identity) (start 0) end)
+ (with-check-length (sequence start end)
+ (let* ((sequence (subseq sequence start end))
+ (smallest-elements (list (elt sequence 0)))
+ (smallest-key (funcall key (elt smallest-elements 0))))
+ (map nil
+ #'(lambda (x)
+ (let ((x-key (funcall key x)))
+ (cond ((funcall predicate x-key smallest-key)
+ (setq smallest-elements (list x))
+ (setq smallest-key x-key))
+ ;; both elements are considered equal if the predicate
+ ;; returns false for (PRED A B) and (PRED B A)
+ ((not (funcall predicate smallest-key x-key))
+ (push x smallest-elements)))))
+ (subseq sequence 1))
+ ;; We use NREVERSE to make this stable (in the sorting algorithm
+ ;; sense of the word 'stable').
+ (nreverse smallest-elements))))
+
+
+
+(define-condition n-most-extreme-not-enough-elements (warning)
+ ((n :initarg :n :reader n-most-extreme-not-enough-elements-n
+ :documentation "The number of elements that need to be returned")
+ (subsequence :initarg :subsequence
+ :reader n-most-extreme-not-enough-elements-subsequence
+ :documentation "The subsequence from which elements
+must be taken. This is determined by the sequence and the :start and
+:end arguments to N-MOST-EXTREME."))
+ (:report (lambda (condition stream)
+ (with-slots (n subsequence) condition
+ (format stream "There are not enough elements in the sequence ~S~% to return the ~D most extreme elements"
+ subsequence n))))
+ (:documentation "There are not enough elements in the sequence given
+to N-MOST-EXTREME to return the N most extreme elements."))
+
+(defun n-most-extreme (n sequence predicate &key (key #'identity) (start 0) end)
+ "Returns a list of the N elements of SEQUENCE that would appear
+first if the sequence were ordered according to SORT using PREDICATE
+and KEY with a stable sorting algorithm. If there are less than N
+elements in the relevant part of the sequence, this will return all
+the elements it can and signal the warning
+N-MOST-EXTREME-NOT-ENOUGH-ELEMENTS"
+ (check-type n (integer 0))
+ (with-check-length (sequence start end)
+ ;; This is faster on vectors than on lists.
+ (let ((sequence (subseq sequence start end)))
+ (if (> n (length sequence))
+ (progn
+ (warn 'n-most-extreme-not-enough-elements
+ :n n :subsequence sequence)
+ (stable-sort (copy-seq sequence) predicate :key key))
+ (subseq (stable-sort (copy-seq sequence) predicate :key key)
+ 0 n)))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/once-only.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/once-only.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,31 @@
+;; The ONCE-ONLY macro is hard to explain, hard to understand, hard to
+;; write, hard to modify, and hard to live without once you figure out
+;; how to use it. It's used in macros to guard against multiple
+;; evaluation of arguments. My version is longer than most, but it
+;; does some error checking and it gives gensym'd variables more
+;; meaningful names than usual.
+
+(in-package :cl-utilities)
+
+(defun %check-once-only-names (names)
+ "Check that all of the NAMES are symbols. If not, raise an error."
+ ;; This only raises an error for the first non-symbol argument
+ ;; found. While this won't report multiple errors, it is probably
+ ;; more convenient to only report one.
+ (let ((bad-name (find-if-not #'symbolp names)))
+ (when bad-name
+ (error "ONCE-ONLY expected a symbol but got ~S" bad-name))))
+
+(defmacro once-only (names &body body)
+ ;; Check the NAMES list for validity.
+ (%check-once-only-names names)
+ ;; Do not touch this code unless you really know what you're doing.
+ (let ((gensyms (loop for name in names collect (gensym (string name)))))
+ `(let (,@(loop for g in gensyms
+ for name in names
+ collect `(,g (gensym ,(string name)))))
+ `(let (,,@(loop for g in gensyms for n in names
+ collect ``(,,g ,,n)))
+ ,(let (,@(loop for n in names for g in gensyms
+ collect `(,n ,g)))
+ , at body)))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/package.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/package.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,49 @@
+(defpackage :cl-utilities
+ (:use :common-lisp)
+ (:export #:split-sequence
+ #:split-sequence-if
+ #:split-sequence-if-not
+ #:partition
+ #:partition-if
+ #:partition-if-not
+
+ #:extremum
+ #:no-extremum
+ #:extremum-fastkey
+ #:extrema
+ #:n-most-extreme
+ #:n-most-extreme-not-enough-elements
+ #:n-most-extreme-not-enough-elements-n
+ #:n-most-extreme-not-enough-elements-subsequence
+
+ #:read-delimited
+ #:read-delimited-bounds-error
+ #:read-delimited-bounds-error-start
+ #:read-delimited-bounds-error-end
+ #:read-delimited-bounds-error-sequence
+
+ #:expt-mod
+
+ #:collecting
+ #:collect
+ #:with-collectors
+
+ #:with-unique-names
+ #:with-gensyms
+ #:list-binding-not-supported
+ #:list-binding-not-supported-binding
+
+ #:once-only
+
+ #:rotate-byte
+
+ #:copy-array
+
+ #:compose))
+
+#+split-sequence-deprecated
+(defpackage :split-sequence
+ (:documentation "This package mimics SPLIT-SEQUENCE for compatibility with
+packages that expect that system.")
+ (:use :cl-utilities)
+ (:export #:split-sequence #:split-sequence-if #:split-sequence-if-not))
Added: dependencies/trunk/cl-utilities-1.2.4/package.sh
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/package.sh Tue Jan 26 15:20:07 2010
@@ -0,0 +1,21 @@
+#!/bin/sh
+
+mkdir cl-utilities-1.2.4
+mkdir cl-utilities-1.2.4/doc
+cp cl-utilities.asd package.sh collecting.lisp split-sequence.lisp expt-mod.lisp package.lisp compose.lisp extremum.lisp read-delimited.lisp test.lisp copy-array.lisp once-only.lisp rotate-byte.lisp with-unique-names.lisp README cl-utilities-1.2.4/
+cp doc/collecting.html doc/expt-mod.html doc/read-delimited.html doc/with-unique-names.html doc/compose.html doc/extremum.html doc/rotate-byte.html doc/copy-array.html doc/index.html doc/split-sequence.html doc/once-only.html doc/style.css cl-utilities-1.2.4/doc/
+
+rm -f cl-utilities-latest.tar.gz cl-utilities-latest.tar.gz.asc
+
+tar -czvf cl-utilities-1.2.4.tar.gz cl-utilities-1.2.4/
+ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz
+gpg -b -a ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz
+ln -s ~/hacking/lisp/cl-utilities/cl-utilities-1.2.4.tar.gz.asc ~/hacking/lisp/cl-utilities/cl-utilities-latest.tar.gz.asc
+rm -Rf cl-utilities-1.2.4/
+
+scp cl-utilities-1.2.4.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.4.tar.gz
+scp cl-utilities-1.2.4.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-1.2.4.tar.gz.asc
+scp cl-utilities-latest.tar.gz pscott at common-lisp.net:/project/cl-utilities/ftp/cl-utilities-1.2.4.tar.gz
+scp cl-utilities-latest.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/ftp/cl-utilities-1.2.4.tar.gz.asc
+scp cl-utilities-latest.tar.gz pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-latest.tar.gz
+scp cl-utilities-latest.tar.gz.asc pscott at common-lisp.net:/project/cl-utilities/public_html/cl-utilities-latest.tar.gz.asc
Added: dependencies/trunk/cl-utilities-1.2.4/read-delimited.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/read-delimited.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,78 @@
+(in-package :cl-utilities)
+
+(defun read-delimited (sequence stream &key (start 0) end
+ (delimiter #\Newline) (test #'eql) (key #'identity))
+ ;; Check bounds on SEQUENCE
+ (multiple-value-setq (start end)
+ (%read-delimited-bounds-check sequence start end))
+ ;; Loop until we run out of input characters or places to put them,
+ ;; or until we encounter the delimiter.
+ (loop for index from start
+ for char = (read-char stream nil nil)
+ for test-result = (funcall test (funcall key char) delimiter)
+ while (and char
+ (< index end)
+ (not test-result))
+ do (setf (elt sequence index) char)
+ finally (return-from read-delimited
+ (values index test-result))))
+
+;; Conditions
+;;;;;;;;;;;;;
+
+(define-condition read-delimited-bounds-error (error)
+ ((start :initarg :start :reader read-delimited-bounds-error-start)
+ (end :initarg :end :reader read-delimited-bounds-error-end)
+ (sequence :initarg :sequence :reader read-delimited-bounds-error-sequence))
+ (:report (lambda (condition stream)
+ (with-slots (start end sequence) condition
+ (format stream "The bounding indices ~S and ~S are bad for a sequence of length ~S"
+ start end (length sequence)))))
+ (:documentation "There's a problem with the indices START and END
+for SEQUENCE. See CLHS SUBSEQ-OUT-OF-BOUNDS:IS-AN-ERROR issue."))
+
+;; Error checking for bounds
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun %read-delimited-bounds-check (sequence start end)
+ "Check to make sure START and END are in bounds when calling
+READ-DELIMITED with SEQUENCE"
+ (check-type start (or integer null))
+ (check-type end (or integer null))
+ (let ((start (%read-delimited-bounds-check-start sequence start end))
+ (end (%read-delimited-bounds-check-end sequence start end)))
+ ;; Returns (values start end)
+ (%read-delimited-bounds-check-order sequence start end)))
+
+(defun %read-delimited-bounds-check-order (sequence start end)
+ "Check the order of START and END bounds, and return them in the
+correct order."
+ (when (< end start)
+ (restart-case (error 'read-delimited-bounds-error
+ :start start :end end :sequence sequence)
+ (continue ()
+ :report "Switch start and end"
+ (rotatef start end))))
+ (values start end))
+
+(defun %read-delimited-bounds-check-start (sequence start end)
+ "Check to make sure START is in bounds when calling READ-DELIMITED
+with SEQUENCE"
+ (when (and start (< start 0))
+ (restart-case (error 'read-delimited-bounds-error
+ :start start :end end :sequence sequence)
+ (continue ()
+ :report "Use default for START instead"
+ (setf start 0))))
+ start)
+
+(defun %read-delimited-bounds-check-end (sequence start end)
+ "Check to make sure END is in bounds when calling READ-DELIMITED
+with SEQUENCE"
+ (when (and end (> end (length sequence)))
+ (restart-case (error 'read-delimited-bounds-error
+ :start start :end end :sequence sequence)
+ (continue ()
+ :report "Use default for END instead"
+ (setf end nil))))
+ (or end (length sequence)))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/rotate-byte.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/rotate-byte.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,29 @@
+(in-package :cl-utilities)
+
+(defun rotate-byte (count bytespec integer)
+ "Rotates a field of bits within INTEGER; specifically, returns an
+integer that contains the bits of INTEGER rotated COUNT times
+leftwards within the byte specified by BYTESPEC, and elsewhere
+contains the bits of INTEGER. See http://www.cliki.net/ROTATE-BYTE"
+ (declare (optimize (speed 3) (safety 0) (space 0) (debug 1)))
+ #-sbcl
+ (let ((size (byte-size bytespec)))
+ (when (= size 0)
+ (return-from rotate-byte integer))
+ (let ((count (mod count size)))
+ (labels ((rotate-byte-from-0 (count size integer)
+ (let ((bytespec (byte size 0)))
+ (if (> count 0)
+ (logior (ldb bytespec (ash integer count))
+ (ldb bytespec (ash integer (- count size))))
+ (logior (ldb bytespec (ash integer count))
+ (ldb bytespec (ash integer (+ count size))))))))
+ (dpb (rotate-byte-from-0 count size (ldb bytespec integer))
+ bytespec
+ integer))))
+ ;; On SBCL, we use the SB-ROTATE-BYTE extension.
+ #+sbcl-uses-sb-rotate-byte (sb-rotate-byte:rotate-byte count bytespec integer))
+
+;; If we're using the SB-ROTATE-BYTE extension, we should inline our
+;; call and let SBCL handle optimization from there.
+#+sbcl-uses-sb-rotate-byte (declaim (inline rotate-byte))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/split-sequence.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/split-sequence.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,244 @@
+;;;; SPLIT-SEQUENCE
+;;;
+;;; This code was based on Arthur Lemmens' in
+;;; ;
+;;;
+;;; changes include:
+;;;
+;;; * altering the behaviour of the :from-end keyword argument to
+;;; return the subsequences in original order, for consistency with
+;;; CL:REMOVE, CL:SUBSTITUTE et al. (:from-end being non-NIL only
+;;; affects the answer if :count is less than the number of
+;;; subsequences, by analogy with the above-referenced functions).
+;;;
+;;; * changing the :maximum keyword argument to :count, by analogy
+;;; with CL:REMOVE, CL:SUBSTITUTE, and so on.
+;;;
+;;; * naming the function SPLIT-SEQUENCE rather than PARTITION rather
+;;; than SPLIT.
+;;;
+;;; * adding SPLIT-SEQUENCE-IF and SPLIT-SEQUENCE-IF-NOT.
+;;;
+;;; * The second return value is now an index rather than a copy of a
+;;; portion of the sequence; this index is the `right' one to feed to
+;;; CL:SUBSEQ for continued processing.
+
+;;; There's a certain amount of code duplication here, which is kept
+;;; to illustrate the relationship between the SPLIT-SEQUENCE
+;;; functions and the CL:POSITION functions.
+
+;;; Examples:
+;;;
+;;; * (split-sequence #\; "a;;b;c")
+;;; -> ("a" "" "b" "c"), 6
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t)
+;;; -> ("a" "" "b" "c"), 0
+;;;
+;;; * (split-sequence #\; "a;;b;c" :from-end t :count 1)
+;;; -> ("c"), 4
+;;;
+;;; * (split-sequence #\; "a;;b;c" :remove-empty-subseqs t)
+;;; -> ("a" "b" "c"), 6
+;;;
+;;; * (split-sequence-if (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("" "" "r" "c" "d" "" "r" ""), 11
+;;;
+;;; * (split-sequence-if-not (lambda (x) (member x '(#\a #\b))) "abracadabra")
+;;; -> ("ab" "a" "a" "ab" "a"), 11
+;;;
+;;; * (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9)
+;;; -> ("oo" "bar" "b"), 9
+
+;; cl-utilities note: the license of this file is unclear, and I don't
+;; even know whom to contact to clarify it. If anybody objects to my
+;; assumption that it is public domain, please contact me so I can do
+;; something about it. Previously I required the split-sequence
+ ; package as a dependency, but that was so unwieldy that it was *the*
+;; sore spot sticking out in the design of cl-utilities. -Peter Scott
+
+(in-package :cl-utilities)
+
+(defun split-sequence (delimiter seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (test nil test-supplied) (test-not nil test-not-supplied) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by delimiter.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (let ((len (length seq))
+ (other-keys (nconc (when test-supplied
+ (list :test test))
+ (when test-not-supplied
+ (list :test-not test-not))
+ (when key-supplied
+ (list :key key)))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position delimiter seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position delimiter seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+(defun split-sequence-if (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by items satisfying
+predicate.
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF. In particular, the
+behaviour of :from-end is possibly different from other versions of
+this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped."
+ (let ((len (length seq))
+ (other-keys (when key-supplied
+ (list :key key))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position-if predicate seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position-if predicate seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+(defun split-sequence-if-not (predicate seq &key (count nil) (remove-empty-subseqs nil) (from-end nil) (start 0) (end nil) (key nil key-supplied))
+ "Return a list of subsequences in seq delimited by items satisfying
+(CL:COMPLEMENT predicate).
+
+If :remove-empty-subseqs is NIL, empty subsequences will be included
+in the result; otherwise they will be discarded. All other keywords
+work analogously to those for CL:SUBSTITUTE-IF-NOT. In particular,
+the behaviour of :from-end is possibly different from other versions
+of this function; :from-end values of NIL and T are equivalent unless
+:count is supplied. The second return value is an index suitable as an
+argument to CL:SUBSEQ into the sequence indicating where processing
+stopped." ; Emacs syntax highlighting is broken, and this helps: "
+ (let ((len (length seq))
+ (other-keys (when key-supplied
+ (list :key key))))
+ (unless end (setq end len))
+ (if from-end
+ (loop for right = end then left
+ for left = (max (or (apply #'position-if-not predicate seq
+ :end right
+ :from-end t
+ other-keys)
+ -1)
+ (1- start))
+ unless (and (= right (1+ left))
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values (nreverse subseqs) right)
+ else
+ collect (subseq seq (1+ left) right) into subseqs
+ and sum 1 into nr-elts
+ until (< left start)
+ finally (return (values (nreverse subseqs) (1+ left))))
+ (loop for left = start then (+ right 1)
+ for right = (min (or (apply #'position-if-not predicate seq
+ :start left
+ other-keys)
+ len)
+ end)
+ unless (and (= right left)
+ remove-empty-subseqs) ; empty subseq we don't want
+ if (and count (>= nr-elts count))
+ ;; We can't take any more. Return now.
+ return (values subseqs left)
+ else
+ collect (subseq seq left right) into subseqs
+ and sum 1 into nr-elts
+ until (>= right end)
+ finally (return (values subseqs right))))))
+
+;;; clean deprecation
+
+(defun partition (&rest args)
+ (apply #'split-sequence args))
+
+(defun partition-if (&rest args)
+ (apply #'split-sequence-if args))
+
+(defun partition-if-not (&rest args)
+ (apply #'split-sequence-if-not args))
+
+(define-compiler-macro partition (&whole form &rest args)
+ (declare (ignore args))
+ (warn "PARTITION is deprecated; use SPLIT-SEQUENCE instead.")
+ form)
+
+(define-compiler-macro partition-if (&whole form &rest args)
+ (declare (ignore args))
+ (warn "PARTITION-IF is deprecated; use SPLIT-SEQUENCE-IF instead.")
+ form)
+
+(define-compiler-macro partition-if-not (&whole form &rest args)
+ (declare (ignore args))
+ (warn "PARTITION-IF-NOT is deprecated; use SPLIT-SEQUENCE-IF-NOT instead")
+ form)
+
+(pushnew :split-sequence *features*)
Added: dependencies/trunk/cl-utilities-1.2.4/test.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/test.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,178 @@
+;; This file requires the FiveAM unit testing framework.
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (asdf:oos 'asdf:load-op :fiveam)
+ (asdf:oos 'asdf:load-op :cl-utilities))
+
+;; To run all the tests:
+;; (5am:run! 'cl-utilities-tests::cl-utilities-suite)
+
+(defpackage :cl-utilities-tests
+ (:use :common-lisp :cl-utilities :5am))
+
+(in-package :cl-utilities-tests)
+
+(def-suite cl-utilities-suite :description "Test suite for cl-utilities")
+(in-suite cl-utilities-suite)
+
+;; These tests were taken directly from the comments at the top of
+;; split-sequence.lisp
+(test split-sequence
+ (is (tree-equal (values (split-sequence #\; "a;;b;c"))
+ '("a" "" "b" "c") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; "a;;b;c" :from-end t))
+ '("a" "" "b" "c") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; "a;;b;c" :from-end t :count 1))
+ '("c") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; "a;;b;c" :remove-empty-subseqs t))
+ '("a" "b" "c") :test #'equal))
+ (is (tree-equal (values (split-sequence-if (lambda (x)
+ (member x '(#\a #\b)))
+ "abracadabra"))
+ '("" "" "r" "c" "d" "" "r" "") :test #'equal))
+ (is (tree-equal (values (split-sequence-if-not (lambda (x)
+ (member x '(#\a #\b)))
+ "abracadabra"))
+ '("ab" "a" "a" "ab" "a") :test #'equal))
+ (is (tree-equal (values (split-sequence #\; ";oo;bar;ba;" :start 1 :end 9))
+ '("oo" "bar" "b") :test #'equal)))
+
+(test extremum
+ (is (= (extremum '(1 23 3 4 5 0) #'< :start 1 :end 4) 3))
+ (signals no-extremum (extremum '() #'<))
+ (is-false (handler-bind ((no-extremum #'continue))
+ (extremum '() #'<)))
+ (is (= (extremum '(2/3 2 3 4) #'> :key (lambda (x) (/ 1 x))) 2/3))
+ (is (= (locally (declare (optimize (speed 3) (safety 0)))
+ (extremum #(1 23 3 4 5 0) #'>))
+ 23))
+ (is (= (extremum-fastkey '(2/3 2 3 4) #'> :key (lambda (x) (/ 1 x))) 2/3)))
+
+(test extrema
+ (is (tree-equal (extrema '(3 2 1 1 2 1) #'<)
+ '(1 1 1)))
+ (is (tree-equal (extrema #(3 2 1 1 2 1) #'<)
+ '(1 1 1)))
+ (is (tree-equal (extrema #(3 2 1 1 2 1) #'< :end 4)
+ '(1 1)))
+ (is (tree-equal (extrema '(3 2 1 1 2 1) #'< :end 4)
+ '(1 1)))
+ (is (tree-equal (extrema #(3 2 1 1 2 1) #'< :start 3 :end 4)
+ '(1)))
+ (is (tree-equal (extrema '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr)
+ '((B . 1) (D . 1)))))
+
+(defmacro quietly (&body body)
+ "Perform BODY quietly, muffling any warnings that may arise"
+ `(handler-bind ((warning #'muffle-warning))
+ , at body))
+
+(test n-most-extreme
+ (is (tree-equal (n-most-extreme 1 '(3 1 2 1) #'>)
+ '(3)))
+ (is (tree-equal (n-most-extreme 2 '(3 1 2 1) #'>)
+ '(3 2)))
+ (is (tree-equal (n-most-extreme 2 '(3 1 2 1) #'<)
+ '(1 1)))
+ (is (tree-equal (n-most-extreme 1 '((A . 3) (B . 1) (C . 2) (D . 1)) #'> :key #'cdr)
+ '((A . 3))))
+ (is (tree-equal (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr)
+ '((B . 1) (D . 1))))
+ (is (tree-equal (quietly (n-most-extreme 20 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr))
+ '((B . 1) (D . 1) (C . 2) (A . 3))))
+ (is (tree-equal (quietly (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr :start 1 :end 2))
+ '((B . 1))))
+ (signals n-most-extreme-not-enough-elements (n-most-extreme 2 '((A . 3) (B . 1) (C . 2) (D . 1)) #'< :key #'cdr :start 1 :end 2)))
+
+(defun delimited-test (&key (delimiter #\|) (start 0) end
+ (string "foogo|ogreogrjejgierjijri|bar|baz"))
+ (with-input-from-string (str string)
+ (let ((buffer (copy-seq " ")))
+ (multiple-value-bind (position delimited-p)
+ (read-delimited buffer str
+ :delimiter delimiter :start start :end end)
+ (declare (ignore delimited-p))
+ (subseq buffer 0 position)))))
+
+(test read-delimited
+ (is (string= (delimited-test) "foogo"))
+ (is (string= (delimited-test :delimiter #\t) "foogo|ogreog"))
+ (is (string= (delimited-test :delimiter #\t :start 3) " foogo|ogr"))
+ (is (string= (delimited-test :start 3) " foogo"))
+ (is (string= (delimited-test :end 3) "foo"))
+ (is (string= (delimited-test :start 1 :end 3) " fo"))
+ (is (string= (delimited-test :string "Hello") "Hello"))
+ (is (string= (delimited-test :string "Hello" :start 3) " Hello"))
+ (is (string= (handler-bind ((read-delimited-bounds-error #'continue))
+ (delimited-test :start 3 :end 1))
+ " fo"))
+ (signals type-error (delimited-test :start 3/2))
+ (signals read-delimited-bounds-error (delimited-test :start -3))
+ (signals read-delimited-bounds-error (delimited-test :end 30))
+ (signals read-delimited-bounds-error (delimited-test :start 3 :end 1)))
+
+;; Random testing would probably work better here.
+(test expt-mod
+ (is (= (expt-mod 2 34 54) (mod (expt 2 34) 54)))
+ (is (= (expt-mod 20 3 54) (mod (expt 20 3) 54)))
+ (is (= (expt-mod 2.5 3.8 34.9) (mod (expt 2.5 3.8) 34.9)))
+ (is (= (expt-mod 2/5 3/8 34/9) (mod (expt 2/5 3/8) 34/9))))
+
+(test collecting
+ (is (tree-equal (collecting (dotimes (x 10) (collect x)))
+ '(0 1 2 3 4 5 6 7 8 9)))
+ (is (tree-equal (collecting
+ (labels ((collect-it (x) (collect x)))
+ (mapcar #'collect-it (reverse '(c b a)))))
+ '(a b c)))
+ (is (tree-equal (multiple-value-bind (a b)
+ (with-collectors (x y)
+ (x 1)
+ (y 2)
+ (x 3))
+ (append a b))
+ '(1 3 2))))
+
+(test with-unique-names
+ (is (equalp (subseq (with-unique-names (foo)
+ (string foo))
+ 0 3)
+ "foo"))
+ (is (equalp (subseq (with-unique-names ((foo "bar"))
+ (string foo))
+ 0 3)
+ "bar"))
+ (is (equalp (subseq (with-unique-names ((foo baz))
+ (string foo))
+ 0 3)
+ "baz"))
+ (is (equalp (subseq (with-unique-names ((foo #\y))
+ (string foo))
+ 0 1)
+ "y"))
+ (is (equalp (subseq (with-gensyms (foo)
+ (string foo))
+ 0 3)
+ "foo")))
+
+;; Taken from spec
+(test rotate-byte
+ (is (= (rotate-byte 3 (byte 32 0) 3) 24))
+ (is (= (rotate-byte 3 (byte 5 5) 3) 3))
+ (is (= (rotate-byte 6 (byte 8 0) -3) -129)))
+
+(test copy-array
+ (let ((test-array (make-array '(10 10) :initial-element 5)))
+ (is (not (eq (copy-array test-array) test-array)))
+ (is (equalp (copy-array test-array) test-array))))
+
+(test compose
+ (labels ((2* (x) (* 2 x)))
+ (is (= (funcall (compose #'1+ #'1+) 1) 3))
+ (is (= (funcall (compose '1+ #'2*) 5) 11))
+ (is (= (funcall (compose #'1+ #'2* '1+) 6) 15))
+ ;; This should signal an undefined function error, since we're
+ ;; using '2* rather than #'2*, which means that COMPOSE will use
+ ;; the dynamic binding at the time it is called rather than the
+ ;; lexical binding here.
+ (signals undefined-function
+ (= (funcall (compose #'1+ '2* '1+) 6) 15))))
\ No newline at end of file
Added: dependencies/trunk/cl-utilities-1.2.4/with-unique-names.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/cl-utilities-1.2.4/with-unique-names.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,46 @@
+(in-package :cl-utilities)
+
+;; Defined at http://www.cliki.net/WITH-UNIQUE-NAMES
+
+(defmacro with-unique-names ((&rest bindings) &body body)
+ "Executes a series of forms with each var bound to a fresh,
+uninterned symbol. See http://www.cliki.net/WITH-UNIQUE-NAMES"
+ `(let ,(mapcar #'(lambda (binding)
+ (multiple-value-bind (var prefix)
+ (%with-unique-names-binding-parts binding)
+ (check-type var symbol)
+ `(,var (gensym ,(format nil "~A"
+ (or prefix var))))))
+ bindings)
+ , at body))
+
+(defun %with-unique-names-binding-parts (binding)
+ "Return (values var prefix) from a WITH-UNIQUE-NAMES binding
+form. If PREFIX is not given in the binding, NIL is returned to
+indicate that the default should be used."
+ (if (consp binding)
+ (values (first binding) (second binding))
+ (values binding nil)))
+
+(define-condition list-binding-not-supported (warning)
+ ((binding :initarg :binding :reader list-binding-not-supported-binding))
+ (:report (lambda (condition stream)
+ (format stream "List binding ~S not supported by WITH-GENSYMS.
+It will work, but you should use WITH-UNIQUE-NAMES instead."
+ (list-binding-not-supported-binding condition))))
+ (:documentation "List bindings aren't supported by WITH-GENSYMS, and
+if you want to use them you should use WITH-UNIQUE-NAMES instead. That
+said, they will work; they'll just signal this warning to complain
+about it."))
+
+
+(defmacro with-gensyms ((&rest bindings) &body body)
+ "Synonym for WITH-UNIQUE-NAMES, but BINDINGS should only consist of
+atoms; lists are not supported. If you try to give list bindings, a
+LIST-BINDING-NOT-SUPPORTED warning will be signalled, but it will work
+the same way as WITH-UNIQUE-NAMES. Don't do it, though."
+ ;; Signal a warning for each list binding, if there are any
+ (dolist (binding (remove-if-not #'listp bindings))
+ (warn 'list-binding-not-supported :binding binding))
+ ;; Otherwise, this is a synonym for WITH-UNIQUE-NAMES
+ `(with-unique-names ,bindings , at body))
\ No newline at end of file
Added: dependencies/trunk/commons-logging.jar
==============================================================================
Binary file. No diff available.
Added: dependencies/trunk/miglayout-3.7.1.jar
==============================================================================
Binary file. No diff available.
Added: dependencies/trunk/named-readtables/LICENSE
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/LICENSE Tue Jan 26 15:20:07 2010
@@ -0,0 +1,36 @@
+
+Copyright (c) 2007 - 2009 Tobias C. Rittweiler
+Copyright (c) 2007, Robert P. Goldman and SIFT, LLC
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the names of Tobias C. Rittweiler, Robert P. Goldman,
+ SIFT, LLC nor the names of its contributors may be used to
+ endorse or promote products derived from this software without
+ specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY Tobias C. Rittweiler, Robert
+P. Goldman and SIFT, LLC ``AS IS'' AND ANY EXPRESS OR IMPLIED
+WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
+OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+DISCLAIMED. IN NO EVENT SHALL Tobias C. Rittweiler, Robert
+P. Goldman or SIFT, LLC BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
+OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE,
+EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
Added: dependencies/trunk/named-readtables/cruft.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/cruft.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,375 @@
+;;;;
+;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler
+;;;;
+;;;; All rights reserved.
+;;;;
+;;;; See LICENSE for details.
+;;;;
+
+(in-package :editor-hints.named-readtables)
+
+(defmacro define-cruft (name lambda-list &body (docstring . alternatives))
+ (assert (typep docstring 'string) (docstring) "Docstring missing!")
+ (assert (not (null alternatives)))
+ `(progn
+ (declaim (inline ,name))
+ (defun ,name ,lambda-list ,docstring ,(first alternatives))))
+
+(eval-when (:compile-toplevel :execute)
+ #+sbcl (when (find-symbol "ASSERT-NOT-STANDARD-READTABLE"
+ (find-package "SB-IMPL"))
+ (pushnew :sbcl+safe-standard-readtable *features*)))
+
+
+;;;;; Implementation-dependent cruft
+
+;;;; Mapping between a readtable object and its readtable-name.
+
+(defvar *readtable-names* (make-hash-table :test 'eq))
+
+(define-cruft %associate-readtable-with-name (name readtable)
+ "Associate READTABLE with NAME for READTABLE-NAME to work."
+ #+ :common-lisp (setf (gethash readtable *readtable-names*) name))
+
+(define-cruft %unassociate-readtable-from-name (name readtable)
+ "Remove the association between READTABLE and NAME."
+ #+ :common-lisp (progn (assert (eq name (gethash readtable *readtable-names*)))
+ (remhash readtable *readtable-names*)))
+
+(define-cruft %readtable-name (readtable)
+ "Return the name associated with READTABLE."
+ #+ :common-lisp (values (gethash readtable *readtable-names*)))
+
+(define-cruft %list-all-readtable-names ()
+ "Return a list of all available readtable names."
+ #+ :common-lisp (list* :standard :current
+ (loop for name being each hash-value of *readtable-names*
+ collect name)))
+
+
+;;;; Mapping between a readtable-name and the actual readtable object.
+
+;;; On Allegro we reuse their named-readtable support so we work
+;;; nicely on their infrastructure.
+
+#-allegro
+(defvar *named-readtables* (make-hash-table :test 'eq))
+
+#+allegro
+(defun readtable-name-for-allegro (symbol)
+ (multiple-value-bind (kwd status)
+ (if (keywordp symbol)
+ (values symbol nil)
+ ;; Kludge: ACL uses keywords to name readtables, we allow
+ ;; arbitrary symbols.
+ (intern (format nil "~A.~A"
+ (package-name (symbol-package symbol))
+ (symbol-name symbol))
+ :keyword))
+ (prog1 kwd
+ (assert (or (not status) (get kwd 'named-readtable-designator)))
+ (setf (get kwd 'named-readtable-designator) t))))
+
+(define-cruft %associate-name-with-readtable (name readtable)
+ "Associate NAME with READTABLE for FIND-READTABLE to work."
+ #+ :allegro (setf (excl:named-readtable (readtable-name-for-allegro name)) readtable)
+ #+ :common-lisp (setf (gethash name *named-readtables*) readtable))
+
+(define-cruft %unassociate-name-from-readtable (name readtable)
+ "Remove the association between NAME and READTABLE"
+ #+ :allegro (let ((n (readtable-name-for-allegro name)))
+ (assert (eq readtable (excl:named-readtable n)))
+ (setf (excl:named-readtable n) nil))
+ #+ :common-lisp (progn (assert (eq readtable (gethash name *named-readtables*)))
+ (remhash name *named-readtables*)))
+
+(define-cruft %find-readtable (name)
+ "Return the readtable named NAME."
+ #+ :allegro (excl:named-readtable (readtable-name-for-allegro name))
+ #+ :common-lisp (values (gethash name *named-readtables* nil)))
+
+
+;;;; Reader-macro related predicates
+
+;;; CLISP creates new function objects for standard reader macros on
+;;; each readtable copy.
+(define-cruft function= (fn1 fn2)
+ "Are reader-macro function-designators FN1 and FN2 the same?"
+ #+ :clisp
+ (let* ((fn1 (ensure-function fn1))
+ (fn2 (ensure-function fn2))
+ (n1 (system::function-name fn1))
+ (n2 (system::function-name fn2)))
+ (if (and (eq n1 :lambda) (eq n2 :lambda))
+ (eq fn1 fn2)
+ (equal n1 n2)))
+ #+ :common-lisp
+ (eq (ensure-function fn1) (ensure-function fn2)))
+
+;;; CCL has a bug that prevents the portable form below from working
+;;; (Ticket 601). CLISP will incorrectly fold the call to G-D-M-C away
+;;; if not declared inline.
+(define-cruft dispatch-macro-char-p (char rt)
+ "Is CHAR a dispatch macro character in RT?"
+ #+ :ccl
+ (let ((def (cdr (nth-value 1 (ccl::%get-readtable-char char rt)))))
+ (or (consp (cdr def))
+ (eq (car def) #'ccl::read-dispatch)))
+ #+ :common-lisp
+ (handler-case (locally
+ #+clisp (declare (notinline get-dispatch-macro-character))
+ (get-dispatch-macro-character char #\x rt)
+ t)
+ (error () nil)))
+
+;; (defun macro-char-p (char rt)
+;; (let ((reader-fn (%get-macro-character char rt)))
+;; (and reader-fn t)))
+
+;; (defun standard-macro-char-p (char rt)
+;; (multiple-value-bind (rt-fn rt-flag) (get-macro-character char rt)
+;; (multiple-value-bind (std-fn std-flag) (get-macro-character char *standard-readtable*)
+;; (and (eq rt-fn std-fn)
+;; (eq rt-flag std-flag)))))
+
+;; (defun standard-dispatch-macro-char-p (disp-char sub-char rt)
+;; (flet ((non-terminating-p (ch rt) (nth-value 1 (get-macro-character ch rt))))
+;; (and (eq (non-terminating-p disp-char rt)
+;; (non-terminating-p disp-char *standard-readtable*))
+;; (eq (get-dispatch-macro-character disp-char sub-char rt)
+;; (get-dispatch-macro-character disp-char sub-char *standard-readtable*)))))
+
+
+;;;; Readtables Iterators
+
+(defmacro with-readtable-iterator ((name readtable) &body body)
+ (let ((it (gensym)))
+ `(let ((,it (%make-readtable-iterator ,readtable)))
+ (macrolet ((,name () `(funcall ,',it)))
+ , at body))))
+
+#+sbcl
+(defun %make-readtable-iterator (readtable)
+ (let ((char-macro-array (sb-impl::character-macro-array readtable))
+ (char-macro-ht (sb-impl::character-macro-hash-table readtable))
+ (dispatch-tables (sb-impl::dispatch-tables readtable))
+ (char-code 0))
+ (with-hash-table-iterator (ht-iterator char-macro-ht)
+ (labels ((grovel-base-chars ()
+ (declare (optimize sb-c::merge-tail-calls))
+ (if (>= char-code sb-int:base-char-code-limit)
+ (grovel-unicode-chars)
+ (let ((reader-fn (svref char-macro-array char-code))
+ (char (code-char (shiftf char-code (1+ char-code)))))
+ (if reader-fn
+ (yield char reader-fn)
+ (grovel-base-chars)))))
+ (grovel-unicode-chars ()
+ (multiple-value-bind (more? char reader-fn) (ht-iterator)
+ (if (not more?)
+ (values nil nil nil nil nil)
+ (yield char reader-fn))))
+ (yield (char reader-fn)
+ (let ((disp-ht))
+ (cond
+ ((setq disp-ht (cdr (assoc char dispatch-tables)))
+ (let* ((disp-fn (get-macro-character char readtable))
+ (sub-char-alist))
+ (maphash (lambda (k v)
+ (push (cons k v) sub-char-alist))
+ disp-ht)
+ (values t char disp-fn t sub-char-alist)))
+ (t
+ (values t char reader-fn nil nil))))))
+ #'grovel-base-chars))))
+
+#+clozure
+(defun %make-readtable-iterator (readtable)
+ (let ((char-macro-alist (ccl::rdtab.alist readtable)))
+ (lambda ()
+ (if char-macro-alist
+ (destructuring-bind (char . defn) (pop char-macro-alist)
+ (if (consp defn)
+ (values t char (car defn) t (cdr defn))
+ (values t char defn nil nil)))
+ (values nil nil nil nil nil)))))
+
+;;; Written on ACL 8.0.
+#+allegro
+(defun %make-readtable-iterator (readtable)
+ (declare (optimize speed)) ; for TCO
+ (check-type readtable readtable)
+ (let* ((macro-table (first (excl::readtable-macro-table readtable)))
+ (dispatch-tables (excl::readtable-dispatch-tables readtable))
+ (table-length (length macro-table))
+ (idx 0))
+ (labels ((grovel-macro-chars ()
+ (if (>= idx table-length)
+ (grovel-dispatch-chars)
+ (let ((read-fn (svref macro-table idx))
+ (oidx idx))
+ (incf idx)
+ (if (or (eq read-fn #'excl::read-token)
+ (eq read-fn #'excl::read-dispatch-char)
+ (eq read-fn #'excl::undefined-macro-char))
+ (grovel-macro-chars)
+ (values t (code-char oidx) read-fn nil nil)))))
+ (grovel-dispatch-chars ()
+ (if (null dispatch-tables)
+ (values nil nil nil nil nil)
+ (destructuring-bind (disp-char sub-char-table)
+ (first dispatch-tables)
+ (setf dispatch-tables (rest dispatch-tables))
+ ;;; Kludge. We can't fully clear dispatch tables
+ ;;; in %CLEAR-READTABLE.
+ (when (eq (svref macro-table (char-code disp-char))
+ #'excl::read-dispatch-char)
+ (values t
+ disp-char
+ (svref macro-table (char-code disp-char))
+ t
+ (loop for subch-fn across sub-char-table
+ for subch-code from 0
+ when subch-fn
+ collect (cons (code-char subch-code)
+ subch-fn))))))))
+ #'grovel-macro-chars)))
+
+
+#-(or sbcl clozure allegro)
+(eval-when (:compile-toplevel)
+ (let ((*print-pretty* t))
+ (simple-style-warn
+ "~&~@< ~@;~A has not been ported to ~A. ~
+ We fall back to a portable implementation of readtable iterators. ~
+ This implementation has to grovel through all available characters. ~
+ On Unicode-aware implementations this may come with some costs.~@:>"
+ (package-name '#.*package*) (lisp-implementation-type))))
+
+#-(or sbcl clozure allegro)
+(defun %make-readtable-iterator (readtable)
+ (check-type readtable readtable)
+ (let ((char-code 0))
+ #'(lambda ()
+ (prog ()
+ :GROVEL
+ (when (< char-code char-code-limit)
+ (let* ((char (code-char char-code))
+ (fn (get-macro-character char readtable)))
+ (incf char-code)
+ (when (not fn) (go :GROVEL))
+ (multiple-value-bind (disp? alist)
+ (handler-case ; grovel dispatch macro characters.
+ (values t
+ ;; Only grovel upper case characters to
+ ;; avoid duplicates.
+ (loop for code from 0 below char-code-limit
+ for subchar = (let ((ch (code-char code)))
+ (when (or (not (alpha-char-p ch))
+ (upper-case-p ch))
+ ch))
+ for disp-fn = (and subchar
+ (get-dispatch-macro-character
+ char subchar readtable))
+ when disp-fn
+ collect (cons subchar disp-fn)))
+ (error () nil))
+ (return (values t char fn disp? alist)))))))))
+
+(defmacro do-readtable ((entry-designator readtable &optional result)
+ &body body)
+ "Iterate through a readtable's macro characters, and dispatch macro characters."
+ (destructuring-bind (char &optional reader-fn non-terminating-p disp? table)
+ (if (symbolp entry-designator)
+ (list entry-designator)
+ entry-designator)
+ (let ((iter (gensym "ITER+"))
+ (more? (gensym "MORE?+"))
+ (rt (gensym "READTABLE+")))
+ `(let ((,rt ,readtable))
+ (with-readtable-iterator (,iter ,rt)
+ (loop
+ (multiple-value-bind (,more?
+ ,char
+ ,@(when reader-fn (list reader-fn))
+ ,@(when disp? (list disp?))
+ ,@(when table (list table)))
+ (,iter)
+ (unless ,more? (return ,result))
+ (let ,(when non-terminating-p
+ ;; FIXME: N-T-P should be incorporated in iterators.
+ `((,non-terminating-p
+ (nth-value 1 (get-macro-character ,char ,rt)))))
+ , at body))))))))
+
+;;;; Misc
+
+;;; This should return an implementation's actual standard readtable
+;;; object only if the implementation makes the effort to guard against
+;;; modification of that object. Otherwise it should better return a
+;;; copy.
+(define-cruft %standard-readtable ()
+ "Return the standard readtable."
+ #+ :sbcl+safe-standard-readtable sb-impl::*standard-readtable*
+ #+ :common-lisp (copy-readtable nil))
+
+;;; On SBCL, SET-SYNTAX-FROM-CHAR does not get rid of a
+;;; readtable's dispatch table properly.
+;;; Same goes for Allegro but that does not seem to provide a
+;;; setter for their readtable's dispatch tables. Hence this ugly
+;;; workaround.
+(define-cruft %clear-readtable (readtable)
+ "Make all macro characters in READTABLE be constituents."
+ #+ :sbcl
+ (prog1 readtable
+ (do-readtable (char readtable)
+ (set-syntax-from-char char #\A readtable))
+ (setf (sb-impl::dispatch-tables readtable) nil))
+ #+ :allegro
+ (prog1 readtable
+ (do-readtable (char readtable)
+ (set-syntax-from-char char #\A readtable))
+ (let ((dispatch-tables (excl::readtable-dispatch-tables readtable)))
+ (setf (cdr dispatch-tables) nil)
+ (setf (caar dispatch-tables) #\Backspace)
+ (setf (cadar dispatch-tables) (fill (cadar dispatch-tables) nil))))
+ #+ :common-lisp
+ (do-readtable (char readtable readtable)
+ (set-syntax-from-char char #\A readtable)))
+
+;;; See Clozure Trac Ticket 601. This is supposed to be removed at
+;;; some point in the future.
+(define-cruft %get-dispatch-macro-character (char subchar rt)
+ "Ensure ANSI behaviour for GET-DISPATCH-MACRO-CHARACTER."
+ #+ :ccl (ignore-errors
+ (get-dispatch-macro-character char subchar rt))
+ #+ :common-lisp (get-dispatch-macro-character char subchar rt))
+
+;;; Allegro stores READ-TOKEN as reader macro function of each
+;;; constituent character.
+(define-cruft %get-macro-character (char rt)
+ "Ensure ANSI behaviour for GET-MACRO-CHARACTER."
+ #+ :allegro (let ((fn (get-macro-character char rt)))
+ (cond ((not fn) nil)
+ ((function= fn #'excl::read-token) nil)
+ (t fn)))
+ #+ :common-lisp (get-macro-character char rt))
+
+
+;;;; Specialized PRINT-OBJECT for named readtables.
+
+;;; As per #19 in CLHS 11.1.2.1.2 defining a method for PRINT-OBJECT
+;;; that specializes on READTABLE is actually forbidden. It's quite
+;;; likely to work (modulo package-locks) on most implementations,
+;;; though.
+
+;;; We don't need this on Allegro CL's as we hook into their
+;;; named-readtable facility, and they provide such a method already.
+#-allegro
+(without-package-lock (:common-lisp)
+ (defmethod print-object :around ((rt readtable) stream)
+ (let ((name (readtable-name rt)))
+ (if name
+ (print-unreadable-object (rt stream :type nil :identity t)
+ (format stream "~A ~S" :named-readtable name))
+ (call-next-method)))))
\ No newline at end of file
Added: dependencies/trunk/named-readtables/define-api.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/define-api.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,63 @@
+
+(in-package :named-readtables)
+
+(defmacro define-api (name lambda-list type-list &body body)
+ (flet ((parse-type-list (type-list)
+ (let ((pos (position '=> type-list)))
+ (assert pos () "You forgot to specify return type (`=>' missing.)")
+ (values (subseq type-list 0 pos)
+ `(values ,@(nthcdr (1+ pos) type-list) &optional)))))
+ (multiple-value-bind (body decls docstring)
+ (parse-body body :documentation t :whole `(define-api ,name))
+ (multiple-value-bind (arg-typespec value-typespec)
+ (parse-type-list type-list)
+ (multiple-value-bind (reqs opts rest keys)
+ (parse-ordinary-lambda-list lambda-list)
+ (declare (ignorable reqs opts rest keys))
+ `(progn
+ (declaim (ftype (function ,arg-typespec ,value-typespec) ,name))
+ (locally
+ ;;; Muffle the annoying "&OPTIONAL and &KEY found in
+ ;;; the same lambda list" style-warning
+ #+sbcl (declare (sb-ext:muffle-conditions style-warning))
+ (defun ,name ,lambda-list
+ ,docstring
+
+ #+sbcl (declare (sb-ext:unmuffle-conditions style-warning))
+
+ , at decls
+
+ ;; SBCL will interpret the ftype declaration as
+ ;; assertion and will insert type checks for us.
+ #-sbcl
+ (progn
+ ;; CHECK-TYPE required parameters
+ ,@(loop for req-arg in reqs
+ for req-type = (pop type-list)
+ do (assert req-type)
+ collect `(check-type ,req-arg ,req-type))
+
+ ;; CHECK-TYPE optional parameters
+ ,@(loop initially (assert (or (null opts)
+ (eq (pop type-list) '&optional)))
+ for (opt-arg . nil) in opts
+ for opt-type = (pop type-list)
+ do (assert opt-type)
+ collect `(check-type ,opt-arg ,opt-type))
+
+ ;; CHECK-TYPE rest parameter
+ ,@(when rest
+ (assert (eq (pop type-list) '&rest))
+ (let ((rest-type (pop type-list)))
+ (assert rest-type)
+ `((dolist (x ,rest)
+ (check-type x ,rest-type)))))
+
+ ;; CHECK-TYPE key parameters
+ ,@(loop initially (assert (or (null keys)
+ (eq (pop type-list) '&key)))
+ for ((keyword key-arg) . nil) in keys
+ for (nil key-type) = (find keyword type-list :key #'car)
+ collect `(check-type ,key-arg ,key-type)))
+
+ , at body))))))))
\ No newline at end of file
Added: dependencies/trunk/named-readtables/doc/named-readtables.html
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/doc/named-readtables.html Tue Jan 26 15:20:07 2010
@@ -0,0 +1,463 @@
+
+
+
+
+
+ EDITOR-HINTS.NAMED-READTABLES
+
+
+
+
+
+
EDITOR-HINTS.NAMED-READTABLES
+
+
by Tobias C Rittweiler
+
+Download:
+
+
+ darcs get http://common-lisp.net/~trittweiler/darcs/editor-hints/named-readtables/ (to be changed)
+
+
+ Named-Readtables is a library that provides a namespace for readtables akin to the already-existing namespace of packages. In particular:
+
+
you can associate readtables with names, and retrieve readtables by names;
+
you can associate source files with readtable names, and be sure that the right readtable is active when compiling/loading the file;
+
similiarly, your development environment now has a chance to automatically determine what readtable should be active while processing source forms on interactive commands. (E.g. think of `C-c C-c' in Slime [yet to be done])
+
+ Additionally, it also attempts to become a facility for using readtables in a modular way. In particular:
+
+
it provides a macro to specify the content of a readtable at a glance;
+
it makes it possible to use multiple inheritance between readtables.
+ There are three major differences between the API of Named-Readtables, and the API of packages.
+
+ 1. Readtable names are symbols not strings.
+
+ Time has shown that the fact that packages are named by strings causes severe headache because of the potential of package names colliding with each other.
+
+ Hence, readtables are named by symbols lest to make the situation worse than it already is. Consequently, readtables named CL-ORACLE:SQL-SYNTAX and CL-MYSQL:SQL-SYNTAX can happily coexist next to each other. Or, taken to an extreme, SCHEME:SYNTAX and ELISP:SYNTAX.
+
+ If, for example to duly signify the importance of your cool readtable hack, you really think it deserves a global name, you can always resort to keywords.
+
+ 2. The inheritance is resolved statically, not dynamically.
+
+ A package that uses another package will have access to all the other package's exported symbols, even to those that will be added after its definition. I.e. the inheritance is resolved at run-time, that is dynamically.
+
+ Unfortunately, we cannot do the same for readtables in a portable manner.
+
+ Therefore, we do not talk about "using" another readtable but about "merging" the other readtable's definition into the readtable we are going to define. I.e. the inheritance is resolved once at definition time, that is statically.
+
+ (Such merging can more or less be implemented portably albeit at a certain cost. Most of the time, this cost manifests itself at the time a readtable is defined, i.e. once at compile-time, so it may not bother you. Nonetheless, we provide extra support for Sbcl, ClozureCL, and AllegroCL at the moment. Patches for your implementation of choice are welcome, of course.)
+
+ 3.DEFREADTABLE does not have compile-time effects.
+
+ If you define a package via DEFPACKAGE, you can make that package the currently active package for the subsequent compilation of the same file via IN-PACKAGE. The same is, however, not true for DEFREADTABLE and IN-READTABLE for the following reason:
+
+ It's unlikely that the need for special reader-macros arises for a problem which can be solved in just one file. Most often, you're going to define the reader macro functions, and set up the corresponding readtable in an extra file.
+
+ If DEFREADTABLE had compile-time effects, you'd have to wrap each definition of a reader-macro function in an EVAL-WHEN to make its definition available at compile-time. Because that's simply not the common case, DEFREADTABLE does not have a compile-time effect.
+
+ If you want to use a readtable within the same file as its definition, wrap the DEFREADTABLE and the reader-macro function definitions in an explicit EVAL-WHEN.
+
+ Thanks to Robert Goldman for making me want to write this library.
+
+ Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart Botta, David Crawford, and Pascal Costanza for being early adopters, providing comments and bugfixes.
+
+
+Define a new named readtable, whose name is given by the symbol name. Or, if a readtable is already registered under that name, redefine that one.
+
+The readtable can be populated using the following options:
+
+ (:MERGEreadtable-designators+)
+
+ Merge the readtables designated into the new readtable being defined as per MERGE-READTABLES-INTO.
+
+ If no :MERGE clause is given, an empty readtable is used. See MAKE-READTABLE.
+
+ (:FUZEreadtable-designators+)
+
+ Like :MERGE except:
+
+ Error conditions of type READER-MACRO-CONFLICT that are signaled during the merge operation will be silently continued. It follows that reader macros in earlier entries will be overwritten by later ones.
+
+ Define a new sub character sub-char for the dispatching macro character macro-char, per SET-DISPATCH-MACRO-CHARACTER. You probably have to define macro-char as a dispatching macro character by the following option first.
+
+ Define a new macro character in the readtable, per SET-MACRO-CHARACTER. If function is the keyword :DISPATCH,macro-char is made a dispatching macro character, per MAKE-DISPATCH-MACRO-CHARACTER.
+
+Any number of option clauses may appear. The options are grouped by their type, but in each group the order the options appeared textually is preserved. The following groups exist and are executed in the following order: :MERGE and :FUZE (one group), :CASE,:MACRO-CHAR and :DISPATCH-MACRO-CHAR (one group), finally :SYNTAX-FROM.
+
+Notes:
+
+ The readtable is defined at load-time. If you want to have it available at compilation time -- say to use its reader-macros in the same file as its definition -- you have to wrap the DEFREADTABLE form in an explicit EVAL-WHEN.
+
+ On redefinition, the target readtable is made empty first before it's refilled according to the clauses.
+
+ NIL,:STANDARD,:COMMON-LISP,:MODERN, and :CURRENT are preregistered readtable names.
+
+
+
+
+Looks up the readtable specified by name and returns it if it's found. If it is not found, it registers the readtable designated by default under the name represented by name; or if no default argument is given, it signals an error of type READTABLE-DOES-NOT-EXIST instead.
+
+
+
+
+Creates and returns a new readtable under the specified name.
+
+merge takes a list of NAMED-READTABLE-DESIGNATORS and specifies the readtables the new readtable is created from. (See the :MERGE clause of DEFREADTABLE for details.)
+
+If merge is NIL, an empty readtable is used instead.
+
+If name is not given, an anonymous empty readtable is returned.
+
+Notes:
+
+ An empty readtable is a readtable where each character's syntax is the same as in the standard readtable except that each macro character has been made a constituent. Basically: whitespace stays whitespace, everything else is constituent.
+
+
+
+
+Copy the contents of each readtable in named-readtables into result-table.
+
+If a macro character appears in more than one of the readtables, i.e. if a conflict is discovered during the merge, an error of type READER-MACRO-CONFLICT is signaled.
+
+
+
+This condition is signaled during the merge process if a) a reader macro (be it a macro character or the sub character of a dispatch macro character) is both present in the source as well as the target readtable, and b) if and only if the two respective reader macro functions differ.
+
+
+
+
+Replaces the associated name of the readtable designated by old-name with new-name. If a readtable is already registered under new-name, an error of type READTABLE-DOES-ALREADY-EXIST is signaled.
+
+
+
+
+Remove the association of named-readtable. Returns T if successfull, NIL otherwise.
+
+
+
+
+
+
+
+
+
+This documentation was generated on 2009-9-29 from a Lisp image using some home-brewn,
+duct-taped, evolutionary hacked extension of Edi Weitz'
+DOCUMENTATION-TEMPLATE.
+
+
+
+
\ No newline at end of file
Added: dependencies/trunk/named-readtables/named-readtables.asd
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/named-readtables.asd Tue Jan 26 15:20:07 2010
@@ -0,0 +1,50 @@
+;;; -*- Mode:Lisp -*-
+
+(in-package :cl-user)
+
+(defclass asdf::named-readtables-source-file (asdf:cl-source-file) ())
+
+#+sbcl
+(defmethod asdf:perform :around ((o asdf:compile-op)
+ (c asdf::named-readtables-source-file))
+ (let ((sb-ext:*derive-function-types* t))
+ (call-next-method)))
+
+
+(asdf:defsystem :named-readtables
+ :description "Library that creates a namespace for named readtable akin to the namespace of packages."
+ :author "Tobias C. Rittweiler "
+ :version "1.0 (unpublished so far)"
+ :licence "BSD"
+ :default-component-class asdf::named-readtables-source-file
+ :components
+ ((:file "package")
+ (:file "utils" :depends-on ("package"))
+ (:file "define-api" :depends-on ("package" "utils"))
+ (:file "cruft" :depends-on ("package" "utils"))
+ (:file "named-readtables" :depends-on ("package" "utils" "cruft" "define-api"))))
+
+(defmethod asdf:perform ((o asdf:test-op)
+ (c (eql (asdf:find-system :named-readtables))))
+ (asdf:operate 'asdf:load-op :named-readtables-test)
+ (asdf:operate 'asdf:test-op :named-readtables-test))
+
+
+(asdf:defsystem :named-readtables-test
+ :description "Test suite for the Named-Readtables library."
+ :author "Tobias C. Rittweiler "
+ :depends-on (:named-readtables)
+ :components
+ ((:module tests
+ :default-component-class asdf::named-readtables-source-file
+ :serial t
+ :components
+ ((:file "package")
+ (:file "rt" :depends-on ("package"))
+ (:file "tests" :depends-on ("package" "rt"))))))
+
+(defmethod asdf:perform ((o asdf:test-op)
+ (c (eql (asdf:find-system
+ :named-readtables-test))))
+ (let ((*package* (find-package :named-readtables-test)))
+ (funcall (intern (string '#:do-tests) *package*))))
\ No newline at end of file
Added: dependencies/trunk/named-readtables/named-readtables.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/named-readtables.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,527 @@
+;;;; -*- Mode:Lisp -*-
+;;;;
+;;;; Copyright (c) 2007 - 2009 Tobias C. Rittweiler
+;;;; Copyright (c) 2007, Robert P. Goldman and SIFT, LLC
+;;;;
+;;;; All rights reserved.
+;;;;
+;;;; See LICENSE for details.
+;;;;
+
+(in-package :editor-hints.named-readtables)
+
+;;;
+;;; ``This is enough of a foothold to implement a more elaborate
+;;; facility for using readtables in a localized way.''
+;;;
+;;; (X3J13 Cleanup Issue IN-SYNTAX)
+;;;
+
+;;;;;; DEFREADTABLE &c.
+
+(defmacro defreadtable (name &body options)
+ "Define a new named readtable, whose name is given by the symbol `name'.
+Or, if a readtable is already registered under that name, redefine that
+one.
+
+The readtable can be populated using the following `options':
+
+ (:MERGE `readtable-designators'+)
+
+ Merge the readtables designated into the new readtable being defined
+ as per MERGE-READTABLES-INTO.
+
+ If no :MERGE clause is given, an empty readtable is used. See
+ MAKE-READTABLE.
+
+ (:FUZE `readtable-designators'+)
+
+ Like :MERGE except:
+
+ Error conditions of type READER-MACRO-CONFLICT that are signaled
+ during the merge operation will be silently _continued_. It follows
+ that reader macros in earlier entries will be overwritten by later
+ ones.
+
+ (:DISPATCH-MACRO-CHAR `macro-char' `sub-char' `function')
+
+ Define a new sub character `sub-char' for the dispatching macro
+ character `macro-char', per SET-DISPATCH-MACRO-CHARACTER. You
+ probably have to define `macro-char' as a dispatching macro character
+ by the following option first.
+
+ (:MACRO-CHAR `macro-char' `function' [`non-terminating-p'])
+
+ Define a new macro character in the readtable, per SET-MACRO-CHARACTER.
+ If `function' is the keyword :DISPATCH, `macro-char' is made a
+ dispatching macro character, per MAKE-DISPATCH-MACRO-CHARACTER.
+
+ (:SYNTAX-FROM `from-readtable-designator' `from-char' `to-char')
+
+ Set the character syntax of `to-char' in the readtable being defined
+ to the same syntax as `from-char' as per SET-SYNTAX-FROM-CHAR.
+
+ (:CASE `case-mode')
+
+ Defines the /case sensitivity mode/ of the resulting readtable.
+
+Any number of option clauses may appear. The options are grouped by their
+type, but in each group the order the options appeared textually is
+preserved. The following groups exist and are executed in the following
+order: :MERGE and :FUZE (one group), :CASE, :MACRO-CHAR
+and :DISPATCH-MACRO-CHAR (one group), finally :SYNTAX-FROM.
+
+Notes:
+
+ The readtable is defined at load-time. If you want to have it available
+ at compilation time -- say to use its reader-macros in the same file as
+ its definition -- you have to wrap the DEFREADTABLE form in an explicit
+ EVAL-WHEN.
+
+ On redefinition, the target readtable is made empty first before it's
+ refilled according to the clauses.
+
+ NIL, :STANDARD, :COMMON-LISP, :MODERN, and :CURRENT are
+ preregistered readtable names.
+"
+ (check-type name symbol)
+ (when (reserved-readtable-name-p name)
+ (error "~A is the designator for a predefined readtable. ~
+ Not acceptable as a user-specified readtable name." name))
+ (flet ((process-option (option var)
+ (destructure-case option
+ ((:merge &rest readtable-designators)
+ `(merge-readtables-into ,var
+ ,@(mapcar #'(lambda (x) `',x) readtable-designators))) ; quotify
+ ((:fuze &rest readtable-designators)
+ `(handler-bind ((reader-macro-conflict #'continue))
+ (merge-readtables-into ,var
+ ,@(mapcar #'(lambda (x) `',x) readtable-designators))))
+ ((:dispatch-macro-char disp-char sub-char function)
+ `(set-dispatch-macro-character ,disp-char ,sub-char ,function ,var))
+ ((:macro-char char function &optional non-terminating-p)
+ (if (eq function :dispatch)
+ `(make-dispatch-macro-character ,char ,non-terminating-p ,var)
+ `(set-macro-character ,char ,function ,non-terminating-p ,var)))
+ ((:syntax-from from-rt-designator from-char to-char)
+ `(set-syntax-from-char ,to-char ,from-char
+ ,var (find-readtable ,from-rt-designator)))
+ ((:case mode)
+ `(setf (readtable-case ,var) ,mode))))
+ (remove-clauses (clauses options)
+ (setq clauses (if (listp clauses) clauses (list clauses)))
+ (remove-if-not #'(lambda (x) (member x clauses))
+ options :key #'first)))
+ (let* ((merge-clauses (remove-clauses '(:merge :fuze) options))
+ (case-clauses (remove-clauses :case options))
+ (macro-clauses (remove-clauses '(:macro-char :dispatch-macro-char)
+ options))
+ (syntax-clauses (remove-clauses :syntax-from options))
+ (other-clauses (set-difference options
+ (append merge-clauses case-clauses
+ macro-clauses syntax-clauses))))
+ (cond
+ ((not (null other-clauses))
+ (error "Bogus DEFREADTABLE clauses: ~/PPRINT-LINEAR/" other-clauses))
+ (t
+ `(eval-when (:load-toplevel :execute)
+ ;; The (FIND-READTABLE ...) isqrt important for proper
+ ;; redefinition semantics, as redefining has to modify the
+ ;; already existing readtable object.
+ (let ((readtable (find-readtable ',name)))
+ (cond ((not readtable)
+ (setq readtable (make-readtable ',name)))
+ (t
+ (setq readtable (%clear-readtable readtable))
+ (simple-style-warn "Overwriting already existing readtable ~S."
+ readtable)))
+ ,@(loop for option in merge-clauses
+ collect (process-option option 'readtable))
+ ,@(loop for option in case-clauses
+ collect (process-option option 'readtable))
+ ,@(loop for option in macro-clauses
+ collect (process-option option 'readtable))
+ ,@(loop for option in syntax-clauses
+ collect (process-option option 'readtable))
+ readtable)))))))
+
+(defmacro in-readtable (name)
+ "Set *READTABLE* to the readtable referred to by the symbol `name'."
+ (check-type name symbol)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ ;; NB. The :LOAD-TOPLEVEL is needed for cases like (DEFVAR *FOO*
+ ;; (GET-MACRO-CHARACTER #\"))
+ (setf *readtable* (ensure-readtable ',name))
+ (when (find-package :swank)
+ (%frob-swank-readtable-alist *package* *readtable*))
+ ))
+
+;;; KLUDGE: [interim solution]
+;;;
+;;; We need support for this in Slime itself, because we want IN-READTABLE
+;;; to work on a per-file basis, and not on a per-package basis.
+;;;
+(defun %frob-swank-readtable-alist (package readtable)
+ (let ((readtable-alist (find-symbol (string '#:*readtable-alist*)
+ (find-package :swank))))
+ (when (boundp readtable-alist)
+ (pushnew (cons (package-name package) readtable)
+ (symbol-value readtable-alist)
+ :test #'(lambda (entry1 entry2)
+ (destructuring-bind (pkg-name1 . rt1) entry1
+ (destructuring-bind (pkg-name2 . rt2) entry2
+ (and (string= pkg-name1 pkg-name2)
+ (eq rt1 rt2)))))))))
+
+(deftype readtable-designator ()
+ `(or null readtable))
+
+(deftype named-readtable-designator ()
+ "Either a symbol or a readtable itself."
+ `(or readtable-designator symbol))
+
+
+(declaim (special *standard-readtable* *empty-readtable*))
+
+(define-api make-readtable
+ (&optional (name nil name-supplied-p) &key merge)
+ (&optional named-readtable-designator &key (:merge list) => readtable)
+ "Creates and returns a new readtable under the specified `name'.
+
+`merge' takes a list of NAMED-READTABLE-DESIGNATORS and specifies the
+readtables the new readtable is created from. (See the :MERGE clause of
+DEFREADTABLE for details.)
+
+If `merge' is NIL, an empty readtable is used instead.
+
+If `name' is not given, an anonymous empty readtable is returned.
+
+Notes:
+
+ An empty readtable is a readtable where each character's syntax is the
+ same as in the /standard readtable/ except that each macro character has
+ been made a constituent. Basically: whitespace stays whitespace,
+ everything else is constituent."
+ (cond ((not name-supplied-p)
+ (copy-readtable *empty-readtable*))
+ ((reserved-readtable-name-p name)
+ (error "~A is the designator for a predefined readtable. ~
+ Not acceptable as a user-specified readtable name." name))
+ ((let ((rt (find-readtable name)))
+ (and rt (prog1 nil
+ (cerror "Overwrite existing entry."
+ 'readtable-does-already-exist :readtable-name name)
+ ;; Explicitly unregister to make sure that we do not hold on
+ ;; of any reference to RT.
+ (unregister-readtable rt)))))
+ (t (let ((result (apply #'merge-readtables-into
+ ;; The first readtable specified in the :merge list is
+ ;; taken as the basis for all subsequent (destructive!)
+ ;; modifications (and hence it's copied.)
+ (copy-readtable (if merge
+ (ensure-readtable (first merge))
+ *empty-readtable*))
+ (rest merge))))
+
+ (register-readtable name result)))))
+
+(define-api rename-readtable
+ (old-name new-name)
+ (named-readtable-designator symbol => readtable)
+ "Replaces the associated name of the readtable designated by `old-name'
+with `new-name'. If a readtable is already registered under `new-name', an
+error of type READTABLE-DOES-ALREADY-EXIST is signaled."
+ (when (find-readtable new-name)
+ (cerror "Overwrite existing entry."
+ 'readtable-does-already-exist :readtable-name new-name))
+ (let* ((readtable (ensure-readtable old-name))
+ (readtable-name (readtable-name readtable)))
+ ;; We use the internal functions directly to omit repeated
+ ;; type-checking.
+ (%unassociate-name-from-readtable readtable-name readtable)
+ (%unassociate-readtable-from-name readtable-name readtable)
+ (%associate-name-with-readtable new-name readtable)
+ (%associate-readtable-with-name new-name readtable)
+ readtable))
+
+(define-api merge-readtables-into
+ (result-readtable &rest named-readtables)
+ (named-readtable-designator &rest named-readtable-designator => readtable)
+ "Copy the contents of each readtable in `named-readtables' into
+`result-table'.
+
+If a macro character appears in more than one of the readtables, i.e. if a
+conflict is discovered during the merge, an error of type
+READER-MACRO-CONFLICT is signaled."
+ (flet ((merge-into (to from)
+ (do-readtable ((char reader-fn non-terminating-p disp? table) from)
+ (check-reader-macro-conflict from to char)
+ (cond ((not disp?)
+ (set-macro-character char reader-fn non-terminating-p to))
+ (t
+ (ensure-dispatch-macro-character char non-terminating-p to)
+ (loop for (subchar . subfn) in table do
+ (check-reader-macro-conflict from to char subchar)
+ (set-dispatch-macro-character char subchar subfn to)))))
+ to))
+ (let ((result-table (ensure-readtable result-readtable)))
+ (dolist (table (mapcar #'ensure-readtable named-readtables))
+ (merge-into result-table table))
+ result-table)))
+
+(defun ensure-dispatch-macro-character (char &optional non-terminating-p
+ (readtable *readtable*))
+ (if (dispatch-macro-char-p char readtable)
+ t
+ (make-dispatch-macro-character char non-terminating-p readtable)))
+
+(define-api copy-named-readtable
+ (named-readtable)
+ (named-readtable-designator => readtable)
+ "Like COPY-READTABLE but takes a NAMED-READTABLE-DESIGNATOR as argument."
+ (copy-readtable (ensure-readtable named-readtable)))
+
+(define-api list-all-named-readtables () (=> list)
+ "Returns a list of all registered readtables. The returned list is
+guaranteed to be fresh, but may contain duplicates."
+ (mapcar #'ensure-readtable (%list-all-readtable-names)))
+
+
+(define-condition readtable-error (error) ())
+
+(define-condition readtable-does-not-exist (readtable-error)
+ ((readtable-name :initarg :readtable-name
+ :initform (required-argument)
+ :accessor missing-readtable-name
+ :type named-readtable-designator))
+ (:report (lambda (condition stream)
+ (format stream "A readtable named ~S does not exist."
+ (missing-readtable-name condition)))))
+
+(define-condition readtable-does-already-exist (readtable-error)
+ ((readtable-name :initarg :readtable-name
+ :initform (required-argument)
+ :accessor existing-readtable-name
+ :type named-readtable-designator))
+ (:report (lambda (condition stream)
+ (format stream "A readtable named ~S already exists."
+ (existing-readtable-name condition))))
+ (:documentation "Continuable."))
+
+(define-condition reader-macro-conflict (readtable-error)
+ ((macro-char
+ :initarg :macro-char
+ :initform (required-argument)
+ :accessor conflicting-macro-char
+ :type character)
+ (sub-char
+ :initarg :sub-char
+ :initform nil
+ :accessor conflicting-dispatch-sub-char
+ :type (or null character))
+ (from-readtable
+ :initarg :from-readtable
+ :initform (required-argument)
+ :accessor from-readtable
+ :type readtable)
+ (to-readtable
+ :initarg :to-readtable
+ :initform (required-argument)
+ :accessor to-readtable
+ :type readtable))
+ (:report
+ (lambda (condition stream)
+ (format stream "~@"
+ (conflicting-dispatch-sub-char condition)
+ (conflicting-macro-char condition)
+ (conflicting-dispatch-sub-char condition)
+ (from-readtable condition)
+ (to-readtable condition))))
+ (:documentation "Continuable.
+
+This condition is signaled during the merge process if a) a reader macro
+\(be it a macro character or the sub character of a dispatch macro
+character\) is both present in the source as well as the target readtable,
+and b) if and only if the two respective reader macro functions differ."))
+
+(defun check-reader-macro-conflict (from to char &optional subchar)
+ (flet ((conflictp (from-fn to-fn)
+ (assert from-fn) ; if this fails, there's a bug in readtable iterators.
+ (and to-fn (not (function= to-fn from-fn)))))
+ (when (if subchar
+ (conflictp (%get-dispatch-macro-character char subchar from)
+ (%get-dispatch-macro-character char subchar to))
+ (conflictp (%get-macro-character char from)
+ (%get-macro-character char to)))
+ (cerror (format nil "Overwrite ~@C in ~A." char to)
+ 'reader-macro-conflict
+ :from-readtable from
+ :to-readtable to
+ :macro-char char
+ :sub-char subchar))))
+
+
+;;; Although there is no way to get at the standard readtable in
+;;; Common Lisp (cf. /standard readtable/, CLHS glossary), we make
+;;; up the perception of its existence by interning a copy of it.
+;;;
+;;; We do this for reverse lookup (cf. READTABLE-NAME), i.e. for
+;;;
+;;; (equal (readtable-name (find-readtable :standard)) "STANDARD")
+;;;
+;;; holding true.
+;;;
+;;; We, however, inherit the restriction that the :STANDARD
+;;; readtable _must not be modified_ (cf. CLHS 2.1.1.2), although it'd
+;;; technically be feasible (as *STANDARD-READTABLE* will contain a
+;;; mutable copy of the implementation-internal standard readtable.)
+;;; We cannot enforce this restriction without shadowing
+;;; CL:SET-MACRO-CHARACTER and CL:SET-DISPATCH-MACRO-FUNCTION which
+;;; is out of scope of this library, though. So we just threaten
+;;; with nasal demons.
+;;;
+(defvar *standard-readtable*
+ (%standard-readtable))
+
+(defvar *empty-readtable*
+ (%clear-readtable (copy-readtable nil)))
+
+(defvar *case-preserving-standard-readtable*
+ (let ((readtable (copy-readtable nil)))
+ (setf (readtable-case readtable) :preserve)
+ readtable))
+
+(defparameter *reserved-readtable-names*
+ '(nil :standard :common-lisp :modern :current))
+
+(defun reserved-readtable-name-p (name)
+ (and (member name *reserved-readtable-names*) t))
+
+;;; In principle, we could DEFREADTABLE some of these. But we do
+;;; reserved readtable lookup seperately, since we can't register a
+;;; readtable for :CURRENT anyway.
+
+(defun find-reserved-readtable (reserved-name)
+ (cond ((eq reserved-name nil) *standard-readtable*)
+ ((eq reserved-name :standard) *standard-readtable*)
+ ((eq reserved-name :common-lisp) *standard-readtable*)
+ ((eq reserved-name :modern) *case-preserving-standard-readtable*)
+ ((eq reserved-name :current) *readtable*)
+ (t (error "Bug: no such reserved readtable: ~S" reserved-name))))
+
+(define-api find-readtable
+ (name)
+ (named-readtable-designator => (or readtable null))
+ "Looks for the readtable specified by `name' and returns it if it is
+found. Returns NIL otherwise."
+ (cond ((readtablep name) name)
+ ((reserved-readtable-name-p name)
+ (find-reserved-readtable name))
+ ((%find-readtable name))))
+
+;;; FIXME: This doesn't take a NAMED-READTABLE-DESIGNATOR, but only a
+;;; STRING-DESIGNATOR. (When fixing, heed interplay with compiler
+;;; macros below.)
+(defsetf find-readtable register-readtable)
+
+(define-api ensure-readtable
+ (name &optional (default nil default-p))
+ (named-readtable-designator &optional (or named-readtable-designator null)
+ => readtable)
+ "Looks up the readtable specified by `name' and returns it if it's found.
+If it is not found, it registers the readtable designated by `default'
+under the name represented by `name'; or if no default argument is given,
+it signals an error of type READTABLE-DOES-NOT-EXIST instead."
+ (cond ((find-readtable name))
+ ((not default-p)
+ (error 'readtable-does-not-exist :readtable-name name))
+ (t (setf (find-readtable name) (ensure-readtable default)))))
+
+
+(define-api register-readtable
+ (name readtable)
+ (symbol readtable => readtable)
+ "Associate `readtable' with `name'. Returns the readtable."
+ (assert (typep name '(not (satisfies reserved-readtable-name-p))))
+ (%associate-readtable-with-name name readtable)
+ (%associate-name-with-readtable name readtable)
+ readtable)
+
+(define-api unregister-readtable
+ (named-readtable)
+ (named-readtable-designator => boolean)
+ "Remove the association of `named-readtable'. Returns T if successfull,
+NIL otherwise."
+ (let* ((readtable (find-readtable named-readtable))
+ (readtable-name (and readtable (readtable-name readtable))))
+ (if (not readtable-name)
+ nil
+ (prog1 t
+ (check-type readtable-name (not (satisfies reserved-readtable-name-p)))
+ (%unassociate-readtable-from-name readtable-name readtable)
+ (%unassociate-name-from-readtable readtable-name readtable)))))
+
+(define-api readtable-name
+ (named-readtable)
+ (named-readtable-designator => symbol)
+ "Returns the name of the readtable designated by `named-readtable', or
+NIL."
+ (let ((readtable (ensure-readtable named-readtable)))
+ (cond ((%readtable-name readtable))
+ ((eq readtable *readtable*) :current)
+ ((eq readtable *standard-readtable*) :common-lisp)
+ ((eq readtable *case-preserving-standard-readtable*) :modern)
+ (t nil))))
+
+
+;;;;; Compiler macros
+
+;;; Since the :STANDARD readtable is interned, and we can't enforce
+;;; its immutability, we signal a style-warning for suspicious uses
+;;; that may result in strange behaviour:
+
+;;; Modifying the standard readtable would, obviously, lead to a
+;;; propagation of this change to all places which use the :STANDARD
+;;; readtable (and thus rendering this readtable to be non-standard,
+;;; in fact.)
+
+
+(defun constant-standard-readtable-expression-p (thing)
+ (cond ((symbolp thing) (or (eq thing 'nil) (eq thing :standard)))
+ ((consp thing) (some (lambda (x) (equal thing x))
+ '((find-readtable nil)
+ (find-readtable :standard)
+ (ensure-readtable nil)
+ (ensure-readtable :standard))))
+ (t nil)))
+
+(defun signal-suspicious-registration-warning (name-expr readtable-expr)
+ (simple-style-warn
+ "Caution: ~~% ~S"
+ (list name-expr name-expr) readtable-expr))
+
+(let ()
+ ;; Defer to runtime because compiler-macros are made available already
+ ;; at compilation time. So without this two subsequent invocations of
+ ;; COMPILE-FILE on this file would result in an undefined function
+ ;; error because the two above functions are not yet available.
+ ;; (This does not use EVAL-WHEN because of Fig 3.7, CLHS 3.2.3.1;
+ ;; cf. last example in CLHS "EVAL-WHEN" entry.)
+
+ (define-compiler-macro register-readtable (&whole form name readtable)
+ (when (constant-standard-readtable-expression-p readtable)
+ (signal-suspicious-registration-warning name readtable))
+ form)
+
+ (define-compiler-macro ensure-readtable (&whole form name &optional (default nil default-p))
+ (when (and default-p (constant-standard-readtable-expression-p default))
+ (signal-suspicious-registration-warning name default))
+ form))
+
+
Added: dependencies/trunk/named-readtables/package.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/package.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,193 @@
+
+(in-package :common-lisp-user)
+
+(defpackage :editor-hints.named-readtables
+ (:use :common-lisp)
+ (:nicknames :named-readtables)
+ (:export
+ #:defreadtable
+ #:in-readtable
+ #:make-readtable
+ #:merge-readtables-into
+ #:find-readtable
+ #:ensure-readtable
+ #:rename-readtable
+ #:readtable-name
+ #:register-readtable
+ #:unregister-readtable
+ #:copy-named-readtable
+ #:list-all-named-readtables
+ ;; Types
+ #:named-readtable-designator
+ ;; Conditions
+ #:reader-macro-conflict
+ #:readtable-does-already-exist
+ #:readtable-does-not-exist
+ )
+ (:documentation
+ "
+* What are Named-Readtables?
+
+ Named-Readtables is a library that provides a namespace for
+ readtables akin to the already-existing namespace of packages. In
+ particular:
+
+ * you can associate readtables with names, and retrieve
+ readtables by names;
+
+ * you can associate source files with readtable names, and be
+ sure that the right readtable is active when compiling/loading
+ the file;
+
+ * similiarly, your development environment now has a chance to
+ automatically determine what readtable should be active while
+ processing source forms on interactive commands. (E.g. think of
+ `C-c C-c' in Slime [yet to be done])
+
+ It follows that Named-Readtables is a facility for using readtables in
+ a localized way.
+
+ Additionally, it also attempts to become a facility for using
+ readtables in a _modular_ way. In particular:
+
+ * it provides a macro to specify the content of a readtable at a
+ glance;
+
+ * it makes it possible to use multiple inheritance between readtables.
+
+* Notes on the API
+
+ The API heavily imitates the API of packages. This has the nice
+ property that any experienced Common Lisper will take it up without
+ effort.
+
+ DEFREADTABLE - DEFPACKAGE
+
+ IN-READTABLE - IN-PACKAGE
+
+ MERGE-READTABLES-INTO - USE-PACKAGE
+
+ MAKE-READTABLE - MAKE-PACKAGE
+
+ UNREGISTER-READTABLE - DELETE-PACKAGE
+
+ RENAME-READTABLE - RENAME-PACKAGE
+
+ FIND-READTABLE - FIND-PACKAGE
+
+ READTABLE-NAME - PACKAGE-NAME
+
+ LIST-ALL-NAMED-READTABLES - LIST-ALL-PACKAGES
+
+* Important API idiosyncrasies
+
+ There are three major differences between the API of Named-Readtables,
+ and the API of packages.
+
+ 1. Readtable names are symbols not strings.
+
+ Time has shown that the fact that packages are named by
+ strings causes severe headache because of the potential of
+ package names colliding with each other.
+
+ Hence, readtables are named by symbols lest to make the
+ situation worse than it already is. Consequently, readtables
+ named CL-ORACLE:SQL-SYNTAX and CL-MYSQL:SQL-SYNTAX can
+ happily coexist next to each other. Or, taken to an extreme,
+ SCHEME:SYNTAX and ELISP:SYNTAX.
+
+ If, for example to duly signify the importance of your cool
+ readtable hack, you really think it deserves a global name,
+ you can always resort to keywords.
+
+ 2. The inheritance is resolved statically, not dynamically.
+
+ A package that uses another package will have access to all
+ the other package's exported symbols, even to those that will
+ be added after its definition. I.e. the inheritance is
+ resolved at run-time, that is dynamically.
+
+ Unfortunately, we cannot do the same for readtables in a
+ portable manner.
+
+ Therefore, we do not talk about \"using\" another readtable
+ but about \"merging\" the other readtable's definition into
+ the readtable we are going to define. I.e. the inheritance is
+ resolved once at definition time, that is statically.
+
+ (Such merging can more or less be implemented portably albeit
+ at a certain cost. Most of the time, this cost manifests
+ itself at the time a readtable is defined, i.e. once at
+ compile-time, so it may not bother you. Nonetheless, we
+ provide extra support for Sbcl, ClozureCL, and AllegroCL at
+ the moment. Patches for your implementation of choice are
+ welcome, of course.)
+
+ 3. DEFREADTABLE does not have compile-time effects.
+
+ If you define a package via DEFPACKAGE, you can make that
+ package the currently active package for the subsequent
+ compilation of the same file via IN-PACKAGE. The same is,
+ however, not true for DEFREADTABLE and IN-READTABLE for the
+ following reason:
+
+ It's unlikely that the need for special reader-macros arises
+ for a problem which can be solved in just one file. Most
+ often, you're going to define the reader macro functions, and
+ set up the corresponding readtable in an extra file.
+
+ If DEFREADTABLE had compile-time effects, you'd have to wrap
+ each definition of a reader-macro function in an EVAL-WHEN to
+ make its definition available at compile-time. Because that's
+ simply not the common case, DEFREADTABLE does not have a
+ compile-time effect.
+
+ If you want to use a readtable within the same file as its
+ definition, wrap the DEFREADTABLE and the reader-macro
+ function definitions in an explicit EVAL-WHEN.
+
+* Preregistered Readtables
+
+ - NIL, :STANDARD, and :COMMON-LISP designate the /standard readtable/.
+
+ - :MODERN designates a _case-preserving_ /standard-readtable/.
+
+ - :CURRENT designates the /current readtable/.
+
+* Examples
+
+ > (defreadtable elisp:syntax
+ > (:merge :standard)
+ > (:macro-char #\\? #'elisp::read-character-literal t)
+ > (:macro-char #\\[ #'elisp::read-vector-literal t)
+ > ...
+ > (:case :preserve))
+ >
+ > (defreadtable scheme:syntax
+ > (:merge :standard)
+ > (:macro-char #\\[ #'(lambda (stream char)
+ > (read-delimited-list #\\] stream)))
+ > (:macro-char #\\# :dispatch)
+ > (:dispatch-macro-char #\\# #\\t #'scheme::read-#t)
+ > (:dispatch-macro-char #\\# #\\f #'scheme::read-#f)
+ > ...
+ > (:case :preserve))
+ >
+ > (in-readtable elisp:syntax)
+ >
+ > ...
+ >
+ > (in-readtable scheme:syntax)
+ >
+ > ...
+
+* Acknowledgements
+
+ Thanks to Robert Goldman for making me want to write this library.
+
+ Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart
+ Botta, David Crawford, and Pascal Costanza for being early adopters,
+ providing comments and bugfixes.
+"))
+
+(pushnew :named-readtables *features*)
\ No newline at end of file
Added: dependencies/trunk/named-readtables/tests/package.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/tests/package.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,12 @@
+;;; -*- Mode:Lisp -*-
+
+(in-package :cl-user)
+
+(defpackage :named-readtables-test
+ (:use :cl :named-readtables)
+ (:import-from :named-readtables
+ #:dispatch-macro-char-p
+ #:do-readtable
+ #:ensure-function
+ #:ensure-dispatch-macro-character
+ #:function=))
\ No newline at end of file
Added: dependencies/trunk/named-readtables/tests/rt.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/tests/rt.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,256 @@
+#|----------------------------------------------------------------------------|
+ | Copyright 1990 by the Massachusetts Institute of Technology, Cambridge MA. |
+ | |
+ | Permission to use, copy, modify, and distribute this software and its |
+ | documentation for any purpose and without fee is hereby granted, provided |
+ | that this copyright and permission notice appear in all copies and |
+ | supporting documentation, and that the name of M.I.T. not be used in |
+ | advertising or publicity pertaining to distribution of the software |
+ | without specific, written prior permission. M.I.T. makes no |
+ | representations about the suitability of this software for any purpose. |
+ | It is provided "as is" without express or implied warranty. |
+ | |
+ | M.I.T. DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING |
+ | ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL |
+ | M.I.T. BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR |
+ | ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, |
+ | WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, |
+ | ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS |
+ | SOFTWARE. |
+ |----------------------------------------------------------------------------|#
+
+;; (defpackage :rt
+;; (:use #:cl)
+;; (:export #:*do-tests-when-defined* #:*test* #:continue-testing
+;; #:deftest #:do-test #:do-tests #:get-test #:pending-tests
+;; #:rem-all-tests #:rem-test)
+;; (:documentation "The MIT regression tester"))
+
+;; (in-package :rt)
+
+(in-package :named-readtables-test)
+
+(defvar *test* nil "Current test name")
+(defvar *do-tests-when-defined* nil)
+(defvar *entries* '(nil) "Test database")
+(defvar *in-test* nil "Used by TEST")
+(defvar *debug* nil "For debugging")
+(defvar *catch-errors* t
+ "When true, causes errors in a test to be caught.")
+(defvar *print-circle-on-failure* nil
+ "Failure reports are printed with *PRINT-CIRCLE* bound to this value.")
+(defvar *compile-tests* nil
+ "When true, compile the tests before running them.")
+(defvar *optimization-settings* '((safety 3)))
+(defvar *expected-failures* nil
+ "A list of test names that are expected to fail.")
+
+(defstruct (entry (:conc-name nil)
+ (:type list))
+ pend name form)
+
+(defmacro vals (entry) `(cdddr ,entry))
+
+(defmacro defn (entry) `(cdr ,entry))
+
+(defun pending-tests ()
+ (do ((l (cdr *entries*) (cdr l))
+ (r nil))
+ ((null l) (nreverse r))
+ (when (pend (car l))
+ (push (name (car l)) r))))
+
+(defun rem-all-tests ()
+ (setq *entries* (list nil))
+ nil)
+
+(defun rem-test (&optional (name *test*))
+ (do ((l *entries* (cdr l)))
+ ((null (cdr l)) nil)
+ (when (equal (name (cadr l)) name)
+ (setf (cdr l) (cddr l))
+ (return name))))
+
+(defun get-test (&optional (name *test*))
+ (defn (get-entry name)))
+
+(defun get-entry (name)
+ (let ((entry (find name (cdr *entries*)
+ :key #'name
+ :test #'equal)))
+ (when (null entry)
+ (report-error t
+ "~%No test with name ~:@(~S~)."
+ name))
+ entry))
+
+(defmacro deftest (name form &rest values)
+ `(add-entry '(t ,name ,form .,values)))
+
+(defun add-entry (entry)
+ (setq entry (copy-list entry))
+ (do ((l *entries* (cdr l))) (nil)
+ (when (null (cdr l))
+ (setf (cdr l) (list entry))
+ (return nil))
+ (when (equal (name (cadr l))
+ (name entry))
+ (setf (cadr l) entry)
+ (report-error nil
+ "Redefining test ~:@(~S~)"
+ (name entry))
+ (return nil)))
+ (when *do-tests-when-defined*
+ (do-entry entry))
+ (setq *test* (name entry)))
+
+(defun report-error (error? &rest args)
+ (cond (*debug*
+ (apply #'format t args)
+ (if error? (throw '*debug* nil)))
+ (error? (apply #'error args))
+ (t (apply #'warn args))))
+
+(defun do-test (&optional (name *test*))
+ (do-entry (get-entry name)))
+
+(defun equalp-with-case (x y)
+ "Like EQUALP, but doesn't do case conversion of characters."
+ (cond
+ ((eq x y) t)
+ ((consp x)
+ (and (consp y)
+ (equalp-with-case (car x) (car y))
+ (equalp-with-case (cdr x) (cdr y))))
+ ((and (typep x 'array)
+ (= (array-rank x) 0))
+ (equalp-with-case (aref x) (aref y)))
+ ((typep x 'vector)
+ (and (typep y 'vector)
+ (let ((x-len (length x))
+ (y-len (length y)))
+ (and (eql x-len y-len)
+ (loop
+ for e1 across x
+ for e2 across y
+ always (equalp-with-case e1 e2))))))
+ ((and (typep x 'array)
+ (typep y 'array)
+ (not (equal (array-dimensions x)
+ (array-dimensions y))))
+ nil)
+ ((typep x 'array)
+ (and (typep y 'array)
+ (let ((size (array-total-size x)))
+ (loop for i from 0 below size
+ always (equalp-with-case (row-major-aref x i)
+ (row-major-aref y i))))))
+ (t (eql x y))))
+
+(defun do-entry (entry &optional
+ (s *standard-output*))
+ (catch '*in-test*
+ (setq *test* (name entry))
+ (setf (pend entry) t)
+ (let* ((*in-test* t)
+ ;; (*break-on-warnings* t)
+ (aborted nil)
+ r)
+ ;; (declare (special *break-on-warnings*))
+
+ (block aborted
+ (setf r
+ (flet ((%do
+ ()
+ (if *compile-tests*
+ (multiple-value-list
+ (funcall (compile
+ nil
+ `(lambda ()
+ (declare
+ (optimize ,@*optimization-settings*))
+ ,(form entry)))))
+ (multiple-value-list
+ (eval (form entry))))))
+ (if *catch-errors*
+ (handler-bind
+ ((style-warning #'muffle-warning)
+ (error #'(lambda (c)
+ (setf aborted t)
+ (setf r (list c))
+ (return-from aborted nil))))
+ (%do))
+ (%do)))))
+
+ (setf (pend entry)
+ (or aborted
+ (not (equalp-with-case r (vals entry)))))
+
+ (when (pend entry)
+ (let ((*print-circle* *print-circle-on-failure*))
+ (format s "~&Test ~:@(~S~) failed~
+ ~%Form: ~S~
+ ~%Expected value~P: ~
+ ~{~S~^~%~17t~}~%"
+ *test* (form entry)
+ (length (vals entry))
+ (vals entry))
+ (format s "Actual value~P: ~
+ ~{~S~^~%~15t~}.~%"
+ (length r) r)))))
+ (when (not (pend entry)) *test*))
+
+(defun continue-testing ()
+ (if *in-test*
+ (throw '*in-test* nil)
+ (do-entries *standard-output*)))
+
+(defun do-tests (&optional
+ (out *standard-output*))
+ (dolist (entry (cdr *entries*))
+ (setf (pend entry) t))
+ (if (streamp out)
+ (do-entries out)
+ (with-open-file
+ (stream out :direction :output)
+ (do-entries stream))))
+
+(defun do-entries (s)
+ (format s "~&Doing ~A pending test~:P ~
+ of ~A tests total.~%"
+ (count t (cdr *entries*)
+ :key #'pend)
+ (length (cdr *entries*)))
+ (dolist (entry (cdr *entries*))
+ (when (pend entry)
+ (format s "~@[~<~%~:; ~:@(~S~)~>~]"
+ (do-entry entry s))))
+ (let ((pending (pending-tests))
+ (expected-table (make-hash-table :test #'equal)))
+ (dolist (ex *expected-failures*)
+ (setf (gethash ex expected-table) t))
+ (let ((new-failures
+ (loop for pend in pending
+ unless (gethash pend expected-table)
+ collect pend)))
+ (if (null pending)
+ (format s "~&No tests failed.")
+ (progn
+ (format s "~&~A out of ~A ~
+ total tests failed: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length pending)
+ (length (cdr *entries*))
+ pending)
+ (if (null new-failures)
+ (format s "~&No unexpected failures.")
+ (when *expected-failures*
+ (format s "~&~A unexpected failures: ~
+ ~:@(~{~<~% ~1:;~S~>~
+ ~^, ~}~)."
+ (length new-failures)
+ new-failures)))
+ ))
+ (finish-output s)
+ (null pending))))
Added: dependencies/trunk/named-readtables/tests/tests.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/tests/tests.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,322 @@
+;;; -*- Mode:Lisp -*-
+
+(in-package :named-readtables-test)
+
+(defun map-alist (car-fn cdr-fn alist)
+ (mapcar #'(lambda (entry)
+ (cons (funcall car-fn (car entry))
+ (funcall cdr-fn (cdr entry))))
+ alist))
+
+(defun length=1 (list)
+ (and list (null (cdr list))))
+
+(defmacro signals-condition-p (name &body body)
+ `(handler-case (prog1 nil , at body)
+ (,(second name) () t)))
+
+(defmacro continue-condition (name &body body)
+ `(handler-bind ((,(second name) #'continue))
+ , at body))
+
+(defun read-with-readtable (name string)
+ (let ((*package* '#.*package*)
+ (*readtable* (find-readtable name)))
+ (values (read-from-string string))))
+
+(defun random-named-readtable ()
+ (let ((readtables (list-all-named-readtables)))
+ (nth (random (length readtables)) readtables)))
+
+
+(defun readtable-content (named-readtable-designator)
+ (let ((readtable (ensure-readtable named-readtable-designator))
+ (result '()))
+ ;; Make sure to canonicalize the order and function designators so
+ ;; we can compare easily.
+ (do-readtable ((char reader-fn ntp disp? table) readtable)
+ (setq table (sort (copy-list table) #'char< :key #'car))
+ (push (list* char
+ (ensure-function reader-fn)
+ ntp
+ (and disp? (list (map-alist #'identity
+ #'ensure-function
+ table))))
+ result))
+ (sort result #'char< :key #'car)))
+
+(defun readtable= (rt1 rt2)
+ (tree-equal (readtable-content rt1) (readtable-content rt2)
+ :test #'(lambda (x y)
+ (if (and (functionp x) (functionp y))
+ (function= x y)
+ (eql x y)))))
+
+
+(defun read-A (stream c)
+ (declare (ignore stream c))
+ :a)
+
+(defun read-A-as-X (stream c)
+ (declare (ignore stream c))
+ :x)
+
+(defun read-B (stream c)
+ (declare (ignore stream c))
+ :b)
+
+(defun read-sharp-paren (stream c n)
+ (declare (ignore stream c n))
+ 'sharp-paren)
+
+(defun read-C (stream c)
+ (declare (ignore stream c))
+ :c)
+
+(defreadtable A
+ (:macro-char #\A #'read-A))
+
+(defreadtable A-as-X
+ (:macro-char #\A #'read-A-as-X))
+
+(defreadtable B
+ (:macro-char #\B #'read-B))
+
+(defreadtable C
+ (:macro-char #\C #'read-C))
+
+(defreadtable A+B+C
+ (:merge A B C))
+
+(defreadtable standard+A+B+C
+ (:merge :standard A+B+C))
+
+(defreadtable sharp-paren
+ (:macro-char #\# :dispatch)
+ (:dispatch-macro-char #\# #\( #'read-sharp-paren))
+
+
+(deftest cruft.1
+ (function= (get-macro-character #\" (copy-readtable nil))
+ (get-macro-character #\" (copy-readtable nil)))
+ t)
+
+(deftest cruft.2
+ (dispatch-macro-char-p #\# (find-readtable :standard))
+ t)
+
+(deftest cruft.3
+ (dispatch-macro-char-p #\# (make-readtable))
+ nil)
+
+(deftest cruft.4
+ (let ((rt (copy-named-readtable :standard)))
+ (ensure-dispatch-macro-character #\# t rt)
+ (dispatch-macro-char-p #\# rt))
+ t)
+
+(deftest cruft.5
+ (let ((rt (make-readtable)))
+ (values
+ (dispatch-macro-char-p #\$ rt)
+ (ensure-dispatch-macro-character #\$ t rt)
+ (dispatch-macro-char-p #\$ rt)))
+ nil t t)
+
+(deftest cruft.6
+ (let ((rt (make-readtable))
+ (fn (constantly nil)))
+ (ensure-dispatch-macro-character #\$ t rt)
+ (set-dispatch-macro-character #\$ #\# fn rt)
+ (values
+ (eq fn (get-dispatch-macro-character #\$ #\# rt))
+ (length=1 (readtable-content rt))))
+ t t)
+
+(deftest cruft.7
+ (let ((rt (make-readtable))
+ (fn (constantly nil)))
+ (set-macro-character #\$ fn t rt)
+ (values
+ (eq fn (get-macro-character #\$ rt))
+ (length=1 (readtable-content rt))))
+ t t)
+
+
+(deftest standard.1
+ (read-with-readtable :standard "ABC")
+ ABC)
+
+(deftest standard.2
+ (read-with-readtable :standard "(A B C)")
+ (A B C))
+
+(deftest standard.3
+ (let ((x (find-readtable nil))
+ (y (find-readtable :standard))
+ (z (find-readtable :common-lisp)))
+ (and (eq x y) (eq y z)))
+ t)
+
+
+(deftest modern.1
+ (read-with-readtable :modern "FooF")
+ |FooF|)
+
+
+(deftest empty.1
+ (null (readtable-content (make-readtable)))
+ t)
+
+(deftest empty.2
+ (readtable= (merge-readtables-into (make-readtable) :standard)
+ (find-readtable :standard))
+ t)
+
+(deftest empty.3
+ (let ((rt (copy-named-readtable :standard)))
+ (readtable= (merge-readtables-into (make-readtable) rt)
+ (merge-readtables-into rt (make-readtable))))
+ t)
+
+
+(deftest basics.1
+ (read-with-readtable 'A "A")
+ :a)
+
+(deftest basics.2
+ (read-with-readtable 'A-as-X "A")
+ :x)
+
+(deftest basics.3
+ (read-with-readtable 'A "B")
+ B)
+
+(deftest basics.4
+ (read-with-readtable 'A "(A B C)")
+ |(|)
+
+
+(deftest unregister.1
+ (let ((rt (find-readtable 'A)))
+ (register-readtable 'does-not-exist rt)
+ (values
+ (and (find-readtable 'does-not-exist) t)
+ (unregister-readtable 'does-not-exist)
+ (and (find-readtable 'does-not-exist) t)))
+ t t nil)
+
+
+(deftest name.1
+ (let ((rt (random-named-readtable)))
+ (eq rt (find-readtable (readtable-name rt))))
+ t)
+
+(deftest ensure.1
+ (unwind-protect
+ (let* ((x (ensure-readtable 'does-not-exist (find-readtable 'A)))
+ (y (find-readtable 'A))
+ (z (find-readtable 'does-not-exist)))
+ (and (eq x y) (eq y z)))
+ (unregister-readtable 'does-not-exist))
+ t)
+
+
+(deftest merge.1
+ (values
+ (read-with-readtable 'A+B+C "A")
+ (read-with-readtable 'A+B+C "B")
+ (read-with-readtable 'A+B+C "C"))
+ :a :b :c)
+
+(deftest merge.2
+ (read-with-readtable 'standard+A+B+C "(A B C)")
+ (:a :b :c))
+
+(deftest merge.3
+ (read-with-readtable 'standard+A+B+C "#(A B C)")
+ #(:a :b :c))
+
+(deftest merge.4
+ (let ((A+B+C+standard (merge-readtables-into (copy-named-readtable 'A+B+C)
+ :standard)))
+ (readtable= 'standard+A+B+C A+B+C+standard))
+ t)
+
+
+(deftest rename.1
+ (unwind-protect
+ (progn (make-readtable 'A* :merge '(A))
+ (rename-readtable 'A* 'A**)
+ (values (and (find-readtable 'A*) t)
+ (and (find-readtable 'A**) t)))
+ (unregister-readtable 'A*)
+ (unregister-readtable 'A**))
+ nil
+ t)
+
+
+(deftest reader-macro-conflict.1
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) 'A 'A-as-X))
+ t)
+
+(deftest reader-macro-conflict.2
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) :standard :standard))
+ nil)
+
+(deftest reader-macro-conflict.3
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) 'A+B+C 'A))
+ nil)
+
+(deftest reader-macro-conflict.4
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) :standard 'sharp-paren))
+ t)
+
+
+(deftest readtable-does-not-exist.1
+ (signals-condition-p 'readtable-does-not-exist
+ (ensure-readtable 'does-not-exist))
+ t)
+
+
+(deftest readtable-does-already-exist.1
+ (signals-condition-p 'readtable-does-already-exist
+ (make-readtable 'A))
+ t)
+
+(deftest readtable-does-already-exist.2
+ (signals-condition-p 'readtable-does-already-exist
+ (make-readtable 'A))
+ t)
+
+(deftest readtable-does-already-exist.3
+ (let ((rt (make-readtable 'does-not-exist :merge '(:standard A B))))
+ (declare (ignore rt))
+ (unwind-protect
+ (read-with-readtable (continue-condition 'readtable-does-already-exist
+ (make-readtable 'does-not-exist
+ :merge '(:standard A C)))
+
+ "(A B C)")
+ (unregister-readtable 'does-not-exist)))
+ (:a B :c))
+
+
+(deftest defreadtable.1
+ (unwind-protect
+ (signals-condition-p 'reader-macro-conflict
+ (eval `(defreadtable does-not-exist (:merge A A-as-X))))
+ (unregister-readtable 'does-not-exist))
+ t)
+
+(deftest defreadtable.2
+ (unwind-protect
+ (signals-condition-p 't
+ (eval `(defreadtable does-not-exist (:fuze A A-as-X))))
+ (unregister-readtable 'does-not-exist))
+ nil)
+
Added: dependencies/trunk/named-readtables/utils.lisp
==============================================================================
--- (empty file)
+++ dependencies/trunk/named-readtables/utils.lisp Tue Jan 26 15:20:07 2010
@@ -0,0 +1,245 @@
+;;;;
+;;;; Copyright (c) 2008 - 2009 Tobias C. Rittweiler
+;;;;
+;;;; All rights reserved.
+;;;;
+;;;; See LICENSE for details.
+;;;;
+
+(in-package :editor-hints.named-readtables)
+
+(defmacro without-package-lock ((&rest package-names) &body body)
+ (declare (ignorable package-names))
+ #+clisp
+ (return-from without-package-lock
+ `(ext:without-package-lock (, at package-names) , at body))
+ #+lispworks
+ (return-from without-package-lock
+ `(let ((hcl:*packages-for-warn-on-redefinition*
+ (set-difference hcl:*packages-for-warn-on-redefinition*
+ '(, at package-names)
+ :key (lambda (package-designator)
+ (if (packagep package-designator)
+ (package-name package-designator)
+ package-designator))
+ :test #'string=)))
+ , at body))
+ `(progn , at body))
+
+;;; Taken from SWANK (which is Public Domain.)
+
+(defmacro destructure-case (value &rest patterns)
+ "Dispatch VALUE to one of PATTERNS.
+A cross between `case' and `destructuring-bind'.
+The pattern syntax is:
+ ((HEAD . ARGS) . BODY)
+The list of patterns is searched for a HEAD `eq' to the car of
+VALUE. If one is found, the BODY is executed with ARGS bound to the
+corresponding values in the CDR of VALUE."
+ (let ((operator (gensym "op-"))
+ (operands (gensym "rand-"))
+ (tmp (gensym "tmp-")))
+ `(let* ((,tmp ,value)
+ (,operator (car ,tmp))
+ (,operands (cdr ,tmp)))
+ (case ,operator
+ ,@(loop for (pattern . body) in patterns collect
+ (if (eq pattern t)
+ `(t , at body)
+ (destructuring-bind (op &rest rands) pattern
+ `(,op (destructuring-bind ,rands ,operands
+ , at body)))))
+ ,@(if (eq (caar (last patterns)) t)
+ '()
+ `((t (error "destructure-case failed: ~S" ,tmp))))))))
+
+;;; Taken from Alexandria (which is Public Domain, or BSD.)
+
+(define-condition simple-style-warning (simple-warning style-warning)
+ ())
+
+(defun simple-style-warn (format-control &rest format-args)
+ (warn 'simple-style-warning
+ :format-control format-control
+ :format-arguments format-args))
+
+(define-condition simple-program-error (simple-error program-error)
+ ())
+
+(defun simple-program-error (message &rest args)
+ (error 'simple-program-error
+ :format-control message
+ :format-arguments args))
+
+(defun required-argument (&optional name)
+ "Signals an error for a missing argument of NAME. Intended for
+use as an initialization form for structure and class-slots, and
+a default value for required keyword arguments."
+ (error "Required argument ~@[~S ~]missing." name))
+
+(defun ensure-list (list)
+ "If LIST is a list, it is returned. Otherwise returns the list
+designated by LIST."
+ (if (listp list)
+ list
+ (list list)))
+
+(declaim (inline ensure-function)) ; to propagate return type.
+(declaim (ftype (function (t) (values function &optional))
+ ensure-function))
+(defun ensure-function (function-designator)
+ "Returns the function designated by FUNCTION-DESIGNATOR:
+if FUNCTION-DESIGNATOR is a function, it is returned, otherwise
+it must be a function name and its FDEFINITION is returned."
+ (if (functionp function-designator)
+ function-designator
+ (fdefinition function-designator)))
+
+(defun parse-body (body &key documentation whole)
+ "Parses BODY into (values remaining-forms declarations doc-string).
+Documentation strings are recognized only if DOCUMENTATION is true.
+Syntax errors in body are signalled and WHOLE is used in the signal
+arguments when given."
+ (let ((doc nil)
+ (decls nil)
+ (current nil))
+ (tagbody
+ :declarations
+ (setf current (car body))
+ (when (and documentation (stringp current) (cdr body))
+ (if doc
+ (error "Too many documentation strings in ~S." (or whole body))
+ (setf doc (pop body)))
+ (go :declarations))
+ (when (and (listp current) (eql (first current) 'declare))
+ (push (pop body) decls)
+ (go :declarations)))
+ (values body (nreverse decls) doc)))
+
+(defun parse-ordinary-lambda-list (lambda-list)
+ "Parses an ordinary lambda-list, returning as multiple values:
+
+ 1. Required parameters.
+ 2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP)
+ where SUPPLIEDP is NIL if not present.
+ 3. Name of the rest parameter, or NIL.
+ 4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP)
+ where SUPPLIEDP is NIL if not present.
+ 5. Boolean indicating &ALLOW-OTHER-KEYS presence.
+ 6. &AUX parameter specifications, normalized into form (NAME INIT).
+
+Signals a PROGRAM-ERROR is the lambda-list is malformed."
+ (let ((state :required)
+ (allow-other-keys nil)
+ (auxp nil)
+ (required nil)
+ (optional nil)
+ (rest nil)
+ (keys nil)
+ (aux nil))
+ (labels ((simple-program-error (format-string &rest format-args)
+ (error 'simple-program-error
+ :format-control format-string
+ :format-arguments format-args))
+ (fail (elt)
+ (simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (check-variable (elt what)
+ (unless (and (symbolp elt) (not (constantp elt)))
+ (simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
+ what elt lambda-list)))
+ (check-spec (spec what)
+ (destructuring-bind (init suppliedp) spec
+ (declare (ignore init))
+ (check-variable suppliedp what)))
+ (make-keyword (name)
+ "Interns the string designated by NAME in the KEYWORD package."
+ (intern (string name) :keyword)))
+ (dolist (elt lambda-list)
+ (case elt
+ (&optional
+ (if (eq state :required)
+ (setf state elt)
+ (fail elt)))
+ (&rest
+ (if (member state '(:required &optional))
+ (setf state elt)
+ (progn
+ (break "state=~S" state)
+ (fail elt))))
+ (&key
+ (if (member state '(:required &optional :after-rest))
+ (setf state elt)
+ (fail elt)))
+ (&allow-other-keys
+ (if (eq state '&key)
+ (setf allow-other-keys t
+ state elt)
+ (fail elt)))
+ (&aux
+ (cond ((eq state '&rest)
+ (fail elt))
+ (auxp
+ (simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (t
+ (setf auxp t
+ state elt))
+ ))
+ (otherwise
+ (when (member elt '#.(set-difference lambda-list-keywords
+ '(&optional &rest &key &allow-other-keys &aux)))
+ (simple-program-error
+ "Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
+ elt lambda-list))
+ (case state
+ (:required
+ (check-variable elt "required parameter")
+ (push elt required))
+ (&optional
+ (cond ((consp elt)
+ (destructuring-bind (name &rest tail) elt
+ (check-variable name "optional parameter")
+ (if (cdr tail)
+ (check-spec tail "optional-supplied-p parameter")
+ (setf elt (append elt '(nil))))))
+ (t
+ (check-variable elt "optional parameter")
+ (setf elt (cons elt '(nil nil)))))
+ (push elt optional))
+ (&rest
+ (check-variable elt "rest parameter")
+ (setf rest elt
+ state :after-rest))
+ (&key
+ (cond ((consp elt)
+ (destructuring-bind (var-or-kv &rest tail) elt
+ (cond ((consp var-or-kv)
+ (destructuring-bind (keyword var) var-or-kv
+ (unless (symbolp keyword)
+ (simple-program-error "Invalid keyword name ~S in ordinary ~
+ lambda-list:~% ~S"
+ keyword lambda-list))
+ (check-variable var "keyword parameter")))
+ (t
+ (check-variable var-or-kv "keyword parameter")
+ (setf var-or-kv (list (make-keyword var-or-kv) var-or-kv))))
+ (if (cdr tail)
+ (check-spec tail "keyword-supplied-p parameter")
+ (setf tail (append tail '(nil))))
+ (setf elt (cons var-or-kv tail))))
+ (t
+ (check-variable elt "keyword parameter")
+ (setf elt (list (list (make-keyword elt) elt) nil nil))))
+ (push elt keys))
+ (&aux
+ (if (consp elt)
+ (destructuring-bind (var &optional init) elt
+ (declare (ignore init))
+ (check-variable var "&aux parameter"))
+ (check-variable elt "&aux parameter"))
+ (push elt aux))
+ (t
+ (simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))
+ (values (nreverse required) (nreverse optional) rest (nreverse keys)
+ allow-other-keys (nreverse aux))))
\ No newline at end of file