[cells-cvs] CVS triple-cells
ktilton
ktilton at common-lisp.net
Fri Dec 21 19:02:11 UTC 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 , 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 !<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")))
More information about the Cells-cvs
mailing list