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

Contents of /triple-cells/observer.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (hide annotations)
Fri Apr 11 09:24:42 2008 UTC (6 years ago) by ktilton
Branch: MAIN
CVS Tags: HEAD
Changes since 1.2: +1 -1 lines
*** empty log message ***
1 ktilton 1.1 ;; -*- mode: Lisp; Syntax: Common-Lisp; Package: triple-cells; -*-
2     ;;;
3     ;;;
4 ktilton 1.2 ;;; Copyright (c) 2008 by Kenneth William Tilton.
5 ktilton 1.1 ;;;
6    
7     (in-package :3c)
8    
9     (defmacro make-observer (id form)
10     `(call-make-observer ,id
11     '(lambda (s p new-value prior-value prior-value?)
12     (declare (ignorable s p new-value prior-value prior-value?))
13     ,form)))
14    
15     (defun call-make-observer (id observer)
16     (add-triple id !ccc:observer-id-rule (mk-upi (prin1-to-string observer)))
17     (setf (3c-observer id) (eval observer))) ;; while we're at it
18    
19    
20     ;;; --- 3cell observation --------------------------------------------------------
21    
22     (defun cell-observe-change (cell s p new-value prior-value prior-value?)
23 ktilton 1.2 (cond
24     (cell
25     (loop for observer in (get-triples-list :s cell :p !ccc:observer-is)
26     do (funcall (3c-observer (object observer)) s p
27     new-value prior-value prior-value?)))
28     (p (loop for observer in (get-triples-list :s p :p !ccc:observer-id-rule)
29     do (funcall (3c-observer-from-rule-triple observer) s p
30     new-value prior-value prior-value?)))))
31    
32     ;;;(defun cell-observe-change (cell s p new-value prior-value prior-value?)
33     ;;; (trc "observing" p new-value)
34     ;;; (if (get-triple :s cell :p !ccc:observer-is) ; just need one to decide to schedule
35     ;;; (let ((o (new-blank-node))) ;; o = observation, an instance of a cell to be observed and its parameters
36     ;;; (add-triple o !ccc:obs-s cell)
37     ;;; (add-triple o !ccc:obs-p cell)
38     ;;; (add-triple o !ccc:obs-new-value (mk-upi new-value))
39     ;;; (add-triple o !ccc:obs-prior-value (mk-upi prior-value))
40     ;;; (add-triple o !ccc:obs-prior-value? (mk-upi prior-value?))
41     ;;; (add-triple !ccc:obs-queue (mk-upi (get-internal-real-time)) o))
42     ;;; (trc "unobserved" s p)))
43    
44     ;;;(defun process-observer-queue ()
45     ;;; (index-new-triples)
46     ;;; (let ((oq (get-triples-list :s !ccc:obs-queue)))
47     ;;; (loop for observation in (mapcar 'object oq)
48     ;;; for s = (object (get-sp observation !ccc:obs-s))
49     ;;; for p = (object (get-sp observation !ccc:obs-p))
50     ;;; for new-value = (get-sp-value observation !ccc:obs-new-value)
51     ;;; for prior-value = (get-sp-value observation !ccc:obs-prior-value)
52     ;;; for prior-value? = (get-sp-value observation !ccc:obs-prior-value)
53     ;;; do (loop for observer in (get-triples-list :s s :p !ccc:observer-is)
54     ;;; do (funcall (3c-observer (object observer)) s p
55     ;;; new-value prior-value prior-value?)))))
56 ktilton 1.1
57    
58     ;;; ----------------------------------------------------
59    
60 ktilton 1.3
61 ktilton 1.1
62     (defun (setf 3c-observer) (function c-node)
63     (assert (functionp function) () "3c-observer setf not rule: ~a ~a" (type-of function) function)
64     (setf (gethash c-node *3c-observers*) function))
65    
66     (defun 3c-observer (c-node &aux (unode (part->string c-node)))
67     (or (gethash unode *3c-observers*)
68     (setf (gethash unode *3c-observers*)
69     (let ((fn$ (get-sp-value unode !ccc:observer-id-rule)))
70     (assert fn$)
71    
72     (eval (read-from-string fn$))))))
73 ktilton 1.2
74     (defun 3c-observer-from-rule-triple (tr)
75     (let ((fn$ (triple-value tr)))
76     (assert fn$)
77     (eval (read-from-string fn$))))

  ViewVC Help
Powered by ViewVC 1.1.5