[cells-cvs] CVS triple-cells - cells-cvs@common-lisp.net - mailman3.common-lisp.net

21 Dec 2007

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 ,@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))
+                  ,@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 !<computer>))
           (happen !"happen")
-          (location !"location"))
-
-      (add-triple dell !ccc:instance-of !<computer>)
+          (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 !<plane> :id "x-plane")))
    (3c-find-id "x-plane")))

    