Create an actor-internal event system oriented around assertions and
messges. internal form ~ external form (know v) ~ (assert v) (on (know p) ...) ~ (on (asserted p) ...) (on (forget p) ...) ~ (on (retracted p) ...) (realize! v) ~ (send! v) (on (realize v) ...) ~ (on (message v) ...)
This commit is contained in:
parent
affa47a2a5
commit
e6b733325c
|
@ -31,6 +31,9 @@
|
||||||
retracted
|
retracted
|
||||||
rising-edge
|
rising-edge
|
||||||
(rename-out [core:message message])
|
(rename-out [core:message message])
|
||||||
|
know
|
||||||
|
forget
|
||||||
|
realize
|
||||||
|
|
||||||
let-event
|
let-event
|
||||||
|
|
||||||
|
@ -58,6 +61,7 @@
|
||||||
perform-actions!
|
perform-actions!
|
||||||
flush!
|
flush!
|
||||||
quit-dataspace!
|
quit-dataspace!
|
||||||
|
realize!
|
||||||
|
|
||||||
syndicate-effects-available?
|
syndicate-effects-available?
|
||||||
|
|
||||||
|
@ -80,6 +84,7 @@
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require racket/contract)
|
(require racket/contract)
|
||||||
|
(require (only-in racket/list flatten))
|
||||||
|
|
||||||
(require (for-syntax racket/base))
|
(require (for-syntax racket/base))
|
||||||
(require (for-syntax syntax/parse))
|
(require (for-syntax syntax/parse))
|
||||||
|
@ -198,10 +203,15 @@
|
||||||
endpoints ;; (Hash EID Endpoint)
|
endpoints ;; (Hash EID Endpoint)
|
||||||
stop-scripts ;; (Listof Script) -- IN REVERSE ORDER
|
stop-scripts ;; (Listof Script) -- IN REVERSE ORDER
|
||||||
children ;; (Setof FID)
|
children ;; (Setof FID)
|
||||||
|
previous-knowledge ;; AssertionSet of internal knowledge
|
||||||
|
knowledge ;; AssertionSet of internal knowledge
|
||||||
) #:prefab)
|
) #:prefab)
|
||||||
|
|
||||||
(struct endpoint (id patch-fn handler-fn) #:prefab)
|
(struct endpoint (id patch-fn handler-fn) #:prefab)
|
||||||
|
|
||||||
|
(struct internal-knowledge (v) #:prefab)
|
||||||
|
(define internal-knowledge-parenthesis (open-parenthesis 1 struct:internal-knowledge))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Script priorities. These are used to ensure that the results of
|
;; Script priorities. These are used to ensure that the results of
|
||||||
;; some *side effects* are visible to certain pieces of code.
|
;; some *side effects* are visible to certain pieces of code.
|
||||||
|
@ -249,6 +259,12 @@
|
||||||
;; Storeof (Constreeof Action)
|
;; Storeof (Constreeof Action)
|
||||||
(define current-pending-actions (make-store))
|
(define current-pending-actions (make-store))
|
||||||
|
|
||||||
|
;; Storeof Patch
|
||||||
|
(define current-pending-internal-patch (make-store))
|
||||||
|
|
||||||
|
;; Storeof (Constreeof Action)
|
||||||
|
(define current-pending-internal-events (make-store))
|
||||||
|
|
||||||
;; Storeof (Vector (Queue Script) ...)
|
;; Storeof (Vector (Queue Script) ...)
|
||||||
;; Mutates the vector!
|
;; Mutates the vector!
|
||||||
(define current-pending-scripts (make-store))
|
(define current-pending-scripts (make-store))
|
||||||
|
@ -407,6 +423,7 @@
|
||||||
(analyze-pattern stx #'P))
|
(analyze-pattern stx #'P))
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(add-endpoint! #,(source-location->string stx)
|
(add-endpoint! #,(source-location->string stx)
|
||||||
|
#f
|
||||||
(lambda ()
|
(lambda ()
|
||||||
#,(let ((patch-stx #`(core:assert #,pat)))
|
#,(let ((patch-stx #`(core:assert #,pat)))
|
||||||
(if #'w.Pred
|
(if #'w.Pred
|
||||||
|
@ -414,6 +431,22 @@
|
||||||
patch-stx)))
|
patch-stx)))
|
||||||
void))]))
|
void))]))
|
||||||
|
|
||||||
|
(define-syntax (know stx)
|
||||||
|
(syntax-parse stx
|
||||||
|
[(_ w:when-pred P)
|
||||||
|
(define-values (proj pat bindings _instantiated)
|
||||||
|
(analyze-pattern stx #'P))
|
||||||
|
(quasisyntax/loc stx
|
||||||
|
(add-endpoint!
|
||||||
|
#,(source-location->string stx)
|
||||||
|
#t
|
||||||
|
(lambda ()
|
||||||
|
#,(let ((patch-stx #`(core:assert (internal-knowledge #,pat))))
|
||||||
|
(if #'w.Pred
|
||||||
|
#`(if w.Pred #,patch-stx patch-empty)
|
||||||
|
patch-stx)))
|
||||||
|
void))]))
|
||||||
|
|
||||||
(define (fid-ancestor? fid maybe-ancestor)
|
(define (fid-ancestor? fid maybe-ancestor)
|
||||||
(and (pair? fid) ;; empty fid lists obviously no ancestors at all!
|
(and (pair? fid) ;; empty fid lists obviously no ancestors at all!
|
||||||
(or (equal? fid maybe-ancestor)
|
(or (equal? fid maybe-ancestor)
|
||||||
|
@ -474,6 +507,7 @@
|
||||||
|
|
||||||
(define (on-event* where proc #:priority [priority *normal-priority*])
|
(define (on-event* where proc #:priority [priority *normal-priority*])
|
||||||
(add-endpoint! where
|
(add-endpoint! where
|
||||||
|
#f
|
||||||
(lambda () patch-empty)
|
(lambda () patch-empty)
|
||||||
(lambda (e _current-interests _synthetic?)
|
(lambda (e _current-interests _synthetic?)
|
||||||
(schedule-script! #:priority priority (lambda () (proc e))))))
|
(schedule-script! #:priority priority (lambda () (proc e))))))
|
||||||
|
@ -547,6 +581,7 @@
|
||||||
(quasisyntax/loc stx
|
(quasisyntax/loc stx
|
||||||
(let ()
|
(let ()
|
||||||
(add-endpoint! #,(source-location->string stx)
|
(add-endpoint! #,(source-location->string stx)
|
||||||
|
#f
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(define subject-id (current-dataflow-subject-id))
|
(define subject-id (current-dataflow-subject-id))
|
||||||
(schedule-script!
|
(schedule-script!
|
||||||
|
@ -570,6 +605,8 @@
|
||||||
(define-syntax (asserted stx) (raise-syntax-error #f "asserted: Used outside event spec" stx))
|
(define-syntax (asserted stx) (raise-syntax-error #f "asserted: Used outside event spec" stx))
|
||||||
(define-syntax (retracted stx) (raise-syntax-error #f "retracted: Used outside event spec" stx))
|
(define-syntax (retracted stx) (raise-syntax-error #f "retracted: Used outside event spec" stx))
|
||||||
(define-syntax (rising-edge stx) (raise-syntax-error #f "rising-edge: Used outside event spec" stx))
|
(define-syntax (rising-edge stx) (raise-syntax-error #f "rising-edge: Used outside event spec" stx))
|
||||||
|
(define-syntax (forget stx) (raise-syntax-error #f "forget: Used outside event spec" stx))
|
||||||
|
(define-syntax (realize stx) (raise-syntax-error #f "realize: Used outside event spec" stx))
|
||||||
|
|
||||||
(define-syntax (suspend-script stx)
|
(define-syntax (suspend-script stx)
|
||||||
(syntax-parse stx
|
(syntax-parse stx
|
||||||
|
@ -772,62 +809,119 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Syntax-time support
|
;; Syntax-time support
|
||||||
|
|
||||||
(define (interests-pre-and-post-patch pat synthetic?)
|
(define (interests-pre-and-post-patch pat synthetic? retrieve-knowledge)
|
||||||
(define (or* x y) (or x y))
|
(define (or* x y) (or x y))
|
||||||
(define a (current-actor-state))
|
(define-values (prev current) (retrieve-knowledge synthetic?))
|
||||||
(define previous-knowledge (if synthetic? trie-empty (actor-state-previous-knowledge a)))
|
(define old (trie-lookup prev pat #f #:wildcard-union or*))
|
||||||
(define old (trie-lookup previous-knowledge pat #f #:wildcard-union or*))
|
(define new (trie-lookup current pat #f #:wildcard-union or*))
|
||||||
(define new (trie-lookup (actor-state-knowledge a) pat #f #:wildcard-union or*))
|
|
||||||
(values old new))
|
(values old new))
|
||||||
|
|
||||||
(define (interest-just-appeared-matching? pat synthetic?)
|
(define (interest-just-appeared-matching? pat synthetic? retrieve-knowledge)
|
||||||
(define-values (old new) (interests-pre-and-post-patch pat synthetic?))
|
(define-values (old new) (interests-pre-and-post-patch pat synthetic? retrieve-knowledge))
|
||||||
(and (not old) new))
|
(and (not old) new))
|
||||||
|
|
||||||
(define (interest-just-disappeared-matching? pat synthetic?)
|
(define (interest-just-disappeared-matching? pat synthetic? retrieve-knowledge)
|
||||||
(define-values (old new) (interests-pre-and-post-patch pat synthetic?))
|
(define-values (old new) (interests-pre-and-post-patch pat synthetic? retrieve-knowledge))
|
||||||
(and old (not new)))
|
(and old (not new)))
|
||||||
|
|
||||||
(define-for-syntax (analyze-asserted/retracted outer-expr-stx
|
;; Bool -> (Values AssertionSet AssertionSet)
|
||||||
when-pred-stx
|
;; retrieve the previous and current knowledge fields from the current actor state
|
||||||
event-stx
|
(define (current-actor-state-knowledges synthetic?)
|
||||||
script-stx
|
(define a (current-actor-state))
|
||||||
asserted?
|
(define previous-knowledge (if synthetic? trie-empty (actor-state-previous-knowledge a)))
|
||||||
P-stx
|
(define current-knowledge (actor-state-knowledge a))
|
||||||
priority-stx)
|
(values previous-knowledge current-knowledge))
|
||||||
|
|
||||||
|
;; Bool -> (Values AssertionSet AssertionSet)
|
||||||
|
;; retrieve the previous and current knowledge fields from the current facet
|
||||||
|
(define (current-facet-knowledges synthetic?)
|
||||||
|
(define f (lookup-facet (current-facet-id)))
|
||||||
|
(define previous-knowledge (if synthetic? trie-empty (facet-previous-knowledge f)))
|
||||||
|
(define current-knowledge (facet-knowledge f))
|
||||||
|
(values previous-knowledge current-knowledge))
|
||||||
|
|
||||||
|
(define-for-syntax (analyze-appear/disappear outer-expr-stx
|
||||||
|
when-pred-stx
|
||||||
|
event-stx
|
||||||
|
script-stx
|
||||||
|
asserted?
|
||||||
|
P-stx
|
||||||
|
priority-stx
|
||||||
|
internal?)
|
||||||
|
(define P+
|
||||||
|
(if internal? #`(internal-knowledge #,P-stx) P-stx))
|
||||||
(define-values (proj-stx pat bindings _instantiated)
|
(define-values (proj-stx pat bindings _instantiated)
|
||||||
(analyze-pattern event-stx P-stx))
|
(analyze-pattern event-stx P+))
|
||||||
(define event-predicate-stx (if asserted? #'patch/added? #'patch/removed?))
|
(define event-predicate-stx (if asserted? #'patch/added? #'patch/removed?))
|
||||||
(define patch-accessor-stx (if asserted? #'patch-added #'patch-removed))
|
(define patch-accessor-stx (if asserted? #'patch-added #'patch-removed))
|
||||||
(define change-detector-stx
|
(define change-detector-stx
|
||||||
(if asserted? #'interest-just-appeared-matching? #'interest-just-disappeared-matching?))
|
(if asserted? #'interest-just-appeared-matching? #'interest-just-disappeared-matching?))
|
||||||
|
(define knowledge-retriever
|
||||||
|
(if internal? #'current-facet-knowledges #'current-actor-state-knowledges))
|
||||||
(quasisyntax/loc outer-expr-stx
|
(quasisyntax/loc outer-expr-stx
|
||||||
(add-endpoint! #,(source-location->string outer-expr-stx)
|
(add-endpoint!
|
||||||
(lambda () (if #,when-pred-stx
|
#,(source-location->string outer-expr-stx)
|
||||||
(core:sub #,pat)
|
#,internal?
|
||||||
patch-empty))
|
(lambda () (if #,when-pred-stx
|
||||||
(lambda (e current-interests synthetic?)
|
(core:sub #,pat)
|
||||||
(when (not (trie-empty? current-interests))
|
patch-empty))
|
||||||
(core:match-event e
|
(lambda (e current-interests synthetic?)
|
||||||
[(? #,event-predicate-stx p)
|
(when (not (trie-empty? current-interests))
|
||||||
(define proj #,proj-stx)
|
(core:match-event e
|
||||||
(define proj-arity (projection-arity proj))
|
[(? #,event-predicate-stx p)
|
||||||
(define entry-set (trie-project/set #:take proj-arity
|
(define proj #,proj-stx)
|
||||||
(#,patch-accessor-stx p)
|
(define proj-arity (projection-arity proj))
|
||||||
proj))
|
(define entry-set (trie-project/set #:take proj-arity
|
||||||
(when (not entry-set)
|
(#,patch-accessor-stx p)
|
||||||
(error 'asserted
|
proj))
|
||||||
"Wildcard interest discovered while projecting by ~v at ~a"
|
(when (not entry-set)
|
||||||
proj
|
(error 'asserted
|
||||||
#,(source-location->string P-stx)))
|
"Wildcard interest discovered while projecting by ~v at ~a"
|
||||||
(for [(entry (in-set entry-set))]
|
proj
|
||||||
(let ((instantiated (instantiate-projection proj entry)))
|
#,(source-location->string P-stx)))
|
||||||
(and (#,change-detector-stx instantiated synthetic?)
|
(for [(entry (in-set entry-set))]
|
||||||
(schedule-script!
|
(let ((instantiated (instantiate-projection proj entry)))
|
||||||
#:priority #,priority-stx
|
(and (#,change-detector-stx instantiated synthetic? #,knowledge-retriever)
|
||||||
(lambda ()
|
(schedule-script!
|
||||||
(match-define (list #,@bindings) entry)
|
#:priority #,priority-stx
|
||||||
#,script-stx)))))]))))))
|
(lambda ()
|
||||||
|
(match-define (list #,@bindings) entry)
|
||||||
|
#,script-stx)))))]))))))
|
||||||
|
|
||||||
|
(define-for-syntax (analyze-message outer-expr-stx
|
||||||
|
when-pred-stx
|
||||||
|
event-stx
|
||||||
|
script-stx
|
||||||
|
P-stx
|
||||||
|
priority-stx
|
||||||
|
internal?)
|
||||||
|
(define-values (proj pat bindings _instantiated)
|
||||||
|
(analyze-pattern event-stx P-stx))
|
||||||
|
(define sub
|
||||||
|
(if internal? #`(internal-knowledge #,pat) pat))
|
||||||
|
(define matchp
|
||||||
|
(if internal? #'(internal-knowledge body) #'body))
|
||||||
|
(quasisyntax/loc outer-expr-stx
|
||||||
|
(add-endpoint!
|
||||||
|
#,(source-location->string outer-expr-stx)
|
||||||
|
#,internal?
|
||||||
|
(lambda () (if #,when-pred-stx
|
||||||
|
(core:sub #,sub)
|
||||||
|
patch-empty))
|
||||||
|
(lambda (e current-interests _synthetic?)
|
||||||
|
(when (not (trie-empty? current-interests))
|
||||||
|
(core:match-event e
|
||||||
|
[(core:message #,matchp)
|
||||||
|
(define capture-vals
|
||||||
|
(match-value/captures
|
||||||
|
body
|
||||||
|
#,proj))
|
||||||
|
(and capture-vals
|
||||||
|
(schedule-script!
|
||||||
|
#:priority #,priority-stx
|
||||||
|
(lambda ()
|
||||||
|
(apply (lambda #,bindings #,script-stx)
|
||||||
|
capture-vals))))]))))))
|
||||||
|
|
||||||
(define-for-syntax orig-insp
|
(define-for-syntax orig-insp
|
||||||
(variable-reference->module-declaration-inspector (#%variable-reference)))
|
(variable-reference->module-declaration-inspector (#%variable-reference)))
|
||||||
|
@ -839,7 +933,7 @@
|
||||||
priority-stx)
|
priority-stx)
|
||||||
(define event-stx (syntax-disarm armed-event-stx orig-insp))
|
(define event-stx (syntax-disarm armed-event-stx orig-insp))
|
||||||
(syntax-parse event-stx
|
(syntax-parse event-stx
|
||||||
#:literals [core:message asserted retracted rising-edge]
|
#:literals [core:message asserted retracted rising-edge know forget realize]
|
||||||
[(expander args ...)
|
[(expander args ...)
|
||||||
#:when (event-expander-id? #'expander)
|
#:when (event-expander-id? #'expander)
|
||||||
(event-expander-transform
|
(event-expander-transform
|
||||||
|
@ -851,33 +945,23 @@
|
||||||
script-stx
|
script-stx
|
||||||
priority-stx)))]
|
priority-stx)))]
|
||||||
[(core:message P)
|
[(core:message P)
|
||||||
(define-values (proj pat bindings _instantiated)
|
(analyze-message outer-expr-stx when-pred-stx event-stx script-stx
|
||||||
(analyze-pattern event-stx #'P))
|
#'P priority-stx #f)]
|
||||||
(quasisyntax/loc outer-expr-stx
|
|
||||||
(add-endpoint! #,(source-location->string outer-expr-stx)
|
|
||||||
(lambda () (if #,when-pred-stx
|
|
||||||
(core:sub #,pat)
|
|
||||||
patch-empty))
|
|
||||||
(lambda (e current-interests _synthetic?)
|
|
||||||
(when (not (trie-empty? current-interests))
|
|
||||||
(core:match-event e
|
|
||||||
[(core:message body)
|
|
||||||
(define capture-vals
|
|
||||||
(match-value/captures
|
|
||||||
body
|
|
||||||
#,proj))
|
|
||||||
(and capture-vals
|
|
||||||
(schedule-script!
|
|
||||||
#:priority #,priority-stx
|
|
||||||
(lambda ()
|
|
||||||
(apply (lambda #,bindings #,script-stx)
|
|
||||||
capture-vals))))])))))]
|
|
||||||
[(asserted P)
|
[(asserted P)
|
||||||
(analyze-asserted/retracted outer-expr-stx when-pred-stx event-stx script-stx
|
(analyze-appear/disappear outer-expr-stx when-pred-stx event-stx script-stx
|
||||||
#t #'P priority-stx)]
|
#t #'P priority-stx #f)]
|
||||||
[(retracted P)
|
[(retracted P)
|
||||||
(analyze-asserted/retracted outer-expr-stx when-pred-stx event-stx script-stx
|
(analyze-appear/disappear outer-expr-stx when-pred-stx event-stx script-stx
|
||||||
#f #'P priority-stx)]
|
#f #'P priority-stx #f)]
|
||||||
|
[(realize P)
|
||||||
|
(analyze-message outer-expr-stx when-pred-stx event-stx script-stx
|
||||||
|
#'P priority-stx #t)]
|
||||||
|
[(know P)
|
||||||
|
(analyze-appear/disappear outer-expr-stx when-pred-stx event-stx script-stx
|
||||||
|
#t #'P priority-stx #t)]
|
||||||
|
[(forget P)
|
||||||
|
(analyze-appear/disappear outer-expr-stx when-pred-stx event-stx script-stx
|
||||||
|
#f #'P priority-stx #t)]
|
||||||
[(rising-edge Pred)
|
[(rising-edge Pred)
|
||||||
(define field-name
|
(define field-name
|
||||||
(datum->syntax event-stx
|
(datum->syntax event-stx
|
||||||
|
@ -887,6 +971,7 @@
|
||||||
(let ()
|
(let ()
|
||||||
(field [#,field-name #f])
|
(field [#,field-name #f])
|
||||||
(add-endpoint! #,(source-location->string outer-expr-stx)
|
(add-endpoint! #,(source-location->string outer-expr-stx)
|
||||||
|
#f
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(when #,when-pred-stx
|
(when #,when-pred-stx
|
||||||
(define old-val (#,field-name))
|
(define old-val (#,field-name))
|
||||||
|
@ -1003,10 +1088,25 @@
|
||||||
(current-pending-actions (list (current-pending-actions)
|
(current-pending-actions (list (current-pending-actions)
|
||||||
((current-action-transformer) p)))))
|
((current-action-transformer) p)))))
|
||||||
|
|
||||||
|
(define (schedule-internal-event! ac)
|
||||||
|
(if (patch? ac)
|
||||||
|
(when (patch-non-empty? ac)
|
||||||
|
(current-pending-internal-patch (compose-patch ac (current-pending-internal-patch))))
|
||||||
|
(begin (flush-pending-internal-patch!)
|
||||||
|
(current-pending-internal-events (list (current-pending-internal-events)
|
||||||
|
((current-action-transformer) ac))))))
|
||||||
|
|
||||||
|
(define (flush-pending-internal-patch!)
|
||||||
|
(define p (current-pending-internal-patch))
|
||||||
|
(when (patch-non-empty? p)
|
||||||
|
(current-pending-internal-patch patch-empty)
|
||||||
|
(current-pending-internal-events (list (current-pending-internal-events)
|
||||||
|
((current-action-transformer) p)))))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Endpoint Creation
|
;; Endpoint Creation
|
||||||
|
|
||||||
(define (add-endpoint! where patch-fn handler-fn)
|
(define (add-endpoint! where internal? patch-fn handler-fn)
|
||||||
(when (in-script?)
|
(when (in-script?)
|
||||||
(error 'add-endpoint!
|
(error 'add-endpoint!
|
||||||
"~a: Cannot add endpoint in script; are you missing a (react ...)?"
|
"~a: Cannot add endpoint in script; are you missing a (react ...)?"
|
||||||
|
@ -1030,7 +1130,9 @@
|
||||||
(hash-set (facet-endpoints f)
|
(hash-set (facet-endpoints f)
|
||||||
new-eid
|
new-eid
|
||||||
(endpoint new-eid patch-fn handler-fn))]))))
|
(endpoint new-eid patch-fn handler-fn))]))))
|
||||||
(schedule-action! delta-aggregate))
|
(if internal?
|
||||||
|
(schedule-internal-event! delta-aggregate)
|
||||||
|
(schedule-action! delta-aggregate)))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Facet Lifecycle
|
;; Facet Lifecycle
|
||||||
|
@ -1045,7 +1147,7 @@
|
||||||
(define fid-uid next-fid-uid)
|
(define fid-uid next-fid-uid)
|
||||||
(define fid (cons fid-uid parent-fid))
|
(define fid (cons fid-uid parent-fid))
|
||||||
(set! next-fid-uid (+ next-fid-uid 1))
|
(set! next-fid-uid (+ next-fid-uid 1))
|
||||||
(update-facet! fid (lambda (_f) (facet fid (hasheqv) '() (set))))
|
(update-facet! fid (lambda (_f) (facet fid (hasheqv) '() (set) trie-empty trie-empty)))
|
||||||
(update-facet! parent-fid
|
(update-facet! parent-fid
|
||||||
(lambda (pf)
|
(lambda (pf)
|
||||||
(and pf (struct-copy facet pf
|
(and pf (struct-copy facet pf
|
||||||
|
@ -1094,8 +1196,24 @@
|
||||||
(dataflow-forget-subject! (actor-state-field-dataflow a) (list fid eid))
|
(dataflow-forget-subject! (actor-state-field-dataflow a) (list fid eid))
|
||||||
(define-values (new-mux _eid _delta delta-aggregate)
|
(define-values (new-mux _eid _delta delta-aggregate)
|
||||||
(mux-remove-stream (actor-state-mux a) eid))
|
(mux-remove-stream (actor-state-mux a) eid))
|
||||||
(current-actor-state (struct-copy actor-state a [mux new-mux]))
|
(define internal (patch-step delta-aggregate internal-knowledge-parenthesis))
|
||||||
(schedule-action! delta-aggregate))))
|
(define external (patch (trie-subtract (patch-added delta-aggregate) (patch-added internal))
|
||||||
|
(trie-subtract (patch-removed delta-aggregate) (patch-removed internal))))
|
||||||
|
(current-actor-state (struct-copy actor-state a
|
||||||
|
[mux new-mux]))
|
||||||
|
(define internal-aggregate (patch-prepend internal-knowledge-parenthesis internal))
|
||||||
|
(schedule-script!
|
||||||
|
#:priority *gc-priority*
|
||||||
|
;; need to do this later for the forget change detector
|
||||||
|
(lambda ()
|
||||||
|
(define a (current-actor-state))
|
||||||
|
(define new-knowledge
|
||||||
|
(update-interests (actor-state-knowledge a) internal))
|
||||||
|
(current-actor-state (struct-copy actor-state a
|
||||||
|
[knowledge new-knowledge]))))
|
||||||
|
|
||||||
|
(schedule-internal-event! internal-aggregate)
|
||||||
|
(schedule-action! external))))
|
||||||
|
|
||||||
(schedule-script!
|
(schedule-script!
|
||||||
#:priority *gc-priority*
|
#:priority *gc-priority*
|
||||||
|
@ -1124,6 +1242,8 @@
|
||||||
(make-dataflow-graph)))
|
(make-dataflow-graph)))
|
||||||
(current-pending-patch patch-empty)
|
(current-pending-patch patch-empty)
|
||||||
(current-pending-actions '())
|
(current-pending-actions '())
|
||||||
|
(current-pending-internal-patch patch-empty)
|
||||||
|
(current-pending-internal-events '())
|
||||||
(current-pending-scripts (make-empty-pending-scripts))
|
(current-pending-scripts (make-empty-pending-scripts))
|
||||||
(current-action-transformer values)]
|
(current-action-transformer values)]
|
||||||
(with-current-facet '() #f
|
(with-current-facet '() #f
|
||||||
|
@ -1151,6 +1271,7 @@
|
||||||
(when script
|
(when script
|
||||||
(script)
|
(script)
|
||||||
(refresh-facet-assertions!)
|
(refresh-facet-assertions!)
|
||||||
|
(dispatch-internal-events!)
|
||||||
(run-all-pending-scripts!)))
|
(run-all-pending-scripts!)))
|
||||||
|
|
||||||
(define (run-scripts!)
|
(define (run-scripts!)
|
||||||
|
@ -1162,6 +1283,16 @@
|
||||||
(core:quit pending-actions)
|
(core:quit pending-actions)
|
||||||
(core:transition (current-actor-state) pending-actions)))
|
(core:transition (current-actor-state) pending-actions)))
|
||||||
|
|
||||||
|
;; dispatch the internal events that have accumulated during script execution
|
||||||
|
(define (dispatch-internal-events!)
|
||||||
|
(flush-pending-internal-patch!)
|
||||||
|
(define pending (flatten (current-pending-internal-events)))
|
||||||
|
(current-pending-internal-events '())
|
||||||
|
(define a (current-actor-state))
|
||||||
|
(for* ([e (in-list pending)]
|
||||||
|
[(fid f) (in-hash (actor-state-facets a))])
|
||||||
|
(facet-handle-event! fid f e #f)))
|
||||||
|
|
||||||
(define (refresh-facet-assertions!)
|
(define (refresh-facet-assertions!)
|
||||||
(dataflow-repair-damage! (actor-state-field-dataflow (current-actor-state))
|
(dataflow-repair-damage! (actor-state-field-dataflow (current-actor-state))
|
||||||
(lambda (subject-id)
|
(lambda (subject-id)
|
||||||
|
@ -1201,6 +1332,8 @@
|
||||||
a))
|
a))
|
||||||
(current-pending-patch patch-empty)
|
(current-pending-patch patch-empty)
|
||||||
(current-pending-actions '())
|
(current-pending-actions '())
|
||||||
|
(current-pending-internal-patch patch-empty)
|
||||||
|
(current-pending-internal-events '())
|
||||||
(current-pending-scripts (make-empty-pending-scripts))
|
(current-pending-scripts (make-empty-pending-scripts))
|
||||||
(current-action-transformer values)]
|
(current-action-transformer values)]
|
||||||
(for [((fid f) (in-hash (actor-state-facets a)))]
|
(for [((fid f) (in-hash (actor-state-facets a)))]
|
||||||
|
@ -1210,6 +1343,16 @@
|
||||||
(define (facet-handle-event! fid f e synthetic?)
|
(define (facet-handle-event! fid f e synthetic?)
|
||||||
(define mux (actor-state-mux (current-actor-state)))
|
(define mux (actor-state-mux (current-actor-state)))
|
||||||
(with-current-facet fid #f
|
(with-current-facet fid #f
|
||||||
|
(when (patch? e)
|
||||||
|
;; quick-and-dirty intersection with (internal-knowledge ?)
|
||||||
|
(define internal (patch-prepend internal-knowledge-parenthesis
|
||||||
|
(patch-step e internal-knowledge-parenthesis)))
|
||||||
|
(update-facet! fid
|
||||||
|
(lambda (f)
|
||||||
|
(and f
|
||||||
|
(struct-copy facet f
|
||||||
|
[previous-knowledge (facet-knowledge f)]
|
||||||
|
[knowledge (apply-patch (facet-knowledge f) internal)])))))
|
||||||
(for [(ep (in-hash-values (facet-endpoints f)))]
|
(for [(ep (in-hash-values (facet-endpoints f)))]
|
||||||
((endpoint-handler-fn ep) e (mux-interests-of mux (endpoint-id ep)) synthetic?))))
|
((endpoint-handler-fn ep) e (mux-interests-of mux (endpoint-id ep)) synthetic?))))
|
||||||
|
|
||||||
|
@ -1306,6 +1449,10 @@
|
||||||
(ensure-in-script! 'send!)
|
(ensure-in-script! 'send!)
|
||||||
(schedule-action! (core:message M)))
|
(schedule-action! (core:message M)))
|
||||||
|
|
||||||
|
(define (realize! M)
|
||||||
|
(ensure-in-script! 'realize!)
|
||||||
|
(schedule-internal-event! (core:message (internal-knowledge M))))
|
||||||
|
|
||||||
(define *adhoc-label* -1)
|
(define *adhoc-label* -1)
|
||||||
|
|
||||||
(define (assert! P)
|
(define (assert! P)
|
||||||
|
@ -1352,7 +1499,7 @@
|
||||||
(fprintf p " - Knowledge:\n ~a" (trie->pretty-string knowledge #:indent 3))
|
(fprintf p " - Knowledge:\n ~a" (trie->pretty-string knowledge #:indent 3))
|
||||||
(fprintf p " - Facets:\n")
|
(fprintf p " - Facets:\n")
|
||||||
(for ([(fid f) (in-hash facets)])
|
(for ([(fid f) (in-hash facets)])
|
||||||
(match-define (facet _fid endpoints _ children) f)
|
(match-define (facet _fid endpoints _ children _ _) f)
|
||||||
(fprintf p " ---- facet ~a, children=~a" fid (set->list children))
|
(fprintf p " ---- facet ~a, children=~a" fid (set->list children))
|
||||||
(when (not (hash-empty? endpoints))
|
(when (not (hash-empty? endpoints))
|
||||||
(fprintf p ", endpoints=~a" (hash-keys endpoints)))
|
(fprintf p ", endpoints=~a" (hash-keys endpoints)))
|
||||||
|
|
|
@ -0,0 +1,62 @@
|
||||||
|
#lang syndicate
|
||||||
|
|
||||||
|
;; Expected Output:
|
||||||
|
#|
|
||||||
|
balance = 0
|
||||||
|
balance = 5
|
||||||
|
balance = 0
|
||||||
|
JEEPERS
|
||||||
|
know overdraft!
|
||||||
|
balance = -1
|
||||||
|
balance = -2
|
||||||
|
no longer in overdraft
|
||||||
|
balance = 8
|
||||||
|
|#
|
||||||
|
|
||||||
|
(assertion-struct balance (v))
|
||||||
|
(message-struct deposit (v))
|
||||||
|
|
||||||
|
(spawn
|
||||||
|
;; Internal Events
|
||||||
|
(message-struct new-transaction (old new))
|
||||||
|
(assertion-struct overdraft ())
|
||||||
|
|
||||||
|
(field [account 0])
|
||||||
|
|
||||||
|
(assert (balance (account)))
|
||||||
|
|
||||||
|
(on (message (deposit $v))
|
||||||
|
(define prev (account))
|
||||||
|
(account (+ v (account)))
|
||||||
|
(realize! (new-transaction prev (account))))
|
||||||
|
|
||||||
|
(on (realize (new-transaction $old $new))
|
||||||
|
(when (and (negative? new)
|
||||||
|
(not (negative? old)))
|
||||||
|
(react
|
||||||
|
;; (this print is to make sure only one of these facets is created)
|
||||||
|
(printf "JEEPERS\n")
|
||||||
|
(know (overdraft))
|
||||||
|
(on (realize (new-transaction $old $new))
|
||||||
|
(when (not (negative? new))
|
||||||
|
(stop-current-facet))))))
|
||||||
|
|
||||||
|
(on (know (overdraft))
|
||||||
|
(printf "know overdraft!\n"))
|
||||||
|
(on (forget (overdraft))
|
||||||
|
(printf "no longer in overdraft\n")))
|
||||||
|
|
||||||
|
(spawn
|
||||||
|
(on (asserted (balance $v))
|
||||||
|
(printf "balance = ~a\n" v)))
|
||||||
|
|
||||||
|
(spawn*
|
||||||
|
(send! (deposit 5))
|
||||||
|
(flush!)
|
||||||
|
(send! (deposit -5))
|
||||||
|
(flush!)
|
||||||
|
(send! (deposit -1))
|
||||||
|
(flush!)
|
||||||
|
(send! (deposit -1))
|
||||||
|
(flush!)
|
||||||
|
(send! (deposit 10)))
|
|
@ -0,0 +1,19 @@
|
||||||
|
#lang syndicate
|
||||||
|
|
||||||
|
;; Expected Output:
|
||||||
|
#|
|
||||||
|
received message bad
|
||||||
|
realized good
|
||||||
|
|#
|
||||||
|
|
||||||
|
(message-struct ping (v))
|
||||||
|
|
||||||
|
(spawn
|
||||||
|
(on (realize (ping $v))
|
||||||
|
(printf "realized ~a\n" v))
|
||||||
|
(on (message (ping $v))
|
||||||
|
(printf "received message ~a\n" v)
|
||||||
|
(realize! (ping 'good))))
|
||||||
|
|
||||||
|
(spawn*
|
||||||
|
(send! (ping 'bad)))
|
|
@ -14,6 +14,7 @@
|
||||||
limit-patch
|
limit-patch
|
||||||
patch-step
|
patch-step
|
||||||
patch-step*
|
patch-step*
|
||||||
|
patch-prepend
|
||||||
compute-aggregate-patch
|
compute-aggregate-patch
|
||||||
apply-patch
|
apply-patch
|
||||||
update-interests
|
update-interests
|
||||||
|
@ -125,6 +126,13 @@
|
||||||
(define (patch-step* p keys)
|
(define (patch-step* p keys)
|
||||||
(foldl (lambda (key p) (patch-step p key)) p keys))
|
(foldl (lambda (key p) (patch-step p key)) p keys))
|
||||||
|
|
||||||
|
;; (U Sigma OpenParenthesis) Trie -> Trie
|
||||||
|
;; Prepend both added and removed sets
|
||||||
|
(define (patch-prepend key p)
|
||||||
|
(match-define (patch added removed) p)
|
||||||
|
(patch (trie-prepend key added)
|
||||||
|
(trie-prepend key removed)))
|
||||||
|
|
||||||
;; Entries labelled with `label` may already exist in `base`; the
|
;; Entries labelled with `label` may already exist in `base`; the
|
||||||
;; patch `p` MUST already have been limited to add only where no
|
;; patch `p` MUST already have been limited to add only where no
|
||||||
;; `label`-labelled portions of `base` exist, and to remove only where
|
;; `label`-labelled portions of `base` exist, and to remove only where
|
||||||
|
|
Loading…
Reference in New Issue