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

Use new projection utilities.

This commit is contained in:
Tony Garnock-Jones 2015-03-06 13:25:38 +00:00
parent 261c84b40d
commit a0da39f6f7
2 changed files with 21 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
prospect/demand-matcher.rkt
View File

@ -4,7 +4,6 @@
(require racket/set)
(require racket/match)
(require "core.rkt")
(require (only-in "route.rkt" matcher-project matcher-key-set))
(require "drivers/timer.rkt")
(provide (except-out (struct-out demand-matcher) demand-matcher)
@ -50,10 +49,10 @@
;; to increased unsatisfied demand and decreased demanded supply.
(define (demand-matcher-update d s p)
(match-define (demand-matcher demand-spec supply-spec inc-h dec-h demand supply) d)
(define added-demand (matcher-key-set (matcher-project (patch-added p) demand-spec)))
(define removed-demand (matcher-key-set (matcher-project (patch-removed p) demand-spec)))
(define added-supply (matcher-key-set (matcher-project (patch-added p) supply-spec)))
(define removed-supply (matcher-key-set (matcher-project (patch-removed p) supply-spec)))
(define added-demand (matcher-project/set (patch-added p) demand-spec))
(define removed-demand (matcher-project/set (patch-removed p) demand-spec))
(define added-supply (matcher-project/set (patch-added p) supply-spec))
(define removed-supply (matcher-project/set (patch-removed p) supply-spec))
(when (not added-demand)
(error 'demand-matcher "Wildcard demand of ~v:\n~a"
@ -123,23 +122,24 @@
base-interests
. projections)
(define timer-id (gensym 'on-claim))
(define (on-claim-handler e current-aggregate)
(match e
[(? patch? p)
(define new-aggregate (update-interests current-aggregate p))
(define projection-results
(map (lambda (p) (matcher-project/set new-aggregate p)) projections))
(define maybe-spawn (apply check-and-maybe-spawn-fn
new-aggregate
projection-results))
(if maybe-spawn
(quit maybe-spawn)
(transition new-aggregate '()))]
[(message (timer-expired (== timer-id) _))
(quit (timeout-handler))]
[_ #f]))
(list
(when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
(spawn (lambda (e current-aggregate)
(match e
[(? patch? p)
(define new-aggregate (update-interests current-aggregate p))
(define projection-results
(map (lambda (p) (matcher-key-set (matcher-project new-aggregate p))) projections))
(define maybe-spawn (apply check-and-maybe-spawn-fn
new-aggregate
projection-results))
(if maybe-spawn
(quit maybe-spawn)
(transition new-aggregate '()))]
[(message (timer-expired (== timer-id) _))
(quit (timeout-handler))]
[_ #f]))
(spawn on-claim-handler
(matcher-empty)
(patch base-interests (matcher-empty))
(patch-seq* (map projection->pattern projections))

3
prospect/ground.rkt
View File

@ -6,7 +6,6 @@
(require racket/match)
(require racket/list)
(require "core.rkt")
(require "route.rkt")
(require "trace/stderr.rkt")
(provide (struct-out external-event)
@ -48,7 +47,7 @@
;; Interests -> (Listof RacketEvent)
;; Projects out the active event subscriptions from the given interests.
(define (extract-active-events interests)
(define es (matcher-key-set/single (matcher-project interests event-projection)))
(define es (matcher-project/set/single interests event-projection))
;; TODO: how should the following error be handled, ideally?
;; In principle, security restrictions should make it impossible.
;; But absent those, what should be done? Should an offending