89 lines
2.9 KiB
Racket
89 lines
2.9 KiB
Racket
#lang racket/base
|
|
|
|
(require racket/set)
|
|
(require racket/match)
|
|
(require "core.rkt")
|
|
(require "gestalt.rkt")
|
|
|
|
(provide (except-out (struct-out demand-matcher) demand-matcher)
|
|
(rename-out [make-demand-matcher demand-matcher])
|
|
demand-matcher-update
|
|
spawn-demand-matcher)
|
|
|
|
(struct demand-matcher (demand-is-subscription?
|
|
pattern
|
|
spec
|
|
meta-level
|
|
demand-level
|
|
supply-level
|
|
increase-handler
|
|
decrease-handler
|
|
current-demand
|
|
current-supply)
|
|
#:transparent)
|
|
|
|
(define (unexpected-supply-decrease . removed-captures)
|
|
'())
|
|
|
|
(define (default-decrease-handler state . removed-captures)
|
|
state)
|
|
|
|
(define (make-demand-matcher demand-is-subscription?
|
|
projection
|
|
meta-level
|
|
demand-level
|
|
supply-level
|
|
increase-handler
|
|
[decrease-handler default-decrease-handler])
|
|
(demand-matcher demand-is-subscription?
|
|
(projection->pattern projection)
|
|
(compile-gestalt-projection projection)
|
|
meta-level
|
|
demand-level
|
|
supply-level
|
|
increase-handler
|
|
decrease-handler
|
|
(set)
|
|
(set)))
|
|
|
|
(define (demand-matcher-update d s g)
|
|
(match-define (demand-matcher demand-is-sub? _ spec ml dl sl inc-h dec-h old-demand old-supply) d)
|
|
(define new-demand (matcher-key-set (gestalt-project g ml dl (not demand-is-sub?) spec)))
|
|
(define new-supply (matcher-key-set (gestalt-project g ml sl demand-is-sub? spec)))
|
|
(define demand+ (set-subtract (set-subtract new-demand old-demand) new-supply))
|
|
(define supply- (set-intersect (set-subtract old-supply new-supply) new-demand))
|
|
(define new-d (struct-copy demand-matcher d
|
|
[current-demand new-demand]
|
|
[current-supply new-supply]))
|
|
(let* ((s (for/fold [(s s)] [(k (in-set demand+))] (apply inc-h s (vector->list k))))
|
|
(s (for/fold [(s s)] [(k (in-set supply-))] (apply dec-h s (vector->list k)))))
|
|
(values new-d s)))
|
|
|
|
(define (demand-matcher-handle-event e d)
|
|
(match e
|
|
[(routing-update gestalt)
|
|
(define-values (new-d actions) (demand-matcher-update d '() gestalt))
|
|
(transition new-d actions)]
|
|
[_ #f]))
|
|
|
|
(define (spawn-demand-matcher projection
|
|
increase-handler
|
|
[decrease-handler unexpected-supply-decrease]
|
|
#:demand-is-subscription? [demand-is-subscription? #t]
|
|
#:meta-level [meta-level 0]
|
|
#:demand-level [demand-level 0]
|
|
#:supply-level [supply-level 0])
|
|
(define d (make-demand-matcher demand-is-subscription?
|
|
projection
|
|
meta-level
|
|
demand-level
|
|
supply-level
|
|
(lambda (acs . rs) (cons (apply increase-handler rs) acs))
|
|
(lambda (acs . rs) (cons (apply decrease-handler rs) acs))))
|
|
(define observer-pattern (demand-matcher-pattern d))
|
|
(define observer-level (+ 1 (max demand-level supply-level)))
|
|
(spawn demand-matcher-handle-event
|
|
d
|
|
(gestalt-union (sub observer-pattern #:meta-level meta-level #:level observer-level)
|
|
(pub observer-pattern #:meta-level meta-level #:level observer-level))))
|