Switch gestalt representations to accommodate n<m filtering.
The previous format separated out the different levels too much. The new format pushes the level representation *under* the routing matcher.
This commit is contained in:
Tony Garnock-Jones
parent
50ed37f52e
commit
b750a01e78
|
|
@ -30,7 +30,9 @@
|
|||
gestalt-ref
|
||||
compile-gestalt-projection
|
||||
gestalt-project
|
||||
gestalt-project-key-set
|
||||
matcher-project-level
|
||||
matcher-project
|
||||
matcher-key-set
|
||||
pretty-print-gestalt
|
||||
|
||||
spawn
|
||||
|
|
@ -75,10 +77,8 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Protocol and utilities
|
||||
|
||||
(define (sub p #:meta-level [ml 0] #:level [l 0])
|
||||
(simple-gestalt (pattern->matcher (set #t) p) #f l ml))
|
||||
(define (pub p #:meta-level [ml 0] #:level [l 0])
|
||||
(simple-gestalt #f (pattern->matcher (set #t) p) l ml))
|
||||
(define (sub p #:meta-level [ml 0] #:level [l 0]) (simple-gestalt #f p l ml))
|
||||
(define (pub p #:meta-level [ml 0] #:level [l 0]) (simple-gestalt #t p l ml))
|
||||
|
||||
(define (spawn behavior state [gestalt (gestalt-empty)]) (process gestalt behavior state))
|
||||
(define (send body #:meta-level [ml 0]) (message body ml #f))
|
||||
|
|
@ -191,13 +191,8 @@
|
|||
|
||||
(define (update-aggregate-gestalt w pid old-g new-g)
|
||||
(struct-copy world w [aggregate-gestalt
|
||||
(gestalt-union (gestalt-combine-straight (world-aggregate-gestalt w)
|
||||
old-g
|
||||
(lambda (side x)
|
||||
(case side
|
||||
[(left-longer) x]
|
||||
[(right-longer) '()]))
|
||||
matcher-erase-path)
|
||||
(gestalt-union (gestalt-erase-path (world-aggregate-gestalt w)
|
||||
old-g)
|
||||
new-g)]))
|
||||
|
||||
(define (issue-local-routing-update w relevant-gestalt)
|
||||
|
|
@ -251,14 +246,14 @@
|
|||
(define (dispatch-event e w)
|
||||
(match e
|
||||
[(message body meta-level feedback?)
|
||||
(define matcher (gestalt-ref (world-aggregate-gestalt w) meta-level 0 feedback?))
|
||||
(define pids (matcher-match-value matcher body))
|
||||
(define matcher (gestalt-ref (world-aggregate-gestalt w) meta-level feedback?))
|
||||
(define pids (levels->pids (matcher-match-value matcher body '())))
|
||||
(define pt (world-process-table w))
|
||||
(for/fold ([w w]) [(pid (in-set pids))]
|
||||
(apply-transition pid (deliver-event e pid (hash-ref pt pid)) w))]
|
||||
[(routing-update affected-subgestalt)
|
||||
(define g (world-aggregate-gestalt w))
|
||||
(define-values (affected-pids uninteresting) (gestalt-match g affected-subgestalt))
|
||||
(define affected-pids (gestalt-match affected-subgestalt g))
|
||||
(define pt (world-process-table w))
|
||||
(for/fold ([w w]) [(pid (in-set affected-pids))]
|
||||
(define p (hash-ref pt pid))
|
||||
|
|
|
|||
|
|
@ -3,6 +3,21 @@
|
|||
(require (only-in racket/port read-line-evt))
|
||||
(require "../drivers/timer.rkt")
|
||||
|
||||
(define (quasi-spy e s)
|
||||
(printf "----------------------------------------\n")
|
||||
(printf "QUASI-SPY:\n")
|
||||
(match e
|
||||
[(routing-update g) (pretty-print-gestalt g)]
|
||||
[other
|
||||
(write other)
|
||||
(newline)])
|
||||
(printf "========================================\n")
|
||||
#f)
|
||||
(spawn quasi-spy (void) (gestalt-union (sub ? #:level 10 #:meta-level 1)
|
||||
(pub ? #:level 10 #:meta-level 1)
|
||||
(sub ? #:level 10)
|
||||
(pub ? #:level 10)))
|
||||
|
||||
(define (r e s)
|
||||
(match e
|
||||
[(message body _ _) (transition s (send `(print got ,body) #:meta-level 1))]
|
||||
|
|
@ -32,7 +47,7 @@
|
|||
[(routing-update g)
|
||||
(printf "EMPTY? ~v\n" (gestalt-empty? g))
|
||||
(printf "REF:")
|
||||
(pretty-print-matcher (gestalt-ref g 0 0 #f) #:indent 4)
|
||||
(pretty-print-matcher (gestalt-ref g 0 #f) #:indent 4)
|
||||
(printf "INTERSECTED:\n")
|
||||
(pretty-print-gestalt (gestalt-filter g (pub (set-timer ? ? ?) #:level 1)))
|
||||
#f]
|
||||
|
|
|
|||
|
|
@ -5,6 +5,17 @@
|
|||
(require "../main.rkt")
|
||||
(require "../drivers/timer.rkt")
|
||||
|
||||
(define (quasi-spy e s)
|
||||
(printf "----------------------------------------\n")
|
||||
(printf "QUASI-SPY:\n")
|
||||
(match e
|
||||
[(routing-update g) (pretty-print-gestalt g)]
|
||||
[other
|
||||
(write other)
|
||||
(newline)])
|
||||
(printf "========================================\n")
|
||||
#f)
|
||||
|
||||
(define (r e s)
|
||||
(match e
|
||||
[(message body _ _) (transition s (send `(print got ,body) #:meta-level 1))]
|
||||
|
|
@ -28,7 +39,7 @@
|
|||
[(routing-update g)
|
||||
(printf "EMPTY? ~v\n" (gestalt-empty? g))
|
||||
(printf "REF:")
|
||||
(pretty-print-matcher (gestalt-ref g 0 0 #f) #:indent 4)
|
||||
(pretty-print-matcher (gestalt-ref g 0 #f) #:indent 4)
|
||||
(printf "INTERSECTED:\n")
|
||||
(pretty-print-gestalt (gestalt-filter g (pub (set-timer ? ? ?) #:level 1)))
|
||||
#f]
|
||||
|
|
@ -46,7 +57,11 @@
|
|||
#f]
|
||||
[_ #f]))
|
||||
|
||||
(run-ground (spawn-timer-driver)
|
||||
(run-ground (spawn quasi-spy (void) (gestalt-union (sub ? #:level 10 #:meta-level 1)
|
||||
(pub ? #:level 10 #:meta-level 1)
|
||||
(sub ? #:level 10)
|
||||
(pub ? #:level 10)))
|
||||
(spawn-timer-driver)
|
||||
(send (set-timer 'tick 1000 'relative))
|
||||
(spawn ticker 1 (gestalt-union (pub (set-timer ? ? ?) #:level 1)
|
||||
(sub (timer-expired 'tick ?))))
|
||||
|
|
|
|||
|
|
@ -10,30 +10,35 @@
|
|||
gestalt-ref
|
||||
compile-gestalt-projection
|
||||
gestalt-project
|
||||
gestalt-project-key-set
|
||||
matcher-project-level
|
||||
levels->pids
|
||||
drop-gestalt
|
||||
lift-gestalt
|
||||
simple-gestalt
|
||||
gestalt-empty
|
||||
gestalt-empty?
|
||||
gestalt-combine
|
||||
gestalt-combine-straight
|
||||
gestalt-combine-crossed
|
||||
gestalt-union
|
||||
gestalt-filter
|
||||
gestalt-match
|
||||
gestalt-erase-path
|
||||
strip-gestalt-label
|
||||
label-gestalt
|
||||
pretty-print-gestalt)
|
||||
|
||||
;; A Gestalt is a (gestalt (Listof (Listof (Pairof Matcher
|
||||
;; Matcher)))), representing the total interests of a process or group
|
||||
;; of processes. The outer list has a present entry for each active
|
||||
;; metalevel, starting with metalevel 0 in the car. The inner lists
|
||||
;; each have an entry for each active observer level at their
|
||||
;; metalevel. The innermost pairs have cars holding matchers
|
||||
;; representing active subscriptions, and cdrs representing active
|
||||
;; advertisements.
|
||||
;; A Gestalt is a (gestalt (Listof (Pairof Matcher Matcher))),
|
||||
;; representing the total interests of a process or group of
|
||||
;; processes. The outer list has a present entry for each active
|
||||
;; metalevel, starting with metalevel 0 in the car. The inner pairs
|
||||
;; have cars holding matchers representing active subscriptions, and
|
||||
;; cdrs representing active advertisements. Each of the Matchers maps
|
||||
;; to (Listof (Option (Setof PID))), with the nth entry in the list
|
||||
;; corresponding to level n, and #f corresponding to empty-set.
|
||||
;;
|
||||
;; So,
|
||||
;; - metalevels: entries in the outermost list.
|
||||
;; - sub/adv: car or cdr of each inner pair, respectively.
|
||||
;; - levels: entries in the list at each Matcher success value.
|
||||
;;
|
||||
;;
|
||||
;; "... a few standardised subsystems, identical from citizen to
|
||||
;; citizen. Two of these were channels for incoming data — one for
|
||||
|
|
@ -44,8 +49,9 @@
|
|||
;;
|
||||
(struct gestalt (metalevels) #:prefab)
|
||||
|
||||
;; Convention: A GestaltSet is a Gestalt where all the patterns map to
|
||||
;; #t rather than a PID or any other value.
|
||||
;; Convention: A GestaltSet is a Gestalt where all the Matchers map to
|
||||
;; (Listof (Option #t)) rather than the (Listof (Option (Setof PID)))
|
||||
;; described above or any other value.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
|
@ -55,64 +61,78 @@
|
|||
['() (fail-thunk)]
|
||||
[(cons x xs) (if (zero? n) x (loop xs (- n 1)))])))
|
||||
|
||||
(define (safe-take gcons xs n)
|
||||
(let walk ((xs xs) (n n))
|
||||
(cond [(null? xs) '()]
|
||||
[(zero? n) '()]
|
||||
[else (gcons (car xs) (walk (cdr xs) (- n 1)))])))
|
||||
|
||||
(define (safe-cdr xs)
|
||||
(if (null? xs)
|
||||
'()
|
||||
(cdr xs)))
|
||||
|
||||
(define (gestalt-ref g metalevel level get-advertisements?)
|
||||
(define v (safe-list-ref (gestalt-metalevels g) metalevel (lambda () '())))
|
||||
(define p (safe-list-ref v level (lambda () '(#f . #f))))
|
||||
((if get-advertisements? cdr car) p))
|
||||
(define ((guarded-cons unit) a d)
|
||||
(if (and (null? d) (equal? a unit))
|
||||
'()
|
||||
(cons a d)))
|
||||
|
||||
(define cons-level (guarded-cons #f))
|
||||
(define cons-metalevel (guarded-cons '(#f . #f)))
|
||||
|
||||
;; Gestalt × Natural × Boolean → Matcher
|
||||
(define (gestalt-ref g metalevel get-advertisements?)
|
||||
(define v (safe-list-ref (gestalt-metalevels g) metalevel (lambda () '(#f . #f))))
|
||||
((if get-advertisements? cdr car) v))
|
||||
|
||||
(define (compile-gestalt-projection spec)
|
||||
(compile-projection spec))
|
||||
|
||||
(define (gestalt-project g metalevel level get-advertisements? capture-spec)
|
||||
(matcher-project (gestalt-ref g metalevel level get-advertisements?) capture-spec))
|
||||
;; Limits the given matcher to only include keys when a subscription
|
||||
;; at *exactly* the given level exists.
|
||||
(define (matcher-project-level m level)
|
||||
(matcher-relabel m (lambda (v) (and (safe-list-ref v level (lambda () #f)) #t))))
|
||||
|
||||
(define (gestalt-project-key-set g metalevel level get-advertisements? capture-spec)
|
||||
(matcher-key-set (gestalt-project g metalevel level get-advertisements? capture-spec)))
|
||||
(define (gestalt-project g metalevel get-advertisements? capture-spec)
|
||||
(matcher-project (gestalt-ref g metalevel get-advertisements?) capture-spec))
|
||||
|
||||
(define (levels->pids ls)
|
||||
(foldl (lambda (e acc) (if e (set-union e acc) acc)) (set) ls))
|
||||
|
||||
(define (drop-gestalt g)
|
||||
(match-define (gestalt metalevels) g)
|
||||
(if (null? metalevels) g (gestalt (cdr metalevels))))
|
||||
(gestalt (safe-cdr (gestalt-metalevels g))))
|
||||
|
||||
(define (lift-gestalt g)
|
||||
(gestalt (cons '#() (gestalt-metalevels g))))
|
||||
(gestalt (cons-metalevel '(#f . #f) (gestalt-metalevels g))))
|
||||
|
||||
(define (prepend n x xs)
|
||||
(if (zero? n)
|
||||
xs
|
||||
(cons x (prepend (- n 1) x xs))))
|
||||
|
||||
(define (simple-gestalt subs advs level metalevel)
|
||||
(gestalt (prepend metalevel '() (list (prepend level '(#f . #f) (list (cons subs advs)))))))
|
||||
(define (simple-gestalt is-adv? p level metalevel)
|
||||
(define m (pattern->matcher (prepend level #f (list #t)) p))
|
||||
(gestalt (prepend metalevel '(#f . #f) (list (if is-adv? (cons #f m) (cons m #f))))))
|
||||
|
||||
(define (gestalt-empty) (gestalt '()))
|
||||
|
||||
(define (gestalt-empty? g)
|
||||
(andmap (lambda (ls) (andmap (lambda (l) (and (matcher-empty? (car l)) (matcher-empty? (cdr l)))) ls))
|
||||
(andmap (lambda (ml) (and (matcher-empty? (car ml)) (matcher-empty? (cdr ml))))
|
||||
(gestalt-metalevels g)))
|
||||
|
||||
(define (map-zip imbalance-handler item-handler right-unit ls1 ls2)
|
||||
(define (map-zip imbalance-handler item-handler gcons ls1 ls2)
|
||||
(let walk ((ls1 ls1) (ls2 ls2))
|
||||
(match* (ls1 ls2)
|
||||
[('() '()) '()]
|
||||
[('() ls) (imbalance-handler 'right-longer ls)]
|
||||
[(ls '()) (imbalance-handler 'left-longer ls)]
|
||||
[((cons l1 ls1) (cons l2 ls2))
|
||||
(define new-item (item-handler l1 l2))
|
||||
(define new-tail (walk ls1 ls2))
|
||||
(if (and (null? new-tail) (equal? new-item right-unit))
|
||||
'()
|
||||
(cons new-item new-tail))])))
|
||||
(gcons (item-handler l1 l2) (walk ls1 ls2))])))
|
||||
|
||||
(define (gestalt-combine g1 g2 imbalance-handler matcher-pair-combiner)
|
||||
(define (yu ls1 ls2) (map-zip imbalance-handler matcher-pair-combiner '(#f . #f) ls1 ls2))
|
||||
(define (xu mls1 mls2) (map-zip imbalance-handler yu '() mls1 mls2))
|
||||
(gestalt (xu (gestalt-metalevels g1)
|
||||
(gestalt-metalevels g2))))
|
||||
(gestalt (map-zip imbalance-handler matcher-pair-combiner cons-metalevel
|
||||
(gestalt-metalevels g1)
|
||||
(gestalt-metalevels g2))))
|
||||
|
||||
(define (gestalt-combine-straight g1 g2 imbalance-handler matcher-combiner)
|
||||
(gestalt-combine g1 g2
|
||||
|
|
@ -128,9 +148,19 @@
|
|||
(cons (matcher-combiner (car sa1) (cdr sa2))
|
||||
(matcher-combiner (car sa2) (cdr sa1))))))
|
||||
|
||||
(define (gestalt-union1 g1 g2) (gestalt-combine-straight g1 g2
|
||||
(lambda (side x) x)
|
||||
matcher-union))
|
||||
(define (empty->false s) (if (set-empty? s) #f s))
|
||||
|
||||
(define (union-levels m1 m2)
|
||||
(matcher-union m1 m2
|
||||
#:combine
|
||||
(lambda (ls1 ls2)
|
||||
(map-zip (lambda (side x) x)
|
||||
(lambda (s1 s2) (empty->false (set-union (or s1 (set)) (or s2 (set)))))
|
||||
cons-level
|
||||
ls1
|
||||
ls2))))
|
||||
|
||||
(define (gestalt-union1 g1 g2) (gestalt-combine-straight g1 g2 (lambda (side x) x) union-levels))
|
||||
|
||||
(define (gestalt-union . gs)
|
||||
(if (null? gs)
|
||||
|
|
@ -140,62 +170,103 @@
|
|||
[(list g) g]
|
||||
[(cons g rest) (gestalt-union1 g (walk rest))]))))
|
||||
|
||||
(define (filter-levels ls1 ls2)
|
||||
(define r (safe-take cons-level ls1 (- (length ls2) 1)))
|
||||
(if (null? r) #f r))
|
||||
(define (filter-matchers m1 m2) (matcher-intersect m1 m2 #:combine filter-levels))
|
||||
|
||||
;; View on g1 from g2's perspective.
|
||||
;; Drops a level from g2 and intersects crossed.
|
||||
(define (gestalt-filter g1 g2)
|
||||
(gestalt-combine-crossed g1
|
||||
(gestalt (map safe-cdr (gestalt-metalevels g2)))
|
||||
(lambda (side x) '())
|
||||
(lambda (g1 g2) (matcher-intersect g1 g2
|
||||
#:combine (lambda (v1 v2) v1)))))
|
||||
(gestalt-combine-crossed g1 g2 (lambda (side x) '()) filter-matchers))
|
||||
|
||||
;; Here we want all pids in sets in ls2 such that there are some pids
|
||||
;; at lower levels in ls1.
|
||||
(define (match-combine-levels ls1 ls2 acc)
|
||||
(let loop ((ls1 ls1) (ls2 ls2))
|
||||
(cond
|
||||
[(null? ls1) acc]
|
||||
[(null? ls2) acc]
|
||||
[(not (car ls1)) (loop (cdr ls1) (cdr ls2))]
|
||||
[else ;; aha! here's a real sub/adv in ls1. The remaining
|
||||
;; sub/advs in (cdr ls2) can see it.
|
||||
(levels->pids (cdr ls2))])))
|
||||
|
||||
;; Much like gestalt-filter, takes a view on gestalt g1 from g2's
|
||||
;; perspective. However, instead of returning the filtered g1, returns
|
||||
;; just the set of values in the g2-map that were overlapped by some
|
||||
;; part of g1.
|
||||
(define (gestalt-match g1 g2)
|
||||
(define (zu sa1 sa2)
|
||||
(define-values (a1 a2) (matcher-match-matcher (car sa1) (car sa2)))
|
||||
(define-values (d1 d2) (matcher-match-matcher (cdr sa1) (cdr sa2)))
|
||||
(values (set-union a1 d1) (set-union a2 d2)))
|
||||
(define (mz xs1 xs2 f)
|
||||
(match* (xs1 xs2)
|
||||
[('() xs) (values (set) (set))]
|
||||
[(xs '()) (values (set) (set))]
|
||||
[((cons x1 xs1) (cons x2 xs2))
|
||||
(define-values (r1 r2) (mz xs1 xs2 f))
|
||||
(define-values (v1 v2) (f x1 x2))
|
||||
(values (set-union v1 r1) (set-union v2 r2))]))
|
||||
(define (yu ls1 ls2) (mz ls1 ls2 zu))
|
||||
(define (xu mls1 mls2) (mz mls1 mls2 yu))
|
||||
(xu (gestalt-metalevels g1)
|
||||
(gestalt-metalevels g2)))
|
||||
(let loop ((mls1 (gestalt-metalevels g1))
|
||||
(mls2 (gestalt-metalevels g2)))
|
||||
(cond [(null? mls1) (set)]
|
||||
[(null? mls2) (set)]
|
||||
[else (match-define (cons subs1 advs1) (car mls1))
|
||||
(match-define (cons subs2 advs2) (car mls2))
|
||||
(let* ((acc (loop (cdr mls1) (cdr mls2)))
|
||||
(acc (matcher-match-matcher subs1 advs2
|
||||
#:combine match-combine-levels
|
||||
#:empty acc))
|
||||
(acc (matcher-match-matcher advs1 subs2
|
||||
#:combine match-combine-levels
|
||||
#:empty acc)))
|
||||
acc)])))
|
||||
|
||||
(define (erase-imbalance-handler side x)
|
||||
(case side
|
||||
[(left-longer) x]
|
||||
[(right-longer) '()]))
|
||||
|
||||
(define (erase-levels ls1 ls2)
|
||||
(map-zip erase-imbalance-handler
|
||||
(lambda (v1 v2) (empty->false (set-subtract (or v1 (set)) (or v2 (set)))))
|
||||
cons-level
|
||||
ls1
|
||||
ls2))
|
||||
|
||||
(define (gestalt-erase-path g1 g2)
|
||||
(gestalt-combine-straight g1 g2
|
||||
erase-imbalance-handler
|
||||
(lambda (m1 m2) (matcher-erase-path m1 m2 #:combine erase-levels))))
|
||||
|
||||
(define ((guarded-map gcons) f xs)
|
||||
(foldr (lambda (e acc) (gcons (f e) acc)) '() xs))
|
||||
|
||||
(define map-metalevels (guarded-map cons-metalevel))
|
||||
|
||||
(define (gestalt-matcher-transform g f)
|
||||
(define (zu sa) (cons (f (car sa)) (f (cdr sa))))
|
||||
(define (yu ls) (map zu ls))
|
||||
(define (xu mls) (map yu mls))
|
||||
(gestalt (xu (gestalt-metalevels g))))
|
||||
(gestalt (map-metalevels (lambda (p) (cons (f (car p)) (f (cdr p))))
|
||||
(gestalt-metalevels g))))
|
||||
|
||||
(define (strip-gestalt-label g)
|
||||
(gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (old) (set #t))))))
|
||||
(define (xform ls) (map (lambda (l) (and l #t)) ls))
|
||||
(gestalt-matcher-transform g (lambda (m) (matcher-relabel m xform))))
|
||||
|
||||
(define (label-gestalt g pid)
|
||||
(gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (old) (set pid))))))
|
||||
(define pidset (set pid))
|
||||
(define (xform ls) (map (lambda (l) (and l pidset)) ls))
|
||||
(gestalt-matcher-transform g (lambda (m) (matcher-relabel m xform))))
|
||||
|
||||
(define (pretty-print-gestalt g [port (current-output-port)])
|
||||
(for [(metalevel (in-naturals)) (ls (in-list (gestalt-metalevels g)))]
|
||||
(for [(level (in-naturals)) (l (in-list ls))]
|
||||
(match-define (cons subs advs) l)
|
||||
(when (or subs advs)
|
||||
(fprintf port "GESTALT metalevel ~v level ~v:\n" metalevel level)
|
||||
(when subs (fprintf port " - subs:") (pretty-print-matcher subs port #:indent 9))
|
||||
(when advs (fprintf port " - advs:") (pretty-print-matcher advs port #:indent 9))))))
|
||||
(for [(metalevel (in-naturals)) (p (in-list (gestalt-metalevels g)))]
|
||||
(match-define (cons subs advs) p)
|
||||
(when (or subs advs)
|
||||
(fprintf port "GESTALT metalevel ~v:\n" metalevel)
|
||||
(when subs (fprintf port " - subs:") (pretty-print-matcher subs port #:indent 9))
|
||||
(when advs (fprintf port " - advs:") (pretty-print-matcher advs port #:indent 9)))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
|
||||
(check-equal? (simple-gestalt 'a 'b 0 0)
|
||||
(gestalt (list (list (cons 'a 'b)))))
|
||||
(check-equal? (simple-gestalt 'a 'b 2 2)
|
||||
(gestalt (list '() '() (list '(#f . #f)
|
||||
'(#f . #f)
|
||||
(cons 'a 'b))))))
|
||||
(check-equal? (gestalt-union (simple-gestalt #f 'a 0 0)
|
||||
(simple-gestalt #t 'b 0 0))
|
||||
(gestalt (list (cons (pattern->matcher (list #t) 'a)
|
||||
(pattern->matcher (list #t) 'b)))))
|
||||
(check-equal? (gestalt-union (simple-gestalt #f 'a 2 2)
|
||||
(simple-gestalt #t 'b 2 2))
|
||||
(gestalt (list (cons #f #f)
|
||||
(cons #f #f)
|
||||
(cons (pattern->matcher (list #f #f #t) 'a)
|
||||
(pattern->matcher (list #f #f #t) 'b))))))
|
||||
|
|
|
|||
|
|
@ -16,7 +16,8 @@
|
|||
(define event-projection (compile-gestalt-projection (event ?! ?)))
|
||||
|
||||
(define (extract-active-events gestalt)
|
||||
(define es (gestalt-project-key-set gestalt 0 0 #f event-projection))
|
||||
(define es
|
||||
(matcher-key-set (matcher-project-level (gestalt-project gestalt 0 #f event-projection) 0)))
|
||||
;; 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
|
||||
|
|
|
|||
|
|
@ -347,63 +347,57 @@
|
|||
[k (walk rest stack k)])])]))))
|
||||
|
||||
(define (matcher-match-matcher re1 re2
|
||||
#:combine [combine-successes set-union]
|
||||
#:empty [result-nil (set)])
|
||||
#:combine [combine-successes (lambda (v1 v2 a)
|
||||
(cons (set-union (car a) v1)
|
||||
(set-union (cdr a) v2)))]
|
||||
#:empty [result-nil (cons (set) (set))])
|
||||
(let ()
|
||||
(define (walk re1 re2 acc1 acc2)
|
||||
(define (walk re1 re2 acc)
|
||||
(match* (re1 re2)
|
||||
[((wildcard-sequence r1) (wildcard-sequence r2)) (walk r1 r2 acc1 acc2)]
|
||||
[((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc1 acc2)]
|
||||
[(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc1 acc2)]
|
||||
[((success v1) (success v2)) (values (combine-successes acc1 v1)
|
||||
(combine-successes acc2 v2))]
|
||||
[((wildcard-sequence r1) (wildcard-sequence r2)) (walk r1 r2 acc)]
|
||||
[((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc)]
|
||||
[(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc)]
|
||||
[((success v1) (success v2)) (combine-successes v1 v2 acc)]
|
||||
[((? hash? h1) (? hash? h2))
|
||||
(define w1 (rlookup h1 ?))
|
||||
(define w2 (rlookup h2 ?))
|
||||
(define-values (r1 r2) (if (and w1 w2)
|
||||
(walk w1 w2 acc1 acc2)
|
||||
(values acc1 acc2)))
|
||||
(define (examine-key r1 r2 key)
|
||||
(define r (if (and w1 w2)
|
||||
(walk w1 w2 acc)
|
||||
acc))
|
||||
(define (examine-key r key)
|
||||
(match* ((rlookup h1 key) (rlookup h2 key))
|
||||
[(#f #f) (values r1 r2)]
|
||||
[(#f k2)
|
||||
(define-values (rr1 rr2) (walk-wild w1 key k2 r1 r2))
|
||||
(values rr1 rr2)]
|
||||
[(k1 #f)
|
||||
(define-values (rr2 rr1) (walk-wild w2 key k1 r2 r1))
|
||||
(values rr1 rr2)]
|
||||
[(k1 k2) (walk k1 k2 r1 r2)]))
|
||||
[(#f #f) r]
|
||||
[(#f k2) (walk-wild walk w1 key k2 r)]
|
||||
[(k1 #f) (walk-wild (lambda (re2 re1 acc) (walk re1 re2 acc)) w2 key k1 r)]
|
||||
[(k1 k2) (walk k1 k2 r)]))
|
||||
;; We optimize as described in matcher-intersect.
|
||||
(match* (w1 w2)
|
||||
[(#f #f) (for/fold [(r1 r1) (r2 r2)] [(key (in-hash-keys (smaller-hash h1 h2)))]
|
||||
(examine-key r1 r2 key))]
|
||||
[(#f _) (for/fold [(r1 r1) (r2 r2)] [(key (in-hash-keys h1))] (examine-key r1 r2 key))]
|
||||
[(_ #f) (for/fold [(r1 r1) (r2 r2)] [(key (in-hash-keys h2))] (examine-key r1 r2 key))]
|
||||
[(_ _) (for/fold [(r1 r1) (r2 r2)] [(key (set-remove (set-union (hash-keys h1)
|
||||
(hash-keys h2))
|
||||
?))]
|
||||
(examine-key r1 r2 key))])]))
|
||||
(define (walk-wild w key k acc1 acc2)
|
||||
[(#f #f) (for/fold [(r r)] [(key (in-hash-keys (smaller-hash h1 h2)))] (examine-key r key))]
|
||||
[(#f _) (for/fold [(r r)] [(key (in-hash-keys h1))] (examine-key r key))]
|
||||
[(_ #f) (for/fold [(r r)] [(key (in-hash-keys h2))] (examine-key r key))]
|
||||
[(_ _) (for/fold [(r r)] [(key (set-remove (set-union (hash-keys h1) (hash-keys h2)) ?))]
|
||||
(examine-key r key))])]))
|
||||
(define (walk-wild walker w key k acc)
|
||||
(if w
|
||||
(cond
|
||||
[(key-open? key) (walk (rwildseq w) k acc1 acc2)]
|
||||
[(key-open? key) (walker (rwildseq w) k acc)]
|
||||
[(key-close? key) (if (wildcard-sequence? w)
|
||||
(walk (wildcard-sequence-matcher w) k acc1 acc2)
|
||||
(values acc1 acc2))]
|
||||
[else (walk w k acc1 acc2)])
|
||||
(values acc1 acc2)))
|
||||
(walker (wildcard-sequence-matcher w) k acc)
|
||||
acc)]
|
||||
[else (walker w k acc)])
|
||||
acc))
|
||||
(match* (re1 re2)
|
||||
[(#f r) (values result-nil result-nil)]
|
||||
[(r #f) (values result-nil result-nil)]
|
||||
[(r1 r2) (walk r1 r2 result-nil result-nil)])))
|
||||
[(#f r) result-nil]
|
||||
[(r #f) result-nil]
|
||||
[(r1 r2) (walk r1 r2 result-nil)])))
|
||||
|
||||
(define (matcher-relabel m f)
|
||||
(let walk ((m m))
|
||||
(match m
|
||||
[#f #f]
|
||||
[(success v) (success (f v))]
|
||||
[(wildcard-sequence m1) (wildcard-sequence (walk m1))]
|
||||
[(? hash?) (for/hash [((k v) (in-hash m))] (values k (walk v)))])))
|
||||
[(success v) (rsuccess (f v))]
|
||||
[(wildcard-sequence m1) (rwildseq (walk m1))]
|
||||
[(? hash?) (for/fold [(acc #f)] [((k v) (in-hash m))] (rupdate acc k (walk v)))])))
|
||||
|
||||
(define (compile-projection p)
|
||||
;; Extremely similar to pattern->matcher. Besides use of conses
|
||||
|
|
@ -928,7 +922,7 @@
|
|||
|
||||
(module+ test
|
||||
(define (matcher-match-matcher-list m1 m2)
|
||||
(define-values (s1 s2) (matcher-match-matcher m1 m2))
|
||||
(match-define (cons s1 s2) (matcher-match-matcher m1 m2))
|
||||
(list s1 s2))
|
||||
(let ((abc (foldr matcher-union (matcher-empty)
|
||||
(list (pattern->matcher SA (list 'a ?))
|
||||
|
|
@ -940,6 +934,10 @@
|
|||
(pattern->matcher SD (list 'd ?))))))
|
||||
(check-equal? (matcher-match-matcher-list abc abc)
|
||||
(list (set 'A 'B 'C) (set 'A 'B 'C)))
|
||||
(check-equal? (matcher-match-matcher abc abc
|
||||
#:combine (lambda (v1 v2 a) (set-union v2 a))
|
||||
#:empty (set))
|
||||
(set 'A 'B 'C))
|
||||
(check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (set #t))))
|
||||
(list (set 'B 'C) (set #t)))
|
||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo ?))
|
||||
|
|
|
|||
Loading…
Reference in New Issue