syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

on-claim fix for incremental, on-claim impl for monolithic

This commit is contained in:
Tony Garnock-Jones 2016-01-24 00:03:59 -05:00
parent ff3ba722ad
commit 0a6cce2d3d
2 changed files with 42 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
prospect-monolithic/demand-matcher.rkt
View File

@ -10,7 +10,8 @@
(provide (except-out (struct-out demand-matcher) demand-matcher)
(rename-out [make-demand-matcher demand-matcher])
demand-matcher-update
spawn-demand-matcher)
spawn-demand-matcher
on-claim)
;; A DemandMatcher keeps track of demand for services based on some
;; Projection over a Trie, as well as a collection of functions
@ -110,6 +111,44 @@
(subscription (projection->pattern supply-spec) #:meta-level meta-level)
(advertisement (projection->pattern supply-spec) #:meta-level meta-level))))
;; (Trie (Option (Setof (Listof Value))) ... -> (Option (Constreeof Action)))
;; Trie Projection ...
;; -> Action
;; Spawns a process that observes the given projections. Any time the
;; environment's interests change in a relevant way, calls
;; check-and-maybe-spawn-fn with the aggregate interests and the
;; projection results. If check-and-maybe-spawn-fn returns #f,
;; continues to wait; otherwise, takes the action(s) returned, and
;; quits.
(define (on-claim #:timeout-msec [timeout-msec #f]
#:on-timeout [timeout-handler (lambda () '())]
check-and-maybe-spawn-fn
base-interests
. projections)
(define timer-id (gensym 'on-claim))
(define (on-claim-handler e state)
(match e
[(scn new-aggregate)
(define projection-results
(map (lambda (p) (trie-project/set new-aggregate (compile-projection p))) projections))
(define maybe-spawn (apply check-and-maybe-spawn-fn
new-aggregate
projection-results))
(if maybe-spawn
(quit maybe-spawn)
#f)]
[(message (timer-expired (== timer-id) _))
(quit (timeout-handler))]
[_ #f]))
(list
(when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
(spawn on-claim-handler
(void)
(scn/union base-interests
(assertion-set-union*
(map (lambda (p) (subscription (projection->pattern p))) projections))
(subscription (timer-expired timer-id ?))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (pretty-print-demand-matcher s [p (current-output-port)])

4
prospect/demand-matcher.rkt
View File

@ -127,7 +127,7 @@
[(? patch? p)
(define new-aggregate (update-interests current-aggregate p))
(define projection-results
(map (lambda (p) (trie-project/set new-aggregate p)) projections))
(map (lambda (p) (trie-project/set new-aggregate (compile-projection p))) projections))
(define maybe-spawn (apply check-and-maybe-spawn-fn
new-aggregate
projection-results))
@ -142,7 +142,7 @@
(spawn on-claim-handler
(trie-empty)
(patch-seq (patch base-interests (trie-empty))
(patch-seq* (map projection->pattern projections))
(patch-seq* (map (lambda (p) (sub projection->pattern)) projections))
(sub (timer-expired timer-id ?))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;