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

Contents of /triple-cells/api.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Sun Dec 23 10:04:56 2007 UTC (6 years, 3 months ago) by ktilton
Branch: MAIN
*** empty log message ***
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 ;;; --- API ---------------------------------------
28
29 (defun 3c-init ()
30 (setf *3c-pulse* 0)
31 (setf *calc-nodes* nil)
32 (setf *3c?* (make-hash-table :test 'equal))
33 (setf *3c-observers* (make-hash-table :test 'equal)))
34
35 ;;; --- API constructors -------------------------------
36
37 (defun 3c-in (initial-value &key ephemeral test observer &aux (c (new-blank-node)))
38 (add-triple c !ccc:type !ccc:input)
39 (when observer
40 (add-triple c !ccc:observer-is (mk-upi observer)))
41 (setf (3c-cell-value c) initial-value)
42 (when ephemeral
43 (add-triple c !ccc:ephemeral !ccc:t))
44 (when test
45 (add-triple c !ccc:test (mk-upi test)))
46 c)
47
48 (defmacro 3c? (rule &key test ephemeral observer)
49 `(call-3c? '(lambda (node cache cache?)
50 (declare (ignorable cache cache?))
51 (let ((*calc-nodes* (cons node *calc-nodes*)))
52 ,rule))
53 :test ,test
54 :observer ,observer
55 :ephemeral ,ephemeral))
56
57 (defun call-3c? (rule &key test ephemeral observer)
58 (let* ((c (new-blank-node)))
59 (add-triple c !ccc:type !ccc:ruled)
60 (add-triple c !ccc:rule (mk-upi (prin1-to-string rule)))
61 (when ephemeral
62 (add-triple c !ccc:ephemeral !ccc:t))
63 (when test
64 (add-triple c !ccc:test (mk-upi test)))
65 (when observer
66 (add-triple c !ccc:observer-is (mk-upi observer)))
67 (let ((rule-fn (eval rule)))
68 ;(trc "rule-fn" rule-fn :from rule)
69 (setf (3c?-rule c) rule-fn)
70 ;(trc "c? type tr" tr-c)
71 ;(trc "c? value tr" tr-cv)
72 c)))
73
74
75
76 ;;; --- API accessors
77
78 (defun clear-usage (cell)
79 (delete-triples :s cell :p !ccc:uses))
80
81 (defun 3c (s p)
82 (assert (and s p))
83 (bif (cell (stmt-cell s p))
84 (progn
85 (3c-ensure-current cell s p)
86 (when *calc-nodes*
87 (assert (listp *calc-nodes*))
88 (assert (not (find cell *calc-nodes*))() "Circularity? ~a ~a" cell *calc-nodes*)
89 (ensure-triple (car *calc-nodes*) !ccc:uses cell))
90
91 (get-sp-value s p))
92 (get-sp-value s p)))
93
94 (defun (setf 3c) (new-value s p)
95 (let* ((cell (stmt-cell s p))
96 (tr-value (get-sp s p))
97 (prior-value (when tr-value (upi->value (object tr-value)))))
98
99 (assert cell () "subject ~a pred ~a not mediated by input cell so cannot be changed from ~a to ~a"
100 s p prior-value new-value)
101 ;(trc "tr-cell" (triple-id tr-cell))
102 ;(trc "tr-value" (triple-id tr-value))
103
104 (unless (equal new-value prior-value)
105 (3c-pulse-advance :setf-3c)
106 (when tr-value
107 (delete-triple (triple-id tr-value)))
108
109 (let* ((new-value-upi (mk-upi new-value))
110 (tr-value-new (add-triple s p new-value-upi)))
111
112 (delete-triples :s cell :p !ccc:value)
113
114 (let ((tr-cell-value-new (add-triple cell !ccc:value new-value-upi)))
115 (3c-propagate cell)
116 (cell-observe-change cell s p new-value prior-value t)
117 (when (3c-ephemeral? cell)
118 ; fix up cell...
119 (delete-triple tr-cell-value-new)
120 ; reset value itself to nil
121 (delete-triple tr-value-new)))))))
122

  ViewVC Help
Powered by ViewVC 1.1.5