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

Contents of /triple-cells/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (show annotations)
Sat Feb 23 01:22:11 2008 UTC (6 years, 1 month ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.3: +66 -54 lines
Version 2, with integrity
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*-
2 ;;;
3 ;;; Copyright (c) 2008 by Kenneth William Tilton.
4 ;;;
5
6 (in-package :3c)
7
8 ;; --- triple-cells ---
9
10 (defvar *calc-nodes*)
11
12 (defun 3c-pulse-advance (&optional (dbg :anon-advance))
13 (declare (ignorable dbg))
14 (trc "PULSE> ---- advancing:" dbg)
15 (delete-triples :s !ccc:integrity :p !ccc:pulse)
16 (add-triple !ccc:integrity !ccc:pulse (new-blank-node)))
17
18 (defun 3c-pulse ()
19 (bwhen (tr (get-triple :s !ccc:integrity :p !ccc:pulse))
20 (object tr)))
21
22 ;;; --- low-level 3cell accessors
23
24 (defun 3c-cell-value (c)
25 (bwhen (tr (get-sp c !ccc:value))
26 (part-value (object tr))))
27
28 (defun (setf 3c-cell-value) (new-value c)
29 (3c-cell-make-current c)
30
31 (delete-triples :s c :p !ccc:value)
32 (when new-value
33 (add-triple c !ccc:value (mk-upi new-value))))
34
35 (defun 3c-cell-make-current (c)
36 (delete-triples :s c :p !ccc:pulse)
37 (add-triple c !ccc:pulse (3c-pulse)))
38
39 (defun 3c-cell-pulse (c)
40 (object (get-sp c !ccc:pulse)))
41
42 ;;; --- rule storage -------------------------------
43
44 (defvar *3c?*)
45
46 #+dump
47 (maphash (lambda (k v) (trc "kk" k v)) *3c?*)
48
49 (defun (setf 3c?-rule) (rule c-node)
50 (assert (functionp rule) () "3c?-rule setf not rule: ~a ~a" (type-of rule) rule)
51 ;;(trc "storing rule!!!! for" c-node rule)
52 (setf (gethash c-node *3c?*) rule))
53
54 (defun 3c?-rule (c-node)
55 (or (gethash c-node *3c?*)
56 (setf (gethash c-node *3c?*)
57 (let ((rule$ (get-sp-value c-node !ccc:rule)))
58 ;;(trc "got rule" rule$)
59 (eval (read-from-string rule$))))))
60
61
62 ;;; --- 3cell predicates -------------------------------------------
63
64 (defun 3c-cell? (c)
65 (when (upip c)
66 (get-sp c !ccc:type)))
67
68 (defun 3c-ephemeral? (c)
69 (get-sp c !ccc:ephemeral))
70
71 (defun 3c-ruled? (c)
72 (when (upip c)
73 (bwhen (tr-type (get-sp c !ccc:type))
74 (part= (object tr-type) !ccc:ruled))))
75
76 (defun 3c-input? (c)
77 (when (upip c)
78 (bwhen (tr-type (get-sp c !ccc:type))
79 (part= (object tr-type) !ccc:input))))
80
81 ;;; --- 3cell accessors -------------------------------------------
82
83 (defun 3c-class-of (s)
84 (let ((type (object (get-sp s !ccc:instance-of))))
85 (echo-sym (upi->value type))))
86
87 (defun 3c-predicate-of (p)
88 (echo-sym (etypecase p
89 (array (upi->value p))
90 (future-part (part->string p)))))
91
92 (defun echo-sym (s)
93 (intern (nsubstitute #\- #\#
94 (up$ (string-trim "<>" s)))))
95
96 ;;; --- access ------------------------------------------
97
98 (defun subject-cells-node (s)
99 (bif (tr (get-triple :s s :p !ccc:cells))
100 (object tr)
101 (let ((n (new-blank-node)))
102 (add-triple s !ccc:cells n)
103 n)))
104
105 (defun (setf stmt-cell) (new-cell s p)
106 (add-triple (subject-cells-node s) p new-cell))
107
108 (defun stmt-cell (s p)
109 (bwhen (tr (get-sp (subject-cells-node s) p))
110 (object tr)))
111
112 (defun cell-predicate (c)
113 (object (get-sp c !ccc:is-cell-of-predicate)))
114
115 (defun cell-model (c)
116 (object (get-sp c !ccc:is-cell-of-model)))
117
118 (defun 3c-install-cell (s p o)
119 (add-triple (subject-cells-node s) p o)
120 (add-triple o !ccc:is-cell-of-model s)
121 (add-triple o !ccc:is-cell-of-predicate p))
122
123 (defun stmt-new (s p o &aux (tv o))
124 (cond
125 ((3c-cell? o)
126 (3c-install-cell s p o)
127 (cond
128 ((3c-input? o)
129 (bwhen (tv (3c-cell-value o))
130 (add-triple s p (mk-upi tv)))
131 (with-3c-integrity (!ccc:observe o)
132 (cell-observe-change o s p tv nil nil)))
133 ((3c-ruled? o)
134 (with-3c-integrity (!ccc:awaken-ruled-cell o)
135 (3c-awaken-ruled-cell o)))
136 (t (break "unknown cell" o))))
137
138 (t (when tv
139 (let ((tr (add-triple s p (mk-upi tv))))
140 (trc "recording k under" p :id tr tv)
141 (with-3c-integrity (!ccc:observe (mk-upi tr))
142 (cell-observe-change o s p tv nil nil)))))))
143
144 (defun 3c-awaken-ruled-cell (c)
145 (let ((s (cell-model c))
146 (p (cell-predicate c))
147 (tv (funcall (3c?-rule c) c nil nil)))
148 ;(trc "awakening ruled" p)
149 (setf (3c-cell-value c) tv)
150 (cell-observe-change c s p tv nil nil)))
151
152 (defun 3c-make (type &key id)
153 "Generates blank node and associates it with type and other options"
154 (let ((node (new-blank-node)))
155 (trc "3c-make storing type" type (type-of type))
156 (add-triple node !ccc:instance-of type)
157 (when id
158 (3c-register node id))
159 node))
160
161 (defun 3c-register (node name)
162 (add-triple (mk-upi name) !ccc:id node))
163
164 (defun 3c-find-id (name)
165 (object (get-sp (mk-upi name) !ccc:id)))
166
167 (defun clear-usage (cell)
168 (delete-triples :s cell :p !ccc:uses))
169
170 #+test
171 (progn
172 (make-tutorial-store)
173 (let ((x (3c-make !<plane> :id "x-plane")))
174 (3c-find-id "x-plane")))

  ViewVC Help
Powered by ViewVC 1.1.5