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)) - ,@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 !<computer>)) - (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.")) - "<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> -
-|#
--- /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$))))))