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

Contents of /triple-cells/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Sun Dec 23 10:04:53 2007 UTC (6 years, 4 months ago) by ktilton
Branch: MAIN
Changes since 1.2: +39 -143 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     ;; --- triple-cells ---
28    
29 ktilton 1.2 (defvar *3c-pulse*)
30 ktilton 1.3 (defvar *calc-nodes*)
31 ktilton 1.2
32     (defun 3c-pulse-advance (dbg)
33 ktilton 1.3 (declare (ignorable dbg))
34     (trc "PULSE> ------------------" (1+ *3c-pulse*) dbg)
35 ktilton 1.2 (incf *3c-pulse*))
36    
37     ;;; --- low-level 3cell accessors
38    
39     (defun 3c-cell-value (c)
40     (bwhen (tr (get-sp c !ccc:value))
41 ktilton 1.3 (part-value (object tr))))
42 ktilton 1.2
43     (defun (setf 3c-cell-value) (new-value c)
44     (delete-triples :s c :p !ccc:value)
45     (when new-value
46     (add-triple c !ccc:value (mk-upi new-value))))
47    
48     (defun 3c-pulse (c)
49     (get-sp-value c !ccc:pulse))
50    
51     ;;; --- rule storage -------------------------------
52    
53 ktilton 1.1 (defvar *3c?*)
54    
55 ktilton 1.3 #+dump
56     (maphash (lambda (k v) (trc "kk" k v)) *3c?*)
57    
58     (defun (setf 3c?-rule) ( rule c-node)
59     (assert (functionp rule) () "3c?-rule setf not rule: ~a ~a" (type-of rule) rule)
60     ;;(trc "storing rule!!!! for" c-node rule)
61 ktilton 1.2 (setf (gethash c-node *3c?*) rule))
62    
63     (defun 3c?-rule (c-node)
64     (or (gethash c-node *3c?*)
65     (setf (gethash c-node *3c?*)
66     (let ((rule$ (get-sp-value c-node !ccc:rule)))
67 ktilton 1.3 ;;(trc "got rule" rule$)
68     (eval (read-from-string rule$))))))
69    
70 ktilton 1.1
71     ;;; --- 3cell predicates -------------------------------------------
72    
73     (defun 3c-cell? (c)
74     (when (upip c)
75     (get-sp c !ccc:type)))
76    
77     (defun 3c-ephemeral? (c)
78     (get-sp c !ccc:ephemeral))
79    
80     (defun 3c-ruled? (c)
81     (when (upip c)
82     (bwhen (tr-type (get-sp c !ccc:type))
83     (part= (object tr-type) !ccc:ruled))))
84    
85 ktilton 1.2 (defun 3c-input? (c)
86     (when (upip c)
87     (bwhen (tr-type (get-sp c !ccc:type))
88     (part= (object tr-type) !ccc:input))))
89    
90 ktilton 1.1 ;;; --- 3cell accessors -------------------------------------------
91    
92     (defun 3c-class-of (s)
93 ktilton 1.3 (let ((type (object (get-sp s !ccc:instance-of))))
94     (echo-sym (upi->value type))))
95 ktilton 1.1
96     (defun 3c-predicate-of (p)
97 ktilton 1.3 (echo-sym (etypecase p
98     (array (upi->value p))
99     (future-part (part->string p)))))
100    
101     (defun echo-sym (s)
102     (intern (nsubstitute #\- #\#
103     (up$ (string-trim "<>" s)))))
104 ktilton 1.1
105    
106    
107     ;;; --- access ------------------------------------------
108    
109 ktilton 1.2 (defun subject-cells-node (s)
110     (bif (tr (get-triple :s s :p !ccc:cells))
111     (object tr)
112     (let ((n (new-blank-node)))
113     (add-triple s !ccc:cells n)
114     n)))
115    
116     (defun (setf stmt-cell) (new-cell s p)
117     (add-triple (subject-cells-node s) p new-cell))
118    
119     (defun stmt-cell (s p)
120 ktilton 1.3 (bwhen (tr (get-sp (subject-cells-node s) p))
121     (object tr)))
122    
123     (defun cell-predicate (c)
124     (predicate (car (get-triples-list :o c))))
125    
126     (defun cell-subject (c)
127     (subject (car (get-triples-list
128     :p !ccc:cells
129     :o (subject (car (get-triples-list :o c)))))))
130 ktilton 1.2
131     (defun stmt-new (s p o &aux (tv o))
132 ktilton 1.1 (when (3c-cell? o)
133 ktilton 1.2 (add-triple (subject-cells-node s) p o)
134 ktilton 1.3
135 ktilton 1.2 (cond
136     ((3c-input? o)
137     (3c-pulse-advance :new-input) ;; why does creating data advance pulse?
138     (setf tv (3c-cell-value o)))
139    
140     ((3c-ruled? o)
141 ktilton 1.3 (setf tv (funcall (3c?-rule o) o nil nil))
142 ktilton 1.2 (setf (3c-cell-value o) tv))
143    
144     (t (break "unknown cell" o)))
145    
146 ktilton 1.1 (add-triple o !ccc:pulse (mk-upi *3c-pulse*))
147     (setf tv (3c-cell-value o)))
148 ktilton 1.3
149 ktilton 1.2 (when tv
150     (add-triple s p (mk-upi tv)))
151 ktilton 1.3
152     (cell-observe-change o s p tv nil nil))
153 ktilton 1.1
154 ktilton 1.2 (defun 3c-make (type &key id)
155     "Generates blank node and associates it with type and other options"
156     (let ((node (new-blank-node)))
157 ktilton 1.3 (trc "3c-make storing type" type (type-of type))
158     (add-triple node !ccc:instance-of type) ; (mk-upi type))
159 ktilton 1.2 (when id
160     (3c-register node id))
161     node))
162    

  ViewVC Help
Powered by ViewVC 1.1.5