[cells-cvs] CVS triple-cells
ktilton
ktilton at common-lisp.net
Sun Dec 23 10:04:57 UTC 2007
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 !<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$))))))
More information about the Cells-cvs
mailing list