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

Contents of /triple-cells/api.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Sat Feb 23 01:22:11 2008 UTC (6 years, 2 months ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.1: +14 -39 lines
Version 2, with integrity
1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*-
2 ;;;
3 ;;;
4 ;;; Copyright (c) 2008 by Kenneth William Tilton.
5 ;;;
6
7
8 (in-package :3c)
9
10 ;;; --- API ---------------------------------------
11
12 (defun 3c-init ()
13 (setf *calc-nodes* nil)
14 (setf *3c?* (make-hash-table :test 'equal))
15 (setf *3c-observers* (make-hash-table :test 'equalp)))
16
17 ;;; --- API constructors -------------------------------
18
19 (defun 3c-in (initial-value &key ephemeral test observer &aux (c (new-blank-node)))
20 (add-triple c !ccc:type !ccc:input)
21 (when observer
22 (add-triple c !ccc:observer-is (mk-upi observer)))
23 (setf (3c-cell-value c) initial-value)
24 (when ephemeral
25 (add-triple c !ccc:ephemeral !ccc:t))
26 (when test
27 (add-triple c !ccc:test (mk-upi test)))
28 c)
29
30 (defmacro 3c? (rule &key test ephemeral observer)
31 `(call-3c? '(lambda (node cache cache?)
32 (declare (ignorable cache cache?))
33 (let ((*calc-nodes* (cons node *calc-nodes*)))
34 ,rule))
35 :test ,test
36 :observer ,observer
37 :ephemeral ,ephemeral))
38
39 (defun call-3c? (rule &key test ephemeral observer)
40 (let* ((c (new-blank-node)))
41 (add-triple c !ccc:type !ccc:ruled)
42 (add-triple c !ccc:rule (mk-upi (prin1-to-string rule)))
43 (when ephemeral
44 ;(trc "bingo ephemeral" rule)
45 (add-triple c !ccc:ephemeral !ccc:t))
46 (when test
47 (add-triple c !ccc:test (mk-upi test)))
48 (when observer
49 (add-triple c !ccc:observer-is (mk-upi observer)))
50 (let ((rule-fn (eval rule)))
51 ;(trc "rule-fn" rule-fn :from rule)
52 (setf (3c?-rule c) rule-fn)
53 ;(trc "c? type tr" tr-c)
54 ;(trc "c? value tr" tr-cv)
55 c)))
56
57 ;;; --- API accessors
58
59 (defun 3c (s p)
60 (assert (and s p))
61 (bif (cell (stmt-cell s p))
62 (progn
63 (3c-ensure-current cell s p)
64 (when *calc-nodes*
65 (assert (listp *calc-nodes*))
66 (assert (not (find cell *calc-nodes*))() "Circularity? ~a ~a" cell *calc-nodes*)
67 (ensure-triple (car *calc-nodes*) !ccc:uses cell))
68
69 (get-sp-value s p))
70 (get-sp-value s p)))
71
72 (defun (setf 3c) (new-value s p)
73 (let* ((cell (stmt-cell s p))
74 (tr-value (get-sp s p))
75 (prior-value (when tr-value (upi->value (object tr-value)))))
76
77 (assert cell () "subject ~a pred ~a not mediated by input cell so cannot be changed from ~a to ~a"
78 s p prior-value new-value)
79 ;(trc "tr-cell" (triple-id tr-cell))
80 ;(trc "tr-value" (triple-id tr-value))
81
82 (unless (equal new-value prior-value)
83 (with-3c-integrity (:change cell)
84 (when tr-value
85 (delete-triple (triple-id tr-value)))
86
87 (let ((new-value-upi (mk-upi new-value)))
88 (add-triple s p new-value-upi)
89 ; cell maintenance, including its own copy of value
90 (delete-triples :s cell :p !ccc:value)
91 (add-triple cell !ccc:value new-value-upi)
92 (3c-propagate cell)
93 (cell-observe-change cell s p new-value prior-value t)
94 (when (3c-ephemeral? cell)
95 (add-triple !ccc:ufb-reset-ephemerals (mk-upi 42) cell)))))))
96
97

  ViewVC Help
Powered by ViewVC 1.1.5