/[cells]/triple-cells/core.lisp
ViewVC logotype

Contents of /triple-cells/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Fri Dec 21 19:02:10 2007 UTC (6 years, 4 months ago) by ktilton
Branch: MAIN
Changes since 1.1: +166 -84 lines
*** empty log message ***
1 ktilton 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*-
2     ;;;
3     ;;;
4     ;;; Copyright (c) 1995,2003 by Kenneth William Tilton.
5     ;;;
6     ;;; Permission is hereby granted, free of charge, to any person obtaining a copy
7     ;;; of this software and associated documentation files (the "Software"), to deal
8     ;;; in the Software without restriction, including without limitation the rights
9     ;;; to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
10     ;;; copies of the Software, and to permit persons to whom the Software is furnished
11     ;;; to do so, subject to the following conditions:
12     ;;;
13     ;;; The above copyright notice and this permission notice shall be included in
14     ;;; all copies or substantial portions of the Software.
15     ;;;
16     ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17     ;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
18     ;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
19     ;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
20     ;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
21     ;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
22     ;;; IN THE SOFTWARE.
23    
24    
25     (in-package :3c)
26    
27     ;; --- ag utils -----------------------
28    
29     (defun triple-value (tr)
30 ktilton 1.2 (when tr
31     (upi->value (object tr))))
32 ktilton 1.1
33     (defun get-sp (s p)
34     #+allegrocl (get-triple :s s :p p)
35     #-allegrocl (car (get-triples-list :s s :p p)))
36    
37     (defun get-spo (s p o)
38     #+allegrocl (get-triple :s s :p p :o o)
39     #-allegrocl (car (get-triples-list :s s :p p :o o)))
40    
41     (defun get-sp-value (s p)
42     (triple-value (get-sp s p)))
43    
44 ktilton 1.2 (defun mk-upi (v)
45     (typecase v
46     (string (literal v))
47     (integer (value->upi v :short))
48     (otherwise v) ;; probably should not occur
49     ))
50    
51 ktilton 1.1 ;; --- triple-cells ---
52    
53 ktilton 1.2
54     (defvar *3c-pulse*)
55     (defvar *calc-node*)
56    
57     (defun 3c-pulse-advance (dbg)
58     (trc "PULSE>" (1+ *3c-pulse*) dbg)
59     (incf *3c-pulse*))
60    
61    
62    
63     ;;; --- low-level 3cell accessors
64    
65     (defun 3c-cell-value (c)
66     (bwhen (tr (get-sp c !ccc:value))
67     (object tr)))
68    
69     (defun (setf 3c-cell-value) (new-value c)
70     (delete-triples :s c :p !ccc:value)
71     (when new-value
72     (add-triple c !ccc:value (mk-upi new-value))))
73    
74     (defun 3c-pulse (c)
75     (get-sp-value c !ccc:pulse))
76    
77     ;;; --- rule storage -------------------------------
78    
79 ktilton 1.1 (defvar *3c?*)
80    
81 ktilton 1.2 (defun (setf 3c?-rule) (c-node rule)
82     (setf (gethash c-node *3c?*) rule))
83    
84     (defun 3c?-rule (c-node)
85     (or (gethash c-node *3c?*)
86     (setf (gethash c-node *3c?*)
87     (let ((rule$ (get-sp-value c-node !ccc:rule)))
88     (trc "got rule" rule$)
89     (eval rule$)))))
90 ktilton 1.1
91     ;;; --- 3cell predicates -------------------------------------------
92    
93     (defun 3c-cell? (c)
94     (when (upip c)
95     (get-sp c !ccc:type)))
96    
97     (defun 3c-ephemeral? (c)
98     (get-sp c !ccc:ephemeral))
99    
100     (defun 3c-ruled? (c)
101     (when (upip c)
102     (bwhen (tr-type (get-sp c !ccc:type))
103     (part= (object tr-type) !ccc:ruled))))
104    
105 ktilton 1.2 (defun 3c-input? (c)
106     (when (upip c)
107     (bwhen (tr-type (get-sp c !ccc:type))
108     (part= (object tr-type) !ccc:input))))
109    
110 ktilton 1.1 ;;; --- 3cell accessors -------------------------------------------
111    
112     (defun 3c-class-of (s)
113     (intern (up$ (get-sp-value s !ccc:instance-of))))
114    
115     (defun 3c-predicate-of (p)
116     (intern (up$ (part-value p))))
117    
118 ktilton 1.2 ;;; --- integrity ----------------------------------------------
119 ktilton 1.1
120 ktilton 1.2 (defun 3c-ensure-current (tr-cell tr-value)
121     (when (and tr-cell (3c-ruled? tr-cell))
122     (trc "ensuring current" *3c-pulse* (3c-pulse tr-cell) (subject tr-cell)(predicate tr-cell)(3c-cell-value tr-cell) )
123     (when (> *3c-pulse* (3c-pulse tr-cell))
124     (let ((new-value (funcall (3c?-rule tr-cell) tr-cell)))
125     (unless (eql new-value (3c-cell-value tr-cell))
126     (let ((s (subject tr-cell))
127     (p (predicate tr-cell))
128     (prior-value (3c-cell-value tr-cell)))
129     (setf (3c-cell-value tr-cell) new-value)
130     (delete-triple tr-value)
131     (prog1
132     (get-triple-by-id
133     (add-triple s p (mk-upi new-value)))
134     (3c-echo-triple s p new-value prior-value t))))))))
135 ktilton 1.1
136    
137    
138    
139    
140     ;;; --- 3cell observation --------------------------------------------------------
141    
142     (defun 3c-echo-triple (s p new-value prior-value prior-value?)
143     (3c-observe-predicate (3c-class-of s)(3c-predicate-of p)
144     new-value
145 ktilton 1.2 prior-value
146 ktilton 1.1 prior-value?))
147    
148     (defmethod 3c-observe-predicate (s p new-value prior-value prior-value?)
149     (trc "3c-observe undefined" s p new-value prior-value prior-value?))
150    
151     ;;; --- access ------------------------------------------
152    
153 ktilton 1.2 (defun subject-cells-node (s)
154     (bif (tr (get-triple :s s :p !ccc:cells))
155     (object tr)
156     (let ((n (new-blank-node)))
157     (add-triple s !ccc:cells n)
158     n)))
159    
160     (defun (setf stmt-cell) (new-cell s p)
161     (add-triple (subject-cells-node s) p new-cell))
162    
163     (defun stmt-cell (s p)
164     (get-sp (subject-cells-node s) p))
165    
166     (defun stmt-new (s p o &aux (tv o))
167 ktilton 1.1 (when (3c-cell? o)
168 ktilton 1.2 (add-triple (subject-cells-node s) p o)
169    
170     (cond
171     ((3c-input? o)
172     (3c-pulse-advance :new-input) ;; why does creating data advance pulse?
173     (setf tv (3c-cell-value o)))
174    
175     ((3c-ruled? o)
176     (setf tv (funcall (3c?-rule o) o))
177     (setf (3c-cell-value o) tv))
178    
179     (t (break "unknown cell" o)))
180    
181 ktilton 1.1 (add-triple o !ccc:pulse (mk-upi *3c-pulse*))
182     (setf tv (3c-cell-value o)))
183 ktilton 1.2 (when tv
184     (add-triple s p (mk-upi tv)))
185 ktilton 1.1 (3c-echo-triple s p tv nil nil))
186    
187 ktilton 1.2 (defun 3c-make (type &key id)
188     "Generates blank node and associates it with type and other options"
189     (let ((node (new-blank-node)))
190     (add-triple node !ccc:instance-of (mk-upi type))
191     (when id
192     (3c-register node id))
193     node))
194    
195     ;;; --- API ---------------------------------------
196    
197     (defun 3c-init ()
198     (setf *3c-pulse* 0)
199     (setf *3c?* (make-hash-table :test 'equal)))
200    
201     ;;; --- API constructors -------------------------------
202    
203     (defun 3c-in (initial-value &key ephemeral &aux (c (new-blank-node)))
204     (add-triple c !ccc:type !ccc:input)
205     (setf (3c-cell-value c) initial-value)
206     (when ephemeral
207     (add-triple c !ccc:ephemeral !ccc:t))
208     c)
209 ktilton 1.1
210 ktilton 1.2 (defmacro 3c? (&body rule)
211     `(call-3c? '(lambda (node)
212     (let ((*calc-node* node))
213     ,@rule))))
214    
215     (defun call-3c? (rule)
216     (let* ((c (new-blank-node))
217     (tr-c (add-triple c !ccc:type !ccc:ruled))
218     (tr-cv (add-triple c !ccc:rule (mk-upi (princ-to-string rule)))))
219     (let ((rule-fn (eval rule)))
220     (trc "rule-fn" rule-fn :from rule)
221     (setf (3c?-rule c) rule-fn)
222     (trc "c? type tr" tr-c)
223     (trc "c? value tr" tr-cv)
224     c)))
225    
226     ;;; --- API accessors
227    
228     (defun 3c (s p &aux (tr-value (get-sp s p)))
229     (bif (tr-cell (stmt-cell s p))
230     (progn
231     (3c-ensure-current (object tr-cell) tr-value)
232     (get-sp-value s p))
233     (when tr-value
234     (triple-value tr-value))))
235 ktilton 1.1
236     (defun (setf 3c) (new-value s p)
237     (trc "SETF>" p new-value)
238 ktilton 1.2 (let* ((tr-cell (stmt-cell s p))
239     (tr-value (get-sp s p))
240     (prior-value (when tr-value (upi->value (object tr-value)))))
241    
242     (assert tr-cell () "subject ~a pred ~a not mediated by input cell so cannot be changed from ~a to ~a"
243     s p prior-value new-value)
244     ;(trc "tr-cell" (triple-id tr-cell))
245     ;(trc "tr-value" (triple-id tr-value))
246    
247     (unless (equal new-value prior-value)
248     (3c-pulse-advance :setf-3c)
249     (when tr-value
250     (delete-triple (triple-id tr-value))
251     (trc "tr-value orig deleted"))
252    
253 ktilton 1.1 (let* ((new-value-upi (mk-upi new-value))
254     (tr-value-new (add-triple s p new-value-upi)))
255    
256 ktilton 1.2 (delete-triples :s (object tr-cell) :p !ccc:value)
257    
258     (let ((tr-cell-value-new (add-triple (object tr-cell) !ccc:value new-value-upi)))
259     (3c-echo-triple s p new-value prior-value t)
260     (when (3c-ephemeral? (object tr-cell))
261     ; fix up cell...
262     (delete-triple tr-cell-value-new)
263     ; reset value itself to nil
264     (delete-triple tr-value-new)))))))
265 ktilton 1.1
266    

  ViewVC Help
Powered by ViewVC 1.1.5