From fgoenninger at common-lisp.net Sun Dec 2 18:14:19 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 2 Dec 2007 13:14:19 -0500 (EST) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20071202181419.62B6F111D1@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv13766 Modified Files: geo-data-structures.lisp Log Message: Added: Comments in code. No other change. --- /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2007/11/30 16:51:19 1.10 +++ /project/cells/cvsroot/cells/gui-geometry/geo-data-structures.lisp 2007/12/02 18:14:18 1.11 @@ -21,13 +21,10 @@ ;----------------------------- (defstruct v2 - (h 0 ) - (v 0 ) + (h 0 ) ;; horizontal coordinate + (v 0 ) ;; vertical coordinate ) -#+(or) -(instance-slots (mkv2 1 2)) - (defmethod print-object ((self v2) s) (format s "~a|~a" (v2-h self)(v2-v self))) From fgoenninger at common-lisp.net Sun Dec 2 18:15:30 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 2 Dec 2007 13:15:30 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20071202181530.042A216034@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv14095 Modified Files: cells.asd Log Message: Added: File variables.lisp --- /project/cells/cvsroot/cells/cells.asd 2006/08/22 15:02:04 1.6 +++ /project/cells/cvsroot/cells/cells.asd 2007/12/02 18:15:30 1.7 @@ -38,7 +38,8 @@ (:file "md-utilities") (:file "family") (:file "fm-utilities") - (:file "family-values"))) + (:file "family-values") + (:file "variables"))) (defmethod perform ((o load-op) (c (eql (find-system :cells)))) (pushnew :cells *features*)) From fgoenninger at common-lisp.net Sun Dec 2 18:28:04 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 2 Dec 2007 13:28:04 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20071202182804.EF77E56243@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv18364 Modified Files: constructors.lisp Log Message: Changed: Moved all symbol exports to beginning of file. Removed: c?+n constructor was defined twice in file. --- /project/cells/cvsroot/cells/constructors.lisp 2007/11/30 16:51:18 1.17 +++ /project/cells/cvsroot/cells/constructors.lisp 2007/12/02 18:28:04 1.18 @@ -19,15 +19,28 @@ (in-package :cells) (eval-now! - (export '(c?n))) + (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)) -(export! .cache-bound-p c?+n) - (defmacro c-lambda-var ((c) &body body) `(lambda (,c &aux (self (c-model ,c)) (.cache (c-value ,c)) @@ -72,8 +85,6 @@ :rule (c-lambda , at body) , at args)) -(export! c?once c?n-until c?1 c_1) - (defmacro c?once (&body body) `(make-c-dependent :code '(without-c-dependency , at body) @@ -114,8 +125,6 @@ :lazy :until-asked :rule (c-lambda , at body))) -(export! c?dbg c_?dbg c-input-dbg) - (defmacro c_?dbg (&body body) "Lazy until asked, then eagerly propagating" `(make-c-dependent From fgoenninger at common-lisp.net Sun Dec 2 18:31:59 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 2 Dec 2007 13:31:59 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20071202183159.0A9FE5C1A8@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv18803 Modified Files: utils-kt.asd Log Message: Changed: Now reflects latest changes from Kenny (as found in .lpr file) --- /project/cells/cvsroot/cells/utils-kt/utils-kt.asd 2006/10/17 21:28:40 1.2 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.asd 2007/12/02 18:31:59 1.3 @@ -18,11 +18,14 @@ :long-description "Low-level utilities used by all of Kenny's projects" :serial t :components ((:file "defpackage") + (:file "core") (:file "debug") (:file "flow-control") (:file "detritus") + (:file "quad") (:file "strings") - (:file "datetime"))) + (:file "datetime") + (:file "split-sequence"))) (defmethod perform ((o load-op) (c (eql (find-system :utils-kt)))) ; (pushnew "CELLS" *modules* :test #'string=) From fgoenninger at common-lisp.net Sun Dec 2 18:43:53 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 2 Dec 2007 13:43:53 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20071202184353.E669E1123@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv22429 Removed Files: asdf.lisp Log Message: Changes: Preventing bit rod: * cells-test.asd moved to cells-test directory * asdf.lisp removed * load.lisp removed (was not maintained any more) In cells.asd: * file "variables.lisp" unused according to newest cells.lpr file. File itself kept for reference. From fgoenninger at common-lisp.net Sun Dec 2 18:44:18 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 2 Dec 2007 13:44:18 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20071202184418.B9DC870EA@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv22555 Modified Files: cells.asd Log Message: Changes: Preventing bit rod: * cells-test.asd moved to cells-test directory * asdf.lisp removed * load.lisp removed (was not maintained any more) In cells.asd: * file "variables.lisp" unused according to newest cells.lpr file. File itself kept for reference. --- /project/cells/cvsroot/cells/cells.asd 2007/12/02 18:15:30 1.7 +++ /project/cells/cvsroot/cells/cells.asd 2007/12/02 18:44:18 1.8 @@ -5,12 +5,13 @@ (declaim (optimize (debug 3) (speed 3) (safety 1) (compilation-speed 0))) (asdf:defsystem :cells - :name "cells" + :name "cells" :author "Kenny Tilton " :maintainer "Kenny Tilton " :licence "Lisp LGPL" :description "Cells" :long-description "Cells: a dataflow extension to CLOS." + :version "3.0" :serial t :components ((:module "utils-kt" :serial t @@ -24,22 +25,21 @@ (:file "trc-eko") (:file "cells") (:file "integrity") - (:file "constructors") (:file "cell-types") - (:file "synapse") - (:file "synapse-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 "variables"))) + (:file "family-values"))) (defmethod perform ((o load-op) (c (eql (find-system :cells)))) (pushnew :cells *features*)) @@ -48,6 +48,4 @@ (oos 'load-op :cells-test)) (defmethod perform ((o test-op) (c (eql :cells))) - (oos 'load-op :cells-test)) - -) \ No newline at end of file + (oos 'load-op :cells-test))) From fgoenninger at common-lisp.net Sun Dec 2 18:44:25 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 2 Dec 2007 13:44:25 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20071202184425.A06AF111D4@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv22593 Removed Files: load.lisp Log Message: Changes: Preventing bit rod: * cells-test.asd moved to cells-test directory * asdf.lisp removed * load.lisp removed (was not maintained any more) In cells.asd: * file "variables.lisp" unused according to newest cells.lpr file. File itself kept for reference. From fgoenninger at common-lisp.net Sun Dec 2 18:46:53 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 2 Dec 2007 13:46:53 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20071202184653.0CBEB2D16B@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv22969 Removed Files: cells-test.asd Log Message: Changes: Preventing bit rod: * cells-test.asd moved to cells-test directory * asdf.lisp removed * load.lisp removed (was not maintained any more) In cells.asd: * file "variables.lisp" unused according to newest cells.lpr file. File itself kept for reference. From fgoenninger at common-lisp.net Sun Dec 2 18:47:20 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 2 Dec 2007 13:47:20 -0500 (EST) Subject: [cells-cvs] CVS cells/cells-test Message-ID: <20071202184720.362BC3D00E@common-lisp.net> Update of /project/cells/cvsroot/cells/cells-test In directory clnet:/tmp/cvs-serv23072 Added Files: cells-test.asd Log Message: Changes: Preventing bit rod: * cells-test.asd moved to cells-test directory * asdf.lisp removed * load.lisp removed (was not maintained any more) In cells.asd: * file "variables.lisp" unused according to newest cells.lpr file. File itself kept for reference. --- /project/cells/cvsroot/cells/cells-test/cells-test.asd 2007/12/02 18:47:20 NONE +++ /project/cells/cvsroot/cells/cells-test/cells-test.asd 2007/12/02 18:47:20 1.1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- (asdf:defsystem :cells-test :name "cells-test" :author "Kenny Tilton " :maintainer "Kenny Tilton " :licence "MIT Style" :description "Cells Regression Test/Documentation" :long-description "Informatively-commented regression tests for Cells" :serial t :depends-on (:cells) :components ((:module "cells-test" :serial t :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"))))) (defmethod perform :after ((op load-op) (system (eql (find-system :cells-test)))) (funcall (find-symbol "TEST-CELLS" "CELLS"))) From fgoenninger at common-lisp.net Sun Dec 2 18:57:10 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Sun, 2 Dec 2007 13:57:10 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20071202185710.D25145E0C8@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv24366 Modified Files: defpackage.lisp Log Message: Added: export of symbol #:export! --- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2007/11/30 16:51:20 1.7 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2007/12/02 18:57:10 1.8 @@ -28,8 +28,10 @@ #+sbcl #:sb-mop #+openmcl-partial-mop #:openmcl-mop #+(and mcl (not openmcl-partial-mop)) #:ccl) - (:export #:utils-kt-reset - #:count-it #:count-of + (:export + #:export! + #:utils-kt-reset + #:count-it #:count-of #:wdbg #:maptimes #:bwhen #:bif #:xor #:with-dynamic-fn #:last1 #:packed-flat! #:with-metrics #:shortc From fgoenninger at common-lisp.net Mon Dec 3 12:21:01 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Mon, 3 Dec 2007 07:21:01 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20071203122101.ECC8549050@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv2552 Modified Files: debug.lisp Log Message: Changed: Exporting of symbols now done in defpackage only. --- /project/cells/cvsroot/cells/utils-kt/debug.lisp 2007/11/30 16:51:20 1.15 +++ /project/cells/cvsroot/cells/utils-kt/debug.lisp 2007/12/03 12:21:01 1.16 @@ -34,12 +34,8 @@ (print "----------UTILSRESET----------------------------------")) - - ;------------- counting --------------------------- -(export! with-counts) - (defmacro with-counts ((onp &rest msg) &body body) `(if ,onp (let ((*counting* (cons t *counting*))) From fgoenninger at common-lisp.net Mon Dec 3 12:21:34 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Mon, 3 Dec 2007 07:21:34 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20071203122134.104964904E@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv3297 Modified Files: defpackage.lisp Log Message: Added: Export of with-counts --- /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2007/12/02 18:57:10 1.8 +++ /project/cells/cvsroot/cells/utils-kt/defpackage.lisp 2007/12/03 12:21:34 1.9 @@ -31,7 +31,7 @@ (:export #:export! #:utils-kt-reset - #:count-it #:count-of + #:count-it #:count-of #:with-counts #:wdbg #:maptimes #:bwhen #:bif #:xor #:with-dynamic-fn #:last1 #:packed-flat! #:with-metrics #:shortc From fgoenninger at common-lisp.net Mon Dec 3 12:22:42 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Mon, 3 Dec 2007 07:22:42 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20071203122242.126D6560FB@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv3505 Modified Files: detritus.lisp Log Message: Changed: Wrappred dependencies to AllegroCL and its IDE into #+ ... --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/11/30 16:51:20 1.14 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/12/03 12:22:41 1.15 @@ -59,6 +59,7 @@ (defun collect-if (test list) (remove-if-not test list)) +#+(and allegro ide) (defun test-setup () #-its-alive! (ide.base::find-new-prompt-command @@ -67,14 +68,17 @@ #+test (test-setup) +#+(and allegro ide) (defun test-prep () (test-setup)) + +#+(and allegro ide) (defun test-init () (test-setup)) +#+(and allegro ide) (export! test-setup test-prep test-init) - ;;; --- FIFO Queue ----------------------------- (defun make-fifo-queue (&rest init-data) From fgoenninger at common-lisp.net Mon Dec 3 12:24:42 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Mon, 3 Dec 2007 07:24:42 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20071203122442.3670031077@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv3688 Modified Files: utils-kt.asd Log Message: Changed: 1. Version now reflects latest change date 2. ASDF dependencies now used instead of :serial t --- /project/cells/cvsroot/cells/utils-kt/utils-kt.asd 2007/12/02 18:31:59 1.3 +++ /project/cells/cvsroot/cells/utils-kt/utils-kt.asd 2007/12/03 12:24:41 1.4 @@ -11,21 +11,19 @@ (asdf:defsystem :utils-kt :name "utils-kt" :author "Kenny Tilton " - :version "18-Oct-2004" + :version "2007-12-02" :maintainer "Kenny Tilton " :licence "MIT Style" :description "Kenny's Utilities" :long-description "Low-level utilities used by all of Kenny's projects" - :serial t :components ((:file "defpackage") - (:file "core") - (:file "debug") - (:file "flow-control") - (:file "detritus") - (:file "quad") - (:file "strings") - (:file "datetime") - (:file "split-sequence"))) + (: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=) From fgoenninger at common-lisp.net Mon Dec 3 12:26:19 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Mon, 3 Dec 2007 07:26:19 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20071203122619.E9E9931077@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv3922 Removed Files: quad.lisp Log Message: Removed: quad.lisp no longer part of utils-kt. From fgoenninger at common-lisp.net Mon Dec 3 12:27:04 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Mon, 3 Dec 2007 07:27:04 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20071203122704.2397631077@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv3994 Modified Files: core.lisp Log Message: Changed: Wrapped dependencies to AllegroCL and its IDE into #+... --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/11/30 16:51:20 1.1 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/12/03 12:27:03 1.2 @@ -42,18 +42,22 @@ (export! exe-path exe-dll font-path) +#+(and allegro ide) (defun exe-path () #+its-alive! (excl:current-directory) #-its-alive! (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) +#+(and allegro ide) (defun font-path () (merge-pathnames (make-pathname :directory #+its-alive! (list :relative "font") - #-its-alive! (append (butlast (pathname-directory (exe-path))) - (list "TY Extender" "font"))) + #-its-alive! (append (butlast (pathname-directory + (exe-path) + )) + (list "TY Extender" "font"))) (exe-path))) #+test From ktilton at common-lisp.net Mon Dec 3 20:11:12 2007 From: ktilton at common-lisp.net (ktilton) Date: Mon, 3 Dec 2007 15:11:12 -0500 (EST) Subject: [cells-cvs] CVS cells Message-ID: <20071203201112.566903C015@common-lisp.net> Update of /project/cells/cvsroot/cells In directory clnet:/tmp/cvs-serv31012 Modified Files: cell-types.lisp family.lisp Log Message: (push :iamnotkenny *features*) to avoid non-portable code --- /project/cells/cvsroot/cells/cell-types.lisp 2007/11/30 16:51:18 1.26 +++ /project/cells/cvsroot/cells/cell-types.lisp 2007/12/03 20:11:11 1.27 @@ -69,7 +69,12 @@ (format stream "=~d/~a/~a]" (c-pulse c) (symbol-name (or (c-slot-name c) :anoncell)) - (bwhen (md (c-model c)) (or (md-name md) :anonmd)))))))) + (print-cell-model (c-model c)))))))) + +(export! print-cell-model) + +(defgeneric print-cell-model (md) + (:method (other) (print-object other nil))) (defmethod trcp :around ((c cell)) (or (c-debug c) --- /project/cells/cvsroot/cells/family.lisp 2007/11/30 22:52:36 1.21 +++ /project/cells/cvsroot/cells/family.lisp 2007/12/03 20:11:11 1.22 @@ -25,7 +25,13 @@ (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) - (.value :initform nil :accessor value :initarg :value))) + (.value :initform nil :accessor value :initarg :value) + (zdbg :initform nil :accessor dbg :initarg :dbg)) + ) + + +(defmethod print-cell-object ((md model)) + (or (md-name md) :md?)) (defmethod fm-parent (other) (declare (ignore other)) From ktilton at common-lisp.net Mon Dec 3 20:11:12 2007 From: ktilton at common-lisp.net (ktilton) Date: Mon, 3 Dec 2007 15:11:12 -0500 (EST) Subject: [cells-cvs] CVS cells/utils-kt Message-ID: <20071203201112.988F73C016@common-lisp.net> Update of /project/cells/cvsroot/cells/utils-kt In directory clnet:/tmp/cvs-serv31012/utils-kt Modified Files: core.lisp detritus.lisp Added Files: quad.lisp Log Message: (push :iamnotkenny *features*) to avoid non-portable code --- /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/12/03 12:27:03 1.2 +++ /project/cells/cvsroot/cells/utils-kt/core.lisp 2007/12/03 20:11:12 1.3 @@ -42,14 +42,14 @@ (export! exe-path exe-dll font-path) -#+(and allegro ide) +#-iamnotkenny (defun exe-path () #+its-alive! (excl:current-directory) #-its-alive! (excl:path-pathname (ide.base::project-file ide.base:*current-project*))) -#+(and allegro ide) +#-iamnotkenny (defun font-path () (merge-pathnames (make-pathname --- /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/12/03 12:22:41 1.15 +++ /project/cells/cvsroot/cells/utils-kt/detritus.lisp 2007/12/03 20:11:12 1.16 @@ -59,7 +59,7 @@ (defun collect-if (test list) (remove-if-not test list)) -#+(and allegro ide) +#-iamnotkenny (defun test-setup () #-its-alive! (ide.base::find-new-prompt-command @@ -68,15 +68,15 @@ #+test (test-setup) -#+(and allegro ide) +#-iamnotkenny (defun test-prep () (test-setup)) -#+(and allegro ide) +#-iamnotkenny (defun test-init () (test-setup)) -#+(and allegro ide) +#-iamnotkenny (export! test-setup test-prep test-init) ;;; --- FIFO Queue ----------------------------- From ktilton at common-lisp.net Tue Dec 11 19:35:16 2007 From: ktilton at common-lisp.net (ktilton) Date: Tue, 11 Dec 2007 14:35:16 -0500 (EST) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20071211193516.CE0355D160@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv22722/gui-geometry Added Files: geo-macros.lisp Log Message: --- /project/cells/cvsroot/cells/gui-geometry/geo-macros.lisp 2007/12/11 19:35:16 NONE +++ /project/cells/cvsroot/cells/gui-geometry/geo-macros.lisp 2007/12/11 19:35:16 1.1 ;; -*- 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?) (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)))) From fgoenninger at common-lisp.net Tue Dec 11 19:41:13 2007 From: fgoenninger at common-lisp.net (fgoenninger) Date: Tue, 11 Dec 2007 14:41:13 -0500 (EST) Subject: [cells-cvs] CVS cells/gui-geometry Message-ID: <20071211194113.030525E006@common-lisp.net> Update of /project/cells/cvsroot/cells/gui-geometry In directory clnet:/tmp/cvs-serv25060 Modified Files: gui-geometry.asd Log Message: Added: file geo-macros.lisp now part of the package. --- /project/cells/cvsroot/cells/gui-geometry/gui-geometry.asd 2006/07/06 22:10:02 1.1 +++ /project/cells/cvsroot/cells/gui-geometry/gui-geometry.asd 2007/12/11 19:41:13 1.2 @@ -8,6 +8,7 @@ :serial t :components ((:file "defpackage") + (:file "geo-macros") (:file "geo-data-structures") (:file "coordinate-xform") (:file "geometer") From ktilton at common-lisp.net Thu Dec 20 13:06:40 2007 From: ktilton at common-lisp.net (ktilton) Date: Thu, 20 Dec 2007 08:06:40 -0500 (EST) Subject: [cells-cvs] CVS triple-cells Message-ID: <20071220130640.EDE39762F5@common-lisp.net> Update of /project/cells/cvsroot/triple-cells In directory clnet:/tmp/cvs-serv11217 Log Message: Status: Vendor Tag: tcvs-vendor Release Tags: tcvs-release No conflicts created by this import From ktilton at common-lisp.net Thu Dec 20 13:08:17 2007 From: ktilton at common-lisp.net (ktilton) Date: Thu, 20 Dec 2007 08:08:17 -0500 (EST) Subject: [cells-cvs] CVS triple-cells Message-ID: <20071220130817.8E0317A012@common-lisp.net> Update of /project/cells/cvsroot/triple-cells In directory clnet:/tmp/cvs-serv11470 Added Files: core.lisp defpackage.lisp hello-world.lisp triple-cells.lpr Log Message: --- /project/cells/cvsroot/triple-cells/core.lisp 2007/12/20 13:08:17 NONE +++ /project/cells/cvsroot/triple-cells/core.lisp 2007/12/20 13:08:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-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 :3c) ;; --- ag utils ----------------------- (defun triple-value (tr) (upi->value (object tr))) (defun get-sp (s p) #+allegrocl (get-triple :s s :p p) #-allegrocl (car (get-triples-list :s s :p p))) (defun get-spo (s p o) #+allegrocl (get-triple :s s :p p :o o) #-allegrocl (car (get-triples-list :s s :p p :o o))) (defun get-sp-value (s p) (triple-value (get-sp s p))) ;; --- triple-cells --- (defvar *3c?*) (defvar *3c-pulse*) (defun 3c-init () (setf *3c-pulse* 0) (setf *3c?* (make-hash-table :test 'equal))) ;;; --- 3cell predicates ------------------------------------------- (defun 3c-cell? (c) (when (upip c) (get-sp c !ccc:type))) (defun 3c-pulse (c) (get-sp-value c !ccc:pulse)) (defun 3c-ephemeral? (c) (get-sp c !ccc:ephemeral)) (defun 3c-ruled? (c) (when (upip c) (bwhen (tr-type (get-sp c !ccc:type)) (part= (object tr-type) !ccc:ruled)))) ;;; --- 3cell accessors ------------------------------------------- (defun 3c-class-of (s) (intern (up$ (get-sp-value s !ccc:instance-of)))) (defun 3c-predicate-of (p) (intern (up$ (part-value p)))) (defun 3c-pred-value (s p) (loop for tr in (get-triples-list :s s :p p) unless (3c-cell? (object tr)) return (triple-value tr))) (defun 3c-cell-value (c) (when (3c-ruled? c) (3c-ensure-current c)) (object (car (get-triples-list :s c :p !ccc:value)))) ;; --- 3cell construction ----------------------------------------- (defun 3cv (initial-value &key ephemeral &aux (c (new-blank-node))) (add-triple c !ccc:type !ccc:input) (add-triple c !ccc:value (mk-upi initial-value)) (when ephemeral (add-triple c !ccc:ephemeral !ccc:t)) c) (defmacro 3c? (&body rule) `(call-3c? '(progn , at rule))) (defun 3c?-rule-store (c-node rule) (setf (gethash *3c?* c-node) rule)) (defun 3c?-rule (c-node) (gethash *3c?* c-node)) (defun call-3c? (rule) (let* ((c (new-blank-node)) (tr-c (add-triple c !ccc:type !ccc:ruled)) (tr-cv (add-triple c !ccc:rule (mk-upi (princ-to-string rule))))) (3c?-rule-store c (eval rule)) (trc "c? type tr" tr-c) (trc "c? value tr" tr-cv) c)) (defun 3c-ensure-current (c) (when (> *3c-pulse* (3c-pulse c)))) ;;; --- 3cell observation -------------------------------------------------------- (defun 3c-echo-triple (s p new-value prior-value prior-value?) (3c-observe-predicate (3c-class-of s)(3c-predicate-of p) new-value (when prior-value (upi->value prior-value)) prior-value?)) (defmethod 3c-observe-predicate (s p new-value prior-value prior-value?) (trc "3c-observe undefined" s p new-value prior-value prior-value?)) ;;; --- access ------------------------------------------ (defun 3c-add-triple (s p o &aux (tv o)) (when (3c-cell? o) (add-triple s p o) ;; associate cell with this s and p (incf *3c-pulse*) (add-triple o !ccc:pulse (mk-upi *3c-pulse*)) (setf tv (3c-cell-value o))) (add-triple s p (mk-upi tv)) (3c-echo-triple s p tv nil nil)) (defun (setf 3c) (new-value s p) (trc "SETF>" p new-value) (let (tr-cell tr-value) (loop for tr in (get-triples-list :s s :p p) if (3c-cell? (object tr)) do (setf tr-cell tr) else do (setf tr-value tr)) (assert tr-cell () "subject ~a pred ~a not mediated by input cell so cannot be changed from ~a to ~a" s p (object tr-value) new-value) ;(trc "tr-cell" (triple-id tr-cell)) ;(trc "tr-value" (triple-id tr-value)) (let ((prior-object (object tr-value))) (unless (equal new-value (upi->value prior-object)) (delete-triple (triple-id tr-value)) ;(trc "tr-value orig deleted") (let* ((new-value-upi (mk-upi new-value)) (tr-value-new (add-triple s p new-value-upi))) (let ((tr-cell-value (car (get-triples-list :s (object tr-cell) :p !ccc:value)))) (assert tr-cell-value) (delete-triple (triple-id tr-cell-value)) (let ((tr-cell-value-new (add-triple (object tr-cell) !ccc:value new-value-upi))) (3c-observe-predicate (3c-class-of s)(3c-predicate-of p) new-value (upi->value prior-object) t) (when (3c-ephemeral? (object tr-cell)) ; fix up cell... (delete-triple tr-cell-value-new) (add-triple (object tr-cell) !ccc:value !ccc:nil) ; reset value itself to nil (delete-triple tr-value-new) (add-triple s p !ccc:nil))))))))) ;;; --- utils ------------------------ (defun mk-upi (v) (typecase v (string (literal v)) (integer (value->upi v :short)) (otherwise v) ;; probably should not occur ))--- /project/cells/cvsroot/triple-cells/defpackage.lisp 2007/12/20 13:08:17 NONE +++ /project/cells/cvsroot/triple-cells/defpackage.lisp 2007/12/20 13:08:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: cl-user; -*- ;;; ;;; 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 :common-lisp-user) ;;; Porting to Redland left as an exercise: http://librdf.org/ (eval-when (:compile-toplevel :load-toplevel :execute) (require :agraph)) (defpackage :triple-cells (:nicknames :3c) (:use #:common-lisp #:utils-kt #:db.agraph #:cells)) ;; cells just fro TRC (so far) --- /project/cells/cvsroot/triple-cells/hello-world.lisp 2007/12/20 13:08:17 NONE +++ /project/cells/cvsroot/triple-cells/hello-world.lisp 2007/12/20 13:08:17 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-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 :3c) #+wait (def-3c-observer happen () (when new-value (format t "~&happen: ~a" new-value))) (defmethod 3c-observe-predicate (s (p (eql 'happen)) new-value prior-value prior-value?) (trc "OBS> happen" s new-value prior-value prior-value?)) (defmethod 3c-observe-predicate (s (p (eql 'location)) new-value prior-value prior-value?) (trc "OBS> location" s new-value prior-value prior-value?)) (defun 3c-test () (let ((*synchronize-automatically* t)) (enable-print-decoded t) (make-tutorial-store) (register-namespace "hw" "helloworld#" :errorp nil) (register-namespace "ccc" "triplecells#" :errorp nil) (let ((dell (new-blank-node)) (happen !"happen") (location !"location")) (add-triple dell !ccc:instance-of !) (3c-add-triple dell happen #+const "test" (3cv "test" :ephemeral t)) (trc "start happen is" (3c-pred-value dell happen)) (3c-add-triple dell location (3c? (if (string-equal (3c-pred-value dell happen) "arrive") "home" "away"))) (trc "start location is" (3c-pred-value dell location)) (loop repeat 2 do (setf (3c dell happen) "knock-knock")) (setf (3c dell happen) "arrive") (setf (3c dell happen) "knock-knock") (setf (3c dell happen) "leave")))) #| (defmd computer () (happen (c-in nil) :cell :ephemeral) (location (c? (case (^happen) (:leave :away) (:arrive :at-home) (t .cache)))) ;; ie, unchanged (response nil :cell :ephemeral)) (defobserver response(self new-response old-response) (when new-response (format t "~&computer: ~a" new-response))) (defobserver happen() (when new-value (format t "~&happen: ~a" new-value))) (def-cell-test hello-world () (let ((dell (make-instance 'computer :response (c? (bwhen (h (happen self)) (if (eql (^location) :at-home) (case h (:knock-knock "who's there?") (:world "hello, world.")) "")))))) (dotimes (n 2) (setf (happen dell) :knock-knock)) (setf (happen dell) :arrive) (setf (happen dell) :knock-knock) (setf (happen dell) :leave) (values))) |# #+(or) (hello-world) #| output happen: KNOCK-KNOCK computer: happen: KNOCK-KNOCK computer: happen: ARRIVE happen: KNOCK-KNOCK computer: who's there? happen: LEAVE computer: |# --- /project/cells/cvsroot/triple-cells/triple-cells.lpr 2007/12/20 13:08:17 NONE +++ /project/cells/cvsroot/triple-cells/triple-cells.lpr 2007/12/20 13:08:17 1.1 ;; -*- lisp-version: "8.1 [Windows] (Dec 2, 2007 6:32)"; cg: "1.103.2.10"; -*- (in-package :cg-user) (defpackage :TRIPLE-CELLS) (define-project :name :triple-cells :modules (list (make-instance 'module :name "defpackage.lisp") (make-instance 'module :name "ag-utils.lisp") (make-instance 'module :name "core.lisp") (make-instance 'module :name "agraph-tutorial") (make-instance 'module :name "hello-world.lisp")) :projects (list (make-instance 'project-module :name "..\\Cells\\cells")) :libraries nil :distributed-files nil :internally-loaded-files nil :project-package-name :triple-cells :main-form nil :compilation-unit t :verbose nil :runtime-modules (list :cg-dde-utils :cg.acache :cg.base :cg.bitmap-pane :cg.bitmap-pane.clipboard :cg.bitmap-stream :cg.button :cg.caret :cg.chart-or-plot :cg.chart-widget :cg.check-box :cg.choice-list :cg.choose-printer :cg.class-grid :cg.class-slot-grid :cg.class-support :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.object-editor :cg.object-editor.layout :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 [36 lines skipped] From ktilton at common-lisp.net Fri Dec 21 19:02:11 2007 From: ktilton at common-lisp.net (ktilton) Date: Fri, 21 Dec 2007 14:02:11 -0500 (EST) Subject: [cells-cvs] CVS triple-cells Message-ID: <20071221190211.0BB8E1C0C4@common-lisp.net> Update of /project/cells/cvsroot/triple-cells In directory clnet:/tmp/cvs-serv20373 Modified Files: core.lisp hello-world.lisp triple-cells.lpr Added Files: namespace.lisp Log Message: --- /project/cells/cvsroot/triple-cells/core.lisp 2007/12/20 13:08:17 1.1 +++ /project/cells/cvsroot/triple-cells/core.lisp 2007/12/21 19:02:10 1.2 @@ -27,7 +27,8 @@ ;; --- ag utils ----------------------- (defun triple-value (tr) - (upi->value (object tr))) + (when tr + (upi->value (object tr)))) (defun get-sp (s p) #+allegrocl (get-triple :s s :p p) @@ -40,14 +41,52 @@ (defun get-sp-value (s p) (triple-value (get-sp s p))) +(defun mk-upi (v) + (typecase v + (string (literal v)) + (integer (value->upi v :short)) + (otherwise v) ;; probably should not occur + )) + ;; --- triple-cells --- -(defvar *3c?*) + (defvar *3c-pulse*) +(defvar *calc-node*) -(defun 3c-init () - (setf *3c-pulse* 0) - (setf *3c?* (make-hash-table :test 'equal))) +(defun 3c-pulse-advance (dbg) + (trc "PULSE>" (1+ *3c-pulse*) dbg) + (incf *3c-pulse*)) + + + +;;; --- low-level 3cell accessors + +(defun 3c-cell-value (c) + (bwhen (tr (get-sp c !ccc:value)) + (object tr))) + +(defun (setf 3c-cell-value) (new-value c) + (delete-triples :s c :p !ccc:value) + (when new-value + (add-triple c !ccc:value (mk-upi new-value)))) + +(defun 3c-pulse (c) + (get-sp-value c !ccc:pulse)) + +;;; --- rule storage ------------------------------- + +(defvar *3c?*) + +(defun (setf 3c?-rule) (c-node rule) + (setf (gethash c-node *3c?*) rule)) + +(defun 3c?-rule (c-node) + (or (gethash c-node *3c?*) + (setf (gethash c-node *3c?*) + (let ((rule$ (get-sp-value c-node !ccc:rule))) + (trc "got rule" rule$) + (eval rule$))))) ;;; --- 3cell predicates ------------------------------------------- @@ -55,9 +94,6 @@ (when (upip c) (get-sp c !ccc:type))) -(defun 3c-pulse (c) - (get-sp-value c !ccc:pulse)) - (defun 3c-ephemeral? (c) (get-sp c !ccc:ephemeral)) @@ -66,6 +102,11 @@ (bwhen (tr-type (get-sp c !ccc:type)) (part= (object tr-type) !ccc:ruled)))) +(defun 3c-input? (c) + (when (upip c) + (bwhen (tr-type (get-sp c !ccc:type)) + (part= (object tr-type) !ccc:input)))) + ;;; --- 3cell accessors ------------------------------------------- (defun 3c-class-of (s) @@ -74,55 +115,34 @@ (defun 3c-predicate-of (p) (intern (up$ (part-value p)))) -(defun 3c-pred-value (s p) - (loop for tr in (get-triples-list :s s :p p) - unless (3c-cell? (object tr)) - return (triple-value tr))) +;;; --- integrity ---------------------------------------------- -(defun 3c-cell-value (c) - (when (3c-ruled? c) - (3c-ensure-current c)) - (object (car (get-triples-list :s c :p !ccc:value)))) +(defun 3c-ensure-current (tr-cell tr-value) + (when (and tr-cell (3c-ruled? tr-cell)) + (trc "ensuring current" *3c-pulse* (3c-pulse tr-cell) (subject tr-cell)(predicate tr-cell)(3c-cell-value tr-cell) ) + (when (> *3c-pulse* (3c-pulse tr-cell)) + (let ((new-value (funcall (3c?-rule tr-cell) tr-cell))) + (unless (eql new-value (3c-cell-value tr-cell)) + (let ((s (subject tr-cell)) + (p (predicate tr-cell)) + (prior-value (3c-cell-value tr-cell))) + (setf (3c-cell-value tr-cell) new-value) + (delete-triple tr-value) + (prog1 + (get-triple-by-id + (add-triple s p (mk-upi new-value))) + (3c-echo-triple s p new-value prior-value t)))))))) -;; --- 3cell construction ----------------------------------------- -(defun 3cv (initial-value &key ephemeral &aux (c (new-blank-node))) - (add-triple c !ccc:type !ccc:input) - (add-triple c !ccc:value (mk-upi initial-value)) - (when ephemeral - (add-triple c !ccc:ephemeral !ccc:t)) - c) - -(defmacro 3c? (&body rule) - `(call-3c? '(progn , at rule))) -(defun 3c?-rule-store (c-node rule) - (setf (gethash *3c?* c-node) rule)) - -(defun 3c?-rule (c-node) - (gethash *3c?* c-node)) - -(defun call-3c? (rule) - (let* ((c (new-blank-node)) - (tr-c (add-triple c !ccc:type !ccc:ruled)) - (tr-cv (add-triple c !ccc:rule (mk-upi (princ-to-string rule))))) - (3c?-rule-store c (eval rule)) - (trc "c? type tr" tr-c) - (trc "c? value tr" tr-cv) - c)) - - -(defun 3c-ensure-current (c) - (when (> *3c-pulse* (3c-pulse c)))) - ;;; --- 3cell observation -------------------------------------------------------- (defun 3c-echo-triple (s p new-value prior-value prior-value?) (3c-observe-predicate (3c-class-of s)(3c-predicate-of p) new-value - (when prior-value (upi->value prior-value)) + prior-value prior-value?)) (defmethod 3c-observe-predicate (s p new-value prior-value prior-value?) @@ -130,55 +150,117 @@ ;;; --- access ------------------------------------------ -(defun 3c-add-triple (s p o &aux (tv o)) +(defun subject-cells-node (s) + (bif (tr (get-triple :s s :p !ccc:cells)) + (object tr) + (let ((n (new-blank-node))) + (add-triple s !ccc:cells n) + n))) + +(defun (setf stmt-cell) (new-cell s p) + (add-triple (subject-cells-node s) p new-cell)) + +(defun stmt-cell (s p) + (get-sp (subject-cells-node s) p)) + +(defun stmt-new (s p o &aux (tv o)) (when (3c-cell? o) - (add-triple s p o) ;; associate cell with this s and p - (incf *3c-pulse*) + (add-triple (subject-cells-node s) p o) + + (cond + ((3c-input? o) + (3c-pulse-advance :new-input) ;; why does creating data advance pulse? + (setf tv (3c-cell-value o))) + + ((3c-ruled? o) + (setf tv (funcall (3c?-rule o) o)) + (setf (3c-cell-value o) tv)) + + (t (break "unknown cell" o))) + (add-triple o !ccc:pulse (mk-upi *3c-pulse*)) (setf tv (3c-cell-value o))) - (add-triple s p (mk-upi tv)) + (when tv + (add-triple s p (mk-upi tv))) (3c-echo-triple s p tv nil nil)) +(defun 3c-make (type &key id) + "Generates blank node and associates it with type and other options" + (let ((node (new-blank-node))) + (add-triple node !ccc:instance-of (mk-upi type)) + (when id + (3c-register node id)) + node)) + +;;; --- API --------------------------------------- + +(defun 3c-init () + (setf *3c-pulse* 0) + (setf *3c?* (make-hash-table :test 'equal))) + +;;; --- API constructors ------------------------------- + +(defun 3c-in (initial-value &key ephemeral &aux (c (new-blank-node))) + (add-triple c !ccc:type !ccc:input) + (setf (3c-cell-value c) initial-value) + (when ephemeral + (add-triple c !ccc:ephemeral !ccc:t)) + c) +(defmacro 3c? (&body rule) + `(call-3c? '(lambda (node) + (let ((*calc-node* node)) + , at rule)))) + +(defun call-3c? (rule) + (let* ((c (new-blank-node)) + (tr-c (add-triple c !ccc:type !ccc:ruled)) + (tr-cv (add-triple c !ccc:rule (mk-upi (princ-to-string rule))))) + (let ((rule-fn (eval rule))) + (trc "rule-fn" rule-fn :from rule) + (setf (3c?-rule c) rule-fn) + (trc "c? type tr" tr-c) + (trc "c? value tr" tr-cv) + c))) + +;;; --- API accessors + +(defun 3c (s p &aux (tr-value (get-sp s p))) + (bif (tr-cell (stmt-cell s p)) + (progn + (3c-ensure-current (object tr-cell) tr-value) + (get-sp-value s p)) + (when tr-value + (triple-value tr-value)))) (defun (setf 3c) (new-value s p) (trc "SETF>" p new-value) - (let (tr-cell tr-value) - (loop for tr in (get-triples-list :s s :p p) - if (3c-cell? (object tr)) do (setf tr-cell tr) - else do (setf tr-value tr)) - (assert tr-cell () "subject ~a pred ~a not mediated by input cell so cannot be changed from ~a to ~a" - s p (object tr-value) new-value) - ;(trc "tr-cell" (triple-id tr-cell)) - ;(trc "tr-value" (triple-id tr-value)) - (let ((prior-object (object tr-value))) - (unless (equal new-value (upi->value prior-object)) - (delete-triple (triple-id tr-value)) - ;(trc "tr-value orig deleted") + (let* ((tr-cell (stmt-cell s p)) + (tr-value (get-sp s p)) + (prior-value (when tr-value (upi->value (object tr-value))))) + + (assert tr-cell () "subject ~a pred ~a not mediated by input cell so cannot be changed from ~a to ~a" + s p prior-value new-value) + ;(trc "tr-cell" (triple-id tr-cell)) + ;(trc "tr-value" (triple-id tr-value)) + + (unless (equal new-value prior-value) + (3c-pulse-advance :setf-3c) + (when tr-value + (delete-triple (triple-id tr-value)) + (trc "tr-value orig deleted")) + (let* ((new-value-upi (mk-upi new-value)) (tr-value-new (add-triple s p new-value-upi))) - (let ((tr-cell-value (car (get-triples-list :s (object tr-cell) :p !ccc:value)))) - (assert tr-cell-value) - (delete-triple (triple-id tr-cell-value)) - (let ((tr-cell-value-new (add-triple (object tr-cell) !ccc:value new-value-upi))) - (3c-observe-predicate (3c-class-of s)(3c-predicate-of p) - new-value - (upi->value prior-object) - t) - (when (3c-ephemeral? (object tr-cell)) - ; fix up cell... - (delete-triple tr-cell-value-new) - (add-triple (object tr-cell) !ccc:value !ccc:nil) - ; reset value itself to nil - (delete-triple tr-value-new) - (add-triple s p !ccc:nil))))))))) + (delete-triples :s (object tr-cell) :p !ccc:value) + + (let ((tr-cell-value-new (add-triple (object tr-cell) !ccc:value new-value-upi))) + (3c-echo-triple s p new-value prior-value t) + (when (3c-ephemeral? (object tr-cell)) + ; fix up cell... + (delete-triple tr-cell-value-new) + ; reset value itself to nil + (delete-triple tr-value-new))))))) -;;; --- utils ------------------------ -(defun mk-upi (v) - (typecase v - (string (literal v)) - (integer (value->upi v :short)) - (otherwise v) ;; probably should not occur - )) \ No newline at end of file --- /project/cells/cvsroot/triple-cells/hello-world.lisp 2007/12/20 13:08:17 1.1 +++ /project/cells/cvsroot/triple-cells/hello-world.lisp 2007/12/21 19:02:10 1.2 @@ -30,38 +30,42 @@ (format t "~&happen: ~a" new-value))) (defmethod 3c-observe-predicate (s (p (eql 'happen)) new-value prior-value prior-value?) - (trc "OBS> happen" s new-value prior-value prior-value?)) + (trc "OBS> happen" *3c-pulse* s new-value prior-value prior-value?)) (defmethod 3c-observe-predicate (s (p (eql 'location)) new-value prior-value prior-value?) - (trc "OBS> location" s new-value prior-value prior-value?)) - + (trc "OBS> location" *3c-pulse* s new-value prior-value prior-value?)) (defun 3c-test () + (3c-init) (let ((*synchronize-automatically* t)) (enable-print-decoded t) (make-tutorial-store) (register-namespace "hw" "helloworld#" :errorp nil) (register-namespace "ccc" "triplecells#" :errorp nil) - - (let ((dell (new-blank-node)) + + (let ((dell (3c-make "dell" :id !)) (happen !"happen") - (location !"location")) - - (add-triple dell !ccc:instance-of !) + (location !"location") + ) - (3c-add-triple dell happen #+const "test" (3cv "test" :ephemeral t)) - (trc "start happen is" (3c-pred-value dell happen)) + (stmt-new dell happen #+const "test" (3c-in nil :ephemeral t)) + (trc "start happen is" (3c dell happen)) - (3c-add-triple dell location - (3c? (if (string-equal (3c-pred-value dell happen) "arrive") - "home" "away"))) - (trc "start location is" (3c-pred-value dell location)) - + (stmt-new dell location + (3c? (trc "RULE-ENTRY>" *3c-pulse*) + (if (string-equal (3c (3c-find-id "dell") !"happen") "arrive") + "home" "away"))) + + (trc "start location is" (3c dell location)) +;;; (setf (3c dell happen) "arrive") +;;; (trc "post-arrive location is" (3c dell location)) (loop repeat 2 do (setf (3c dell happen) "knock-knock")) (setf (3c dell happen) "arrive") (setf (3c dell happen) "knock-knock") - (setf (3c dell happen) "leave")))) + (setf (3c dell happen) "leave") + + ))) #| --- /project/cells/cvsroot/triple-cells/triple-cells.lpr 2007/12/20 13:08:17 1.1 +++ /project/cells/cvsroot/triple-cells/triple-cells.lpr 2007/12/21 19:02:10 1.2 @@ -9,6 +9,7 @@ (make-instance 'module :name "ag-utils.lisp") (make-instance 'module :name "core.lisp") (make-instance 'module :name "agraph-tutorial") + (make-instance 'module :name "namespace.lisp") (make-instance 'module :name "hello-world.lisp")) :projects (list (make-instance 'project-module :name "..\\Cells\\cells")) --- /project/cells/cvsroot/triple-cells/namespace.lisp 2007/12/21 19:02:10 NONE +++ /project/cells/cvsroot/triple-cells/namespace.lisp 2007/12/21 19:02:10 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-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 :3c) (defun 3c-register (node name) (add-triple node !ccc:id (mk-upi name))) (defun 3c-find-id (name) (car (get-triples-list :p !ccc:id :o (mk-upi name)))) #+test (progn (make-tutorial-store) (let ((x (3c-make ! :id "x-plane"))) (3c-find-id "x-plane"))) From ktilton at common-lisp.net Sun Dec 23 10:04:57 2007 From: ktilton at common-lisp.net (ktilton) Date: Sun, 23 Dec 2007 05:04:57 -0500 (EST) Subject: [cells-cvs] CVS triple-cells Message-ID: <20071223100457.3A66F5C186@common-lisp.net> Update of /project/cells/cvsroot/triple-cells In directory clnet:/tmp/cvs-serv31046 Modified Files: core.lisp hello-world.lisp namespace.lisp triple-cells.lpr Added Files: api.lisp dataflow.lisp observer.lisp Log Message: --- /project/cells/cvsroot/triple-cells/core.lisp 2007/12/21 19:02:10 1.2 +++ /project/cells/cvsroot/triple-cells/core.lisp 2007/12/23 10:04:53 1.3 @@ -24,47 +24,21 @@ (in-package :3c) -;; --- ag utils ----------------------- - -(defun triple-value (tr) - (when tr - (upi->value (object tr)))) - -(defun get-sp (s p) - #+allegrocl (get-triple :s s :p p) - #-allegrocl (car (get-triples-list :s s :p p))) - -(defun get-spo (s p o) - #+allegrocl (get-triple :s s :p p :o o) - #-allegrocl (car (get-triples-list :s s :p p :o o))) - -(defun get-sp-value (s p) - (triple-value (get-sp s p))) - -(defun mk-upi (v) - (typecase v - (string (literal v)) - (integer (value->upi v :short)) - (otherwise v) ;; probably should not occur - )) - ;; --- triple-cells --- - (defvar *3c-pulse*) -(defvar *calc-node*) +(defvar *calc-nodes*) (defun 3c-pulse-advance (dbg) - (trc "PULSE>" (1+ *3c-pulse*) dbg) + (declare (ignorable dbg)) + (trc "PULSE> ------------------" (1+ *3c-pulse*) dbg) (incf *3c-pulse*)) - - ;;; --- low-level 3cell accessors (defun 3c-cell-value (c) (bwhen (tr (get-sp c !ccc:value)) - (object tr))) + (part-value (object tr)))) (defun (setf 3c-cell-value) (new-value c) (delete-triples :s c :p !ccc:value) @@ -78,15 +52,21 @@ (defvar *3c?*) -(defun (setf 3c?-rule) (c-node rule) +#+dump +(maphash (lambda (k v) (trc "kk" k v)) *3c?*) + +(defun (setf 3c?-rule) ( rule c-node) + (assert (functionp rule) () "3c?-rule setf not rule: ~a ~a" (type-of rule) rule) + ;;(trc "storing rule!!!! for" c-node rule) (setf (gethash c-node *3c?*) rule)) (defun 3c?-rule (c-node) (or (gethash c-node *3c?*) (setf (gethash c-node *3c?*) (let ((rule$ (get-sp-value c-node !ccc:rule))) - (trc "got rule" rule$) - (eval rule$))))) + ;;(trc "got rule" rule$) + (eval (read-from-string rule$)))))) + ;;; --- 3cell predicates ------------------------------------------- @@ -110,44 +90,20 @@ ;;; --- 3cell accessors ------------------------------------------- (defun 3c-class-of (s) - (intern (up$ (get-sp-value s !ccc:instance-of)))) + (let ((type (object (get-sp s !ccc:instance-of)))) + (echo-sym (upi->value type)))) (defun 3c-predicate-of (p) - (intern (up$ (part-value p)))) - -;;; --- integrity ---------------------------------------------- - -(defun 3c-ensure-current (tr-cell tr-value) - (when (and tr-cell (3c-ruled? tr-cell)) - (trc "ensuring current" *3c-pulse* (3c-pulse tr-cell) (subject tr-cell)(predicate tr-cell)(3c-cell-value tr-cell) ) - (when (> *3c-pulse* (3c-pulse tr-cell)) - (let ((new-value (funcall (3c?-rule tr-cell) tr-cell))) - (unless (eql new-value (3c-cell-value tr-cell)) - (let ((s (subject tr-cell)) - (p (predicate tr-cell)) - (prior-value (3c-cell-value tr-cell))) - (setf (3c-cell-value tr-cell) new-value) - (delete-triple tr-value) - (prog1 - (get-triple-by-id - (add-triple s p (mk-upi new-value))) - (3c-echo-triple s p new-value prior-value t)))))))) - + (echo-sym (etypecase p + (array (upi->value p)) + (future-part (part->string p))))) + +(defun echo-sym (s) + (intern (nsubstitute #\- #\# + (up$ (string-trim "<>" s))))) - -;;; --- 3cell observation -------------------------------------------------------- - -(defun 3c-echo-triple (s p new-value prior-value prior-value?) - (3c-observe-predicate (3c-class-of s)(3c-predicate-of p) - new-value - prior-value - prior-value?)) - -(defmethod 3c-observe-predicate (s p new-value prior-value prior-value?) - (trc "3c-observe undefined" s p new-value prior-value prior-value?)) - ;;; --- access ------------------------------------------ (defun subject-cells-node (s) @@ -161,106 +117,46 @@ (add-triple (subject-cells-node s) p new-cell)) (defun stmt-cell (s p) - (get-sp (subject-cells-node s) p)) + (bwhen (tr (get-sp (subject-cells-node s) p)) + (object tr))) + +(defun cell-predicate (c) + (predicate (car (get-triples-list :o c)))) + +(defun cell-subject (c) + (subject (car (get-triples-list + :p !ccc:cells + :o (subject (car (get-triples-list :o c))))))) (defun stmt-new (s p o &aux (tv o)) (when (3c-cell? o) (add-triple (subject-cells-node s) p o) - + (cond ((3c-input? o) (3c-pulse-advance :new-input) ;; why does creating data advance pulse? (setf tv (3c-cell-value o))) ((3c-ruled? o) - (setf tv (funcall (3c?-rule o) o)) + (setf tv (funcall (3c?-rule o) o nil nil)) (setf (3c-cell-value o) tv)) (t (break "unknown cell" o))) (add-triple o !ccc:pulse (mk-upi *3c-pulse*)) (setf tv (3c-cell-value o))) + (when tv (add-triple s p (mk-upi tv))) - (3c-echo-triple s p tv nil nil)) + + (cell-observe-change o s p tv nil nil)) (defun 3c-make (type &key id) "Generates blank node and associates it with type and other options" (let ((node (new-blank-node))) - (add-triple node !ccc:instance-of (mk-upi type)) + (trc "3c-make storing type" type (type-of type)) + (add-triple node !ccc:instance-of type) ; (mk-upi type)) (when id (3c-register node id)) node)) -;;; --- API --------------------------------------- - -(defun 3c-init () - (setf *3c-pulse* 0) - (setf *3c?* (make-hash-table :test 'equal))) - -;;; --- API constructors ------------------------------- - -(defun 3c-in (initial-value &key ephemeral &aux (c (new-blank-node))) - (add-triple c !ccc:type !ccc:input) - (setf (3c-cell-value c) initial-value) - (when ephemeral - (add-triple c !ccc:ephemeral !ccc:t)) - c) - -(defmacro 3c? (&body rule) - `(call-3c? '(lambda (node) - (let ((*calc-node* node)) - , at rule)))) - -(defun call-3c? (rule) - (let* ((c (new-blank-node)) - (tr-c (add-triple c !ccc:type !ccc:ruled)) - (tr-cv (add-triple c !ccc:rule (mk-upi (princ-to-string rule))))) - (let ((rule-fn (eval rule))) - (trc "rule-fn" rule-fn :from rule) - (setf (3c?-rule c) rule-fn) - (trc "c? type tr" tr-c) - (trc "c? value tr" tr-cv) - c))) - -;;; --- API accessors - -(defun 3c (s p &aux (tr-value (get-sp s p))) - (bif (tr-cell (stmt-cell s p)) - (progn - (3c-ensure-current (object tr-cell) tr-value) - (get-sp-value s p)) - (when tr-value - (triple-value tr-value)))) - -(defun (setf 3c) (new-value s p) - (trc "SETF>" p new-value) - (let* ((tr-cell (stmt-cell s p)) - (tr-value (get-sp s p)) - (prior-value (when tr-value (upi->value (object tr-value))))) - - (assert tr-cell () "subject ~a pred ~a not mediated by input cell so cannot be changed from ~a to ~a" - s p prior-value new-value) - ;(trc "tr-cell" (triple-id tr-cell)) - ;(trc "tr-value" (triple-id tr-value)) - - (unless (equal new-value prior-value) - (3c-pulse-advance :setf-3c) - (when tr-value - (delete-triple (triple-id tr-value)) - (trc "tr-value orig deleted")) - - (let* ((new-value-upi (mk-upi new-value)) - (tr-value-new (add-triple s p new-value-upi))) - - (delete-triples :s (object tr-cell) :p !ccc:value) - - (let ((tr-cell-value-new (add-triple (object tr-cell) !ccc:value new-value-upi))) - (3c-echo-triple s p new-value prior-value t) - (when (3c-ephemeral? (object tr-cell)) - ; fix up cell... - (delete-triple tr-cell-value-new) - ; reset value itself to nil - (delete-triple tr-value-new))))))) - - --- /project/cells/cvsroot/triple-cells/hello-world.lisp 2007/12/21 19:02:10 1.2 +++ /project/cells/cvsroot/triple-cells/hello-world.lisp 2007/12/23 10:04:56 1.3 @@ -24,102 +24,101 @@ (in-package :3c) -#+wait -(def-3c-observer happen () - (when new-value - (format t "~&happen: ~a" new-value))) -(defmethod 3c-observe-predicate (s (p (eql 'happen)) new-value prior-value prior-value?) - (trc "OBS> happen" *3c-pulse* s new-value prior-value prior-value?)) +(defun 3c-test-reopen () + (close-triple-store) + (open-triple-store "hello-world" + :directory (project-path) + :if-does-not-exist :error) + (let ((dell (3c-find-id "dell")) + (happen !hw:happen) + (location !hw:location) + (response !hw:response)) + + (trc "start" (3c dell happen)(3c dell location)(3c dell response)) + (setf (3c dell happen) "knock-knock") + (setf (3c dell happen) "arrive") + (setf (3c dell happen) "knock-knock") + )) -(defmethod 3c-observe-predicate (s (p (eql 'location)) new-value prior-value prior-value?) - (trc "OBS> location" *3c-pulse* s new-value prior-value prior-value?)) +#+test +(3c-test) (defun 3c-test () - (3c-init) + (test-prep "3c") + (unwind-protect + (progn + (3c-init) (let ((*synchronize-automatically* t)) (enable-print-decoded t) - (make-tutorial-store) + (create-triple-store "hello-world" + :if-exists :supersede + :directory (project-path)) (register-namespace "hw" "helloworld#" :errorp nil) (register-namespace "ccc" "triplecells#" :errorp nil) - (let ((dell (3c-make "dell" :id !)) - (happen !"happen") - (location !"location") - ) - - (stmt-new dell happen #+const "test" (3c-in nil :ephemeral t)) - (trc "start happen is" (3c dell happen)) + + + (let ((dell (3c-make !hw:computer :id "dell")) + (happen !hw:happen) + (location !hw:location) + (response !hw:response)) + (assert dell) + + (make-observer !hw:echo-happen (trc "happen:" new-value)) + (make-observer !hw:obs-location (trc "We are now" new-value )) + (make-observer !hw:obs-response (trc "Speak:" new-value )) + + (stmt-new dell happen #+const "test" + (3c-in nil :ephemeral t + :observer !hw:echo-happen + :test 'equal)) (stmt-new dell location - (3c? (trc "RULE-ENTRY>" *3c-pulse*) - (if (string-equal (3c (3c-find-id "dell") !"happen") "arrive") - "home" "away"))) - - (trc "start location is" (3c dell location)) -;;; (setf (3c dell happen) "arrive") -;;; (trc "post-arrive location is" (3c dell location)) - (loop repeat 2 do - (setf (3c dell happen) "knock-knock")) - (setf (3c dell happen) "arrive") - (setf (3c dell happen) "knock-knock") - (setf (3c dell happen) "leave") + (3c? ;(trc "RULE-ENTRY>" *3c-pulse*) + (let ((h (3c (3c-find-id "dell") !hw:happen))) + ;(trc "rule sees happen" h) + (cond + ((string-equal h "arrive") "home") + ((string-equal h "leave") "away") + (cache? cache) + (t "away"))) + :observer !hw:obs-location + :test 'equal)) + + (stmt-new dell response + (3c? (let* ((dell (3c-find-id "dell")) + (h (3c dell !hw:happen)) + (loc (3c dell !hw:location))) + ;(trc "response rule sees happen" h :loc loc) + (cond + ((string-equal h "knock-knock") + (cond + ((string-equal loc "home") "who's there?") + (t "silence"))) + ((string-equal h "arrive") + (cond + ((string-equal loc "home") "honey, i am home!"))) + ((string-equal h "leave") + (cond + ((string-equal loc "away") "bye-bye!"))) + (t cache))) + :observer !hw:obs-response + :test 'equal)) + + (time + (progn + (setf (3c dell happen) "knock-knock") + (loop repeat 2 do + (setf (3c dell happen) "knock-knock")) + (setf (3c dell happen) "arrive") + + (setf (3c dell happen) "knock-knock") + (setf (3c dell happen) "leave"))) ))) + (dribble))) -#| - -(defmd computer () - (happen (c-in nil) :cell :ephemeral) - (location (c? (case (^happen) - (:leave :away) - (:arrive :at-home) - (t .cache)))) ;; ie, unchanged - (response nil :cell :ephemeral)) - -(defobserver response(self new-response old-response) - (when new-response - (format t "~&computer: ~a" new-response))) - -(defobserver happen() - (when new-value - (format t "~&happen: ~a" new-value))) - -(def-cell-test hello-world () - (let ((dell (make-instance 'computer - :response (c? (bwhen (h (happen self)) - (if (eql (^location) :at-home) - (case h - (:knock-knock "who's there?") - (:world "hello, world.")) - "")))))) - (dotimes (n 2) - (setf (happen dell) :knock-knock)) - - (setf (happen dell) :arrive) - (setf (happen dell) :knock-knock) - (setf (happen dell) :leave) - (values))) - -|# - -#+(or) -(hello-world) - - -#| output - -happen: KNOCK-KNOCK -computer: -happen: KNOCK-KNOCK -computer: -happen: ARRIVE -happen: KNOCK-KNOCK -computer: who's there? -happen: LEAVE -computer: - -|# --- /project/cells/cvsroot/triple-cells/namespace.lisp 2007/12/21 19:02:10 1.1 +++ /project/cells/cvsroot/triple-cells/namespace.lisp 2007/12/23 10:04:56 1.2 @@ -25,10 +25,10 @@ (in-package :3c) (defun 3c-register (node name) - (add-triple node !ccc:id (mk-upi name))) + (add-triple (mk-upi name) !ccc:id node)) (defun 3c-find-id (name) - (car (get-triples-list :p !ccc:id :o (mk-upi name)))) + (object (get-sp (mk-upi name) !ccc:id))) #+test (progn --- /project/cells/cvsroot/triple-cells/triple-cells.lpr 2007/12/21 19:02:10 1.2 +++ /project/cells/cvsroot/triple-cells/triple-cells.lpr 2007/12/23 10:04:56 1.3 @@ -6,10 +6,13 @@ (define-project :name :triple-cells :modules (list (make-instance 'module :name "defpackage.lisp") - (make-instance 'module :name "ag-utils.lisp") (make-instance 'module :name "core.lisp") (make-instance 'module :name "agraph-tutorial") (make-instance 'module :name "namespace.lisp") + (make-instance 'module :name "api.lisp") + (make-instance 'module :name "ag-utilities.lisp") + (make-instance 'module :name "dataflow.lisp") + (make-instance 'module :name "observer.lisp") (make-instance 'module :name "hello-world.lisp")) :projects (list (make-instance 'project-module :name "..\\Cells\\cells")) --- /project/cells/cvsroot/triple-cells/api.lisp 2007/12/23 10:04:57 NONE +++ /project/cells/cvsroot/triple-cells/api.lisp 2007/12/23 10:04:57 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-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 :3c) ;;; --- API --------------------------------------- (defun 3c-init () (setf *3c-pulse* 0) (setf *calc-nodes* nil) (setf *3c?* (make-hash-table :test 'equal)) (setf *3c-observers* (make-hash-table :test 'equal))) ;;; --- API constructors ------------------------------- (defun 3c-in (initial-value &key ephemeral test observer &aux (c (new-blank-node))) (add-triple c !ccc:type !ccc:input) (when observer (add-triple c !ccc:observer-is (mk-upi observer))) (setf (3c-cell-value c) initial-value) (when ephemeral (add-triple c !ccc:ephemeral !ccc:t)) (when test (add-triple c !ccc:test (mk-upi test))) c) (defmacro 3c? (rule &key test ephemeral observer) `(call-3c? '(lambda (node cache cache?) (declare (ignorable cache cache?)) (let ((*calc-nodes* (cons node *calc-nodes*))) ,rule)) :test ,test :observer ,observer :ephemeral ,ephemeral)) (defun call-3c? (rule &key test ephemeral observer) (let* ((c (new-blank-node))) (add-triple c !ccc:type !ccc:ruled) (add-triple c !ccc:rule (mk-upi (prin1-to-string rule))) (when ephemeral (add-triple c !ccc:ephemeral !ccc:t)) (when test (add-triple c !ccc:test (mk-upi test))) (when observer (add-triple c !ccc:observer-is (mk-upi observer))) (let ((rule-fn (eval rule))) ;(trc "rule-fn" rule-fn :from rule) (setf (3c?-rule c) rule-fn) ;(trc "c? type tr" tr-c) ;(trc "c? value tr" tr-cv) c))) ;;; --- API accessors (defun clear-usage (cell) (delete-triples :s cell :p !ccc:uses)) (defun 3c (s p) (assert (and s p)) (bif (cell (stmt-cell s p)) (progn (3c-ensure-current cell s p) (when *calc-nodes* (assert (listp *calc-nodes*)) (assert (not (find cell *calc-nodes*))() "Circularity? ~a ~a" cell *calc-nodes*) (ensure-triple (car *calc-nodes*) !ccc:uses cell)) (get-sp-value s p)) (get-sp-value s p))) (defun (setf 3c) (new-value s p) (let* ((cell (stmt-cell s p)) (tr-value (get-sp s p)) (prior-value (when tr-value (upi->value (object tr-value))))) (assert cell () "subject ~a pred ~a not mediated by input cell so cannot be changed from ~a to ~a" s p prior-value new-value) ;(trc "tr-cell" (triple-id tr-cell)) ;(trc "tr-value" (triple-id tr-value)) (unless (equal new-value prior-value) (3c-pulse-advance :setf-3c) (when tr-value (delete-triple (triple-id tr-value))) (let* ((new-value-upi (mk-upi new-value)) (tr-value-new (add-triple s p new-value-upi))) (delete-triples :s cell :p !ccc:value) (let ((tr-cell-value-new (add-triple cell !ccc:value new-value-upi))) (3c-propagate cell) (cell-observe-change cell s p new-value prior-value t) (when (3c-ephemeral? cell) ; fix up cell... (delete-triple tr-cell-value-new) ; reset value itself to nil (delete-triple tr-value-new))))))) --- /project/cells/cvsroot/triple-cells/dataflow.lisp 2007/12/23 10:04:57 NONE +++ /project/cells/cvsroot/triple-cells/dataflow.lisp 2007/12/23 10:04:57 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-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 :3c) (defun 3c-propagate (cell) (loop for user in (get-triples-list :p !ccc:uses :o cell) do (trc nil "propagating !!!!!!!!!!!!" cell :to (subject user)) (3c-ensure-current (subject user)))) ;;; --- integrity -----------------(part-value prior-value)----------------------------- (defun 3c-ensure-current (cell &optional s p) ;; when we don't have s/p extend to work backwards from cell (unless s (setf s (cell-subject cell) p (cell-predicate cell))) ;(trc "3c-ensure-current" s p) (when (and cell (3c-ruled? cell)) (when (> *3c-pulse* (3c-pulse cell)) ;(trc "old" (3c-cell-value cell)) (let* ((prior-value (3c-cell-value cell)) (new-value (progn (clear-usage cell) (funcall (3c?-rule cell) cell prior-value t))) (test (or (bwhen (test (get-sp-value cell !ccc:test)) (intern test)) 'EQL))) ;(trc "prop new" new-value) (unless (funcall test new-value prior-value) (let ((prior-value (3c-cell-value cell))) (setf (3c-cell-value cell) new-value) (delete-triples :s s :p p) (when new-value (add-triple s p (mk-upi new-value))) (3c-propagate cell) (cell-observe-change cell s p new-value prior-value t))))))) --- /project/cells/cvsroot/triple-cells/observer.lisp 2007/12/23 10:04:57 NONE +++ /project/cells/cvsroot/triple-cells/observer.lisp 2007/12/23 10:04:57 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-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 :3c) (defmacro make-observer (id form) `(call-make-observer ,id '(lambda (s p new-value prior-value prior-value?) (declare (ignorable s p new-value prior-value prior-value?)) ,form))) (defun call-make-observer (id observer) (trc "storing observer!!!!!!!!!!!" id !ccc:observer-id-rule (mk-upi (prin1-to-string observer))) (add-triple id !ccc:observer-id-rule (mk-upi (prin1-to-string observer))) (setf (3c-observer id) (eval observer))) ;; while we're at it ;;; --- 3cell observation -------------------------------------------------------- (defun cell-observe-change (cell s p new-value prior-value prior-value?) (bif (otr (get-sp cell !ccc:observer-is)) (funcall (3c-observer (object otr)) s p new-value prior-value prior-value?) (trc "unobserved" s p))) ;;; ---------------------------------------------------- (defvar *3c-observers*) (defun (setf 3c-observer) (function c-node) (assert (functionp function) () "3c-observer setf not rule: ~a ~a" (type-of function) function) (setf (gethash c-node *3c-observers*) function)) (defun 3c-observer (c-node &aux (unode (part->string c-node))) (or (gethash unode *3c-observers*) (setf (gethash unode *3c-observers*) (let ((fn$ (get-sp-value unode !ccc:observer-id-rule))) (assert fn$) (eval (read-from-string fn$))))))