[snow-cvs] r2 - in trunk: . dist docs docs/images lib lib/cells lib/cells/Use Cases lib/cells/Use Cases/dow-jones lib/cells/cells-test lib/cells/doc lib/cells/gui-geometry lib/cells/tutorial lib/cells/utils-kt src src/java src/java/snow src/java/snow/binding src/java/snow/editor src/java/snow/example src/java/snow/list src/java/snow/swing src/java/snow/tree src/lisp src/lisp/snow src/lisp/snow/debugger src/lisp/snow/swing test test/bin test/src test/src/snow
Alessio Stalla
astalla at common-lisp.net
Wed Sep 30 20:06:52 UTC 2009
Author: astalla
Date: Wed Sep 30 16:06:52 2009
New Revision: 2
Log:
Initial import.
Added:
trunk/build.xml (contents, props changed)
trunk/changelog (contents, props changed)
trunk/copying (contents, props changed)
trunk/dist/
trunk/docs/
trunk/docs/faq.html (contents, props changed)
trunk/docs/images/
trunk/docs/images/oh-no.png (contents, props changed)
trunk/docs/style.css (contents, props changed)
trunk/docs/tutorial.html (contents, props changed)
trunk/docs/widget-reference.html (contents, props changed)
trunk/lib/
trunk/lib/abcl.jar (contents, props changed)
trunk/lib/binding-2.0.6.jar (contents, props changed)
trunk/lib/cells/
trunk/lib/cells/README.txt (contents, props changed)
trunk/lib/cells/Use Cases/
trunk/lib/cells/Use Cases/dow-jones/
trunk/lib/cells/Use Cases/dow-jones/dow-jones.lpr (contents, props changed)
trunk/lib/cells/Use Cases/dow-jones/stock-exchange.lisp (contents, props changed)
trunk/lib/cells/cell-types.lisp (contents, props changed)
trunk/lib/cells/cells-manifesto.txt (contents, props changed)
trunk/lib/cells/cells-store.lisp (contents, props changed)
trunk/lib/cells/cells-test/
trunk/lib/cells/cells-test/boiler-examples.lisp (contents, props changed)
trunk/lib/cells/cells-test/build-sys.lisp (contents, props changed)
trunk/lib/cells/cells-test/cells-test.asd (contents, props changed)
trunk/lib/cells/cells-test/cells-test.lpr (contents, props changed)
trunk/lib/cells/cells-test/deep-cells.lisp (contents, props changed)
trunk/lib/cells/cells-test/df-interference.lisp (contents, props changed)
trunk/lib/cells/cells-test/echo-setf.lisp (contents, props changed)
trunk/lib/cells/cells-test/hello-world-q.lisp (contents, props changed)
trunk/lib/cells/cells-test/hello-world.lisp (contents, props changed)
trunk/lib/cells/cells-test/internal-combustion.lisp (contents, props changed)
trunk/lib/cells/cells-test/lazy-propagation.lisp (contents, props changed)
trunk/lib/cells/cells-test/output-setf.lisp (contents, props changed)
trunk/lib/cells/cells-test/person.lisp (contents, props changed)
trunk/lib/cells/cells-test/synapse-testing.lisp (contents, props changed)
trunk/lib/cells/cells-test/test-cycle.lisp (contents, props changed)
trunk/lib/cells/cells-test/test-cyclicity.lisp (contents, props changed)
trunk/lib/cells/cells-test/test-ephemeral.lisp (contents, props changed)
trunk/lib/cells/cells-test/test-family.lisp (contents, props changed)
trunk/lib/cells/cells-test/test-kid-slotting.lisp (contents, props changed)
trunk/lib/cells/cells-test/test-lazy.lisp (contents, props changed)
trunk/lib/cells/cells-test/test-synapse.lisp (contents, props changed)
trunk/lib/cells/cells-test/test.lisp (contents, props changed)
trunk/lib/cells/cells-test/test.lpr (contents, props changed)
trunk/lib/cells/cells.asd (contents, props changed)
trunk/lib/cells/cells.lisp (contents, props changed)
trunk/lib/cells/cells.lpr (contents, props changed)
trunk/lib/cells/constructors.lisp (contents, props changed)
trunk/lib/cells/defmodel.lisp (contents, props changed)
trunk/lib/cells/defpackage.lisp (contents, props changed)
trunk/lib/cells/doc/
trunk/lib/cells/doc/01-Cell-basics.lisp (contents, props changed)
trunk/lib/cells/doc/cell-doc.lisp (contents, props changed)
trunk/lib/cells/doc/cells-overview.pdf (contents, props changed)
trunk/lib/cells/doc/hw.lisp (contents, props changed)
trunk/lib/cells/doc/motor-control.lisp (contents, props changed)
trunk/lib/cells/family-values.lisp (contents, props changed)
trunk/lib/cells/family.lisp (contents, props changed)
trunk/lib/cells/fm-utilities.lisp (contents, props changed)
trunk/lib/cells/gui-geometry/
trunk/lib/cells/gui-geometry/coordinate-xform.lisp (contents, props changed)
trunk/lib/cells/gui-geometry/defpackage.lisp (contents, props changed)
trunk/lib/cells/gui-geometry/geo-data-structures.lisp (contents, props changed)
trunk/lib/cells/gui-geometry/geo-family.lisp (contents, props changed)
trunk/lib/cells/gui-geometry/geo-macros.lisp (contents, props changed)
trunk/lib/cells/gui-geometry/geometer.lisp (contents, props changed)
trunk/lib/cells/gui-geometry/gui-geometry.asd (contents, props changed)
trunk/lib/cells/gui-geometry/gui-geometry.lpr (contents, props changed)
trunk/lib/cells/initialize.lisp (contents, props changed)
trunk/lib/cells/integrity.lisp (contents, props changed)
trunk/lib/cells/link.lisp (contents, props changed)
trunk/lib/cells/load.lisp (contents, props changed)
trunk/lib/cells/md-slot-value.lisp (contents, props changed)
trunk/lib/cells/md-utilities.lisp (contents, props changed)
trunk/lib/cells/model-object.lisp (contents, props changed)
trunk/lib/cells/propagate.lisp (contents, props changed)
trunk/lib/cells/slot-utilities.lisp (contents, props changed)
trunk/lib/cells/synapse-types.lisp (contents, props changed)
trunk/lib/cells/synapse.lisp (contents, props changed)
trunk/lib/cells/test-cc.lisp (contents, props changed)
trunk/lib/cells/test-cycle.lisp (contents, props changed)
trunk/lib/cells/test-ephemeral.lisp (contents, props changed)
trunk/lib/cells/test-propagation.lisp (contents, props changed)
trunk/lib/cells/test-synapse.lisp (contents, props changed)
trunk/lib/cells/test.lisp (contents, props changed)
trunk/lib/cells/trc-eko.lisp (contents, props changed)
trunk/lib/cells/tutorial/
trunk/lib/cells/tutorial/01-lesson.lisp (contents, props changed)
trunk/lib/cells/tutorial/01a-dataflow.lisp (contents, props changed)
trunk/lib/cells/tutorial/01b-change-handling.lisp (contents, props changed)
trunk/lib/cells/tutorial/01c-cascade.lisp (contents, props changed)
trunk/lib/cells/tutorial/02-lesson.lisp (contents, props changed)
trunk/lib/cells/tutorial/03-ephemeral.lisp (contents, props changed)
trunk/lib/cells/tutorial/04-formula-once-then-input.lisp (contents, props changed)
trunk/lib/cells/tutorial/test.lisp (contents, props changed)
trunk/lib/cells/tutorial/tutorial.lpr (contents, props changed)
trunk/lib/cells/utils-kt/
trunk/lib/cells/utils-kt/core.lisp (contents, props changed)
trunk/lib/cells/utils-kt/datetime.lisp (contents, props changed)
trunk/lib/cells/utils-kt/debug.lisp (contents, props changed)
trunk/lib/cells/utils-kt/defpackage.lisp (contents, props changed)
trunk/lib/cells/utils-kt/detritus.lisp (contents, props changed)
trunk/lib/cells/utils-kt/flow-control.lisp (contents, props changed)
trunk/lib/cells/utils-kt/quad.lisp (contents, props changed)
trunk/lib/cells/utils-kt/split-sequence.lisp (contents, props changed)
trunk/lib/cells/utils-kt/strings.lisp (contents, props changed)
trunk/lib/cells/utils-kt/utils-kt.asd (contents, props changed)
trunk/lib/cells/utils-kt/utils-kt.lpr (contents, props changed)
trunk/lib/cells/variables.lisp (contents, props changed)
trunk/lib/commons-logging.jar (contents, props changed)
trunk/lib/miglayout-3.6.2.jar (contents, props changed)
trunk/src/
trunk/src/java/
trunk/src/java/abcl-script-config.lisp (contents, props changed)
trunk/src/java/snow/
trunk/src/java/snow/AwtDialogPromptStream.java (contents, props changed)
trunk/src/java/snow/DialogPromptStream.java (contents, props changed)
trunk/src/java/snow/Snow.java (contents, props changed)
trunk/src/java/snow/SwingDialogPromptStream.java (contents, props changed)
trunk/src/java/snow/binding/
trunk/src/java/snow/binding/AccessorBinding.java (contents, props changed)
trunk/src/java/snow/binding/Converter.java (contents, props changed)
trunk/src/java/snow/editor/
trunk/src/java/snow/editor/SnowEditor.java (contents, props changed)
trunk/src/java/snow/editor/snow-editor.lisp (contents, props changed)
trunk/src/java/snow/example/
trunk/src/java/snow/example/SnowExample.java (contents, props changed)
trunk/src/java/snow/example/example.lisp (contents, props changed)
trunk/src/java/snow/list/
trunk/src/java/snow/list/ConsListCellRenderer.java (contents, props changed)
trunk/src/java/snow/list/ConsListModel.java (contents, props changed)
trunk/src/java/snow/swing/
trunk/src/java/snow/swing/ConsoleDocument.java (contents, props changed)
trunk/src/java/snow/swing/WindowListener.java (contents, props changed)
trunk/src/java/snow/tree/
trunk/src/java/snow/tree/ConsTreeCellRenderer.java (contents, props changed)
trunk/src/java/snow/tree/ConsTreeModel.java (contents, props changed)
trunk/src/lisp/
trunk/src/lisp/snow/
trunk/src/lisp/snow/backend.lisp (contents, props changed)
trunk/src/lisp/snow/compile-system.lisp (contents, props changed)
trunk/src/lisp/snow/debugger/
trunk/src/lisp/snow/debugger.lisp (contents, props changed)
trunk/src/lisp/snow/inspector.lisp (contents, props changed)
trunk/src/lisp/snow/packages.lisp (contents, props changed)
trunk/src/lisp/snow/repl.lisp (contents, props changed)
trunk/src/lisp/snow/sexy-java.lisp (contents, props changed)
trunk/src/lisp/snow/snow.asd (contents, props changed)
trunk/src/lisp/snow/snow.lisp (contents, props changed)
trunk/src/lisp/snow/start.lisp (contents, props changed)
trunk/src/lisp/snow/swing/
trunk/src/lisp/snow/swing/binding-jgoodies.lisp (contents, props changed)
trunk/src/lisp/snow/swing/cells.lisp (contents, props changed)
trunk/src/lisp/snow/swing/snow-swing.asd (contents, props changed)
trunk/src/lisp/snow/swing/swing.lisp (contents, props changed)
trunk/src/lisp/snow/utils.lisp (contents, props changed)
trunk/test/
trunk/test/bin/
trunk/test/src/
trunk/test/src/snow/
trunk/test/src/snow/BindingTest.java (contents, props changed)
Added: trunk/build.xml
==============================================================================
--- (empty file)
+++ trunk/build.xml Wed Sep 30 16:06:52 2009
@@ -0,0 +1,223 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<project xmlns="antlib:org.apache.tools.ant"
+ name="snow-master" default="help" basedir=".">
+ <description>Compiling and packaging Snow</description>
+
+ <property file="build.properties"/>
+
+ <property name="build.dir"
+ value="${basedir}/build"/>
+ <property name="build.classes.dir"
+ value="${build.dir}/bin"/>
+ <property name="src.dir"
+ value="${basedir}/src"/>
+ <property name="lib.dir"
+ value="${basedir}/lib"/>
+ <property name="dist.dir"
+ value="${basedir}/dist"/>
+ <property name="snow.jar.path"
+ value="${dist.dir}/snow.jar"/>
+ <property name="snow.ext.dir"
+ value="${basedir}/ext"/>
+
+ <target name="help">
+ <echo>Main Ant targets:
+ snow.compile
+ -- compile SNOW to ${build.classes.dir}.
+ snow.jar
+ -- create packaged ${snow.jar.path}.
+ snow.source.zip snow.source.tar
+ -- create source distributions in ${dist.dir}.
+ snow.clean
+ -- remove SNOW intermediate files</echo>
+ </target>
+
+ <patternset id="snow.source.java">
+ <include name="snow/**/*.java"/>
+ </patternset>
+
+ <patternset id="snow.source.lisp">
+ <include name="snow/**/*.lisp"/>
+ <include name="snow/**/*.asd"/>
+ </patternset>
+
+ <patternset id="snow.objects">
+ <include name="snow/**/*.class"/>
+ <include name="snow/**/*.cls"/>
+ <include name="snow/**/*.abcl"/>
+ <patternset refid="snow.source.lisp"/>
+ </patternset>
+
+ <path id="snow.classpath.dist">
+ <pathelement location="${snow.jar.path}"/>
+ </path>
+
+ <path id="snow.classpath.build">
+ <pathelement location="${build.classes.dir}"/>
+ <fileset dir="${lib.dir}">
+ <include name="**/*.jar"/>
+ </fileset>
+ </path>
+
+ <target name="snow.compile" depends="snow.compile.lisp">
+ <echo>Compiled SNOW with Java version: ${java.version}</echo>
+ </target>
+
+ <target name="snow.init">
+ <tstamp>
+ <format property="build" pattern="EEE MMM dd yyyy HH:mm:ss zzz"/>
+ </tstamp>
+
+ <tstamp>
+ <format property="build.stamp" pattern="yyyymmdd-HHmm"/>
+ </tstamp>
+
+ <property name="snow.test.log.file"
+ value="snow-test-${build.stamp}.log"/>
+
+ <!--- antversion fails in ant 1.7.1 <antversion property="ant.version"
+ atleast="1.7"/> -->
+ <property name="java.path"
+ value="${java.home}/bin/java"/>
+ </target>
+
+ <target name="snow.compile.java"
+ depends="snow.init">
+ <mkdir dir="${build.dir}"/>
+ <mkdir dir="${build.classes.dir}"/>
+ <javac destdir="${build.classes.dir}"
+ classpathref="snow.classpath.build"
+ debug="true"
+ target="1.6"
+ failonerror="true">
+ <src path="${src.dir}/java"/>
+ <patternset refid="snow.source.java"/>
+ </javac>
+ <echo message="${build}"
+ file="${build.classes.dir}/snow/build"/>
+ </target>
+
+ <target name="snow.copy.lisp">
+ <copy todir="${build.classes.dir}" preservelastmodified="yes">
+ <fileset dir="${src.dir}/lisp">
+ <patternset refid="snow.source.lisp"/>
+ </fileset>
+ <fileset dir="${lib.dir}">
+ <patternset>
+ <include name="**/*" />
+ <exclude name="**/*.jar"/>
+ </patternset>
+ </fileset>
+ </copy>
+ </target>
+
+ <target name="snow.compile.lisp"
+ depends="snow.copy.lisp,snow.compile.java">
+ <java classpathref="snow.classpath.build"
+ fork="true"
+ failonerror="true"
+ classname="org.armedbear.lisp.Main"
+ dir="${build.classes.dir}">
+ <arg value="--noinit"/>
+ <arg value="--load"/>
+ <arg value="snow/compile-system.lisp"/>
+ </java>
+ </target>
+
+ <target name="snow.jar.uptodate" depends="snow.compile">
+ <uptodate property="snow.jar.uptodate.p" targetfile="${snow.jar.path}">
+ <srcfiles dir="${build.classes.dir}">
+ <patternset refid="snow.objects"/>
+ </srcfiles>
+ </uptodate>
+ </target>
+
+ <target name="snow.jar" depends="snow.jar.uptodate"
+ unless="snow.jar.uptodate.p">
+ <mkdir dir="${dist.dir}"/>
+ <jar destfile="${snow.jar.path}"
+ compress="true"
+ basedir="${build.classes.dir}">
+ <manifest>
+ <attribute name="Main-Class" value="snow.Snow"/>
+ </manifest>
+ </jar>
+ </target>
+
+ <target name="snow.run" depends="snow.jar">
+ <java fork="true"
+ classpathref="snow.classpath.dist"
+ classname="snow.Snow">
+ </java>
+ </target>
+
+ <target name="snow.clean">
+ <delete dir="${build.dir}"/>
+ <delete file="${snow.jar.path}"/>
+ </target>
+
+ <target name="snow.dist" depends="snow.jar">
+ <copy file="${snow.jar.path}"
+ toFile="${dist.dir}/snow.jar"/>
+ </target>
+
+ <target name="snow.distclean" depends="snow.clean">
+ <delete dir="${dist.dir}"/>
+ </target>
+
+ <patternset id="snow.dist.misc"
+ description="Additional includes in the source distributions relative to basedir">
+ <include name="build.xml"/>
+ <include name="COPYING"/>
+ </patternset>
+
+ <patternset id="snow.source.misc"
+ description="Additional includes in the source distribution relative to source root">
+ </patternset>
+
+ <target name="snow.source.prepare">
+ <property name="snow.source.eol" value="asis"/>
+ <echo>Using snow.source.eol='${snow.source.eol}' to drive
+ source code line-ending transformations.</echo>
+ <property name="snow.build.src.dir"
+ value="${build.dir}/snow-src"/>
+ <mkdir dir="${snow.build.src.dir}/src"/>
+ <fixcrlf srcdir="${src.dir}"
+ eol="${snow.source.eol}"
+ destdir="${snow.build.src.dir}/src"
+ preservelastmodified="true">
+ <patternset refid="snow.source.java"/>
+ <patternset refid="snow.source.lisp"/>
+ <patternset refid="snow.source.misc"/>
+ </fixcrlf>
+ <fixcrlf srcdir="${basedir}"
+ eol="${snow.source.eol}"
+ destdir="${snow.build.src.dir}"
+ preservelastmodified="true">
+ <patternset refid="snow.dist.misc"/>
+ </fixcrlf>
+ </target>
+
+ <target name="snow.source.tar" depends="snow.source.prepare">
+ <mkdir dir="${dist.dir}"/>
+ <tar destfile="${dist.dir}/snow-src.tar.gz"
+ compression="gzip">
+ <tarfileset dir="${build.dir}">
+ <include name="snow-src/**"/>
+ </tarfileset>
+ </tar>
+ </target>
+
+ <target name="snow.source.zip" depends="snow.source.prepare">
+ <mkdir dir="${dist.dir}"/>
+ <zip destfile="${dist.dir}/snow-src.zip"
+ compress="true">
+ <zipfileset dir="${snow.build.src.dir}" prefix="snow-src"/>
+ </zip>
+ </target>
+
+ <import file="netbeans-build.xml" optional="true"/>
+<!-- <import file="j-build.xml" optional="true"/> -->
+ <import file="not.org-build.xml" optional="true"/>
+</project>
+
Added: trunk/changelog
==============================================================================
--- (empty file)
+++ trunk/changelog Wed Sep 30 16:06:52 2009
@@ -0,0 +1,193 @@
+------------------------------------------------------------------------
+r43 | snow | 2009-09-03 23:43:46 +0200 (gio, 03 set 2009) | 4 lines
+
+- Updated documentation
+- Created snow-user package, used by default in gui repl from main()
+- Modified GUI-REPL to accept a dynamic environment
+- Use graphical debugger by default in gui repl
+------------------------------------------------------------------------
+r42 | snow | 2009-09-01 22:10:35 +0200 (mar, 01 set 2009) | 1 line
+
+Fixed build.xml not to include abcl-script-config into the jar - the user might want to configure abcl differently.
+------------------------------------------------------------------------
+r41 | snow | 2009-08-31 22:49:28 +0200 (lun, 31 ago 2009) | 3 lines
+
+- added ant based build (which assembles a jar)
+- snow is now able to load itself from a jar (by first unpacking it in a temporary directory)
+- updated documentation
+------------------------------------------------------------------------
+r40 | snow | 2009-08-24 00:14:55 +0200 (lun, 24 ago 2009) | 1 line
+
+Refactoring: Lisp sources now are in a snow/ subdirectory of src/lisp, this is consistent with how Java code is organized.
+------------------------------------------------------------------------
+r39 | snow | 2009-08-24 00:01:41 +0200 (lun, 24 ago 2009) | 1 line
+
+Added license info. Improved help (faq). Added window close event.
+------------------------------------------------------------------------
+r38 | snow | 2009-08-12 00:55:15 +0200 (mer, 12 ago 2009) | 1 line
+
+Enhanced GUI REPL.
+------------------------------------------------------------------------
+r37 | snow | 2009-08-05 21:43:13 +0200 (mer, 05 ago 2009) | 3 lines
+
+Integrated gui repl
+fixed some bugs
+updated to latest ABCL
+------------------------------------------------------------------------
+r36 | snow | 2009-08-04 23:39:31 +0200 (mar, 04 ago 2009) | 1 line
+
+Improved ConsoleDocument
+------------------------------------------------------------------------
+r35 | snow | 2009-08-04 00:27:47 +0200 (mar, 04 ago 2009) | 1 line
+
+Small improvements to the inspector; added ConsoleDocument to be used with JTextAreas (written in Java).
+------------------------------------------------------------------------
+r34 | snow | 2009-07-30 23:16:56 +0200 (gio, 30 lug 2009) | 1 line
+
+Perfectioned inspector
+------------------------------------------------------------------------
+r33 | snow | 2009-07-29 23:06:56 +0200 (mer, 29 lug 2009) | 1 line
+
+Progress with the inspector; updated to the last abcl.
+------------------------------------------------------------------------
+r32 | snow | 2009-07-28 00:07:54 +0200 (mar, 28 lug 2009) | 2 lines
+
+Implemented tabs widget
+first attempt at a graphical inspector
+------------------------------------------------------------------------
+r31 | snow | 2009-07-24 20:33:40 +0200 (ven, 24 lug 2009) | 1 line
+
+Functional api and interface/implementation separation complete for existing widgets.
+------------------------------------------------------------------------
+r30 | snow | 2009-07-23 23:41:00 +0200 (gio, 23 lug 2009) | 1 line
+
+More functional api (less dependent on macros), proceeded with interface/implementation separation.
+------------------------------------------------------------------------
+r29 | snow | 2009-07-22 23:44:39 +0200 (mer, 22 lug 2009) | 1 line
+
+More functional api (less dependent on macros), proceeded with interface/implementation separation.
+------------------------------------------------------------------------
+r28 | snow | 2009-07-06 23:25:19 +0200 (lun, 06 lug 2009) | 1 line
+
+Started using definterface/defimplementation
+------------------------------------------------------------------------
+r27 | snow | 2009-06-30 22:50:39 +0200 (mar, 30 giu 2009) | 1 line
+
+Interface-implementation thing
+------------------------------------------------------------------------
+r26 | snow | 2009-06-28 23:38:01 +0200 (dom, 28 giu 2009) | 1 line
+
+Refactoring to make it easier to have multiple backends (chosen at compile-time)
+------------------------------------------------------------------------
+r25 | snow | 2009-06-24 21:50:41 +0200 (mer, 24 giu 2009) | 3 lines
+
+Implemented converters for models.
+Updated to latest abcl to fix bugs in properties.
+Debugger correctly working.
+------------------------------------------------------------------------
+r24 | snow | 2009-06-22 23:41:03 +0200 (lun, 22 giu 2009) | 1 line
+
+Basically working graphical debugger.
+------------------------------------------------------------------------
+r23 | snow | 2009-06-19 00:24:44 +0200 (ven, 19 giu 2009) | 1 line
+
+Initial Cells integration working (binding to a cell).
+------------------------------------------------------------------------
+r22 | snow | 2009-06-18 07:19:27 +0200 (gio, 18 giu 2009) | 2 lines
+
+Begun Cells integration attempt.
+Minor fixes and improvements.
+------------------------------------------------------------------------
+r21 | snow | 2009-05-24 23:27:47 +0200 (dom, 24 mag 2009) | 5 lines
+
+Updated abcl to latest from svn
+Begun graphical debugger
+*widget* special var replaced by self lexical var
+*parent-widget* replaced by *parent* (should ideally be global lexical)
+ConsListModel calls javaInstance() on model objects.
+------------------------------------------------------------------------
+r20 | snow | 2009-05-22 22:59:17 +0200 (ven, 22 mag 2009) | 1 line
+
+Added support for the "enabled" property.
+------------------------------------------------------------------------
+r19 | snow | 2009-05-20 07:44:25 +0200 (mer, 20 mag 2009) | 1 line
+
+minor refactoring
+------------------------------------------------------------------------
+r18 | snow | 2009-05-13 22:48:33 +0200 (mer, 13 mag 2009) | 3 lines
+
+Snow is now loadable with ASDF (and the Snow Java class loads it that way).
+Fixed some things wrt compilation.
+Updated abcl.jar to latest svn head (which fixes compilation issues in JSR-223).
+------------------------------------------------------------------------
+r17 | snow | 2009-05-12 20:35:29 +0200 (mar, 12 mag 2009) | 1 line
+
+Refactored code organization: separated java and lisp in src/java and src/lisp (flat without subdirectories)
+------------------------------------------------------------------------
+r16 | snow | 2009-05-12 20:26:41 +0200 (mar, 12 mag 2009) | 5 lines
+
+Created packages.lisp and used snow package everywhere
+Deleted snowlets (unnecessary complication)
+Created faq
+minor fixes and refactoring
+
+------------------------------------------------------------------------
+r15 | snow | 2009-05-06 23:55:22 +0200 (mer, 06 mag 2009) | 1 line
+
+Created docs directory and preliminary version of the FAQ.
+------------------------------------------------------------------------
+r14 | snow | 2009-05-06 00:00:11 +0200 (mer, 06 mag 2009) | 1 line
+
+Little enhancements to the basic DSL
+------------------------------------------------------------------------
+r13 | snow | 2009-05-04 21:08:23 +0200 (lun, 04 mag 2009) | 3 lines
+
+Reintegrated list and tree widgets.
+Deleted unused syntax.lisp.
+Refactored binding and added support for "simple" binding i.e. plain ValueHolder (with a little Lisp-side support).
+------------------------------------------------------------------------
+r12 | snow | 2009-04-29 23:41:24 +0200 (mer, 29 apr 2009) | 1 line
+
+Rationalized widget macros
+------------------------------------------------------------------------
+r11 | snow | 2009-04-28 22:54:12 +0200 (mar, 28 apr 2009) | 1 line
+
+Restored most of the previous functionality. Updated abcl to latest from svn.
+------------------------------------------------------------------------
+r10 | snow | 2009-04-27 22:56:45 +0200 (lun, 27 apr 2009) | 1 line
+
+Reintegrated JGoodies binding
+------------------------------------------------------------------------
+r9 | snow | 2009-04-22 22:40:35 +0200 (mer, 22 apr 2009) | 1 line
+
+Changed signature of define-widget-macro
+------------------------------------------------------------------------
+r8 | snow | 2009-04-21 23:58:25 +0200 (mar, 21 apr 2009) | 1 line
+
+Improved widget property setter
+------------------------------------------------------------------------
+r7 | snow | 2009-04-15 21:55:57 +0200 (mer, 15 apr 2009) | 1 line
+
+Beginning DSL implementation change.
+------------------------------------------------------------------------
+r6 | snow | 2009-03-31 23:08:39 +0200 (mar, 31 mar 2009) | 1 line
+
+
+------------------------------------------------------------------------
+r5 | snow | 2009-02-12 22:41:51 +0100 (gio, 12 feb 2009) | 1 line
+
+Refactoring, dead files removed
+------------------------------------------------------------------------
+r4 | snow | 2009-02-12 22:21:49 +0100 (gio, 12 feb 2009) | 1 line
+
+Refactoring, dead files removed
+------------------------------------------------------------------------
+r3 | snow | 2009-02-10 22:53:26 +0100 (mar, 10 feb 2009) | 1 line
+
+Initial Import
+------------------------------------------------------------------------
+r1 | snow | 2009-02-10 22:35:56 +0100 (mar, 10 feb 2009) | 2 lines
+
+trunk created
+
+------------------------------------------------------------------------
Added: trunk/copying
==============================================================================
--- (empty file)
+++ trunk/copying Wed Sep 30 16:06:52 2009
@@ -0,0 +1,351 @@
+The software in this package is distributed under the GNU General Public
+License (with a special exception described below as 13th term).
+
+ GNU GENERAL PUBLIC LICENSE
+ Version 2, June 1991
+
+ Copyright (C) 1989, 1991 Free Software Foundation, Inc.
+ 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+ Everyone is permitted to copy and distribute verbatim copies
+ of this license document, but changing it is not allowed.
+
+ Preamble
+
+ The licenses for most software are designed to take away your
+freedom to share and change it. By contrast, the GNU General Public
+License is intended to guarantee your freedom to share and change free
+software--to make sure the software is free for all its users. This
+General Public License applies to most of the Free Software
+Foundation's software and to any other program whose authors commit to
+using it. (Some other Free Software Foundation software is covered by
+the GNU Library General Public License instead.) You can apply it to
+your programs, too.
+
+ When we speak of free software, we are referring to freedom, not
+price. Our General Public Licenses are designed to make sure that you
+have the freedom to distribute copies of free software (and charge for
+this service if you wish), that you receive source code or can get it
+if you want it, that you can change the software or use pieces of it
+in new free programs; and that you know you can do these things.
+
+ To protect your rights, we need to make restrictions that forbid
+anyone to deny you these rights or to ask you to surrender the rights.
+These restrictions translate to certain responsibilities for you if you
+distribute copies of the software, or if you modify it.
+
+ For example, if you distribute copies of such a program, whether
+gratis or for a fee, you must give the recipients all the rights that
+you have. You must make sure that they, too, receive or can get the
+source code. And you must show them these terms so they know their
+rights.
+
+ We protect your rights with two steps: (1) copyright the software, and
+(2) offer you this license which gives you legal permission to copy,
+distribute and/or modify the software.
+
+ Also, for each author's protection and ours, we want to make certain
+that everyone understands that there is no warranty for this free
+software. If the software is modified by someone else and passed on, we
+want its recipients to know that what they have is not the original, so
+that any problems introduced by others will not reflect on the original
+authors' reputations.
+
+ Finally, any free program is threatened constantly by software
+patents. We wish to avoid the danger that redistributors of a free
+program will individually obtain patent licenses, in effect making the
+program proprietary. To prevent this, we have made it clear that any
+patent must be licensed for everyone's free use or not licensed at all.
+
+ The precise terms and conditions for copying, distribution and
+modification follow.
+
+ GNU GENERAL PUBLIC LICENSE
+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
+
+ 0. This License applies to any program or other work which contains
+a notice placed by the copyright holder saying it may be distributed
+under the terms of this General Public License. The "Program", below,
+refers to any such program or work, and a "work based on the Program"
+means either the Program or any derivative work under copyright law:
+that is to say, a work containing the Program or a portion of it,
+either verbatim or with modifications and/or translated into another
+language. (Hereinafter, translation is included without limitation in
+the term "modification".) Each licensee is addressed as "you".
+
+Activities other than copying, distribution and modification are not
+covered by this License; they are outside its scope. The act of
+running the Program is not restricted, and the output from the Program
+is covered only if its contents constitute a work based on the
+Program (independent of having been made by running the Program).
+Whether that is true depends on what the Program does.
+
+ 1. You may copy and distribute verbatim copies of the Program's
+source code as you receive it, in any medium, provided that you
+conspicuously and appropriately publish on each copy an appropriate
+copyright notice and disclaimer of warranty; keep intact all the
+notices that refer to this License and to the absence of any warranty;
+and give any other recipients of the Program a copy of this License
+along with the Program.
+
+You may charge a fee for the physical act of transferring a copy, and
+you may at your option offer warranty protection in exchange for a fee.
+
+ 2. You may modify your copy or copies of the Program or any portion
+of it, thus forming a work based on the Program, and copy and
+distribute such modifications or work under the terms of Section 1
+above, provided that you also meet all of these conditions:
+
+ a) You must cause the modified files to carry prominent notices
+ stating that you changed the files and the date of any change.
+
+ b) You must cause any work that you distribute or publish, that in
+ whole or in part contains or is derived from the Program or any
+ part thereof, to be licensed as a whole at no charge to all third
+ parties under the terms of this License.
+
+ c) If the modified program normally reads commands interactively
+ when run, you must cause it, when started running for such
+ interactive use in the most ordinary way, to print or display an
+ announcement including an appropriate copyright notice and a
+ notice that there is no warranty (or else, saying that you provide
+ a warranty) and that users may redistribute the program under
+ these conditions, and telling the user how to view a copy of this
+ License. (Exception: if the Program itself is interactive but
+ does not normally print such an announcement, your work based on
+ the Program is not required to print an announcement.)
+
+These requirements apply to the modified work as a whole. If
+identifiable sections of that work are not derived from the Program,
+and can be reasonably considered independent and separate works in
+themselves, then this License, and its terms, do not apply to those
+sections when you distribute them as separate works. But when you
+distribute the same sections as part of a whole which is a work based
+on the Program, the distribution of the whole must be on the terms of
+this License, whose permissions for other licensees extend to the
+entire whole, and thus to each and every part regardless of who wrote it.
+
+Thus, it is not the intent of this section to claim rights or contest
+your rights to work written entirely by you; rather, the intent is to
+exercise the right to control the distribution of derivative or
+collective works based on the Program.
+
+In addition, mere aggregation of another work not based on the Program
+with the Program (or with a work based on the Program) on a volume of
+a storage or distribution medium does not bring the other work under
+the scope of this License.
+
+ 3. You may copy and distribute the Program (or a work based on it,
+under Section 2) in object code or executable form under the terms of
+Sections 1 and 2 above provided that you also do one of the following:
+
+ a) Accompany it with the complete corresponding machine-readable
+ source code, which must be distributed under the terms of Sections
+ 1 and 2 above on a medium customarily used for software interchange; or,
+
+ b) Accompany it with a written offer, valid for at least three
+ years, to give any third party, for a charge no more than your
+ cost of physically performing source distribution, a complete
+ machine-readable copy of the corresponding source code, to be
+ distributed under the terms of Sections 1 and 2 above on a medium
+ customarily used for software interchange; or,
+
+ c) Accompany it with the information you received as to the offer
+ to distribute corresponding source code. (This alternative is
+ allowed only for noncommercial distribution and only if you
+ received the program in object code or executable form with such
+ an offer, in accord with Subsection b above.)
+
+The source code for a work means the preferred form of the work for
+making modifications to it. For an executable work, complete source
+code means all the source code for all modules it contains, plus any
+associated interface definition files, plus the scripts used to
+control compilation and installation of the executable. However, as a
+special exception, the source code distributed need not include
+anything that is normally distributed (in either source or binary
+form) with the major components (compiler, kernel, and so on) of the
+operating system on which the executable runs, unless that component
+itself accompanies the executable.
+
+If distribution of executable or object code is made by offering
+access to copy from a designated place, then offering equivalent
+access to copy the source code from the same place counts as
+distribution of the source code, even though third parties are not
+compelled to copy the source along with the object code.
+
+ 4. You may not copy, modify, sublicense, or distribute the Program
+except as expressly provided under this License. Any attempt
+otherwise to copy, modify, sublicense or distribute the Program is
+void, and will automatically terminate your rights under this License.
+However, parties who have received copies, or rights, from you under
+this License will not have their licenses terminated so long as such
+parties remain in full compliance.
+
+ 5. You are not required to accept this License, since you have not
+signed it. However, nothing else grants you permission to modify or
+distribute the Program or its derivative works. These actions are
+prohibited by law if you do not accept this License. Therefore, by
+modifying or distributing the Program (or any work based on the
+Program), you indicate your acceptance of this License to do so, and
+all its terms and conditions for copying, distributing or modifying
+the Program or works based on it.
+
+ 6. Each time you redistribute the Program (or any work based on the
+Program), the recipient automatically receives a license from the
+original licensor to copy, distribute or modify the Program subject to
+these terms and conditions. You may not impose any further
+restrictions on the recipients' exercise of the rights granted herein.
+You are not responsible for enforcing compliance by third parties to
+this License.
+
+ 7. If, as a consequence of a court judgment or allegation of patent
+infringement or for any other reason (not limited to patent issues),
+conditions are imposed on you (whether by court order, agreement or
+otherwise) that contradict the conditions of this License, they do not
+excuse you from the conditions of this License. If you cannot
+distribute so as to satisfy simultaneously your obligations under this
+License and any other pertinent obligations, then as a consequence you
+may not distribute the Program at all. For example, if a patent
+license would not permit royalty-free redistribution of the Program by
+all those who receive copies directly or indirectly through you, then
+the only way you could satisfy both it and this License would be to
+refrain entirely from distribution of the Program.
+
+If any portion of this section is held invalid or unenforceable under
+any particular circumstance, the balance of the section is intended to
+apply and the section as a whole is intended to apply in other
+circumstances.
+
+It is not the purpose of this section to induce you to infringe any
+patents or other property right claims or to contest validity of any
+such claims; this section has the sole purpose of protecting the
+integrity of the free software distribution system, which is
+implemented by public license practices. Many people have made
+generous contributions to the wide range of software distributed
+through that system in reliance on consistent application of that
+system; it is up to the author/donor to decide if he or she is willing
+to distribute software through any other system and a licensee cannot
+impose that choice.
+
+This section is intended to make thoroughly clear what is believed to
+be a consequence of the rest of this License.
+
+ 8. If the distribution and/or use of the Program is restricted in
+certain countries either by patents or by copyrighted interfaces, the
+original copyright holder who places the Program under this License
+may add an explicit geographical distribution limitation excluding
+those countries, so that distribution is permitted only in or among
+countries not thus excluded. In such case, this License incorporates
+the limitation as if written in the body of this License.
+
+ 9. The Free Software Foundation may publish revised and/or new versions
+of the General Public License from time to time. Such new versions will
+be similar in spirit to the present version, but may differ in detail to
+address new problems or concerns.
+
+Each version is given a distinguishing version number. If the Program
+specifies a version number of this License which applies to it and "any
+later version", you have the option of following the terms and conditions
+either of that version or of any later version published by the Free
+Software Foundation. If the Program does not specify a version number of
+this License, you may choose any version ever published by the Free Software
+Foundation.
+
+ 10. If you wish to incorporate parts of the Program into other free
+programs whose distribution conditions are different, write to the author
+to ask for permission. For software which is copyrighted by the Free
+Software Foundation, write to the Free Software Foundation; we sometimes
+make exceptions for this. Our decision will be guided by the two goals
+of preserving the free status of all derivatives of our free software and
+of promoting the sharing and reuse of software generally.
+
+ NO WARRANTY
+
+ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
+REPAIR OR CORRECTION.
+
+ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
+POSSIBILITY OF SUCH DAMAGES.
+
+ 13. Linking this library statically or dynamically with other modules is making a combined work based on this library. Thus, the terms and conditions of the GNU General Public License cover the whole combination.
+
+As a special exception, the copyright holders of this software give you
+permission to link this software 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 software. If you modify this
+software, you may extend this exception to your version of the software, but
+you are not obligated to do so. If you do not wish to do so, delete this
+exception statement from your version.
+
+
+ END OF TERMS AND CONDITIONS
+
+ How to Apply These Terms to Your New Programs
+
+ If you develop a new program, and you want it to be of the greatest
+possible use to the public, the best way to achieve this is to make it
+free software which everyone can redistribute and change under these terms.
+
+ To do so, attach the following notices to the program. It is safest
+to attach them to the start of each source file to most effectively
+convey the exclusion of warranty; and each file should have at least
+the "copyright" line and a pointer to where the full notice is found.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) 19yy <name of author>
+
+ 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
+
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) 19yy name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
Added: trunk/docs/faq.html
==============================================================================
--- (empty file)
+++ trunk/docs/faq.html Wed Sep 30 16:06:52 2009
@@ -0,0 +1,111 @@
+<html>
+<head>
+<title>Snow FAQ - Fictionally Asked Questions</title>
+<link rel="stylesheet" type="text/css" href="style.css">
+</head>
+<body>
+<h1>Snow FAQ - Fictionally Asked Questions</h1>
+<h3>That is, questions I'd like to be asked. Snow has too few users for "Frequently" to mean something relevant ;-)</h3>
+<ol>
+ <li><a href="#general">General questions about Snow</a>
+ <ol>
+ <li><a href="#ch001">So, what is Snow?</a></li>
+ <li><a href="#ch002">Which technologies is Snow built upon?</a></li>
+ <li><a href="#ch007">Who is Snow targeted at?</a></li>
+ <li><a href="#ch008">Am I really forced to use Swing if I use Snow? What about SWT or other GUI libraries?</a></li>
+ <li><a href="#status">What is the current status of Snow? How much of Swing is covered?</a></li>
+ <li><a href="#license">Which license is Snow distributed under?</a></li>
+ </ol>
+ </li>
+ <li><a href="#java">Questions for Java programmers</a>
+ <ol>
+ <li><a href="#ch003">Common Lisp? What the heck is that?</a></li>
+ <li><a href="#ch004">Uhm, and what does Snow code look like?</a></li>
+ <li><a href="#ch005">Whoa! Why all those ugly parentheses?</a></li>
+ <li><a href="#ch006">Then why not use XML like everyone else?</a></li>
+ </ol>
+ </li>
+ <li><a href="#lisp">Questions for Lisp programmers</a>
+ <ol>
+ <li><a href="#otherlispguis">How does Snow compare to other mature Common Lisp GUI toolkits, like LTK or Cells-GTK?</a></li>
+ </ol>
+ </li>
+ <li><a href="#use">Installing and using Snow</a>
+ <ol>
+ <li><a href="#ch009">Ok, Snow is great! Now, how do I use it in my application?</a></li>
+ </ol>
+ </li>
+</ol>
+<a name="general" /><h2>General questions about Snow</h2>
+<a name="ch001" /><h3>So, what is Snow?</h3>
+Snow is a declarative language (DSL) targeted to build graphical user interfaces based on the Java Swing GUI library.
+It is somewhat similar in spirit to <a href="http://www.mozilla.org/projects/xul/">XUL</a> or <a href="http://www.swixml.org/">SwiX<sup>ml</sup></a>, while adopting a unique approach which has many advantages over XML + scripting languages. Snow is a fully interactive language - you can prototype your GUI at the read-eval-print loop and see the results immediately, without a lengthy batch compilation phase.
+<a name="ch002" /><h3>Which technologies is Snow built upon?</h3>
+Snow is written in a combination of <a href="http://java.sun.com/">Java</a> and Common Lisp (particularly its implementation
+<a href="http://common-lisp.net/project/armedbear/">ABCL</a>, which runs on the JVM). It uses <a href="http://www.miglayout.com/">MiG Layout</a>
+for declarative, CSS-like component layout, <a href="https://binding.dev.java.net/">JGoodies Binding</a> for data binding (communication between the GUI and the application code) to Java objects, and a slightly modified version of Ken Tilton's Cells library to do the same thing (and more) with Lisp.<br />
+Snow can be thought of as a GUI extension for ABCL, and indeed it provides the GUI counterparts of some of ABCL's facilities - the REPL, a minimal debugger, and the inspector - although the main objective of Snow is to be a GUI library, and these add-ons exist more as examples of what Snow can do.
+<a name="ch007" /><h3>Who is Snow targeted at?</h3>
+Snow is meant to be useful both to Lisp developers looking for an easy, cross-platform GUI solution, and Java developers in search of an easier way to write Swing code without sacrificing too much flexibility, as it is often the case with GUI editors. It can be used in a Lisp application without writing
+any Java, and it can be used in a Java application writing only a minimal amount of Lisp code (that is, the GUI code itself and little
+or no else). Of course, writing in a mix of the two languages might be necessary if you want to do something advanced, like writing
+your custom components in Java and integrating them with Snow. This practice is likely to be less frequent than when you write Swing code in Java, because Snow makes it easier to use aggregation rather than inheritance for component creation. Still, you may need to, e.g., use third-party components, or override some method in your custom component - in this case you need to write a little Lisp glue code to make Snow aware of your components.
+<a name="ch008" /><h3>Am I really forced to use Swing if I use Snow? What about SWT or other Java GUI libraries?</h3>
+While Snow's API follow quite closely those of Swing (in terms of names of components, properties, layouts, ...), some care has been taken to make it possible to plug in other GUI backends. No other backend besides the Swing one currently exists, and the author has not enough time and expertise in SWT to create an SWT one, but it should be quite possible in principle, with the necessary adaptations.
+<a name="status" /><h3>What is the current status of Snow? How much of Swing is covered?</h3>
+I consider Snow's core to be quite stable, although young. Coverage of Swing is poor, only a bunch of components are supported, and even those only have few properties mapped. This means Snow at this stage is too incomplete to be used in production; it can only showcase the basic ideas behind it. However, I'm slowly working on adding more components: if you're interested in one in particular, drop me a line, I'll be happy to prioritize work on it.
+<a name="license" /><h3>Which license is Snow distributed under?</h3>
+The same license as ABCL and GNU Classpath, that is, GNU GPL + the classpath exception. Basically this means you can link your code to Snow without having to release it under the GPL. The GPL still applies to modifications to Snow itself.
+<a name="java" /><h2>Questions for Java programmers</h2>
+The following questions are more likely to interest Java programmers. You may skip them if you aren't interested in Java, and/or you already know Lisp.
+<a name="ch003" /><h3>Common Lisp? What the heck is that?</h3>
+The ANSI standard Common Lisp is a language in the Lisp family, one of the oldest families of programming languages still in use.
+It is a multi-paradigm, dynamic language with very regular syntax and advanced features that make it great for prototyping and exploration of new ideas, yet solid and fast enough to build big systems. Common Lisp
+can be both interpreted and compiled. Thanks to the work of Peter Graves and the people who took care of developing ABCL after Peter stopped working on it, Common Lisp is today one of the languages that can run on the Java Virtual Machine.
+<a name="ch004" /><h3>Uhm, and what does Snow code look like?</h3>
+Here is an example:<br />
+<pre class="paste-area">
+(frame (<span class="lisp-keyword">:title</span> <span class="lisp-string">"Snow Example"</span> <span class="lisp-keyword">:visible-p</span> t)
+ (panel (<span class="lisp-keyword">:layout</span> <span class="lisp-string">"wrap"</span>)
+ (button <span class="lisp-keyword">:text</span> <span class="lisp-string">"Hello, world!"</span>
+ <span class="lisp-keyword">:on-action</span> (<span class="lisp-special-op">lambda</span> (event)
+ (<span class="lisp-cl-function">print</span> <span class="lisp-string">"Hello, world!"</span>)))))
+</pre>
+<a name="ch005"/><h3>Whoa! Why all those ugly parentheses?</h3>
+That's Lisp, baby! If it looks alien, you can just pretend it's XML in disguise: imagine the example above like
+<pre class="paste-area">
+<frame <span class="lisp-keyword">title</span>=<span class="lisp-string">"Snow Example"</span> <span class="lisp-keyword">visible</span>=<span class="lisp-string">"true"</span>>
+ <panel <span class="lisp-keyword">layout</span>=<span class="lisp-string">"wrap"</span>>
+ <button <span class="lisp-keyword">text</span>=<span class="lisp-string">"Hello, world!"</span>
+ <span class="lisp-keyword">on-action</span>=<span class="lisp-string">"function(event) { print('Hello, world!'); }"</span> />
+ </panel>
+</frame>
+</pre>
+<a name="ch006" /><h3>Then why not use XML like everyone else?</h3>
+While Snow (and to some extent Lisp) is structurally similar to XML due to its tree-based form,
+the similarity ends here.<br />
+XML is a markup language meant to describe documents or structured data. It *can* be perverted enough to use it as the syntax of
+a programming language (see <a href="http://www.xsharp.org/">X#</a>), but the results are not exactly pretty (in this FAQ author's
+humble opinion).<br />
+Lisp, on the other hand, has been a full programming language from day one. See how in the fictional XML translation of Snow above a pseudo-JavaScript in an XML attribute was used to define an action, while in the original example an anonymous Lisp function was used - which is not a string to be fed to some external interpreter, but real Lisp code, which can e.g. be factored out in a function, compiled, easily tested in isolation and so on.<br />
+Consider also that you can mix "regular" Lisp code with Snow with no problems, thus getting much more dynamicity in building your GUI:
+<pre class="paste-area">
+(label <span class="lisp-keyword">:text</span> (if (some-condition-holds) <span class="lisp-string">"Yes!"</span> <span class="lisp-string">"No!"</span>))
+
+(list-widget <span class="lisp-keyword">:model</span> (make-list-model (generate-my-list-model-at-runtime)))
+
+(<span class="lisp-cl-macro">dotimes</span> (i 42) <span class="lisp-comment">;creates 42 labels with the text "Label No. n".</span>
+ (label <span class="lisp-keyword">:text</span> (str <span class="lisp-string">"Label No. "</span> i)))
+</pre>
+and so on. You can't do that with XML unless you have a mechanism like e.g. JSP taglibs, and even that is not as easy and powerful.
+Furthermore, Lisp supports and encourages interactive programming: you can try and test your code while you write it, without
+recompiling, restarting, or redeploying anything.
+<a name="lisp" /><h2>Questions for Lisp programmers</h2>
+The following questions are more likely to interest Lisp programmers. You may skip them if you're only interested in Java.
+<a name="otherlispguis" /><h3>How does Snow compare to other mature Common Lisp GUI toolkits, like LTK or Cells-GTK?</h3>
+Snow is much younger, and much more incomplete, than most other GUI toolkits available in Common Lisp. At this stage, I'd suggest that you use Snow only if you need a CL GUI app that closely interoperates with Java, or if you need your GUI to run on all the platforms the JVM runs on and you can't use a CL implementation (besides ABCL) that runs on all those platforms. That said, Snow already supports Cells (although it needs a modified version - distributed together with it - that can run on ABCL).
+<a name="use" /><h2>Installing and using Snow</h2>
+<a name="ch009" /><h3>Ok, Snow is great! Now, how do I use it in my application?</h3>
+Refer to the <a href="tutorial.html">tutorial</a> for installation instructions and a brief explanation of Snow.
+</body>
+</html>
Added: trunk/docs/images/oh-no.png
==============================================================================
Binary file. No diff available.
Added: trunk/docs/style.css
==============================================================================
--- (empty file)
+++ trunk/docs/style.css Wed Sep 30 16:06:52 2009
@@ -0,0 +1,40 @@
+pre.paste-area {
+ /* Taken from paste.lisp.org */
+ background-color:#F4F4F4;
+ border:2px solid #AAAAAA;
+ padding:4px;
+ white-space:pre-wrap !important;
+}
+
+.lisp-keyword { color: #770000; }
+
+.lisp-string { color: #777777; }
+
+.lisp-special-op {
+ background-color:transparent;
+ border:0 none;
+ color:#770055;
+ margin:0;
+ font-style: italic;
+}
+
+.lisp-cl-macro {
+ background-color:transparent;
+ border:0 none;
+ color:#770055;
+ margin:0;
+ font-style: italic;
+}
+
+.lisp-cl-function {
+ background-color:transparent;
+ border:0 none;
+ color:#229955;
+ margin:0;
+ text-decoration:none;
+}
+
+.lisp-comment {
+ background-color:inherit;
+ color:#007777;
+}
\ No newline at end of file
Added: trunk/docs/tutorial.html
==============================================================================
--- (empty file)
+++ trunk/docs/tutorial.html Wed Sep 30 16:06:52 2009
@@ -0,0 +1,170 @@
+<html>
+<head>
+<title>Snow Tutorial</title>
+<link rel="stylesheet" type="text/css" href="style.css">
+</head>
+<body>
+<h1>Snow Tutorial</h1>
+<ol>
+ <li><a href="#ch001">Getting and Installing Snow</a></li>
+ <li><a href="#terminology">Terminology</a></li>
+ <li><a href="#repl">The Snow REPL</a></li>
+ <li><a href="#basic-concepts">Basic Concepts</a></li>
+ <li><a href="#layout">Layout</a></li>
+ <li><a href="#events">Event handling</a></li>
+ <li><a href="#embedding">Embedding Snow</a></li>
+ <li><a href="#more">What's more?</a></li>
+</ol>
+<a name="ch001" /><h3>Getting and Installing Snow</h3>
+You can download the latest Snow binary distribution from <a href="http://alessiostalla.altervista.org/software/snow/index.php">http://alessiostalla.altervista.org/software/snow/index.php</a>. It contains Snow and all its dependencies in a single Zip file. Since Snow can be used both in Lisp and Java applications, procedures for installing it can vary in each of the two cases.
+<ul>
+ <li><h4>Java applications:</h4>simply make sure snow.jar and all the jars in the lib/ folder are in the classpath of your application. Snow uses JSR-223 and is built with Java 1.6, so that's the minimum Java version you can use. However, it should be possible to run Snow on 1.5 as well, but you'll need to recompile both Snow and ABCL from sources with a JSR-223 implementation in your classpath. See the <a href="#embedding">Embedding Snow</a> section below for details about using Snow inside your Java application.</li>
+ <li><h4>Lisp applications:</h4>
+ <ul>
+ <li>Snow come prepackaged with ABCL 0.16, and it wraps the ABCL launcher with its own, that makes sure to load Snow prior to your application. So you can just follow the procedure for Java applications above, and use the snow.Snow class in place of org.armedbear.lisp.Main as the main Java class to launch, e.g. via a shell script. The only difference is that, when launched with no command-line switches, Snow will pop up a GUI repl. You can pass a dummy --no-gui-repl switch to inhibit that. If you are new to Java, the classpath is a list of search places that the JVM uses to resolve classes (think asdf:*central-registry* if you will). It can be set with the environment variable CLASSPATH or with the -classpath command line switch to the java bytecode interpreter (the 'java' command). It is a list of directories and/or .jar files, separated by a platform-dependent character (':' on Linux, ';' on Windows, I don't know about Macs). So for example, you can launch Snow on Linux with '<code>java -classpath snow.jar:lib/abcl.jar:lib/binding-2.0.6.jar:lib/commons-logging.jar:lib/miglayout-3.6.2.jar snow.Snow</code>'.</li>
+ <li>Also, Snow has its own version of Cells built in. It is a random, but fairly recent version from CVS, with some fixes to make it run on ABCL. I'm looking forward to having those fixes merged with trunk, so you'll be able to freely update Cells independently.</li>
+ <li>Last but not least, Snow is built with ASDF, so if you are brave enough you can extract the contents of snow.jar (it is a regular zip file), it will create a directory tree full of .lisp source files, fasls and compiled Java classes (.class files). You will then be able to load Snow with ASDF using your own version of ABCL and/or Cells, provided you still meet the requirements about the classpath for Java applications. (there are two .asd files, one in snow/ and one in snow/swing).</li>
+ </ul>
+ </li>
+</ul>
+Currently Snow, when run from the jar, requires a temporary directory to load itself; make sure your application has write permissions on your OS's tmp directory. Snow should automatically clear its temporary files when the application exits.
+<a name="terminology" /><h3>Terminology</h3>
+The boring part :) you can skip this if you know Lisp, since I'm going to loosely define some terms Snow borrows from Lisp that will be used in this tutorial.
+<ul>
+ <li><dd><strong>car</strong></dd><dt>the first element of a list.</dt></li>
+ <li><dd><strong>cdr</strong></dd><dt>the rest of a list (all elements except the first).</dt></li>
+ <li><dd><strong>nil</strong></dd><dt>the empty list, and the only boolean false value.</dt></li>
+ <li><dd><strong>t</strong></dd><dt>a self-evaluating symbol representing the canonical boolean true value (among other things).</dt></li>
+ <li><dd><strong>form</strong></dd><dt>an expression to be evaluated or compiled.</dt></li>
+ <li><dd><strong>keyword</strong></dd><dt>a self-evaluating symbol starting with a colon (like <code>:title</code>). More correctly, a symbol in the KEYWORD package.</dt></li>
+</ul>
+<a name="repl" /><h3>The Snow REPL</h3>
+Being based on Lisp, Snow offers a REPL (read-eval-print-loop), an interactive prompt that allows you to evaluate arbitrary pieces of code. If you launch Snow through its main class (snow.Snow) with no command-line arguments, it will show a window containing the REPL (which is nothing more than a wrapped ABCL REPL). It should print
+<br /><br />
+<code>SNOW-USER(1): </code>
+<br /><br />
+SNOW-USER is the active package (namespace), (1) is the line number of the REPL. Now, the obligatory hello world:
+<pre class="paste-area">
+(frame (<span class="lisp-keyword">:title</span> <span class="lisp-string">"Snow Example"</span>)
+ (button <span class="lisp-keyword">:text</span> <span class="lisp-string">"Hello, world!"</span>
+ <span class="lisp-keyword">:on-action</span> (<span class="lisp-special-op">lambda</span> (event)
+ (<span class="lisp-cl-function">print</span> <span class="lisp-string">"Hello, world!"</span>)))
+ (pack self)
+ (show self))
+</pre>
+Evaluating this will show a window containing a single button which, when pressed, will output "Hello, world!". The terminology should be familiar to Swing developers. Actually, the output from the button will NOT go to the REPL, but to the OS console instead; I'll explain this later, please ignore it for now. <br />
+The REPL is great for experimenting: the code you input is immediately executed by an interpreter. You can also compile your code, either on the fly in the REPL or from a file; this is outside the scope of this tutorial, but you can find more information in any decent tutorial or book about Common Lisp (I suggest the free ebook Practical Common Lisp by Peter Seibel, available at <a href="http://gigamonkeys.com/book/">http://gigamonkeys.com/book/</a>). However, experiments sometimes go wrong; if you make a mistake - for example, evaluating an unexisting function - you will end in the debugger. Try typing the function call
+<pre class="paste-area">
+(oh-no!)
+</pre>
+- you should see something like this:
+<br /><br />
+<img src="images/oh-no.png" alt="Debugger window"/>
+<br /><br />
+The <i>restarts</i> are the actions the system can perform to recover the situation; this is an important feature of Common Lisp, worth studying by itself. You'll always be able to choose the TOP-LEVEL restart, which will bring you back to the REPL.<br />
+You can quit the REPL (and terminate the application) any time by closing the REPL window, or by typing (quit)<sup><a href="#notes_1">1</a></sup>.
+<a name="basic-concepts" /><h3>Basic Concepts</h3>
+As you can see from the previous examples, Snow code consists of a tree of widgets; nesting in the code means nesting in the widget hierarchy, for example:
+<pre class="paste-area">
+(frame (:visible-p t)
+ (panel (:layout "wrap")
+ (label <span class="lisp-keyword">:text</span> <span class="lisp-string">"1"</span>)
+ (label <span class="lisp-keyword">:text</span> <span class="lisp-string">"2"</span>)
+ (label <span class="lisp-keyword">:text</span> <span class="lisp-string">"3"</span>))
+ (panel ()
+ (label <span class="lisp-keyword">:text</span> <span class="lisp-string">"4"</span>)
+ (label <span class="lisp-keyword">:text</span> <span class="lisp-string">"5"</span>)
+ (label <span class="lisp-keyword">:text</span> <span class="lisp-string">"6"</span>))
+ (pack self))
+</pre>
+Creates a frame with two children, both panels with 3 children each - one has labels from 1 to 3, the other from 4 to 6.<br />
+You can set the <i>properties</i> of the widgets using keyword-value pairs like <code>:visible-p t</code> which means <code>setVisible(true)</code> (-p is a suffix traditionally used in Lisp to name predicates, T is the canonical true value). Containers must have their properties set in a list after the widget name -
+<pre class="paste-area">(panel (<i>...here go the properties...</i>) ...here goes the body...)</pre>
+ - the list serves to separate them from the body. Non-containers have no body and thus their properties do not require to be wrapped in a list: <pre class="paste-area">(label <i>...here go the properties...</i>)</pre>
+<h4>How does this work?</h4>
+The Snow API consists of a set of macros that can be used to declaratively construct a tree of widgets. These macros are designed in such a way to make the tree structure of Lisp source code closely mirror the GUI widget tree structure (in the general case). The macros expand to code that uses a functional interface to create widgets, however it is not recommended to use this functional API directly since it depends on the context established by the macros.
+
+The aspects of such context of interest to the user are:
+
+<h4>lexical variable <code>self</code></h4>
+
+Holds the current widget being processed. Example:
+<pre class="paste-area">
+(frame ()
+ (print self))
+</pre>
+will output something like:
+<pre class="paste-area">
+#<javax.swing.JFrame ...frame.toString()... {identityHashCode}>
+</pre>
+<h4>special variable <code>*parent*</code></h4>
+Holds the current parent widget. When *parent* is non-nil, any widget created through a macro will be automatically added to the container referenced by *parent*. All Snow widget macros process the forms in their body in the following way:
+<ul>
+ <li>if the form is a list, its car is a symbol, and this symbol has a property named widget-p, then the form is wrapped in a <code>(let ((*parent* self)) ...)</code> i.e., it is evaluated in a dynamic context where the parent is the widget created by the macro.</li>
+ <li>else, the form is wrapped in a <code>(let ((*parent* nil)) ...)</code>, i.e., it is evaluated in a dynamic context where no parent widget is defined (and thus widgets created by the form are not added to any widget).</li>
+</ul>
+
+These rules make the nesting of Snow widget macros work in an intuitive way:
+<ul>
+ <li>a widget defined at the top level in the body of another (container) widget w will be added to w. Example: <code>(frame () (panel ()))</code> will result in a frame with a panel child.</li>
+ <li>widgets appearing in code in the body of another widgets, but not at top level, will not be added. Example: <code>(frame () (let ((p (panel ())))))</code> will result in a frame with no children, and will create an "orphan" panel.</li>
+</ul>
+Snow provides operators to alter this default behavior:
+<ul>
+ <li><code>(dont-add form)</code> will always execute form in a dynamic context in which no parent widget is defined.</li>
+ <li><code>(add-child container child &optional layout-constraints)</code> will force child to be added to container, even if container is not the value of *parent*.</li>
+</ul>
+
+<h4>widget id</h4>
+
+Additionally, all container widget macros support a pseudo-property called <code><b>id</b></code> which can be used to bind a lexical variable of choice to the widget locally to the macro body. Example:
+<pre class="paste-area">
+(frame (:id foo)
+ (print foo))
+</pre>
+will output something like:
+<pre class="paste-area">
+#<javax.swing.JFrame ...frame.toString()... {identityHashCode}>
+</pre>
+<a name="layout" /><h3>Layout</h3>
+By default, Snow uses <a href="www.miglayout.com/">MiG Layout</a> as the layout manager to organize components inside a container. When you create a component that will be automatically added to <code>*parent*</code> by Snow, you can use the pseudo-property <code>:layout</code> to specify (as a string) additional information for the layout manager. If you use <code>add-child</code>, instead, you have to pass this string to <code>add-child</code> as its last optional parameter (I hope I can fix this inconsistency). Here's a quick cheat sheet of the constraints you can use with MiG Layout: <a href="http://www.migcalendar.com/miglayout/cheatsheet.html">http://www.migcalendar.com/miglayout/cheatsheet.html</a> (look for "Component Constraints").<br />
+You can use another layout instead of MiG: to do so, use the <code>layout-manager</code> property of the container. The values you can pass are:
+<ul>
+ <li>a keyword (supported ones are <code>:default</code>, <code>:mig</code>, <code>:border</code>, <code>:box</code>) to select the layout manager by name; the names refer to layout managers available in Swing;</li>
+ <li>a list whose car is one of the symbols above, and whose cdr is a list of the arguments passed to the layout manager (e.g. <code>(list :box :y)</code> to have components be laid out in a vertical stack);</li>
+ <li>a Java object which can be used by Swing as a layout manager (e.g. <code>(new "java.awt.FlowLayout")</code>).</li>
+</ul>
+<a name="events" /><h3>Event handling</h3>
+Certain widgets can trigger events on certain types of user actions. These events can be handled by user code. Event-handling callbacks can be set using properties named <code>:on-<i>event-name</i></code> (for example, <code>:on-action</code> for handling clicks on buttons, or ActionEvents in Swing/AWT parlance). Currently extremely few events are supported! I'll add new ones in future releases.<br />
+A callback for an event is either a Lisp function with a single argument (the event object), or an appropriate native Java event handler for the event (e.g., an instance of <code>java.awt.ActionListener</code>).<br />
+Events happen on a dedicated thread (in Swing's terminology, the EDT - Event Dispatching Thread). That's why, in the Hello World example, the string got printed to the console and not to the REPL! In fact, the REPL has its own dynamic, thread-local context, which rebinds the value of <code>*terminal-io*</code> to a stream that reads and writes on the REPL; the event, instead, is run in another thread, which doesn't have access to this context, and thus uses the global value of <code>*terminal-io*</code>. If you want to capture the value of a dynamic variable from the thread that creates the event handler, you have to explicitly do so like this:
+<pre class="paste-area">
+(button :on-action (let ((tmp *some-thread-local-variable*))
+ (lambda (event)
+ (let ((*some-thread-local-variable* tmp))
+ ...do stuff...))))
+</pre>
+
+<a name="embedding" /><h3>Embedding Snow</h3>
+Snow can easily be embedded in a Java application by using JSR-223. The snow.Snow class has some static methods that can be used to load some Snow source code from a .lisp file (or classpath resource), or to obtain an instance of <code>javax.script.ScriptEngine</code> which you can use for more advanced stuff (e.g. compiling Lisp code, or calling specific Lisp functions). When embedding Snow to define (part of) the application's GUI, it is recommended that you modularize the Snow code in functions, which you'll call from Java to obtain the GUI components:
+<h4><code>file.lisp</code></h4>
+<pre class="paste-area">
+(defun create-main-frame (&rest args)
+ ...snow code...)
+</pre>
+<h4><code>MyClass.java</code></h4>
+<pre class="paste-area">
+...
+Snow.evalResource(new FileReader("file.lisp"));
+JFrame mainFrame = (JFrame) Snow.getInvocable().invokeFunction("create-main-frame", args);
+...
+</pre>
+<a name="more" /><h3>What's more?</h3>
+I haven't covered which widgets are supported and how much of their API is supported. At this stage, Snow is little more than a prototype, so very little of the Swing API is covered. The best way to learn about Snow usage is to look at the examples included with Snow: the debugger (debugger.lisp), inspector (inspector.lisp) and the REPL (repl.lisp and swing/swing.lisp). Also, I haven't talked about how to use your custom widgets with Snow, and probably other things. Drop me a line at alessiostalla @ Google's mail service, and I'll be happy to help you.
+<hr />
+<h3>Footnotes</h3>
+<ol>
+ <li><a name="notes_1" />If you <i>really</i> mess things up, you can change the package of the REPL to one where the symbol QUIT is not visible. If you find yourself in this situation, type (ext:quit) to exit.</li>
+</ol>
+</body>
+</html>
Added: trunk/docs/widget-reference.html
==============================================================================
--- (empty file)
+++ trunk/docs/widget-reference.html Wed Sep 30 16:06:52 2009
@@ -0,0 +1,189 @@
+<html>
+<head>
+<title>Snow Widget Reference</title>
+<link rel="stylesheet" type="text/css" href="style.css">
+</head>
+<body>
+<h1>Snow Widget Reference</h1>
+<h3>Common properties</h3>
+These properties are available on every widget, unless stated otherwise.
+<table border="1">
+ <tr>
+ <th>Name</th>
+ <th style="width: 30%;">Type</th>
+ <th style="width: 30%;">Description</th>
+ <th>Examples</th>
+ <th>Notes</th>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>id</code></strong></td>
+ <td style="text-align: center;">symbol</td>
+ <td>Binds a lexical variable to the current widget locally to the widget body.</td>
+ <td><pre class="paste-area">
+(frame (:id foo)
+ (print foo))</pre></td>
+ <td>For containers only.</td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>layout-manager</code></strong></td>
+ <td>
+ <ul>
+ <li>one of :default, :mig, :border, :box, :flow</li>
+ <li>a list whose car is one of the above and whose cdr are additional arguments</li>
+ <li>a native Java layout manager.</li>
+ </ul>
+ </td>
+ <td>Sets the policy for laying out the component's children.</td>
+ <td><pre class="paste-area">
+(panel (:layout-manager '(:box :y))
+ (label :text "First Line")
+ (label :text "Second Line"))</pre></td>
+ <td>For containers only.</td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>layout</code></strong></td>
+ <td style="text-align: center;">string</td>
+ <td>Constraints used to control how the component is to be laid out in its container. The possible values and their meaning depend on the layout manager of the container.</td>
+ <td><pre class="paste-area">
+(panel ()
+ (label :layout "grow, wrap"
+ :text "hello")
+ (label :text "world"))</pre></td>
+ <td><br /></td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>enabled-p</code></strong></td>
+ <td style="text-align: center;">boolean</td>
+ <td>Controls whether the widget is enabled (able to receive user input).</td>
+ <td><br /></td>
+ <td><br /></td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>size</code></strong></td>
+ <td style="text-align: center;">complex</td>
+ <td>Sets the size of the widget.</td>
+ <td><pre class="paste-area">
+(frame (:size #C(800 600)))</pre></td>
+ <td>The size is represented as a complex number whose real part is the Width and imaginary part is the Height.</td>
+ </tr>
+</table>
+<h3>Widgets</h3>
+Here's a summary of the widgets (GUI components) currently available in Snow. The "C" column indicates whether the widget is a container. You can follow the hyperlink on a widget's name to read about its properties.
+<table border="1">
+ <tr>
+ <th rowspan="2">Name</th>
+ <th rowspan="2">Description</th>
+ <th rowspan="2">C</th>
+ <th>Backend</th>
+ <th rowspan="2">Examples</th>
+ <th rowspan="2">Notes</th>
+ </tr>
+ <tr>
+ <th>Swing</th>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><a href="#button_props"><code>button</code></a></strong></td>
+ <td>A button with text on it.</td>
+ <td><br /></td>
+ <td style="text-align: center;">Y</td>
+ <td><pre class="paste-area">
+(button :text "Ok!")</pre></td>
+ <td><br /></td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>check-box</code></strong></td>
+ <td>A checkbox with optional text.</td>
+ <td><br /></td>
+ <td style="text-align: center;">Y</td>
+ <td><pre class="paste-area">
+(check-box :text "Enabled")</pre></td>
+ <td><br /></td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>frame</code></strong></td>
+ <td>A top-level window.</td>
+ <td style="text-align: center;">Y</td>
+ <td style="text-align: center;">Y</td>
+ <td><pre class="paste-area">
+(frame (:title "A frame" :on-close :exit)
+ (label :text "push")
+ (button :text "this!"))</pre></td>
+ <td><br /></td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>label</code></strong></td>
+ <td>Read-only text.</td>
+ <td><br /></td>
+ <td style="text-align: center;">Y</td>
+ <td><pre class="paste-area">
+(label :text "Hello")</pre></td>
+ <td><br /></td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>list-widget</code></strong></td>
+ <td>Displays a list of strings.</td>
+ <td><br /></td>
+ <td style="text-align: center;">Y</td>
+ <td><pre class="paste-area">
+(list-widget :model (make-cons-list-model '("foo" "bar" "baz")))</pre></td>
+ <td>Not named list to avoid clashing with the commonly used function by the same name in the COMMON-LISP package.</td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>panel</code></strong></td>
+ <td>A generic container for other components.</td>
+ <td style="text-align: center;">Y</td>
+ <td style="text-align: center;">Y</td>
+ <td><pre class="paste-area">
+(panel ()
+ (label :text "push")
+ (button :text "this!"))</pre></td>
+ <td><br /></td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>scroll</code></strong></td>
+ <td>A container for a single child, providing scrollbar support.</td>
+ <td style="text-align: center;">Y</td>
+ <td style="text-align: center;">Y</td>
+ <td><pre class="paste-area">
+(scroll ()
+ (text-area :text "very, very, ..., long text"))</pre></td>
+ <td><br /></td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>text-area</code></strong></td>
+ <td>Allows the user to enter multiple lines of text.</td>
+ <td><br /></td>
+ <td style="text-align: center;">Y</td>
+ <td><pre class="paste-area">
+(text-area :text "type something here")</pre></td>
+ <td><br /></td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>text-field</code></strong></td>
+ <td>Allows the user to enter a single line of text.</td>
+ <td><br /></td>
+ <td style="text-align: center;">Y</td>
+ <td><pre class="paste-area">
+(text-field :text "type something here")</pre></td>
+ <td><br /></td>
+ </tr>
+ <tr>
+ <td style="text-align: center;"><strong><code>tree</code></strong></td>
+ <td>Displays hierarchical data in the form of a tree with expandable/collapsible nodes.</td>
+ <td><br /></td>
+ <td style="text-align: center;">Y</td>
+ <td><pre class="paste-area">
+(tree :model (make-cons-tree-model '("foo" ("bar" "baz"))))</pre></td>
+ <td><br /></td>
+ </tr>
+</table>
+<h3>Widget-specific properties</h3>
+<a name="button_props" /><h4>button</h4>
+<p>
+<dd><code>:text</code></dd>
+<dt>Sets the text displayed on the button</dt>
+<dd><code>:on-action</code></dd>
+<dt>Sets a callback to be invoked when the button is activated (e.g. by a mouse click or using the keyboard)</dt>
+</p>
+</body>
+</html>
Added: trunk/lib/abcl.jar
==============================================================================
Binary file. No diff available.
Added: trunk/lib/binding-2.0.6.jar
==============================================================================
Binary file. No diff available.
Added: trunk/lib/cells/README.txt
==============================================================================
--- (empty file)
+++ trunk/lib/cells/README.txt Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/Use Cases/dow-jones/dow-jones.lpr
==============================================================================
--- (empty file)
+++ trunk/lib/cells/Use Cases/dow-jones/dow-jones.lpr Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/Use Cases/dow-jones/stock-exchange.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/Use Cases/dow-jones/stock-exchange.lisp Wed Sep 30 16:06:52 2009
@@ -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) <the :date message>)
+;;
+;; 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 :index message>)
+;;
+;; 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 (<slot-name> 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: trunk/lib/cells/cell-types.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cell-types.lisp Wed Sep 30 16:06:52 2009
@@ -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 <ephem> '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) "<vld>"))
+ ((c-unboundp c) "<unb>")
+ ((not (c-currentp c)) "dirty")
+ (t "<err>"))))
+
+(defmethod c-print-value (c stream)
+ (declare (ignore c stream)))
+
Added: trunk/lib/cells/cells-manifesto.txt
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-manifesto.txt Wed Sep 30 16:06:52 2009
@@ -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 <function-name>
+
+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: trunk/lib/cells/cells-store.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-store.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/boiler-examples.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/boiler-examples.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/build-sys.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/build-sys.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/cells-test.asd
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/cells-test.asd Wed Sep 30 16:06:52 2009
@@ -0,0 +1,26 @@
+;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
+
+(asdf:defsystem :cells-test
+ :name "cells-test"
+ :author "Kenny Tilton <ktilton at nyc.rr.com>"
+ :maintainer "Kenny Tilton <ktilton at nyc.rr.com>"
+ :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: trunk/lib/cells/cells-test/cells-test.lpr
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/cells-test.lpr Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/deep-cells.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/deep-cells.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/df-interference.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/df-interference.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/echo-setf.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/echo-setf.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/hello-world-q.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/hello-world-q.lisp Wed Sep 30 16:06:52 2009
@@ -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."))
+ "<silence>"))))))
+ (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: <silence>
+happen: knock-knock
+computer: <silence>
+happen: arrive
+happen: knock-knock
+computer: who's there?
+happen: world
+computer: hello, world.
+
+|#
+
Added: trunk/lib/cells/cells-test/hello-world.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/hello-world.lisp Wed Sep 30 16:06:52 2009
@@ -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."))
+ "<silence>"))))))
+ (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: <silence>
+happen: KNOCK-KNOCK
+computer: <silence>
+happen: ARRIVE
+happen: KNOCK-KNOCK
+computer: who's there?
+happen: LEAVE
+computer: <silence>
+
+
+|#
+
Added: trunk/lib/cells/cells-test/internal-combustion.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/internal-combustion.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/lazy-propagation.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/lazy-propagation.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/output-setf.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/output-setf.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/person.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/person.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/synapse-testing.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/synapse-testing.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/test-cycle.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/test-cycle.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/test-cyclicity.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/test-cyclicity.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/test-ephemeral.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/test-ephemeral.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/test-family.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/test-family.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/test-kid-slotting.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/test-kid-slotting.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/test-lazy.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/test-lazy.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/test-synapse.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/test-synapse.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/test.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/test.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells-test/test.lpr
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells-test/test.lpr Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/cells.asd
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells.asd Wed Sep 30 16:06:52 2009
@@ -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 <kentilton at gmail.com>"
+ :maintainer "Kenny Tilton <kentilton at gmail.com>"
+ :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: trunk/lib/cells/cells.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells.lisp Wed Sep 30 16:06:52 2009
@@ -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 "<nootherdata>"))
+ (: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 <c-enabling>: ~s" condition)
+ (break "~&i say, unhandled <c-enabling>: ~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: trunk/lib/cells/cells.lpr
==============================================================================
--- (empty file)
+++ trunk/lib/cells/cells.lpr Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/constructors.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/constructors.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/defmodel.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/defmodel.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/defpackage.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/defpackage.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/doc/01-Cell-basics.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/doc/01-Cell-basics.lisp Wed Sep 30 16:06:52 2009
@@ -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)
+ <set up undo>
+ <toss selected text>
+ <etc><etc>
+ (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))
+ <lotsa other stuff>
+ (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 <value>) 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 #<simple-error @ #x210925f2>
+
+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 #<simple-error @ #x2123e392>
+
+;-----------------------------------------------------------
+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: trunk/lib/cells/doc/cell-doc.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/doc/cell-doc.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/doc/cells-overview.pdf
==============================================================================
Binary files (empty file) and trunk/lib/cells/doc/cells-overview.pdf Wed Sep 30 16:06:52 2009 differ
Added: trunk/lib/cells/doc/hw.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/doc/hw.lisp Wed Sep 30 16:06:52 2009
@@ -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) "<silence>"))))
+ (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: <silence>
+hear: knock-knock
+respond: who's there?
+hear: knock-knock
+respond: i said, "who's there?"
+hear: world
+respond: hello, world
+
+|#
+
Added: trunk/lib/cells/doc/motor-control.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/doc/motor-control.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/family-values.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/family-values.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/family.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/family.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/fm-utilities.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/fm-utilities.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/gui-geometry/coordinate-xform.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/gui-geometry/coordinate-xform.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/gui-geometry/defpackage.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/gui-geometry/defpackage.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/gui-geometry/geo-data-structures.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/gui-geometry/geo-data-structures.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/gui-geometry/geo-family.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/gui-geometry/geo-family.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/gui-geometry/geo-macros.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/gui-geometry/geo-macros.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/gui-geometry/geometer.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/gui-geometry/geometer.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/gui-geometry/gui-geometry.asd
==============================================================================
--- (empty file)
+++ trunk/lib/cells/gui-geometry/gui-geometry.asd Wed Sep 30 16:06:52 2009
@@ -0,0 +1,15 @@
+;;;; -*- Mode: lisp; indent-tabs-mode: nil -*-
+
+(asdf:defsystem :gui-geometry
+ :author "Kenny Tilton <kentilton at gmail.com>"
+ :maintainer "Kenny Tilton <kentilton at gmail.com>"
+ :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: trunk/lib/cells/gui-geometry/gui-geometry.lpr
==============================================================================
--- (empty file)
+++ trunk/lib/cells/gui-geometry/gui-geometry.lpr Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/initialize.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/initialize.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/integrity.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/integrity.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/link.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/link.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/load.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/load.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/md-slot-value.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/md-slot-value.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/md-utilities.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/md-utilities.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/model-object.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/model-object.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/propagate.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/propagate.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/slot-utilities.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/slot-utilities.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/synapse-types.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/synapse-types.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/synapse.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/synapse.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/test-cc.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/test-cc.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/test-cycle.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/test-cycle.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/test-ephemeral.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/test-ephemeral.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/test-propagation.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/test-propagation.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/test-synapse.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/test-synapse.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/test.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/test.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/trc-eko.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/trc-eko.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/tutorial/01-lesson.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/tutorial/01-lesson.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/tutorial/01a-dataflow.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/tutorial/01a-dataflow.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/tutorial/01b-change-handling.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/tutorial/01b-change-handling.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/tutorial/01c-cascade.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/tutorial/01c-cascade.lisp Wed Sep 30 16:06:52 2009
@@ -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/#<RECTANGLE>] | (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 | [? :<vld>=[24]WIDTH/#<RECTANGLE>] | (AREA)
+0> c-propagate-to-users > notifying users of | [? :<vld>=[24]AREA/#<RECTANGLE>] | (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: trunk/lib/cells/tutorial/02-lesson.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/tutorial/02-lesson.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/tutorial/03-ephemeral.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/tutorial/03-ephemeral.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/tutorial/04-formula-once-then-input.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/tutorial/04-formula-once-then-input.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/tutorial/test.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/tutorial/test.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/tutorial/tutorial.lpr
==============================================================================
--- (empty file)
+++ trunk/lib/cells/tutorial/tutorial.lpr Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/utils-kt/core.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/utils-kt/core.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/utils-kt/datetime.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/utils-kt/datetime.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/utils-kt/debug.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/utils-kt/debug.lisp Wed Sep 30 16:06:52 2009
@@ -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 "~&<non-gc user cpu> ~a" (- cpu-tot-user cpu-gc-user))
+ (format t "~&<non-gc sys cpu> ~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: trunk/lib/cells/utils-kt/defpackage.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/utils-kt/defpackage.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/utils-kt/detritus.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/utils-kt/detritus.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/utils-kt/flow-control.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/utils-kt/flow-control.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/utils-kt/quad.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/utils-kt/quad.lisp Wed Sep 30 16:06:52 2009
@@ -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: <foo>123</foo> would thus be represented by (foo nil "123"),
+ <foo>123</foo><bar>456</bar> by (foo nil "123" bar nil "456"), and
+ <zot><foo>123</foo><bar>456</bar></zot> 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: trunk/lib/cells/utils-kt/split-sequence.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/utils-kt/split-sequence.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,223 @@
+;;;; SPLIT-SEQUENCE
+;;;
+;;; This code was based on Arthur Lemmens' in
+;;; <URL:http://groups.google.com/groups?as_umsgid=39F36F1A.B8F19D20%40simplex.nl>;
+;;;
+;;; 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: trunk/lib/cells/utils-kt/strings.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/utils-kt/strings.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/utils-kt/utils-kt.asd
==============================================================================
--- (empty file)
+++ trunk/lib/cells/utils-kt/utils-kt.asd Wed Sep 30 16:06:52 2009
@@ -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 <ktilton at nyc.rr.com>"
+ :version "2007-12-02"
+ :maintainer "Kenny Tilton <ktilton at nyc.rr.com>"
+ :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: trunk/lib/cells/utils-kt/utils-kt.lpr
==============================================================================
--- (empty file)
+++ trunk/lib/cells/utils-kt/utils-kt.lpr Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/cells/variables.lisp
==============================================================================
--- (empty file)
+++ trunk/lib/cells/variables.lisp Wed Sep 30 16:06:52 2009
@@ -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: trunk/lib/commons-logging.jar
==============================================================================
Binary file. No diff available.
Added: trunk/lib/miglayout-3.6.2.jar
==============================================================================
Binary file. No diff available.
Added: trunk/src/java/abcl-script-config.lisp
==============================================================================
--- (empty file)
+++ trunk/src/java/abcl-script-config.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,5 @@
+(in-package :abcl-script-user)
+
+(setq *launch-swank-at-startup* t)
+(setq *swank-dir* #P"/home/alessio/slime/slime/")
+(setq *use-throwing-debugger* nil)
\ No newline at end of file
Added: trunk/src/java/snow/AwtDialogPromptStream.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/AwtDialogPromptStream.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,60 @@
+package snow;
+
+import java.awt.BorderLayout;
+import java.awt.Dialog;
+import java.awt.FlowLayout;
+import java.awt.Frame;
+import java.awt.Label;
+import java.awt.Panel;
+import java.awt.TextField;
+import java.awt.event.ActionEvent;
+import java.awt.event.ActionListener;
+
+import javax.swing.JButton;
+
+public class AwtDialogPromptStream extends DialogPromptStream {
+
+ private Dialog dialog = new Dialog((Frame)null, true);
+ private Label prompt = new Label();
+ private TextField input = new TextField(32);
+
+ public AwtDialogPromptStream() {
+ this("Prompt");
+ }
+
+ public AwtDialogPromptStream(String title) {
+ super();
+ dialog.setTitle(title);
+ Panel tmpPanel = new Panel();
+ tmpPanel.add(prompt);
+ tmpPanel.add(input);
+ dialog.add(tmpPanel);
+ JButton okBtn = new JButton("Ok");
+ okBtn.addActionListener(new ActionListener() {
+
+ @Override
+ public void actionPerformed(ActionEvent e) {
+ synchronized(dialog) {
+ dialog.dispose();
+ }
+ }
+ });
+ tmpPanel = new Panel(new FlowLayout());
+ tmpPanel.add(okBtn);
+ dialog.add(tmpPanel, BorderLayout.SOUTH);
+ }
+
+ @Override
+ protected void closeDialog() {
+ dialog.dispose();
+ }
+
+ @Override
+ protected String readInputFromModalDialog(String promptText) {
+ prompt.setText(promptText);
+ dialog.pack();
+ dialog.setVisible(true);
+ return input.getText();
+ }
+
+}
Added: trunk/src/java/snow/DialogPromptStream.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/DialogPromptStream.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,75 @@
+package snow;
+
+import java.io.IOException;
+import java.io.Reader;
+import java.io.StringReader;
+import java.io.StringWriter;
+
+import org.armedbear.lisp.Stream;
+
+/**
+ * A bidirectional stream that captures input from a modal dialog. The dialog reports a label (prompt line)
+ * which shows to the user everything that has been printed to the stream up to the moment when the dialog
+ * became visible. It is usable as a drop-in replacement for e.g. *debug-io*.<br />
+ * This is an abstract class that does not depend on any GUI library. Subclasses are expected to provide
+ * the actual code to show the dialog and read input from the user.
+ * @author Alessio Stalla
+ *
+ */
+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();
+ }
+
+ @Override
+ public int read(char[] cbuf, int off, int len) throws IOException {
+ if(stringReader == null) {
+ writtenSoFar.flush();
+ String promptText = writtenSoFar.toString();
+ writtenSoFar.getBuffer().delete(0, Integer.MAX_VALUE);
+ String inputStr = readInputFromModalDialog(promptText) + System.getProperty("line.separator", "\n");
+ stringReader = new StringReader(inputStr);
+ inputSize = inputStr.length();
+ }
+ int read = stringReader.read(cbuf, off, len);
+ if(read != -1) {
+ inputSize -= read;
+ }
+ if(read == -1 || inputSize == 0) {
+ inputSize = 0;
+ stringReader = null;
+ }
+ return read;
+ }
+
+ };
+
+ /**
+ * Inits this stream. Should be called by subclasses' constructors.
+ */
+ protected DialogPromptStream() {
+ initAsCharacterOutputStream(writtenSoFar);
+ initAsCharacterInputStream(reader);
+ }
+
+ /**
+ * Closes the dialog when this stream is closed, aborting the read operation.
+ */
+ protected abstract void closeDialog();
+
+ /**
+ * Shows the dialog and blocks the calling thread until the user has closed the dialog.
+ * @param promptText the text to be shown to the user (the prompt).
+ * @return a string holding input from the user.
+ */
+ protected abstract String readInputFromModalDialog(String promptText);
+
+}
Added: trunk/src/java/snow/Snow.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/Snow.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,223 @@
+/*
+ * Snow.java
+ *
+ * Copyright (C) 2008-2009 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 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;
+
+public abstract class Snow {
+
+ private static boolean init = false;
+ private static ScriptEngine lispEngine;
+ private static final String fileSeparator = System.getProperty("file.separator");
+
+ private static final String fixDirPath(String path) {
+ if(!path.endsWith(fileSeparator)) {
+ path += fileSeparator;
+ }
+ return path;
+ }
+
+ public static synchronized ScriptEngine init() throws ScriptException {
+ if(!init) {
+ lispEngine = new ScriptEngineManager(Snow.class.getClassLoader()).getEngineByExtension("lisp");
+ URL url = Snow.class.getResource("/snow/snow.asd");
+ if(url == null) {
+ throw new RuntimeException("snow.asd not found in classpath: have you installed Snow correctly?");
+ }
+ String baseDir;
+ String libDir;
+ if(!"file".equals(url.getProtocol())) {
+ if("jar".equals(url.getProtocol())) {
+ ZipInputStream extractor = null;
+ try {
+ String tmpDir = System.getProperty("java.io.tmpdir");
+ if(tmpDir != null && fileSeparator != null) {
+ tmpDir = fixDirPath(tmpDir);
+ String jarUrlStr = url.getPath();
+ int bangPos = jarUrlStr.indexOf('!');
+ if(bangPos >= 0) {
+ jarUrlStr = jarUrlStr.substring(0, bangPos);
+ }
+ URL jarUrl = new URL(jarUrlStr);
+ extractor = new ZipInputStream(jarUrl.openStream());
+ int targetDirIndex = 0;
+ File targetDir;
+ do {
+ targetDir = new File(tmpDir + "snow" + (targetDirIndex++));
+ } while(targetDir.exists());
+ targetDir.mkdir();
+ targetDir.deleteOnExit();
+ baseDir = targetDir.getAbsolutePath();
+ baseDir = fixDirPath(baseDir);
+ libDir = baseDir;
+ for(ZipEntry entry = extractor.getNextEntry(); entry != null; entry = extractor.getNextEntry()) {
+ File extracted = new File(baseDir + entry.getName());
+ extracted.deleteOnExit();
+ if(entry.isDirectory()) {
+ extracted.mkdirs();
+ } else {
+ extracted.getParentFile().mkdirs();
+ byte[] buf = new byte[(int)entry.getSize()]; //probably inefficient
+ int read = 0;
+ while(true) {
+ int justRead = extractor.read(buf, read, buf.length - read);
+ if(justRead >= 0 && read < buf.length) {
+ read += justRead;
+ } else {
+ break;
+ }
+ }
+ FileOutputStream fos = new FileOutputStream(extracted);
+ fos.write(buf);
+ fos.flush();
+ fos.close();
+ }
+ extracted.setLastModified(entry.getTime());
+ System.out.println("Extracted " + extracted.getAbsolutePath());
+ }
+ } else {
+ throw new RuntimeException("Cannot extract jar " + url + " - no temp dir or file separator defined");
+ }
+ } catch(Exception e) {
+ throw new RuntimeException("Cannot extract jar " + url, e);
+ } finally {
+ if(extractor != null) {
+ try {
+ extractor.close();
+ } catch (IOException e) {
+ System.err.println("Couldn't close jar extractor: " + e.getMessage());
+ e.printStackTrace();
+ }
+ }
+ }
+ } else {
+ throw new RuntimeException("Unsupported URL for snow.asd: " + url +
+ " make sure it is a regular file or is in a jar.");
+ }
+ } else {
+ URI uri;
+ try {
+ uri = url.toURI();
+ } catch (URISyntaxException e) {
+ throw new RuntimeException(e);
+ }
+ File f = new File(uri);
+ baseDir = fixDirPath(f.getParentFile().getParent());
+ libDir = fixDirPath(new File(baseDir).getParent()) + "lib" + fileSeparator;
+ }
+ lispEngine.eval("(pushnew #P\"" + baseDir + "snow/\" asdf:*central-registry* :test #'equal)");
+ lispEngine.eval("(pushnew #P\"" + baseDir + "snow/swing/\" asdf:*central-registry* :test #'equal)");
+ lispEngine.eval("(pushnew #P\"" + libDir + "cells/\" asdf:*central-registry* :test #'equal)");
+ lispEngine.eval("(pushnew #P\"" + libDir + "cells/utils-kt/\" asdf:*central-registry* :test #'equal)");
+ 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 {
+ throw new RuntimeException("Already initialized");
+ }
+ }
+
+ public static synchronized ScriptEngine initIfNecessary() throws ScriptException {
+ if(!init) {
+ init();
+ }
+ return lispEngine;
+ }
+
+ public static Object evalResource(Class<?> aClass, String resourcePath) throws ScriptException {
+ return evalResource(aClass, resourcePath, true);
+ }
+
+ public static Object evalResource(Class<?> aClass, String resourcePath, boolean compileItFirst) throws ScriptException {
+ Reader r = new InputStreamReader(aClass.getResourceAsStream(resourcePath));
+ return evalResource(r, compileItFirst);
+ }
+
+ public static Object evalResource(Reader reader) throws ScriptException {
+ return evalResource(reader, true);
+ }
+
+ public static Object evalResource(Reader reader, boolean compileItFirst) throws ScriptException {
+ initIfNecessary();
+ if(compileItFirst) {
+ return getCompilable().compile(reader).eval();
+ } else {
+ return lispEngine.eval(reader);
+ }
+ }
+
+ public static ScriptEngine getScriptEngine() {
+ return lispEngine;
+ }
+
+ public static Compilable getCompilable() {
+ return (Compilable) lispEngine;
+ }
+
+ public static Invocable getInvocable() {
+ return (Invocable) lispEngine;
+ }
+
+ public static void main(String[] args) {
+ try {
+ Snow.init();
+ if(args.length == 0) { //Launch GUI REPL
+ evalResource(Snow.class, "/snow/start.lisp", true);
+ } else { //Launch regular ABCL
+ org.armedbear.lisp.Main.main(args);
+ }
+ } catch (Exception e) {
+ e.printStackTrace();
+ }
+ }
+
+
+}
Added: trunk/src/java/snow/SwingDialogPromptStream.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/SwingDialogPromptStream.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,60 @@
+package snow;
+
+import java.awt.BorderLayout;
+import java.awt.FlowLayout;
+import java.awt.Frame;
+import java.awt.event.ActionEvent;
+import java.awt.event.ActionListener;
+
+import javax.swing.JButton;
+import javax.swing.JDialog;
+import javax.swing.JLabel;
+import javax.swing.JPanel;
+import javax.swing.JTextField;
+
+public class SwingDialogPromptStream extends DialogPromptStream {
+
+ private JDialog dialog = new JDialog((Frame)null, true);
+ private JLabel prompt = new JLabel();
+ private JTextField input = new JTextField(32);
+
+ public SwingDialogPromptStream() {
+ this("Prompt");
+ }
+
+ public SwingDialogPromptStream(String title) {
+ super();
+ dialog.setTitle(title);
+ JPanel tmpPanel = new JPanel();
+ tmpPanel.add(prompt);
+ tmpPanel.add(input);
+ dialog.add(tmpPanel);
+ JButton okBtn = new JButton("Ok");
+ okBtn.addActionListener(new ActionListener() {
+
+ @Override
+ public void actionPerformed(ActionEvent e) {
+ synchronized(dialog) {
+ dialog.dispose();
+ }
+ }
+ });
+ tmpPanel = new JPanel(new FlowLayout());
+ tmpPanel.add(okBtn);
+ dialog.add(tmpPanel, BorderLayout.SOUTH);
+ }
+
+ @Override
+ protected void closeDialog() {
+ dialog.dispose();
+ }
+
+ @Override
+ protected String readInputFromModalDialog(String promptText) {
+ prompt.setText(promptText);
+ dialog.pack();
+ dialog.setVisible(true);
+ return input.getText();
+ }
+
+}
Added: trunk/src/java/snow/binding/AccessorBinding.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/binding/AccessorBinding.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,108 @@
+/*
+ * AccessorBinding.java
+ *
+ * Copyright (C) 2008-2009 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.binding;
+
+import org.armedbear.lisp.ConditionThrowable;
+import org.armedbear.lisp.JavaObject;
+import org.armedbear.lisp.LispObject;
+
+import com.jgoodies.binding.value.AbstractValueModel;
+import com.jgoodies.binding.value.ValueModel;
+
+public class AccessorBinding extends AbstractValueModel implements ValueModel {
+
+ private LispObject reader;
+ private LispObject writer;
+ private LispObject place;
+ private Object oldValue;
+
+ public AccessorBinding(LispObject place, LispObject reader, LispObject writer) {
+ super();
+ this.place = place;
+ this.reader = reader;
+ this.writer = writer;
+ oldValue = getValue();
+ }
+
+
+ @Override
+ public Object getValue() {
+ try {
+ return reader.execute(place).javaInstance();
+ } catch (ConditionThrowable e) {
+ throw new RuntimeException(e);
+ }
+ }
+
+ @Override
+ public void setValue(Object value) {
+ try {
+ writer.execute(JavaObject.getInstance(value, true), place);
+ //valueChanged(value);
+ } catch (ConditionThrowable e) {
+ throw new RuntimeException(e);
+ }
+ }
+
+ public void valueChanged(Object value) {
+ fireValueChange(oldValue, value, false);
+ oldValue = value;
+ }
+
+ public LispObject getPlace() {
+ return place;
+ }
+
+
+ public void setPlace(LispObject place) {
+ this.place = place;
+ }
+
+
+ public LispObject getReader() {
+ return reader;
+ }
+
+ public void setReader(LispObject reader) {
+ this.reader = reader;
+ }
+
+ public LispObject getWriter() {
+ return writer;
+ }
+
+ public void setWriter(LispObject writer) {
+ this.writer = writer;
+ }
+
+}
Added: trunk/src/java/snow/binding/Converter.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/binding/Converter.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,102 @@
+/*
+ * Converter.java
+ *
+ * Copyright (C) 2008-2009 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.binding;
+
+import org.armedbear.lisp.ConditionThrowable;
+import org.armedbear.lisp.JavaObject;
+import org.armedbear.lisp.LispObject;
+
+import com.jgoodies.binding.value.AbstractValueModel;
+import com.jgoodies.binding.value.ValueModel;
+
+public class Converter extends AbstractValueModel implements ValueModel {
+
+ private ValueModel valueModel;
+ private LispObject converterFrom;
+ private LispObject converterTo;
+
+ public Converter(ValueModel valueModel, LispObject converterFrom, LispObject converterTo) {
+ super();
+ this.valueModel = valueModel;
+ this.converterFrom = converterFrom;
+ this.converterTo = converterTo;
+ }
+
+
+ @Override
+ public Object getValue() {
+ Object value = valueModel.getValue();
+ try {
+ return converterTo.execute(JavaObject.getInstance(value, true)).javaInstance();
+ } catch (ConditionThrowable e) {
+ throw new RuntimeException(e);
+ }
+ }
+
+ @Override
+ public void setValue(Object obj) {
+ try {
+ Object value = converterFrom.execute(JavaObject.getInstance(obj, true)).javaInstance();
+ valueModel.setValue(value);
+ } catch (ConditionThrowable e) {
+ throw new RuntimeException(e);
+ }
+ }
+
+ public ValueModel getValueModel() {
+ return valueModel;
+ }
+
+
+ public void setValueModel(ValueModel valueModel) {
+ this.valueModel = valueModel;
+ }
+
+ public LispObject getConverterFrom() {
+ return converterFrom;
+ }
+
+ public void setConverterFrom(LispObject converterFrom) {
+ this.converterFrom = converterFrom;
+ }
+
+ public LispObject getConverterTo() {
+ return converterTo;
+ }
+
+ public void setConverterTo(LispObject converterTo) {
+ this.converterTo = converterTo;
+ }
+
+
+}
Added: trunk/src/java/snow/editor/SnowEditor.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/editor/SnowEditor.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,21 @@
+package snow.editor;
+
+import javax.script.ScriptException;
+
+import snow.Snow;
+
+public class SnowEditor {
+
+ /**
+ * @param args
+ */
+ public static void main(String[] args) {
+ try {
+ Snow.init();
+ Snow.evalResource(SnowEditor.class, "snow-editor.lisp");
+ } catch (ScriptException e) {
+ e.printStackTrace();
+ }
+ }
+
+}
Added: trunk/src/java/snow/editor/snow-editor.lisp
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/editor/snow-editor.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,66 @@
+(in-package :snow)
+
+(defmodel my-model ()
+ ((a :accessor aaa :initform (c-in "4"))
+ (b :accessor bbb :initform (c? (concatenate 'string (aaa self) "2")))))
+
+(defvar *object* (new "snow.example.SnowExample"))
+(defvar *variable* (make-var "42"))
+(defvar *cells-object* (make-instance 'my-model))
+
+(let ((myframe
+ (frame (:id frame-id :title "Sample JFrame" :visible-p t)
+ (tree :model (make-tree-model '(1 2 (c (a b)) 3)))
+ (button :text "push me"
+ :on-action (lambda (event)
+ (princ "Thanks for pushing me! ")
+ (format t "My parent is ~A~%" frame-id)
+ (finish-output)))
+ (scroll (:layout "grow")
+ (list-widget :model (make-list-model '(1 2 (c (a b)) 3))
+ :prototype-cell-value "abcdefghijklmnopq"))
+ (panel (:layout-manager :border :layout "wrap")
+ (button :text "borderlayout - center")
+ (button :text "borderlayout - east"
+ :layout (jfield "java.awt.BorderLayout" "EAST")))
+ (scroll ()
+ (panel ()
+ (label :binding (make-bean-binding *object* "property1"))
+ (label :binding (make-cells-binding (c? (aaa *cells-object*))))
+ (label :binding (make-cells-binding (c? (bbb *cells-object*))))
+ (label :binding (make-simple-binding *variable*))
+ (button :text "another one" :layout "wrap")
+ (text-field :binding (make-bean-binding *object* "property1")
+ :layout "growx")
+ (button :text "Test!"
+ :layout "wrap"
+ :on-action (lambda (event)
+ (setf (jproperty-value *object* "property1")
+ "Test!")
+ (setf (var *variable*) "Test var")
+ (setf (aaa *cells-object*) "Test cell"))))))))
+ (pack myframe))
+
+(let ((fr (frame (:title "pippo" :visible-p t)
+ (panel (:layout "wrap")
+ (button :text "ciao" :enabled nil)
+ (button :text "mondo" :enabled 42
+ :on-action (lambda (event)
+ (print "Hello, world!")
+ (print event)))
+ (text-field :binding (make-bean-binding *object* "property1"))
+ (text-field :binding
+ (make-cells-binding (c? (aaa *cells-object*))
+ #'(lambda (x)
+ (setf (aaa *cells-object*) x))))
+ (text-field :binding (make-simple-binding *variable*)
+ :layout "wrap")
+ (label :text "haha")
+ (panel (:layout-manager :mig :layout "grow")
+ (button :text "Test Location" :location #(30 30)))
+ (label :text "hihi")))))
+ (let ((lbl1 (label :text "a label"))
+ (lbl2 (label :text "another")))
+ (add-child lbl1 fr "growx")
+ (add-child lbl2 fr "wrap"))
+ (pack fr))
\ No newline at end of file
Added: trunk/src/java/snow/example/SnowExample.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/example/SnowExample.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,37 @@
+package snow.example;
+
+import javax.script.ScriptException;
+import javax.swing.JFrame;
+import javax.swing.JOptionPane;
+
+import snow.Snow;
+
+import com.jgoodies.binding.beans.Model;
+
+public class SnowExample extends Model {
+
+ private String property1 = "Initial value";
+
+ public static void main(String[] args) {
+ try {
+ Snow.evalResource(Snow.class, "/snow/example/example.lisp");
+ } catch (ScriptException e) {
+ e.printStackTrace();
+ }
+ }
+
+ public void someAction() {
+ JOptionPane.showMessageDialog(null, "Example dialog from Java");
+ }
+
+ public String getProperty1() {
+ return property1;
+ }
+
+ public void setProperty1(String property) {
+ String oldValue = property1;
+ property1 = property;
+ firePropertyChange("property1", oldValue, property1);
+ }
+
+}
Added: trunk/src/java/snow/example/example.lisp
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/example/example.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,68 @@
+(in-package :snow)
+
+(defmodel my-model ()
+ ((a :accessor aaa :initform (c-in "4"))
+ (b :accessor bbb :initform (c? (concatenate 'string (aaa self) "2")))))
+
+(defvar *object* (new "snow.example.SnowExample"))
+(defvar *variable* (make-var "42"))
+(defvar *cells-object* (make-instance 'my-model))
+
+(with-gui (:swing)
+ (let ((myframe
+ (frame (:id frame-id :title "Sample JFrame" :visible-p t)
+ (tree :model (make-tree-model '(1 2 (c (a b)) 3)))
+ (button :text "push me"
+ :on-action (lambda (event)
+ (princ "Thanks for pushing me! ")
+ (format t "My parent is ~A~%" frame-id)
+ (finish-output)))
+ (scroll (:layout "grow")
+ (list-widget :model (make-list-model '(1 2 (c (a b)) 3))
+ :prototype-cell-value "abcdefghijklmnopq"))
+ (panel (:layout-manager :border :layout "wrap")
+ (button :text "borderlayout - center")
+ (button :text "borderlayout - east"
+ :layout (jfield "java.awt.BorderLayout" "EAST")))
+ (scroll ()
+ (panel ()
+ (label :binding (make-bean-binding *object* "property1"))
+ (label :binding (make-cells-binding (c? (aaa *cells-object*))))
+ (label :binding (make-cells-binding (c? (bbb *cells-object*))))
+ (label :binding (make-simple-binding *variable*))
+ (button :text "another one" :layout "wrap")
+ (text-field :binding (make-bean-binding *object* "property1")
+ :layout "growx")
+ (button :text "Test!"
+ :layout "wrap"
+ :on-action (lambda (event)
+ (setf (jproperty-value *object* "property1")
+ "Test property")
+ (setf (var *variable*) "Test var")
+ (setf (aaa *cells-object*) "Test cell"))))))))
+ (pack myframe)))
+
+(let ((fr (frame (:title "pippo" :visible-p t)
+ (panel (:layout "wrap")
+ (button :text "ciao" :enabled nil)
+ (button :text "mondo" :enabled 42
+ :on-action (lambda (event)
+ (print "Hello, world!")
+ (print event)))
+ (text-field :binding (make-bean-binding *object* "property1"))
+ (text-field :binding
+ (make-cells-binding (c? (aaa *cells-object*))
+ #'(lambda (x)
+ (setf (aaa *cells-object*) x))))
+ (text-field :binding (make-slot-binding *cells-object* 'aaa))
+ (text-field :binding (make-simple-binding *variable*)
+ :layout "wrap")
+ (label :text "haha")
+ (panel (:layout-manager :mig :layout "grow")
+ (button :text "Test Location" :location #(30 30)))
+ (label :text "hihi")))))
+ (let ((lbl1 (label :text "a label"))
+ (lbl2 (label :text "another")))
+ (add-child lbl1 fr "growx")
+ (add-child lbl2 fr "wrap"))
+ (pack fr))
Added: trunk/src/java/snow/list/ConsListCellRenderer.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/list/ConsListCellRenderer.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,70 @@
+/*
+ * ConsListCellRenderer.java
+ *
+ * Copyright (C) 2008-2009 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.list;
+
+import java.awt.Component;
+
+import javax.swing.DefaultListCellRenderer;
+import javax.swing.JList;
+
+import org.armedbear.lisp.ConditionThrowable;
+import org.armedbear.lisp.Function;
+import org.armedbear.lisp.LispObject;
+
+public class ConsListCellRenderer extends DefaultListCellRenderer {
+
+ private Function function = null;
+
+ public ConsListCellRenderer() {
+ }
+
+ public ConsListCellRenderer(Function fn) {
+ this.function = fn;
+ }
+
+ @Override
+ public Component getListCellRendererComponent(JList list, Object value,
+ int index, boolean isSelected, boolean cellHasFocus) {
+ Object retVal;
+ try {
+ retVal = function != null && value instanceof LispObject ? function.execute((LispObject) value) : value;
+ if(retVal instanceof LispObject) {
+ retVal = ((LispObject) retVal).writeToString();
+ }
+ } catch (ConditionThrowable e) {
+ throw new RuntimeException(e);
+ }
+ return super.getListCellRendererComponent(list, retVal, index, isSelected, cellHasFocus);
+ }
+
+}
Added: trunk/src/java/snow/list/ConsListModel.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/list/ConsListModel.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,75 @@
+/*
+ * ConsListModel.java
+ *
+ * Copyright (C) 2008-2009 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.list;
+
+import javax.swing.AbstractListModel;
+
+import org.armedbear.lisp.ConditionThrowable;
+import org.armedbear.lisp.Cons;
+import org.armedbear.lisp.Fixnum;
+import org.armedbear.lisp.Lisp;
+import org.armedbear.lisp.LispObject;
+import org.armedbear.lisp.Symbol;
+
+public class ConsListModel extends AbstractListModel {
+
+ private LispObject cons;
+
+ public ConsListModel(Cons cons) {
+ if(cons != null) {
+ this.cons = cons;
+ } else {
+ this.cons = Lisp.NIL;
+ }
+ }
+
+ @Override
+ public Object getElementAt(int index) {
+ try {
+ LispObject o = Symbol.NTH.execute(Fixnum.getInstance(index), cons);
+ return o.javaInstance();
+ } catch (ConditionThrowable e) {
+ throw new RuntimeException(e);
+ }
+ }
+
+ @Override
+ public int getSize() {
+ try {
+ return Symbol.LENGTH.execute(cons).intValue();
+ } catch(ConditionThrowable e) {
+ throw new RuntimeException(e);
+ }
+ }
+
+}
Added: trunk/src/java/snow/swing/ConsoleDocument.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/swing/ConsoleDocument.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,320 @@
+/*
+ * ConsoleDocument.java
+ *
+ * Copyright (C) 2008-2009 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.swing;
+
+import java.awt.Window;
+import java.awt.event.WindowAdapter;
+import java.awt.event.WindowEvent;
+import java.io.BufferedReader;
+import java.io.BufferedWriter;
+import java.io.IOException;
+import java.io.Reader;
+import java.io.Writer;
+
+import javax.swing.JFrame;
+import javax.swing.JScrollPane;
+import javax.swing.JTextArea;
+import javax.swing.event.DocumentEvent;
+import javax.swing.event.DocumentListener;
+import javax.swing.text.AttributeSet;
+import javax.swing.text.BadLocationException;
+import javax.swing.text.DefaultStyledDocument;
+import javax.swing.text.JTextComponent;
+
+import org.armedbear.lisp.ConditionThrowable;
+import org.armedbear.lisp.Function;
+import org.armedbear.lisp.Interpreter;
+import org.armedbear.lisp.LispObject;
+import org.armedbear.lisp.LispThread;
+import org.armedbear.lisp.Package;
+import org.armedbear.lisp.SpecialBinding;
+import org.armedbear.lisp.Stream;
+import org.armedbear.lisp.Symbol;
+import org.armedbear.lisp.TwoWayStream;
+
+public class ConsoleDocument extends DefaultStyledDocument {
+
+ private int lastEditableOffset = 0;
+ private StringBuffer inputBuffer = new StringBuffer();
+
+ private Reader reader = new Reader() {
+
+ @Override
+ public void close() throws IOException {
+ }
+
+ @Override
+ public synchronized int read(char[] cbuf, int off, int len) throws IOException {
+ try {
+ int length = Math.min(inputBuffer.length(), len);
+ while(length <= 0) {
+ wait();
+ length = Math.min(inputBuffer.length(), len);
+ }
+ inputBuffer.getChars(0, length, cbuf, off);
+ inputBuffer.delete(0, length);
+ lastEditableOffset += length;
+ return length;
+ } catch (InterruptedException e) {
+ throw new IOException(e);
+ }
+
+ }
+ };
+
+ private Writer writer = new Writer() {
+
+ @Override
+ public void close() throws IOException {}
+
+ @Override
+ public void flush() throws IOException {}
+
+ @Override
+ public void write(char[] cbuf, int off, int len) throws IOException {
+ synchronized(reader) {
+ try {
+ if(inputBuffer.toString().trim().isEmpty()) {
+ int length = inputBuffer.length();
+ inputBuffer.delete(0, length);
+ lastEditableOffset -= length;
+ }
+ reader.notifyAll();
+ superInsertString(getLength(), new String(cbuf, off, len), null);
+ lastEditableOffset = getLength();
+ } catch (Exception e) {
+ throw new RuntimeException(e);
+ }
+ }
+ }
+ };
+
+ private boolean disposed = false;
+ private final Thread replThread;
+
+ public ConsoleDocument(LispObject replFunction) {
+ final LispObject replWrapper = makeReplWrapper(new StreamEx(new BufferedReader(reader)),
+ new StreamEx(new BufferedWriter(writer)),
+ replFunction);
+ replThread = new Thread("REPL-thread-" + System.identityHashCode(this)) {
+ public void run() {
+ try {
+ while(true) {
+ replWrapper.execute();
+ yield();
+ }
+ } catch (ConditionThrowable e) {
+ throw new RuntimeException(e);
+ }
+ }
+ };
+ replThread.start();
+ }
+
+ @Override
+ public void insertString(int offs, String str, AttributeSet a)
+ throws BadLocationException {
+ if(offs < lastEditableOffset) {
+ throw new BadLocationException("Can only insert after " + lastEditableOffset, offs);
+ }
+ synchronized(reader) {
+ superInsertString(offs, str, a);
+ inputBuffer.insert(offs - lastEditableOffset, str);
+ if(processInputP(inputBuffer, str)) {
+ reader.notifyAll();
+ }
+ }
+ }
+
+ protected void superInsertString(int offs, String str, AttributeSet a)
+ throws BadLocationException {
+ super.insertString(offs, str, a);
+ }
+
+ /**
+ * Guaranteed to run with exclusive access to the buffer.
+ * @param sb NB sb MUST NOT be destructively modified!!
+ * @return
+ */
+ protected boolean processInputP(StringBuffer sb, String str) {
+ if(str.indexOf(System.getProperty("line.separator", "\n")) == -1) {
+ return false;
+ }
+ int parenCount = 0;
+ int len = sb.length();
+ for(int i = 0; i < len; i++) {
+ char c = sb.charAt(i);
+ if(c == '(') {
+ parenCount++;
+ } else if(c == ')') {
+ parenCount--;
+ if(parenCount == 0) {
+ return true;
+ }
+ }
+ }
+ return parenCount <= 0;
+ }
+
+ @Override
+ public void remove(int offs, int len) throws BadLocationException {
+ if(offs < lastEditableOffset) {
+ throw new BadLocationException("Can only remove after " + lastEditableOffset, offs);
+ }
+ super.remove(offs, len);
+ synchronized(reader) {
+ inputBuffer.delete(offs - lastEditableOffset, offs - lastEditableOffset + len);
+ }
+ }
+
+ public Reader getReader() {
+ return reader;
+ }
+
+ public Writer getWriter() {
+ 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() {
+
+ @Override
+ public void changedUpdate(DocumentEvent e) {
+ txt.setCaretPosition(getLength());
+ }
+
+ @Override
+ public void insertUpdate(DocumentEvent e) {
+ txt.setCaretPosition(getLength());
+ }
+
+ @Override
+ public void removeUpdate(DocumentEvent e) {
+ txt.setCaretPosition(getLength());
+ }
+ });
+ txt.setCaretPosition(getLength());
+ }
+
+ public void dispose() {
+ disposed = true;
+ for(DocumentListener listener : getDocumentListeners()) {
+ removeDocumentListener(listener);
+ }
+ try {
+ reader.close();
+ writer.close();
+ } catch (IOException e) {
+ throw new RuntimeException(e);
+ }
+ replThread.interrupt(); //really?
+ }
+
+ private final LispObject debuggerHook = new Function() {
+
+ @Override
+ public LispObject execute(LispObject condition, LispObject debuggerHook)
+ throws ConditionThrowable {
+ if(disposed) {
+ return Package.PACKAGE_SYS.findSymbol("%DEBUGGER-HOOK-FUNCTION").execute(condition, debuggerHook);
+ } else {
+ return NIL;
+ }
+ }
+
+ };
+
+ public LispObject makeReplWrapper(final Stream in, final Stream out, final LispObject fn) {
+ return new Function() {
+ @Override
+ public LispObject execute()
+ throws ConditionThrowable {
+ SpecialBinding lastSpecialBinding = LispThread.currentThread().lastSpecialBinding;
+ try {
+ TwoWayStream ioStream = new TwoWayStream(in, out);
+ LispThread.currentThread().bindSpecial(Symbol.DEBUGGER_HOOK, debuggerHook);
+ LispThread.currentThread().bindSpecial(Symbol.STANDARD_INPUT, in);
+ LispThread.currentThread().bindSpecial(Symbol.STANDARD_OUTPUT, out);
+ LispThread.currentThread().bindSpecial(Symbol.TERMINAL_IO, ioStream);
+ LispThread.currentThread().bindSpecial(Symbol.DEBUG_IO, ioStream);
+ LispThread.currentThread().bindSpecial(Symbol.QUERY_IO, ioStream);
+ return fn.execute();
+ } finally {
+ LispThread.currentThread().lastSpecialBinding = lastSpecialBinding;
+ }
+ }
+
+ };
+ }
+
+ public void disposeOnClose(Window parent) {
+ parent.addWindowListener(new WindowAdapter() {
+ @Override
+ public void windowClosing(WindowEvent e) {
+ dispose();
+ }
+ });
+ }
+
+ public static void main(String[] args) {
+ LispObject repl = null;
+ try {
+ repl = Interpreter.createInstance().eval("#'top-level::top-level-loop");
+ } catch (Throwable e) {
+ e.printStackTrace();
+ System.exit(1);
+ }
+ final ConsoleDocument d = new ConsoleDocument(repl);
+ final JTextComponent txt = new JTextArea(d);
+ d.setupTextComponent(txt);
+ JFrame f = new JFrame();
+ f.add(new JScrollPane(txt));
+ d.disposeOnClose(f);
+ f.setDefaultCloseOperation(f.EXIT_ON_CLOSE);
+ f.pack();
+ f.setVisible(true);
+ }
+
+}
Added: trunk/src/java/snow/swing/WindowListener.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/swing/WindowListener.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,110 @@
+/*
+ * WindowListener.java
+ *
+ * Copyright (C) 2008-2009 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.swing;
+
+import java.awt.event.WindowEvent;
+
+import org.armedbear.lisp.ConditionThrowable;
+import org.armedbear.lisp.JavaObject;
+import org.armedbear.lisp.LispObject;
+
+public class WindowListener implements java.awt.event.WindowListener {
+
+ private LispObject windowActivated;
+ private LispObject windowClosed;
+ private LispObject windowClosing;
+ private LispObject windowDeactivated;
+ private LispObject windowDeiconified;
+ private LispObject windowIconified;
+ private LispObject windowOpened;
+
+ public WindowListener(LispObject windowActivated, LispObject windowClosed,
+ LispObject windowClosing, LispObject windowDeactivated,
+ LispObject windowDeiconified, LispObject windowIconified,
+ LispObject windowOpened) {
+ super();
+ this.windowActivated = windowActivated;
+ this.windowClosed = windowClosed;
+ this.windowClosing = windowClosing;
+ this.windowDeactivated = windowDeactivated;
+ this.windowDeiconified = windowDeiconified;
+ this.windowIconified = windowIconified;
+ this.windowOpened = windowOpened;
+ }
+
+ private static final void invokeDelegate(LispObject delegate, WindowEvent e) {
+ if(delegate != null) {
+ try {
+ delegate.execute(new JavaObject(e));
+ } catch (ConditionThrowable e1) {
+ throw new RuntimeException(e1);
+ }
+ }
+ }
+
+ @Override
+ public void windowActivated(WindowEvent e) {
+ invokeDelegate(windowActivated, e);
+ }
+
+ @Override
+ public void windowClosed(WindowEvent e) {
+ invokeDelegate(windowClosed, e);
+ }
+
+ @Override
+ public void windowClosing(WindowEvent e) {
+ invokeDelegate(windowClosing, e);
+ }
+
+ @Override
+ public void windowDeactivated(WindowEvent e) {
+ invokeDelegate(windowDeactivated, e);
+ }
+
+ @Override
+ public void windowDeiconified(WindowEvent e) {
+ invokeDelegate(windowDeiconified, e);
+ }
+
+ @Override
+ public void windowIconified(WindowEvent e) {
+ invokeDelegate(windowIconified, e);
+ }
+
+ @Override
+ public void windowOpened(WindowEvent e) {
+ invokeDelegate(windowOpened, e);
+ }
+
+}
Added: trunk/src/java/snow/tree/ConsTreeCellRenderer.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/tree/ConsTreeCellRenderer.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,70 @@
+/*
+ * ConsTreeCellRenderer.java
+ *
+ * Copyright (C) 2008-2009 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.tree;
+
+import java.awt.Component;
+
+import javax.swing.JTree;
+import javax.swing.tree.DefaultTreeCellRenderer;
+
+import org.armedbear.lisp.ConditionThrowable;
+import org.armedbear.lisp.Cons;
+import org.armedbear.lisp.LispObject;
+
+public class ConsTreeCellRenderer extends DefaultTreeCellRenderer {
+
+ @Override
+ public Component getTreeCellRendererComponent(JTree tree, Object value,
+ boolean sel, boolean expanded, boolean leaf, int row,
+ boolean hasFocus) {
+ if(value instanceof LispObject) {
+ LispObject obj = (LispObject) value;
+ try {
+ if(obj instanceof Cons) {
+ return super.getTreeCellRendererComponent(tree, ((Cons) obj).car.writeToString(), sel, expanded, leaf,
+ row, hasFocus);
+ } else {
+ return super.getTreeCellRendererComponent(tree, obj.writeToString(), sel, expanded, leaf,
+ row, hasFocus);
+ }
+ } catch(ConditionThrowable t) {
+ //Should never happen
+ throw new RuntimeException(t);
+ }
+ } else {
+ return super.getTreeCellRendererComponent(tree, value, sel, expanded, leaf,
+ row, hasFocus);
+ }
+ }
+
+}
Added: trunk/src/java/snow/tree/ConsTreeModel.java
==============================================================================
--- (empty file)
+++ trunk/src/java/snow/tree/ConsTreeModel.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,136 @@
+/*
+ * ConsTreeModel.java
+ *
+ * Copyright (C) 2008-2009 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.tree;
+
+import java.util.ArrayList;
+import java.util.List;
+
+import javax.swing.event.TreeModelListener;
+import javax.swing.tree.TreeModel;
+import javax.swing.tree.TreePath;
+
+import org.armedbear.lisp.ConditionThrowable;
+import org.armedbear.lisp.Cons;
+import org.armedbear.lisp.Fixnum;
+import org.armedbear.lisp.Lisp;
+import org.armedbear.lisp.LispObject;
+import org.armedbear.lisp.Symbol;
+
+public class ConsTreeModel implements TreeModel {
+
+ private Cons cons;
+ private List<TreeModelListener> listeners = new ArrayList<TreeModelListener>();
+
+ public ConsTreeModel(Cons cons) {
+ super();
+ this.cons = cons;
+ }
+
+ @Override
+ public Object getChild(Object parent, int index) {
+ if(parent instanceof Cons) {
+ try {
+ return Symbol.NTH.execute(Fixnum.getInstance(index + 1), (Cons) parent);
+ } catch (ConditionThrowable e) {
+ return null;
+ }
+ } else {
+ return null;
+ }
+ }
+
+ @Override
+ public int getChildCount(Object parent) {
+ if(parent instanceof Cons) {
+ try {
+ return ((Fixnum) Symbol.LENGTH.execute((Cons) parent)).value - 1;
+ } catch (ConditionThrowable e) {
+ return 0;
+ }
+ } else {
+ return 0;
+ }
+ }
+
+ @Override
+ public int getIndexOfChild(Object parent, Object child) {
+ if(parent == null || child == null) {
+ return -1;
+ }
+ try {
+ if(Symbol.MEMBER.execute((LispObject) parent, cons) != Lisp.NIL) {
+ Object pos = Symbol.POSITION.execute((LispObject) child, (LispObject) parent);
+ if(pos instanceof Fixnum) {
+ return ((Fixnum) pos).value - 1;
+ } else {
+ return -1;
+ }
+ } else {
+ return -1;
+ }
+ } catch (ConditionThrowable e) {
+ return -1;
+ }
+ }
+
+ @Override
+ public Object getRoot() {
+ return cons;
+ }
+
+ @Override
+ public boolean isLeaf(Object node) {
+ try {
+ return Symbol.ATOM.execute((LispObject) node) != Lisp.NIL;
+ } catch (ConditionThrowable e) {
+ return true;
+ }
+ }
+
+ @Override
+ public void addTreeModelListener(TreeModelListener l) {
+ listeners.add(l);
+ }
+
+ @Override
+ public void removeTreeModelListener(TreeModelListener l) {
+ listeners.remove(l);
+ }
+
+ @Override
+ public void valueForPathChanged(TreePath path, Object newValue) {
+ // TODO Auto-generated method stub
+
+ }
+
+}
Added: trunk/src/lisp/snow/backend.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/backend.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,2 @@
+;;Edit this file to choose the backend that should be used by Snow
+(asdf:oos 'asdf:load-op :snow-swing)
\ No newline at end of file
Added: trunk/src/lisp/snow/compile-system.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/compile-system.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,17 @@
+(require :asdf)
+
+(unwind-protect
+ (unless
+ (progn
+ (pushnew #P"snow/" asdf:*central-registry* :test #'equal)
+ (pushnew #P"snow/swing/" asdf:*central-registry* :test #'equal)
+ (pushnew #P"cells/" asdf:*central-registry* :test #'equal)
+ (pushnew #P"cells/utils-kt/" asdf:*central-registry* :test #'equal)
+ (pushnew :snow-cells *features*)
+
+ (format t "asdf:*central-registry*: ~A" asdf:*central-registry*)
+
+ (asdf:oos 'asdf:compile-op :snow)
+ t)
+ (format t "failed"))
+ (quit))
\ No newline at end of file
Added: trunk/src/lisp/snow/debugger.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/debugger.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,74 @@
+;;; debugger.lisp
+;;;
+;;; Copyright (C) 2008-2009 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)
+
+(defvar *graphical-debugger-hook*
+ (lambda (condition debugger-hook)
+ (declare (ignore debugger-hook))
+ (show-snow-debugger condition)))
+
+(defun show-snow-debugger (condition)
+ (let* ((restarts (compute-restarts))
+ (list (list-widget
+ :model (make-list-model
+ (mapcar (lambda (restart)
+ (format nil "~A" (restart-name restart)))
+ restarts)))))
+ (dialog (:id dlg :title "Condition signaled" :modal-p t)
+ (label
+ :layout "wrap"
+ :text (format nil
+ "Debugger invoked on condition of type ~A:"
+ (type-of condition)))
+ (label :layout "wrap" :text (format nil "~A" condition))
+ (label :layout "wrap" :text "Available restarts:")
+ (scroll (:layout "grow, wrap") list)
+ (button :text "Ok"
+ :on-action (lambda (evt)
+ (declare (ignore evt))
+ (when (>= (widget-property list :selected-index) 0)
+ (dispose dlg))))
+ (pack dlg)
+ (show dlg))
+ (let ((*query-io* (make-dialog-prompt-stream)))
+ (when (>= (widget-property list :selected-index) 0)
+ (invoke-restart-interactively
+ (nth (widget-property list :selected-index) restarts))))))
+
+(defun install-graphical-debugger ()
+ (let ((old-debugger-hook *debugger-hook*))
+ (setq *debugger-hook* *graphical-debugger-hook*)
+ (values *debugger-hook* old-debugger-hook)))
+
+(defun test-graphical-debugger ()
+ (let ((*debugger-hook* *debugger-hook*))
+ (install-graphical-debugger)
+ (eval '(omfg))))
\ No newline at end of file
Added: trunk/src/lisp/snow/inspector.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/inspector.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,175 @@
+;;; inspector.lisp
+;;;
+;;; Copyright (C) 2008-2009 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)
+
+(defclass object-descriptor ()
+ ((object :initarg :object :reader described-object)
+ (description :initarg :description :accessor object-description)
+ (type :initarg :type :accessor object-type)
+ (class :initarg :class :accessor object-class)))
+
+(defgeneric object-parts (descriptor))
+
+(defmethod object-parts ((descriptor object-descriptor))
+ (describe-parts (described-object descriptor)))
+
+(defgeneric refreshed-descriptor (obj))
+
+(defmethod refreshed-descriptor ((obj object-descriptor))
+ (object-descriptor (described-object obj)))
+
+#|
+(defgeneric inspector-actions (obj))
+
+(defmethod inspector-actions ((obj object-descriptor))
+ (cond
+ ((jinstance-of-p (described-object obj)
+ "org.armedbear.lisp.JavaObject.FieldRef")
+ )))|#
+
+(defun make-object-descriptor (obj description)
+ (make-instance 'object-descriptor
+ :object obj
+ :description description
+ :type (type-of obj)
+ :class (class-of obj)))
+
+(defgeneric object-descriptor (obj))
+
+(defmethod object-descriptor (obj)
+ (make-object-descriptor obj (sys::inspected-description obj)))
+
+(defgeneric describe-parts (obj))
+
+(defmethod describe-parts (obj)
+ (mapcar (lambda (pair)
+ (cons (car pair) (object-descriptor (cdr pair))))
+ (sys:inspected-parts obj)))
+
+(defmethod describe-parts ((obj package))
+ `(("symbols" . ,(object-descriptor
+ (loop :for x :being :the :present-symbols :of obj
+ :collect x)))))
+
+(defmethod describe-parts ((obj cons))
+ (if (listp (cdr obj))
+ (loop
+ :for i :from 0
+ :for x :in obj
+ :collect (cons (princ-to-string i)
+ (object-descriptor x)))
+ `(("car" . ,(object-descriptor (car obj)))
+ ("cdr" . ,(object-descriptor (cdr obj))))))
+
+(defun part-name (part)
+ (car part))
+
+(defun part-descriptor (part)
+ (cdr part))
+
+(defmacro with-parent-widget (parent &body body)
+ `(let ((*parent* ,parent))
+ , at body))
+
+(defun inspector-panel (stack container &optional window)
+ (let ((descr (refreshed-descriptor (car stack))))
+ (panel (:id panel
+ :layout-manager (:box :y))
+ (scroll (:layout "grow, wrap")
+ (with-widget ((text-area :text (object-description descr))
+ :id txt :layout "grow")
+ (setf (widget-property txt :line-wrap) (jbool t))));Swing specific!!!
+ (bwhen (parts (object-parts descr))
+ (with-parent-widget panel
+ (tabs (:id tabs :layout "grow, wrap" :wrap nil :tab-placement :left)
+ (dolist (part parts)
+ (let ((part part))
+ (tab (part-name part)
+ (panel ()
+ (text-area
+ :text (object-description (part-descriptor part))
+ :layout "grow, wrap, span 2")
+ (button
+ :text "Inspect"
+ :layout "wrap"
+ :on-action (lambda (evt)
+ (update-inspector
+ panel
+ (inspector-panel (cons (part-descriptor part)
+ stack)
+ container window)
+ container)))
+ (button :text "Inspect (new window)"
+ :on-action (lambda (evt)
+ (inspect-object (part-descriptor part)))))))))))
+ (scroll (:layout "grow, wrap")
+ (gui-repl :dispose-on-close window))
+ (panel ()
+ (button :text "Back" :enabled-p (cdr stack)
+ :on-action (lambda (evt)
+ (update-inspector
+ panel
+ (inspector-panel (cdr stack) container window)
+ container)))))))
+
+(defun update-inspector (old-panel new-panel container)
+ (invoke "remove" container old-panel);Swing specific!!!
+ (add-child new-panel container)
+ (invoke "validate" container);Swing specific!!!
+ (pack container))
+
+(defun ensure-object-descriptor (obj)
+ (if (typep obj 'object-descriptor)
+ obj
+ (object-descriptor obj)))
+
+(defun inspect-object (obj)
+ (let ((stack (list (ensure-object-descriptor obj))))
+ (with-gui ()
+ (frame (:id frame :layout-manager :border)
+ (add-child (inspector-panel stack frame frame) frame)
+ (pack frame)
+ (show frame)))))
+
+(defun install-graphical-inspector ()
+ (let ((old-inspector-hook ext:*inspector-hook*))
+ (setq ext:*inspector-hook* #'inspect-object)
+ (values ext:*inspector-hook* old-inspector-hook)))
+
+#||
+(inspect-object 3)
+(inspect-object 'inspect-object)
+(inspect-object *package*)
+(inspect-object *standard-output*)
+(inspect-object (new "java.util.ArrayList"))
+(inspect-object (new "javax.swing.JButton"))
+(inspect-object (inspect-object 3))
+||#
\ No newline at end of file
Added: trunk/src/lisp/snow/packages.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/packages.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,53 @@
+;;; packages.lisp
+;;;
+;;; Copyright (C) 2008-2009 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.
+
+
+(defpackage :snow
+ (:use :common-lisp :java #+snow-cells :cells)
+ (:shadow #+snow-cells #:dbg)
+ (:export
+ ;Widgets
+ #:button
+ #:frame
+ #:label
+ #:panel
+ #:text-field
+ ;Common operations on widgets
+ #:hide
+ #:pack
+ #:show
+ ;Various
+ #:install-graphical-debugger
+ #:*parent*
+ #:self
+ #:with-widget))
+
+(defpackage :snow-user
+ (:use :common-lisp :snow :java :ext #+snow-cells :cells))
\ No newline at end of file
Added: trunk/src/lisp/snow/repl.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/repl.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,40 @@
+;;; repl.lisp
+;;;
+;;; Copyright (C) 2008-2009 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)
+
+(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.")
+
+(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.")
Added: trunk/src/lisp/snow/sexy-java.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/sexy-java.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,196 @@
+;;; sexy-java.lisp
+;;;
+;;; Copyright (C) 2008-2009 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)
+
+(defpackage :java-classes (:nicknames :jcl))
+
+(defun java-class-name (java-class)
+ (let* ((name (jclass-name java-class))
+ (pos (position #\. name :from-end t)))
+ (if pos
+ (subseq name (1+ pos))
+ name)))
+
+(defun intern-and-export (string &optional (package *package*))
+ (let ((sym (intern string package)))
+ (export sym package)
+ sym))
+
+(defun intern-java-class (java-class-designator &optional symbol)
+ (let* ((java-class (jclass java-class-designator))
+ (interned-symbol
+ (or symbol
+ (intern-and-export (string-upcase (java-class-name java-class))
+ :java-classes)))
+ (interned-class (get interned-symbol 'java-class)))
+ (flet ((do-intern-java-class (java-class)
+ (progn (setf (get interned-symbol 'java-class) java-class)
+ (values interned-symbol java-class))))
+ (if interned-class
+ (if (equal interned-class java-class)
+ (values interned-symbol java-class)
+ (restart-case
+ (error "Symbol ~A already refers to java class ~A"
+ interned-symbol (jclass-name interned-class))
+ (continue ()
+ :report "Keep the previous import and ignore the new one."
+ (values interned-symbol interned-class))
+ (replace ()
+ :report "Replace the previous import with the new one."
+ (do-intern-java-class java-class))))
+ (do-intern-java-class java-class)))))
+
+(defun jmethod-parameter-types (method-or-constructor)
+ (jcall (jmethod (jclass-of method-or-constructor) "getParameterTypes")
+ method-or-constructor))
+
+(defun jclass-superclass-p/autoboxing (super class)
+ (let ((boolean-type #.(jfield "java.lang.Boolean" "TYPE"))
+ (boolean-class #.(jclass "java.lang.Boolean"))
+ (integer-type #.(jfield "java.lang.Integer" "TYPE"))
+ (integer-class #.(jclass "java.lang.Integer")))
+ (or (null class)
+ (jclass-superclass-p super class) ;TODO handle other primitive types
+ (and (equal super boolean-type) (equal class boolean-class))
+ (and (equal super boolean-class) (equal class boolean-type))
+ (and (equal super integer-type) (equal class integer-class))
+ (and (equal super integer-class) (equal class integer-type)))))
+
+(defun jmethod-applicable-p (method-or-constructor arg-types)
+ (let ((param-types (jmethod-parameter-types method-or-constructor)))
+ (and (eql (length arg-types) (length param-types)) ;TODO handle varargs? how?
+ (every #'identity (map 'vector #'jclass-superclass-p/autoboxing
+ param-types
+ arg-types)))))
+
+(defun java-class-of (obj)
+ (when obj
+ (jcall (jmethod "java.lang.Object" "getClass") obj)))
+
+(defun derive-java-types (args)
+ (mapcar #'java-class-of args))
+
+(defun find-applicable-jmethod (class method-name args)
+ (let ((arg-types (derive-java-types args))
+ (methods (jclass-methods (jclass class))))
+ (dotimes (i (length methods))
+ (let ((method (aref methods i)))
+ (when (and
+ (string= (jmethod-name method) method-name)
+ (jmethod-applicable-p method arg-types))
+ (return-from find-applicable-jmethod method))))))
+
+(defun find-applicable-jconstructor (class args)
+ (let ((arg-types (derive-java-types args))
+ (constructors (jclass-constructors (jclass class))))
+ (dotimes (i (length constructors))
+ (let ((constructor (aref constructors i)))
+ (when (jmethod-applicable-p constructor arg-types)
+ (return-from find-applicable-jconstructor constructor))))))
+
+(defun canonicalize-jclass (class)
+ (typecase class
+ (symbol (get class 'java-class))
+ (t (jclass class))))
+
+(defun new (class &rest args)
+ (let ((constr (find-applicable-jconstructor
+ (canonicalize-jclass class)
+ args)))
+ (if constr
+ (apply #'jnew constr args)
+ (error "No applicable constructor for ~A (args: ~A, types: ~A)"
+ class args (mapcar #'jclass-name
+ (derive-java-types args))))))
+
+(defun invoke (method object &rest args)
+ (if (jinstance-of-p method "java.lang.reflect.Method")
+ (apply #'jcall method object args)
+ (let ((jmethod (find-applicable-jmethod
+ (java-class-of object)
+ method
+ args)))
+ (if jmethod
+ (apply #'jcall jmethod object args)
+ (error "No applicable method ~A in ~A (class: ~A) for args: ~A, types: ~A"
+ method object (java-class-of object)
+ args (mapcar #'jclass-name (derive-java-types args)))))))
+
+(defmacro jimport (class &optional symbol)
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (intern-java-class ,class ,symbol)))
+
+(define-compiler-macro new (&whole form class &rest args)
+ (let ((constr
+ (when (constantp class)
+ (ignore-errors
+ (find-applicable-jconstructor
+ (canonicalize-jclass (eval class))
+ args)))))
+ (if constr
+ `(jnew ,constr , at args)
+ form))) ;Try delaying method resolution till runtime...
+
+(defun jbool (obj)
+ (make-immediate-object (not (not obj)) :boolean))
+
+(defun jnot (obj)
+ (make-immediate-object (not obj) :boolean))
+
+(define-compiler-macro invoke (&whole form method object &rest args)
+ (if (constantp method)
+ (let ((method (eval method)))
+ (cond
+ ((jinstance-of-p method "java.lang.reflect.Method")
+ `(jcall ,method ,object , at args))
+ ((null args)
+ (if (constantp object)
+ `(jcall (jmethod ,(java-class-of (eval object)) ,method) ,object)
+ (let ((obj (gensym)))
+ `(let ((,obj ,object))
+ (jcall (jmethod (java-class-of ,obj) ,method) ,obj)))))
+ ((and (constantp object) (every #'constantp args))
+ (let* ((obj (eval object))
+ (meth (ignore-errors
+ (find-applicable-jmethod
+ (java-class-of obj)
+ method
+ (mapcar #'eval args)))))
+ (if meth
+ `(jcall ,meth ,object , at args)
+ form))) ;Try delaying method resolution till runtime...
+ (t form)))
+ form))
+
+(defun ensure-list (obj)
+ (if (listp obj)
+ obj
+ (list obj)))
\ No newline at end of file
Added: trunk/src/lisp/snow/snow.asd
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/snow.asd Wed Sep 30 16:06:52 2009
@@ -0,0 +1,43 @@
+;;; snow.asd
+;;;
+;;; Copyright (C) 2008-2009 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.
+
+;;Core stuff + cells if needed
+(asdf:defsystem :snow
+ :serial t
+ :version "0.1"
+ :depends-on (#+snow-cells :cells)
+ :components ((:file "packages")
+ (:file "sexy-java")
+ (:file "utils")
+ (:file "snow")
+ (:file "repl")
+ (:file "backend")
+ (:file "debugger")
+ (:file "inspector")))
\ No newline at end of file
Added: trunk/src/lisp/snow/snow.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/snow.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,302 @@
+;;; snow.lisp
+;;;
+;;; Copyright (C) 2008-2009 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)
+
+(defvar *parent* nil)
+
+(defun dashed->camelcased (string-designator)
+ (let ((str (string string-designator))
+ (last-was-dash-p nil))
+ (with-output-to-string (out)
+ (map nil (lambda (ch)
+ (if (char= #\- ch)
+ (setq last-was-dash-p t)
+ (if last-was-dash-p
+ (progn
+ (princ (char-upcase ch) out)
+ (setq last-was-dash-p nil))
+ (princ (char-downcase ch) out))))
+ str))))
+
+(defgeneric widget-property (widget name))
+(defgeneric (setf widget-property) (value widget name))
+
+(defmethod (setf widget-property) (value widget name)
+ (setf (jproperty-value widget (dashed->camelcased name))
+ value))
+
+(defmethod widget-property (widget name)
+ (jproperty-value widget (dashed->camelcased name)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun map-keys (fn arglist &key (filter-if (constantly nil)))
+ "Maps _fn_ over _arglist_, returning a new list containing the results of applying _fn_ on each key-value pair, in the same order. As an exception to this, when _fn_ returns a value V such that (funcall _filter-if_ V) is true, the value is not included in the returned list."
+ (when arglist
+ (let (key result)
+ (loop
+ :for x :in arglist :for even := t :then (not even)
+ :if even :do (setq key x)
+ :else :do (let ((value (funcall fn key x)))
+ (unless (funcall filter-if value)
+ (push value result))))
+ (nreverse result)))))
+
+(defmacro set-widget-properties (widget &rest props)
+ (with-unique-names (widget-var)
+ `(let ((,widget-var ,widget))
+ ,@(map-keys (lambda (key value)
+ `(setf (widget-property ,widget-var ,key) ,value))
+ props))))
+
+(defgeneric bind-widget (widget binding))
+
+(definterface make-layout-manager *gui-backend* (widget type &rest args))
+
+(defun generate-common-container-setup
+ (&key (layout-manager :default) &allow-other-keys)
+ `((setf (widget-property self :layout);;Swing specific!!
+ (make-layout-manager self ,@(ensure-list layout-manager)))))
+
+(defun generate-default-children-processing-code (id children)
+ (let ((code
+ (loop
+ :for form :in children
+ :collect (if (listp form)
+ (cond
+ ((get (car form) 'widget-p)
+ `(let ((*parent* self)) ,form))
+ (t `(let ((*parent* nil)) ,form)))
+ form))))
+ (if id
+ `((let ((,id self))
+ , at code))
+ code)))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun common-widget-args ()
+ '(id layout binding (enabled-p t) location size))
+ (defun common-widget-args-declarations ()
+ (let ((arg-names (mapcar (lambda (x) (if (atom x) x (car x)))
+ (common-widget-args))))
+ `((declare (ignorable , at arg-names)))))
+ (defun filter-widget-args (args)
+ "Eliminates widget arguments processed by common-widget-setup; else, they would be evaluated twice in the macro expansion."
+ (loop
+ :for key :in args :by #'cddr
+ :for value :in (cdr args) by #'cddr
+ :when (not (member key '(:id :layout :binding :enabled-p :location
+ :layout-manager :size)))
+ :collect key :and
+ :collect value)))
+
+(defun common-widget-setup (self layout binding enabled-p location size)
+ (when *parent* (add-child self *parent* layout))
+ (setf (widget-enabled-p self) enabled-p)
+ (when location (setf (widget-location self) location))
+ (when binding (bind-widget self binding))
+ (when size (setf (widget-size self) size)))
+
+#+emacs (put 'define-widget-macro 'lisp-indent-function 3)
+#+emacs (put 'define-widget 'lisp-indent-function 3)
+#+emacs (put 'define-container-widget 'lisp-indent-function 3)
+
+(defmacro define-widget-macro (name arglist constructor &body body)
+ `(progn
+ (defmacro ,name (, at arglist)
+ `(let ((self ,,constructor)) ;The lexical variable self is always bound to the current widget.
+ ,, at body
+ self))
+ (setf (get ',name 'widget-p) t)))
+
+;Experimental - not working right now
+(defmacro define-widget-function (name arglist constructor &body body)
+ `(progn
+ (defun ,name (, at arglist)
+ `(let ((self ,,constructor)) ;The lexical variable self is always bound to the current widget.
+ ,, at body
+ self))
+ (setf (get ',name 'widget-p) t)))
+
+(define-widget-macro with-widget
+ ((widget &rest args &key id layout binding (enabled-p t) location size)
+ &body body)
+ `(dont-add ,widget)
+ `(progn
+ ,@(generate-default-children-processing-code id body)
+ (common-widget-setup self ,layout ,binding ,enabled-p ,location ,size)))
+
+(defmacro define-widget (name keys constructor &body body)
+ (with-unique-names (args)
+ `(define-widget-macro ,name
+ (&rest ,args &key ,@(common-widget-args) , at keys)
+ `(,',constructor ,@(filter-widget-args ,args))
+ `(progn
+ (common-widget-setup self ,layout ,binding ,enabled-p ,location
+ ,size)
+ ,, at body))))
+
+(defmacro define-container-widget (name keys constructor &body body)
+ (with-unique-names (args macro-body)
+ `(define-widget-macro ,name
+ ((&rest ,args &key ,@(common-widget-args) layout-manager , at keys)
+ &body ,macro-body)
+ `(,',constructor ,@(filter-widget-args ,args))
+ `(progn
+ ,@(apply #'generate-common-container-setup ,args)
+ ,(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)
+ (common-widget-setup self ,layout ,binding ,enabled-p ,location
+ ,size)))))
+
+(defmacro auto-add-children (&body body)
+ `(let ((*parent* self))
+ , at body))
+
+(defmacro dont-add (&body body)
+ `(let ((*parent* nil))
+ , at body))
+
+(definterface call-in-gui-thread *gui-backend* (fn)
+ "Arranges <fn> to be called from a thread in which it is safe to create GUI components (for example, the Event Dispatching Thread in Swing).")
+
+(defmacro with-gui ((&optional (gui-backend '*gui-backend*)) &body body)
+ (with-unique-names (gui-backend-var)
+ `(let* ((,gui-backend-var ,gui-backend)
+ (*gui-backend* ,gui-backend-var))
+ (call-in-gui-thread
+ (lambda ()
+ (let ((*gui-backend* ,gui-backend-var))
+ , at body))))))
+
+;;Common Interfaces
+(defvar *gui-backend* :swing)
+
+(definterface add-child *gui-backend* (child &optional (parent *parent*) layout-constraints))
+
+(definterface widget-enabled-p *gui-backend* (widget))
+
+(definterface (setf widget-enabled-p) *gui-backend* (value widget))
+
+(definterface (setf widget-location) *gui-backend* (value widget))
+
+(definterface (setf widget-size) *gui-backend* (value widget))
+
+(definterface dispose *gui-backend* (obj))
+
+(definterface show *gui-backend* (obj))
+
+(definterface hide *gui-backend* (obj))
+
+(definterface pack *gui-backend* (window))
+
+;;Windows
+(definterface make-frame *gui-backend* (&key title visible-p on-close))
+
+(define-container-widget frame (title visible-p on-close) make-frame)
+
+(definterface make-dialog *gui-backend*
+ (&key parent title modal-p visible-p))
+
+(define-container-widget dialog (parent title modal-p visible-p)
+ make-dialog)
+
+;;Panels
+(definterface make-panel *gui-backend* (&key &allow-other-keys))
+
+(define-container-widget panel () make-panel)
+
+(defvar *tabs*)
+
+(definterface make-tabs *gui-backend* (&key (wrap t) (tab-placement :top)
+ &allow-other-keys))
+
+(define-widget-macro tabs
+ ((&rest args
+ &key id layout binding (enabled-p t) location size (wrap t)
+ (tab-placement :top))
+ &body body)
+ `(make-tabs :wrap ,wrap :tab-placement ,tab-placement)
+ `(let ((*tabs* self))
+ (dont-add
+ ,@(if id
+ `((let ((,id self))
+ , at body))
+ body))
+ (common-widget-setup self ,layout ,binding ,enabled-p ,location ,size)))
+
+(defmacro tab (name &body body)
+ `(if *tabs*
+ (add-child (progn , at body) *tabs* ,name)
+ (error "tab outside tabset: ~A" ,name)))
+
+(definterface make-scroll-panel *gui-backend* (view))
+
+(definterface scroll-panel-view *gui-backend* (self))
+
+(definterface (setf scroll-panel-view) *gui-backend* (view self))
+
+(define-widget-macro scroll
+ ((&rest args &key layout binding (enabled-p t) location size) body)
+ `(make-scroll-panel (dont-add ,body))
+ `(common-widget-setup self ,layout ,binding ,enabled-p ,location ,size))
+
+;;Buttons and similar
+(definterface make-button *gui-backend* (&key text on-action &allow-other-keys))
+
+(define-widget button (text on-action &allow-other-keys) make-button)
+
+(definterface make-check-box *gui-backend* (&key text selected-p &allow-other-keys))
+
+(define-widget check-box (text selected-p &allow-other-keys) make-check-box)
+
+;;Text
+(definterface make-label *gui-backend* (&key text &allow-other-keys))
+
+(define-widget label (text &allow-other-keys) make-label)
+
+(definterface make-text-field *gui-backend* (&key text &allow-other-keys))
+
+(define-widget text-field (text &allow-other-keys) make-text-field)
+
+(definterface make-text-area *gui-backend* (&key text &allow-other-keys))
+
+(define-widget text-area (text &allow-other-keys) make-text-area)
+
+;;Lists
+(definterface make-list-widget *gui-backend* (&key model selected-index &allow-other-keys))
+
+(define-widget list-widget (model selected-index &allow-other-keys)
+ make-list-widget)
+
+;;Trees
+(definterface make-tree-widget *gui-backend* (&key model &allow-other-keys))
+
+(define-widget tree (model &allow-other-keys) make-tree-widget)
\ No newline at end of file
Added: trunk/src/lisp/snow/start.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/start.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,40 @@
+;;; start.lisp
+;;;
+;;; Copyright (C) 2008-2009 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)
+
+(with-gui ()
+ (frame (:id frame :title "ABCL - Snow REPL"
+ :size #C(800 300)
+ :visible-p t :layout-manager (:mig "fill" "[fill]" "")
+ :on-close :exit)
+ (scroll (:layout "grow")
+ (gui-repl :dispose-on-close frame
+ :environment `((*package* ,(find-package :snow-user)))))))
Added: trunk/src/lisp/snow/swing/binding-jgoodies.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/swing/binding-jgoodies.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,163 @@
+;;; binding-jgoodies.lisp
+;;;
+;;; Copyright (C) 2008-2009 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)
+
+(defvar *presentation-model*)
+
+(defclass binding ()
+ ((converter :initarg :converter :initform nil :accessor binding-converter)))
+
+(defgeneric make-model (binding))
+
+(defmethod make-model :around ((binding binding))
+ (let ((model (call-next-method)))
+ (with-slots (converter) binding
+ (cond
+ ((functionp converter)
+ (new "snow.binding.Converter" model converter converter))
+ ((consp converter)
+ (new "snow.binding.Converter" model (car converter) (cdr converter)))
+ ((null converter) model)
+ (t (error "~A is not a valid converter" converter))))))
+
+(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 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)
+
+(defun trigger-commit (&optional (presentation-model *presentation-model*))
+ (jcall (jmethod "com.jgoodies.binding.PresentationModel"
+ "triggerCommit")
+ presentation-model))
+
+(defmacro form ((bean) &body body)
+ `(let ((*presentation-model*
+ (new "com.jgoodies.binding.PresentationModel" ,bean)))
+ , at body))
+
+(defmacro make-action (args &body body)
+ (with-unique-names (presentation-model)
+ `(let ((,presentation-model *presentation-model*))
+ (lambda ,args
+ (let ((*presentation-model* ,presentation-model))
+ , at body)))))
+
+;;Concrete Binding implementations
+
+;;Simple Binding
+(defclass simple-binding (binding)
+ ((variable :initarg :variable :reader binding-variable :initform (error "variable is required"))))
+
+(defun make-var (&optional obj)
+ (new "com.jgoodies.binding.value.ValueHolder" obj (jbool nil)))
+
+(defun var (var)
+ (invoke "getValue" var))
+
+(defun (setf var) (value var)
+ (invoke "setValue" var value)
+ value)
+
+(defun make-simple-binding (variable)
+ (make-instance 'simple-binding :variable variable))
+
+(defmethod make-model ((binding simple-binding))
+ (binding-variable binding))
+
+;;Bean Binding
+(defclass bean-binding (binding)
+ ((object :initarg :object :reader binding-object
+ :initform (or *presentation-model* (error "object is required")))
+ (property :initarg :property :reader binding-property
+ :initform (error "property is required"))
+ (observed-p :initarg :observed-p :reader binding-observed-p :initform t)
+ (buffered-p :initarg :buffered-p :reader binding-buffered-p :initform nil)))
+
+(defun make-bean-binding (object property &rest args)
+ (apply #'make-instance 'bean-binding :object object :property property
+ args))
+
+(defmethod make-model ((binding bean-binding))
+ (let ((presentation-model-class
+ (jclass "com.jgoodies.binding.PresentationModel")))
+ (if (jinstance-of-p (binding-object binding) presentation-model-class)
+ (if (binding-buffered-p binding)
+ (jcall (jmethod presentation-model-class
+ "getBufferedModel" "java.lang.String")
+ (binding-object binding)
+ (dashed->camelcased (binding-property binding)))
+ (jcall (jmethod presentation-model-class
+ "getModel" "java.lang.String")
+ (binding-object binding)
+ (dashed->camelcased (binding-property binding))))
+ (jnew (jconstructor "com.jgoodies.binding.beans.PropertyAdapter"
+ "java.lang.Object" "java.lang.String"
+ "boolean")
+ (binding-object binding)
+ (dashed->camelcased (binding-property binding))
+ (jbool (binding-observed-p binding))))))
+
+;;Default binding types
+(defun default-binding-types ()
+ (let ((ht (make-hash-table)))
+ (setf (gethash :simple ht) 'simple-binding)
+ (setf (gethash :bean ht) 'bean-binding)
+ ht))
+
+(defparameter *binding-types* (default-binding-types))
+
+(defun get-binding-class (binding-type)
+ (if (keywordp binding-type)
+ (gethash binding-type *binding-types*)
+ binding-type))
+
+(defun make-binding (type &rest options)
+ (apply #'make-instance (get-binding-class type) options))
Added: trunk/src/lisp/snow/swing/cells.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/swing/cells.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,73 @@
+;;; cells.lisp
+;;;
+;;; Copyright (C) 2008-2009 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)
+
+;;Cellular slot Binding
+(defmodel cells-binding (binding cells::model-object)
+ ((expression :initarg :expression :reader binding-expression
+ :initform (error "expression is mandatory")
+ :cell t)
+ (writer :initarg writer :accessor binding-writer :initform nil :cell nil)
+ (model :accessor binding-model :initform nil :cell nil)))
+
+(defmethod initialize-instance :after ((obj cells-binding) &rest args)
+ (declare (ignore args))
+ (setf (binding-model obj)
+ (make-cells-value-model obj)))
+
+(defobserver expression ((binding cells-binding) new-value)
+ (bwhen (it (binding-model binding))
+ (invoke "valueChanged" it new-value)))
+
+(defun make-cells-binding (expression &optional writer)
+ (check-type writer (or null function))
+ (let ((instance
+ (make-instance 'cells-binding :expression expression)))
+ (setf (binding-writer instance) writer)
+ instance))
+
+(defun make-slot-binding (object slot-accessor-name)
+ (make-cells-binding
+ (eval `(c? (,slot-accessor-name ,object)))
+ (compile nil `(lambda (x)
+ (setf (,slot-accessor-name ,object) x)))))
+
+(defmethod make-model ((binding cells-binding))
+ (binding-model binding))
+
+(defun make-cells-value-model (binding)
+ (new "snow.binding.AccessorBinding"
+ binding
+ #'binding-expression
+ (lambda (value place)
+ (declare (ignore place))
+ (bwhen (it (binding-writer binding))
+ (funcall it value)))))
\ No newline at end of file
Added: trunk/src/lisp/snow/swing/snow-swing.asd
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/swing/snow-swing.asd Wed Sep 30 16:06:52 2009
@@ -0,0 +1,39 @@
+;;; snow-swing.asd
+;;;
+;;; Copyright (C) 2008-2009 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.
+
+;;The snow system using the Swing backend
+(asdf:defsystem :snow-swing
+ :serial t
+ :version "0.1"
+ :depends-on ()
+ :components ((:file "swing")
+ (:file "binding-jgoodies")
+ #+snow-cells
+ (:file "cells")))
Added: trunk/src/lisp/snow/swing/swing.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/swing/swing.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,262 @@
+;;; swing.lisp
+;;;
+;;; Copyright (C) 2008-2009 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)
+
+(defmacro defimpl (name args &body body)
+ `(defimplementation ,name (*gui-backend* :swing) ,args
+ , at body))
+
+(defun make-action-listener (obj)
+ (if (or (functionp obj) (symbolp obj))
+ (jmake-proxy "java.awt.event.ActionListener"
+ (lambda (this method-name event)
+ (declare (ignore this method-name))
+ (funcall obj event)))
+ obj)) ;This allows to use a native Java action listener
+
+(defimplementation make-layout-manager (*gui-backend* :swing)
+ (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))))
+
+(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"))
+
+(defimplementation call-in-gui-thread (*gui-backend* :swing) (fn)
+ ;TODO...
+ (funcall fn))
+
+;;Base API implementation
+(defimplementation add-child (*gui-backend* :swing)
+ (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)))
+
+(defimplementation (setf widget-enabled-p) (*gui-backend* :swing)
+ (value widget)
+ (setf (widget-property widget :enabled) value))
+
+(defimplementation widget-enabled-p (*gui-backend* :swing) (widget)
+ (widget-property widget :enabled))
+
+(defimplementation (setf widget-location) (*gui-backend* :swing) (value widget)
+ (invoke "setLocation" widget (aref value 0) (aref value 1)))
+
+(defimpl (setf widget-size) (value widget)
+ (invoke "setSize" widget (realpart value) (imagpart value)))
+
+(defimplementation dispose (*gui-backend* :swing) (obj)
+ (invoke "dispose" obj))
+
+(defimplementation show (*gui-backend* :swing) (obj)
+ (invoke "show" obj))
+
+(defimplementation hide (*gui-backend* :swing) (obj)
+ (invoke "hide" obj))
+
+;;; --- Widgets --- ;;;
+
+;Frames and dialogs
+(defimplementation make-frame (*gui-backend* :swing)
+ (&key 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 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))
+
+(defimplementation make-dialog (*gui-backend* :swing)
+ (&key parent title modal-p visible-p &allow-other-keys)
+ (let ((d (new "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
+ :visible (jbool visible-p))
+ d))
+
+(defimplementation pack (*gui-backend* :swing) (window)
+ (jcall (jmethod "java.awt.Window" "pack") window)
+ window)
+
+;Panels
+(defimplementation make-panel (*gui-backend* :swing) (&key &allow-other-keys)
+ (new "javax.swing.JPanel"))
+
+(defimplementation make-tabs (*gui-backend* :swing)
+ (&key (wrap t) (tab-placement :top) &allow-other-keys)
+ (let ((tabs (new "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
+ (case 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))
+
+(defimplementation make-scroll-panel (*gui-backend* :swing) (view)
+ (let ((p (new "javax.swing.JScrollPane")))
+ (setf (scroll-panel-view p) view)
+ p))
+
+(defimplementation scroll-panel-view (*gui-backend* :swing) (self)
+ (jproperty-value self "viewportView"))
+
+(defimplementation (setf scroll-panel-view) (*gui-backend* :swing) (view self)
+ (setf (jproperty-value self "viewportView") view))
+
+;Buttons
+(defimplementation make-button (*gui-backend* :swing)
+ (&key text on-action &allow-other-keys)
+ (let ((btn (new "javax.swing.JButton")))
+ (when text
+ (setf (widget-property btn :text) text))
+ (when on-action
+ (invoke "addActionListener"
+ btn
+ (make-action-listener on-action)))
+ btn))
+
+(defimpl 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))
+
+;Text
+(defimplementation make-label (*gui-backend* :swing)
+ (&key text &allow-other-keys)
+ (let ((lbl (new "javax.swing.JLabel")))
+ (when text
+ (setf (widget-property lbl :text) text))
+ lbl))
+
+(defimplementation make-text-field (*gui-backend* :swing)
+ (&key text &allow-other-keys)
+ (let ((field (new "javax.swing.JTextField")))
+ (when text
+ (setf (widget-property field :text) text))
+ field))
+
+(defimplementation make-text-area (*gui-backend* :swing)
+ (&key text &allow-other-keys)
+ (let ((text-area (new "javax.swing.JTextArea")))
+ (when text
+ (setf (widget-property text-area :text) text))
+ text-area))
+
+(defun make-dialog-prompt-stream ()
+ (new "snow.SwingDialogPromptStream"))
+
+;;Lists
+(defun make-list-model (list)
+ (new "snow.list.ConsListModel" list))
+
+(defimplementation make-list-widget (*gui-backend* :swing)
+ (&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)
+ (new "snow.list.ConsListCellRenderer"))
+ (setf (widget-property list :prototype-cell-value) prototype-cell-value)
+ (when selected-index
+ (setf (widget-property list :selected-index) selected-index))
+ list))
+
+;;Trees
+(defun make-tree-model (list)
+ (new "snow.tree.ConsTreeModel" list))
+
+(defimplementation make-tree-widget (*gui-backend* :swing)
+ (&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))
+
+;;REPL
+(defimplementation make-gui-repl (*gui-backend* :swing)
+ (&key dispose-on-close environment)
+ (let ((text-area (new "javax.swing.JTextArea"))
+ (repl-doc (new "snow.swing.ConsoleDocument"
+ (compile nil
+ `(lambda ()
+ (let (, at environment)
+ ;safe: *debugger-hook* is rebound
+ (install-graphical-debugger)
+ (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))
+
+(defimplementation dispose-gui-repl (*gui-backend* :swing) (repl)
+ (invoke "dispose" (widget-property repl :document)))
Added: trunk/src/lisp/snow/utils.lisp
==============================================================================
--- (empty file)
+++ trunk/src/lisp/snow/utils.lisp Wed Sep 30 16:06:52 2009
@@ -0,0 +1,200 @@
+;;; snow.lisp
+;;;
+;;; Copyright (C) 2008-2009 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)
+
+;;Some utilities...
+(defmacro with-unique-names ((&rest bindings) &body body)
+ `(let ,(mapcar #'(lambda (binding)
+ (destructuring-bind (var prefix)
+ (if (consp binding) binding (list binding binding))
+ `(,var (gensym ,(string prefix)))))
+ bindings)
+ , at body))
+
+#|(defmacro with-captured-specials ((&rest specials) &body body)
+ (with-unique-names (tmp)
+ `(let* (,@(loop
+ :for var :in specials
+ :append `((,tmp ,var) (,var ,tmp))))
+ , at body)))|#
+
+(defmacro bwhen ((var condition) &body body)
+ `(let ((,var ,condition))
+ (when ,var , at body)))
+
+(defmacro bif ((var condition) then else)
+ `(let ((,var ,condition))
+ (if ,var ,then ,else)))
+
+(defun ensure-list (obj)
+ (if (listp obj)
+ obj
+ (list obj)))
+
+;;Interface/implementation
+(defstruct interface name lambda-list (implementations (list)))
+
+(defun ensure-property (plist indicator &optional default)
+ (let ((prop (getf plist indicator)))
+ (if prop
+ prop
+ (setf (getf plist indicator) default))))
+
+(defun get-interfaces (dispatch-var)
+ (getf (symbol-plist dispatch-var) 'interfaces))
+
+(defun get-interface (dispatch-var interface-name)
+ (cdr (assoc interface-name (getf (symbol-plist dispatch-var) 'interfaces)
+ :test #'equal))) ;to handle (setf x) function names
+
+(defun (setf get-interface) (value dispatch-var interface-name)
+ (bif (it (assoc interface-name
+ (getf (symbol-plist dispatch-var) 'interfaces)
+ :test #'equal)) ;to handle (setf x) function names
+ (setf (cdr it) value)
+ (progn
+ (push (cons interface-name value)
+ (getf (symbol-plist dispatch-var) 'interfaces))
+ value)))
+
+(defun interface-implementation (interface dispatch-value)
+ (getf (interface-implementations interface) dispatch-value))
+
+(defun (setf interface-implementation) (value interface dispatch-value)
+ (setf (getf (interface-implementations interface) dispatch-value)
+ value))
+
+(defun get-implementation (dispatch-var interface-name dispatch-value)
+ (interface-implementation (get-interface dispatch-var interface-name)
+ dispatch-value))
+
+(defun (setf get-implementation) (value dispatch-var interface-name
+ dispatch-value)
+ (let ((interface (get-interface dispatch-var interface-name)))
+ (if interface
+ (setf (interface-implementation interface dispatch-value) value)
+ (error "Interface ~A not found in ~A" interface-name dispatch-var))))
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defun extract-argument-names (arglist)
+ (loop
+ :for x :in arglist
+ :unless (member x '(&optional &key &rest &allow-other-keys))
+ :collect (if (consp x) (car x) x))))
+
+(defmacro definterface (name dispatch-var arglist &optional documentation)
+ (with-unique-names (args)
+ `(progn
+ (defun ,name (&rest ,args) ;todo...
+ ,@(when documentation `(,documentation))
+ (destructuring-bind ,arglist ,args
+ (declare (ignore ,@(extract-argument-names arglist))))
+ (let ((impl (get-implementation ',dispatch-var ',name ,dispatch-var)))
+ (if impl
+ (apply impl ,args)
+ (error "No implementation is defined for ~A when ~A = ~A"
+ ',name ',dispatch-var ,dispatch-var))))
+ (setf (get-interface ',dispatch-var ',name)
+ (make-interface :name ',name :lambda-list ',arglist)))))
+
+(defmacro defimplementation (name (dispatch-var dispatch-value) arglist
+ &body body)
+ `(setf (get-implementation ',dispatch-var ',name ,dispatch-value)
+ (lambda ,arglist , at body))) ;todo check arglist is congruent with interface
+
+;;BROKEN
+(defmacro with-implementation ((dispatch-var
+ &optional (dispatch-value (eval dispatch-var)))
+ &body body)
+ "Evaluates body in an environment where all implementations of interfaces dispatched by dispatch-var are selected at macro-expansion-time."
+ `(let ((,dispatch-var ,dispatch-value))
+ (flet (,@(loop
+ :for entry :in (get-interfaces dispatch-var)
+ :collect `(,(car entry) (&rest args)
+ (apply ,(interface-implementation
+ (cdr entry) dispatch-value)
+ args))))
+ (declare (inline ,@(mapcar #'car (get-interfaces dispatch-var))))
+ , at body)))
+
+#||
+(setf (getf (symbol-plist '*aaa*) 'interfaces) nil)
+
+(defvar *aaa* :aaa)
+
+(definterface pippo *aaa* (a b c))
+
+(defimplementation pippo (*aaa* :aaa) (a b c) (list a b c))
+
+(defimplementation pippo (*aaa* :bbb) (a b c) (list c b a))
+
+(pippo 1 2 3)
+
+(let ((*aaa* :bbb))
+ (pippo 1 2 3))
+
+(get-interfaces '*aaa*)
+
+(with-implementation (*aaa* :aaa) (pippo 1 2 3))
+(with-implementation (*aaa* :bbb) (pippo 1 2 3))
+(with-implementation (*aaa*) (pippo 1 2 3))
+||#
+
+;;Other stuff
+(defmacro dbg (form &optional (stream '*standard-output*) &environment env)
+ (with-unique-names (stream-var)
+ `(let ((,stream-var ,stream))
+ (format ,stream-var "~%;;; --debug--~%")
+ (format ,stream-var "; Form:~%")
+ (pprint (quote ,form) ,stream-var)
+ ,@(when (and (consp form)
+ (symbolp (car form))
+ (macro-function (car form) env))
+ `((format ,stream-var "~%; Macroexpansion:~%")
+ (pprint ',(macroexpand form env) ,stream-var)))
+ (format ,stream-var "~%;;; --end debug--~%")
+ ,form)))
+
+(defun str (&rest args)
+ (with-output-to-string (str)
+ (map nil (lambda (x) (princ x str)) args)))
+
+(defmacro function* (form)
+ (cond
+ ((symbolp form) `(function ,form))
+ ((listp form)
+ (let ((f (car form))
+ (provided-args (cdr form)))
+ `(let ((f (function ,f))) ;To provoke undefined-function error early
+ (lambda (&rest args)
+ (apply f , at provided-args args)))))
+ (t (error "function*: ~A should be a symbol or a list" form))))
Added: trunk/test/src/snow/BindingTest.java
==============================================================================
--- (empty file)
+++ trunk/test/src/snow/BindingTest.java Wed Sep 30 16:06:52 2009
@@ -0,0 +1,77 @@
+package snow;
+
+import java.awt.event.ActionEvent;
+import java.awt.event.ActionListener;
+
+import javax.swing.JButton;
+import javax.swing.JFrame;
+import javax.swing.JLabel;
+import javax.swing.JTextField;
+
+import net.miginfocom.swing.MigLayout;
+
+import org.junit.Test;
+
+import com.jgoodies.binding.adapter.Bindings;
+import com.jgoodies.binding.beans.Model;
+import com.jgoodies.binding.beans.PropertyAdapter;
+import com.jgoodies.binding.value.ValueModel;
+
+public class BindingTest {
+
+ @Test
+ public void testBinding() {
+ final Bean bean = new Bean();
+ ValueModel valueModel = new PropertyAdapter<Bean>(bean, Bean.PROPERTY, true);
+ JFrame frame = new JFrame("test");
+ frame.setLayout(new MigLayout());
+ JTextField field1 = new JTextField(20);
+ frame.add(field1, "wrap");
+ JTextField field2 = new JTextField(20);
+ field2.setColumns(20);
+ frame.add(field2, "wrap");
+ JLabel field3 = new JLabel();
+ frame.add(field3, "wrap");
+ Bindings.bind(field1, valueModel, true);
+ Bindings.bind(field2, valueModel, false);
+ Bindings.bind(field3, "text", new PropertyAdapter<Bean>(bean, Bean.PROPERTY, true));
+ JButton resetButton = new JButton("reset");
+ resetButton.addActionListener(new ActionListener() {
+
+ @Override
+ public void actionPerformed(ActionEvent e) {
+ bean.setProperty("cippalippa");
+ }
+
+ });
+ frame.add(resetButton);
+ frame.setDefaultCloseOperation(frame.EXIT_ON_CLOSE);
+ frame.pack();
+ frame.setVisible(true);
+ }
+
+ public static void main(String[] args) {
+ new BindingTest().testBinding();
+ }
+
+ public static class Bean extends Model {
+
+ public static final String PROPERTY = "property";
+
+ private String property = "cippalippa";
+
+ public String getProperty() {
+ System.out.println("get " + property);
+ return property;
+ }
+
+ public void setProperty(String property) {
+ String oldProperty = this.property;
+ this.property = property;
+ System.out.println("set " + property);
+ firePropertyChange(PROPERTY, oldProperty, property);
+ }
+
+ }
+
+}
More information about the snow-cvs
mailing list