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

Contents of /triple-cells/observer.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Sun Dec 23 10:04:56 2007 UTC (6 years, 4 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 (defmacro make-observer (id form)
28 `(call-make-observer ,id
29 '(lambda (s p new-value prior-value prior-value?)
30 (declare (ignorable s p new-value prior-value prior-value?))
31 ,form)))
32
33 (defun call-make-observer (id observer)
34 (trc "storing observer!!!!!!!!!!!" id !ccc:observer-id-rule (mk-upi (prin1-to-string observer)))
35 (add-triple id !ccc:observer-id-rule (mk-upi (prin1-to-string observer)))
36 (setf (3c-observer id) (eval observer))) ;; while we're at it
37
38
39 ;;; --- 3cell observation --------------------------------------------------------
40
41
42 (defun cell-observe-change (cell s p new-value prior-value prior-value?)
43 (bif (otr (get-sp cell !ccc:observer-is))
44 (funcall (3c-observer (object otr)) s p new-value prior-value prior-value?)
45 (trc "unobserved" s p)))
46
47
48 ;;; ----------------------------------------------------
49
50 (defvar *3c-observers*)
51
52 (defun (setf 3c-observer) (function c-node)
53 (assert (functionp function) () "3c-observer setf not rule: ~a ~a" (type-of function) function)
54 (setf (gethash c-node *3c-observers*) function))
55
56 (defun 3c-observer (c-node &aux (unode (part->string c-node)))
57 (or (gethash unode *3c-observers*)
58 (setf (gethash unode *3c-observers*)
59 (let ((fn$ (get-sp-value unode !ccc:observer-id-rule)))
60 (assert fn$)
61
62 (eval (read-from-string fn$))))))

  ViewVC Help
Powered by ViewVC 1.1.5