fix bugs in internal events
This commit is contained in:
parent
056d467402
commit
f4701a3f70
|
@ -856,6 +856,12 @@
|
||||||
(if internal? #`(internal-knowledge #,P-stx) P-stx))
|
(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+))
|
(analyze-pattern event-stx P+))
|
||||||
|
(define interest-stx
|
||||||
|
(if internal?
|
||||||
|
#`(patch-seq (core:sub #,pat)
|
||||||
|
;; Allow other facets to see our interest
|
||||||
|
(core:assert (internal-knowledge (observe #,(cadr pat)))))
|
||||||
|
#`(core:sub #,pat)))
|
||||||
(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
|
||||||
|
@ -867,7 +873,7 @@
|
||||||
#,(source-location->string outer-expr-stx)
|
#,(source-location->string outer-expr-stx)
|
||||||
#,internal?
|
#,internal?
|
||||||
(lambda () (if #,when-pred-stx
|
(lambda () (if #,when-pred-stx
|
||||||
(core:sub #,pat)
|
#,interest-stx
|
||||||
patch-empty))
|
patch-empty))
|
||||||
(lambda (e current-interests synthetic?)
|
(lambda (e current-interests synthetic?)
|
||||||
(when (not (trie-empty? current-interests))
|
(when (not (trie-empty? current-interests))
|
||||||
|
@ -1200,12 +1206,9 @@
|
||||||
(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))
|
||||||
(define internal (patch-step delta-aggregate internal-knowledge-parenthesis))
|
(define-values (internal external) (split-internal/external 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
|
(current-actor-state (struct-copy actor-state a
|
||||||
[mux new-mux]))
|
[mux new-mux]))
|
||||||
(define internal-aggregate (patch-prepend internal-knowledge-parenthesis internal))
|
|
||||||
(schedule-script!
|
(schedule-script!
|
||||||
#:priority *gc-priority*
|
#:priority *gc-priority*
|
||||||
;; need to do this later for the forget change detector
|
;; need to do this later for the forget change detector
|
||||||
|
@ -1216,7 +1219,7 @@
|
||||||
(current-actor-state (struct-copy actor-state a
|
(current-actor-state (struct-copy actor-state a
|
||||||
[knowledge new-knowledge]))))
|
[knowledge new-knowledge]))))
|
||||||
|
|
||||||
(schedule-internal-event! internal-aggregate)
|
(schedule-internal-event! internal)
|
||||||
(schedule-action! external))))
|
(schedule-action! external))))
|
||||||
|
|
||||||
(schedule-script!
|
(schedule-script!
|
||||||
|
@ -1328,7 +1331,9 @@
|
||||||
(define-values (new-mux _eid _delta delta-aggregate)
|
(define-values (new-mux _eid _delta delta-aggregate)
|
||||||
(mux-update-stream (actor-state-mux a) eid patch))
|
(mux-update-stream (actor-state-mux a) eid patch))
|
||||||
(current-actor-state (struct-copy actor-state a [mux new-mux]))
|
(current-actor-state (struct-copy actor-state a [mux new-mux]))
|
||||||
(schedule-action! delta-aggregate))
|
(define-values (internal external) (split-internal/external delta-aggregate))
|
||||||
|
(schedule-internal-event! internal)
|
||||||
|
(schedule-action! external))
|
||||||
|
|
||||||
(define (actor-behavior e a)
|
(define (actor-behavior e a)
|
||||||
(and e
|
(and e
|
||||||
|
@ -1352,9 +1357,7 @@
|
||||||
(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)
|
(when (patch? e)
|
||||||
;; quick-and-dirty intersection with (internal-knowledge ?)
|
(define internal (internal-patch e))
|
||||||
(define internal (patch-prepend internal-knowledge-parenthesis
|
|
||||||
(patch-step e internal-knowledge-parenthesis)))
|
|
||||||
(update-facet! fid
|
(update-facet! fid
|
||||||
(lambda (f)
|
(lambda (f)
|
||||||
(and f
|
(and f
|
||||||
|
@ -1492,6 +1495,23 @@
|
||||||
(ensure-in-script! 'quit-dataspace!)
|
(ensure-in-script! 'quit-dataspace!)
|
||||||
(schedule-action! (core:quit-dataspace)))
|
(schedule-action! (core:quit-dataspace)))
|
||||||
|
|
||||||
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; Helpers
|
||||||
|
|
||||||
|
;; Patch -> (Values Patch Patch)
|
||||||
|
;; split a patch into its internal and external components
|
||||||
|
(define (split-internal/external e)
|
||||||
|
(define internal (internal-patch e))
|
||||||
|
(values internal
|
||||||
|
(patch (trie-subtract (patch-added e) (patch-added internal))
|
||||||
|
(trie-subtract (patch-removed e) (patch-removed internal)))))
|
||||||
|
|
||||||
|
;; Patch -> Patch
|
||||||
|
;; Remove all items from a patch not constructed with internal-knowledge
|
||||||
|
(define (internal-patch e)
|
||||||
|
(patch-prepend internal-knowledge-parenthesis
|
||||||
|
(patch-step e internal-knowledge-parenthesis)))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (format-field-descriptor d)
|
(define (format-field-descriptor d)
|
||||||
|
|
Loading…
Reference in New Issue