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

Contents of /triple-cells/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Thu Dec 20 13:08:17 2007 UTC (6 years, 3 months ago) by ktilton
Branch: MAIN
*** 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     (upi->value (object tr)))
31    
32     (defun get-sp (s p)
33     #+allegrocl (get-triple :s s :p p)
34     #-allegrocl (car (get-triples-list :s s :p p)))
35    
36     (defun get-spo (s p o)
37     #+allegrocl (get-triple :s s :p p :o o)
38     #-allegrocl (car (get-triples-list :s s :p p :o o)))
39    
40     (defun get-sp-value (s p)
41     (triple-value (get-sp s p)))
42    
43     ;; --- triple-cells ---
44    
45     (defvar *3c?*)
46     (defvar *3c-pulse*)
47    
48     (defun 3c-init ()
49     (setf *3c-pulse* 0)
50     (setf *3c?* (make-hash-table :test 'equal)))
51    
52     ;;; --- 3cell predicates -------------------------------------------
53    
54     (defun 3c-cell? (c)
55     (when (upip c)
56     (get-sp c !ccc:type)))
57    
58     (defun 3c-pulse (c)
59     (get-sp-value c !ccc:pulse))
60    
61     (defun 3c-ephemeral? (c)
62     (get-sp c !ccc:ephemeral))
63    
64     (defun 3c-ruled? (c)
65     (when (upip c)
66     (bwhen (tr-type (get-sp c !ccc:type))
67     (part= (object tr-type) !ccc:ruled))))
68    
69     ;;; --- 3cell accessors -------------------------------------------
70    
71     (defun 3c-class-of (s)
72     (intern (up$ (get-sp-value s !ccc:instance-of))))
73    
74     (defun 3c-predicate-of (p)
75     (intern (up$ (part-value p))))
76    
77     (defun 3c-pred-value (s p)
78     (loop for tr in (get-triples-list :s s :p p)
79     unless (3c-cell? (object tr))
80     return (triple-value tr)))
81    
82     (defun 3c-cell-value (c)
83     (when (3c-ruled? c)
84     (3c-ensure-current c))
85     (object (car (get-triples-list :s c :p !ccc:value))))
86    
87    
88     ;; --- 3cell construction -----------------------------------------
89    
90     (defun 3cv (initial-value &key ephemeral &aux (c (new-blank-node)))
91     (add-triple c !ccc:type !ccc:input)
92     (add-triple c !ccc:value (mk-upi initial-value))
93     (when ephemeral
94     (add-triple c !ccc:ephemeral !ccc:t))
95     c)
96    
97     (defmacro 3c? (&body rule)
98     `(call-3c? '(progn ,@rule)))
99    
100     (defun 3c?-rule-store (c-node rule)
101     (setf (gethash *3c?* c-node) rule))
102    
103     (defun 3c?-rule (c-node)
104     (gethash *3c?* c-node))
105    
106     (defun call-3c? (rule)
107     (let* ((c (new-blank-node))
108     (tr-c (add-triple c !ccc:type !ccc:ruled))
109     (tr-cv (add-triple c !ccc:rule (mk-upi (princ-to-string rule)))))
110     (3c?-rule-store c (eval rule))
111     (trc "c? type tr" tr-c)
112     (trc "c? value tr" tr-cv)
113     c))
114    
115    
116     (defun 3c-ensure-current (c)
117     (when (> *3c-pulse* (3c-pulse c))))
118    
119    
120     ;;; --- 3cell observation --------------------------------------------------------
121    
122     (defun 3c-echo-triple (s p new-value prior-value prior-value?)
123     (3c-observe-predicate (3c-class-of s)(3c-predicate-of p)
124     new-value
125     (when prior-value (upi->value prior-value))
126     prior-value?))
127    
128     (defmethod 3c-observe-predicate (s p new-value prior-value prior-value?)
129     (trc "3c-observe undefined" s p new-value prior-value prior-value?))
130    
131     ;;; --- access ------------------------------------------
132    
133     (defun 3c-add-triple (s p o &aux (tv o))
134     (when (3c-cell? o)
135     (add-triple s p o) ;; associate cell with this s and p
136     (incf *3c-pulse*)
137     (add-triple o !ccc:pulse (mk-upi *3c-pulse*))
138     (setf tv (3c-cell-value o)))
139     (add-triple s p (mk-upi tv))
140     (3c-echo-triple s p tv nil nil))
141    
142    
143    
144     (defun (setf 3c) (new-value s p)
145     (trc "SETF>" p new-value)
146     (let (tr-cell tr-value)
147     (loop for tr in (get-triples-list :s s :p p)
148     if (3c-cell? (object tr)) do (setf tr-cell tr)
149     else do (setf tr-value tr))
150     (assert tr-cell () "subject ~a pred ~a not mediated by input cell so cannot be changed from ~a to ~a"
151     s p (object tr-value) new-value)
152     ;(trc "tr-cell" (triple-id tr-cell))
153     ;(trc "tr-value" (triple-id tr-value))
154     (let ((prior-object (object tr-value)))
155     (unless (equal new-value (upi->value prior-object))
156     (delete-triple (triple-id tr-value))
157     ;(trc "tr-value orig deleted")
158     (let* ((new-value-upi (mk-upi new-value))
159     (tr-value-new (add-triple s p new-value-upi)))
160     (let ((tr-cell-value (car (get-triples-list :s (object tr-cell) :p !ccc:value))))
161     (assert tr-cell-value)
162     (delete-triple (triple-id tr-cell-value))
163     (let ((tr-cell-value-new (add-triple (object tr-cell) !ccc:value new-value-upi)))
164     (3c-observe-predicate (3c-class-of s)(3c-predicate-of p)
165     new-value
166     (upi->value prior-object)
167     t)
168     (when (3c-ephemeral? (object tr-cell))
169     ; fix up cell...
170     (delete-triple tr-cell-value-new)
171     (add-triple (object tr-cell) !ccc:value !ccc:nil)
172     ; reset value itself to nil
173     (delete-triple tr-value-new)
174     (add-triple s p !ccc:nil)))))))))
175    
176    
177     ;;; --- utils ------------------------
178    
179     (defun mk-upi (v)
180     (typecase v
181     (string (literal v))
182     (integer (value->upi v :short))
183     (otherwise v) ;; probably should not occur
184     ))

  ViewVC Help
Powered by ViewVC 1.1.5