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

Contents of /triple-cells/core.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide 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 ktilton 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*-
2     ;;;
3 ktilton 1.4 ;;; Copyright (c) 2008 by Kenneth William Tilton.
4 ktilton 1.1 ;;;
5    
6     (in-package :3c)
7    
8     ;; --- triple-cells ---
9    
10 ktilton 1.3 (defvar *calc-nodes*)
11 ktilton 1.2
12 ktilton 1.4 (defun 3c-pulse-advance (&optional (dbg :anon-advance))
13 ktilton 1.3 (declare (ignorable dbg))
14 ktilton 1.4 (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 ktilton 1.2
22     ;;; --- low-level 3cell accessors
23    
24     (defun 3c-cell-value (c)
25     (bwhen (tr (get-sp c !ccc:value))
26 ktilton 1.3 (part-value (object tr))))
27 ktilton 1.2
28     (defun (setf 3c-cell-value) (new-value c)
29 ktilton 1.4 (3c-cell-make-current c)
30    
31 ktilton 1.2 (delete-triples :s c :p !ccc:value)
32     (when new-value
33     (add-triple c !ccc:value (mk-upi new-value))))
34    
35 ktilton 1.4 (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 ktilton 1.2
42     ;;; --- rule storage -------------------------------
43    
44 ktilton 1.1 (defvar *3c?*)
45    
46 ktilton 1.3 #+dump
47     (maphash (lambda (k v) (trc "kk" k v)) *3c?*)
48    
49 ktilton 1.4 (defun (setf 3c?-rule) (rule c-node)
50 ktilton 1.3 (assert (functionp rule) () "3c?-rule setf not rule: ~a ~a" (type-of rule) rule)
51     ;;(trc "storing rule!!!! for" c-node rule)
52 ktilton 1.2 (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 ktilton 1.3 ;;(trc "got rule" rule$)
59     (eval (read-from-string rule$))))))
60    
61 ktilton 1.1
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 ktilton 1.2 (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 ktilton 1.1 ;;; --- 3cell accessors -------------------------------------------
82    
83     (defun 3c-class-of (s)
84 ktilton 1.3 (let ((type (object (get-sp s !ccc:instance-of))))
85     (echo-sym (upi->value type))))
86 ktilton 1.1
87     (defun 3c-predicate-of (p)
88 ktilton 1.3 (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 ktilton 1.1
96     ;;; --- access ------------------------------------------
97    
98 ktilton 1.2 (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 ktilton 1.3 (bwhen (tr (get-sp (subject-cells-node s) p))
110     (object tr)))
111    
112     (defun cell-predicate (c)
113 ktilton 1.4 (object (get-sp c !ccc:is-cell-of-predicate)))
114 ktilton 1.3
115 ktilton 1.4 (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 ktilton 1.2
123     (defun stmt-new (s p o &aux (tv o))
124 ktilton 1.4 (cond
125     ((3c-cell? o)
126     (3c-install-cell s p o)
127 ktilton 1.2 (cond
128     ((3c-input? o)
129 ktilton 1.4 (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 ktilton 1.1
152 ktilton 1.2 (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 ktilton 1.3 (trc "3c-make storing type" type (type-of type))
156 ktilton 1.4 (add-triple node !ccc:instance-of type)
157 ktilton 1.2 (when id
158     (3c-register node id))
159     node))
160    
161 ktilton 1.4 (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