First commit switching from sets to tsets for labels in RHSs of matchers.
This commit is contained in:
Tony Garnock-Jones
parent
1ff931eb80
commit
457d53fc54
|
|
@ -8,6 +8,7 @@
|
|||
(require "gestalt.rkt")
|
||||
(require "functional-queue.rkt")
|
||||
(require "trace.rkt")
|
||||
(require "tset.rkt")
|
||||
|
||||
(provide (struct-out routing-update)
|
||||
(struct-out message)
|
||||
|
|
@ -462,12 +463,12 @@
|
|||
[(message body meta-level feedback?)
|
||||
(define pids (gestalt-match-value (world-partial-gestalt w) body meta-level feedback?))
|
||||
(define pt (world-process-table w))
|
||||
(for/fold ([w w]) [(pid (in-set pids))] (step-process e pid (hash-ref pt pid) w))]
|
||||
(for/fold ([w w]) [(pid (in-list (tset->list pids)))] (step-process e pid (hash-ref pt pid) w))]
|
||||
[(pending-routing-update g affected-subgestalt known-target)
|
||||
(define affected-pids (gestalt-match affected-subgestalt g))
|
||||
(define pt (world-process-table w))
|
||||
(for/fold ([w w])
|
||||
[(pid (in-set (if known-target (set-add affected-pids known-target) affected-pids)))]
|
||||
[(pid (in-list (tset->list (if known-target (tset-add affected-pids known-target) affected-pids))))]
|
||||
(match (hash-ref pt pid (lambda () #f))
|
||||
[#f w]
|
||||
[p (step-process (routing-update (gestalt-filter g (process-gestalt p))) pid p w)]))]))
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@
|
|||
(require (only-in racket/port with-output-to-string))
|
||||
|
||||
(require "route.rkt")
|
||||
(require "tset.rkt")
|
||||
|
||||
(provide (struct-out gestalt)
|
||||
(struct-out projection)
|
||||
|
|
@ -139,7 +140,7 @@
|
|||
(define (gestalt-match-value g body metalevel is-feedback?)
|
||||
(define extract-matcher (if is-feedback? cdr car)) ;; feedback targets advertisers/publishers
|
||||
(define (pids-at level) (matcher-match-value (extract-matcher level) body))
|
||||
(apply set-union (set) (map pids-at (gestalt-metalevel-ref g metalevel))))
|
||||
(foldr tset-union (datum-tset) (map pids-at (gestalt-metalevel-ref g metalevel))))
|
||||
|
||||
;; project-subs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
|
||||
;; project-pubs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
|
||||
|
|
@ -365,14 +366,14 @@
|
|||
(match ls2
|
||||
['() acc]
|
||||
[(cons (cons subs2 advs2) lrest2)
|
||||
(loop lrest2 (set-union (matcher-match-matcher subs1 advs2)
|
||||
(matcher-match-matcher advs1 subs2)
|
||||
acc))])))
|
||||
(loop lrest2 (tset-union (tset-union (matcher-match-matcher subs1 advs2)
|
||||
(matcher-match-matcher advs1 subs2))
|
||||
acc))])))
|
||||
|
||||
(lambda (g1 g2)
|
||||
(parameterize ((matcher-match-matcher-successes (lambda (v1 v2 acc) (set-union v2 acc)))
|
||||
(matcher-match-matcher-unit (set)))
|
||||
(match-metalevels (gestalt-metalevels g1) (gestalt-metalevels g2) (set))))))
|
||||
(parameterize ((matcher-match-matcher-successes (lambda (v1 v2 acc) (tset-union v2 acc)))
|
||||
(matcher-match-matcher-unit (datum-tset)))
|
||||
(match-metalevels (gestalt-metalevels g1) (gestalt-metalevels g2) (datum-tset))))))
|
||||
|
||||
;; Gestalt Gestalt -> Gestalt
|
||||
;; Erases the g2-subset of g1 from g1, yielding the result.
|
||||
|
|
@ -414,7 +415,7 @@
|
|||
;; GestaltSet -> Gestalt
|
||||
;; Relabels g so that all matched keys map to (set pid).
|
||||
(define (label-gestalt g pid)
|
||||
(define pidset (set pid))
|
||||
(define pidset (datum-tset pid))
|
||||
(gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (v) pidset)))))
|
||||
|
||||
;; Gestalt Nat -> Nat
|
||||
|
|
|
|||
|
|
@ -57,6 +57,7 @@
|
|||
(require (only-in racket/class object?))
|
||||
(require "canonicalize.rkt")
|
||||
(require "treap.rkt")
|
||||
(require "tset.rkt")
|
||||
(require data/order)
|
||||
|
||||
(require rackunit)
|
||||
|
|
@ -71,23 +72,23 @@
|
|||
(match* (v1 v2)
|
||||
[(#t v) v]
|
||||
[(v #t) v]
|
||||
[(v1 v2) (set-union v1 v2)]))))
|
||||
[(v1 v2) (tset-union v1 v2)]))))
|
||||
|
||||
(define matcher-intersect-successes (make-parameter set-union))
|
||||
(define matcher-intersect-successes (make-parameter tset-union))
|
||||
|
||||
(define matcher-subtract-successes
|
||||
(make-parameter
|
||||
(lambda (s1 s2)
|
||||
(define r (set-subtract s1 s2))
|
||||
(if (set-empty? r) #f r))))
|
||||
(define r (tset-subtract s1 s2))
|
||||
(if (tset-empty? r) #f r))))
|
||||
|
||||
(define matcher-match-matcher-successes
|
||||
(make-parameter
|
||||
(lambda (v1 v2 a)
|
||||
(cons (set-union (car a) v1)
|
||||
(set-union (cdr a) v2)))))
|
||||
(cons (tset-union (car a) v1)
|
||||
(tset-union (cdr a) v2)))))
|
||||
|
||||
(define matcher-match-matcher-unit (make-parameter (cons (set) (set))))
|
||||
(define matcher-match-matcher-unit (make-parameter (cons (datum-tset) (datum-tset))))
|
||||
|
||||
;; The project-success function should return #f to signal "no success values".
|
||||
(define matcher-project-success (make-parameter values))
|
||||
|
|
@ -493,7 +494,7 @@
|
|||
;; Sigmas and runs them through the Matcher r. If v leads to a success
|
||||
;; Matcher, returns the values contained in the success Matcher;
|
||||
;; otherwise, returns failure-result.
|
||||
(define (matcher-match-value r v [failure-result (set)])
|
||||
(define (matcher-match-value r v [failure-result (datum-tset)])
|
||||
(let walk ((vs (list v)) (stack '(())) (r r))
|
||||
(match r
|
||||
[#f failure-result]
|
||||
|
|
@ -805,7 +806,7 @@
|
|||
(walk (+ i 5) k)]
|
||||
[(success vs)
|
||||
(d "{")
|
||||
(d vs)
|
||||
(d (if (tset? vs) (cons 'tset (tset->list vs)) vs))
|
||||
(d "}")]
|
||||
[(? treap? h)
|
||||
(if (zero? (treap-size h))
|
||||
|
|
@ -897,13 +898,15 @@
|
|||
(module+ test
|
||||
(require racket/pretty)
|
||||
|
||||
(define SA (set 'A))
|
||||
(define SB (set 'B))
|
||||
(define SC (set 'C))
|
||||
(define SD (set 'D))
|
||||
(define Sfoo (set 'foo))
|
||||
(define S+ (set '+))
|
||||
(define SX (set 'X))
|
||||
(define tset datum-tset)
|
||||
|
||||
(define SA (tset 'A))
|
||||
(define SB (tset 'B))
|
||||
(define SC (tset 'C))
|
||||
(define SD (tset 'D))
|
||||
(define Sfoo (tset 'foo))
|
||||
(define S+ (tset '+))
|
||||
(define SX (tset 'X))
|
||||
(define (E v) (rseq EOS (rsuccess v)))
|
||||
(check-equal? (pattern->matcher SA 123) (rseq 123 (E SA)))
|
||||
(check-equal? (pattern->matcher SA (cons 1 2))
|
||||
|
|
@ -925,7 +928,7 @@
|
|||
(define actualset (matcher-match-value matcher message))
|
||||
(printf "~v ==> ~v\n" message actualset)
|
||||
(check-equal? actualset
|
||||
(apply set (map (lambda (c) (string->symbol (string c)))
|
||||
(apply tset (map (lambda (c) (string->symbol (string c)))
|
||||
(string->list expectedstr))))
|
||||
(walk rest)])))
|
||||
|
||||
|
|
@ -991,7 +994,7 @@
|
|||
(void (pretty-print-matcher* (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
|
||||
;; Note: this is a largely nonsense matcher,
|
||||
;; since it expects no input at all
|
||||
(rseq EOS (rsuccess (set 'B))))))
|
||||
(rseq EOS (rsuccess (tset 'B))))))
|
||||
|
||||
(check-matches
|
||||
(pretty-print-matcher*
|
||||
|
|
@ -1031,7 +1034,7 @@
|
|||
(define ps
|
||||
(for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")))
|
||||
(define csym (string->symbol (string c)))
|
||||
(pattern->matcher (set csym) (list csym ?))))
|
||||
(pattern->matcher (tset csym) (list csym ?))))
|
||||
(matcher-union (foldr matcher-union (matcher-empty) ps)
|
||||
(pattern->matcher S+ (list 'Z (list ? '- ?)))))
|
||||
|
||||
|
|
@ -1198,7 +1201,7 @@
|
|||
(matcher-intersect (pattern->matcher SA a)
|
||||
(pattern->matcher SB b)))
|
||||
|
||||
(define EAB (E (set 'A 'B)))
|
||||
(define EAB (E (tset 'A 'B)))
|
||||
|
||||
(define (rseq* x . xs)
|
||||
(let walk ((xs (cons x xs)))
|
||||
|
|
@ -1253,9 +1256,9 @@
|
|||
(define m2 (pretty-print-matcher* (pattern->matcher SD ?)))
|
||||
(define mi (pretty-print-matcher* (matcher-intersect m1 m2)))
|
||||
(check-requal? mi
|
||||
(H SOL (H 'a (H ? (H EOS (E (set 'A 'D))))
|
||||
'b (H ? (H EOS (E (set 'B 'D)))
|
||||
'c (H EOS (E (set 'B 'C 'D)))))))
|
||||
(H SOL (H 'a (H ? (H EOS (E (tset 'A 'D))))
|
||||
'b (H ? (H EOS (E (tset 'B 'D)))
|
||||
'c (H EOS (E (tset 'B 'C 'D)))))))
|
||||
(check-requal? (pretty-print-matcher*
|
||||
(parameterize ((matcher-intersect-successes (lambda (v1 v2) v1)))
|
||||
(matcher-intersect m1 m2)))
|
||||
|
|
@ -1275,22 +1278,22 @@
|
|||
(pattern->matcher SC (list 'c ?))
|
||||
(pattern->matcher SD (list 'd ?))))))
|
||||
(check-equal? (matcher-match-matcher-list abc abc)
|
||||
(list (set 'A 'B 'C) (set 'A 'B 'C)))
|
||||
(list (tset 'A 'B 'C) (tset 'A 'B 'C)))
|
||||
(check-equal? (parameterize ((matcher-match-matcher-successes (lambda (v1 v2 a)
|
||||
(set-union v2 a)))
|
||||
(matcher-match-matcher-unit (set)))
|
||||
(tset-union v2 a)))
|
||||
(matcher-match-matcher-unit (tset)))
|
||||
(matcher-match-matcher abc abc))
|
||||
(set 'A 'B 'C))
|
||||
(check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (set #t))))
|
||||
(list (set 'B 'C) (set #t)))
|
||||
(tset 'A 'B 'C))
|
||||
(check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (tset #t))))
|
||||
(list (tset 'B 'C) (tset #t)))
|
||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo ?))
|
||||
(list (set 'A 'B 'C) (set 'foo)))
|
||||
(list (tset 'A 'B 'C) (tset 'foo)))
|
||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? ?)))
|
||||
(list (set 'A 'B 'C) (set 'foo)))
|
||||
(list (tset 'A 'B 'C) (tset 'foo)))
|
||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x)))
|
||||
(list (set 'A 'B 'C) (set 'foo)))
|
||||
(list (tset 'A 'B 'C) (tset 'foo)))
|
||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x ?)))
|
||||
(list (set) (set)))))
|
||||
(list (tset) (tset)))))
|
||||
|
||||
(module+ test
|
||||
(check-equal? (compile-projection (cons 'a 'b))
|
||||
|
|
@ -1460,14 +1463,14 @@
|
|||
(pattern->matcher SB (list 3 4)))))
|
||||
(S '((("(")
|
||||
((1 ((2 (((")") (((")") ("" ("A")))))))
|
||||
(3 (((")") (((")") ("" ("D" "C")))))))))
|
||||
(3 (((")") (((")") ("" ("C" "D")))))))))
|
||||
(3 ((2 (((")") (((")") ("" ("A")))))))
|
||||
(3 (((")") (((")") ("" ("D")))))))
|
||||
(4 (((")") (((")") ("" ("B")))))))))
|
||||
(("__") ((2 (((")") (((")") ("" ("A")))))))
|
||||
(3 (((")") (((")") ("" ("D"))))))))))))))
|
||||
(check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (set->list v)))) S)
|
||||
(check-requal? (jsexpr->matcher S (lambda (v) (list->set (map string->symbol v)))) M)))
|
||||
(check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (tset->list v)))) S)
|
||||
(check-requal? (jsexpr->matcher S (lambda (v) (make-tset datum-order (map string->symbol v)))) M)))
|
||||
|
||||
(module+ test
|
||||
(check-requal? (pretty-print-matcher*
|
||||
|
|
|
|||
|
|
@ -8,14 +8,17 @@
|
|||
;; Further, we explicitly canonicalize N instances, so eq? works to compare treaps by value.
|
||||
|
||||
(provide treap?
|
||||
treap-order
|
||||
treap-size
|
||||
treap-empty
|
||||
treap-empty?
|
||||
treap->empty
|
||||
treap-insert
|
||||
treap-delete
|
||||
treap-get
|
||||
treap-keys
|
||||
treap-values
|
||||
treap-fold
|
||||
treap-to-alist
|
||||
treap-has-key?
|
||||
|
||||
|
|
@ -63,6 +66,8 @@
|
|||
|
||||
(define (treap-empty? t) (zero? (treap-size t)))
|
||||
|
||||
(define (treap->empty t) (treap-empty (treap-order t)))
|
||||
|
||||
(define (default-priority key)
|
||||
;; Loosely based on a restriction of murmur32 v3
|
||||
(define c1 #xcc9e2d51)
|
||||
|
|
@ -185,6 +190,12 @@
|
|||
[(L) acc]
|
||||
[(N k _ _ left right) (walk left (cons k (walk right acc)))])))
|
||||
|
||||
(define (treap-fold t f seed)
|
||||
(let walk ((n (treap-root t)) (acc seed))
|
||||
(match n
|
||||
[(L) acc]
|
||||
[(N k v _ left right) (walk left (f (walk right acc) k v))])))
|
||||
|
||||
(define (treap-to-alist t)
|
||||
(let walk ((n (treap-root t)) (acc '()))
|
||||
(match n
|
||||
|
|
|
|||
|
|
@ -0,0 +1,96 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "treap.rkt")
|
||||
|
||||
(provide tset?
|
||||
datum-tset
|
||||
make-tset
|
||||
tset-count
|
||||
tset-empty
|
||||
tset-empty?
|
||||
tset-add
|
||||
tset-remove
|
||||
tset-union
|
||||
tset-intersect
|
||||
tset-subtract
|
||||
tset->list
|
||||
tset-member?
|
||||
)
|
||||
|
||||
(require data/order)
|
||||
|
||||
(define (tset? t)
|
||||
(treap? t))
|
||||
|
||||
(define (datum-tset . elts)
|
||||
(make-tset datum-order elts))
|
||||
|
||||
(define (make-tset o elts)
|
||||
(for/fold [(t (tset-empty o))] [(e elts)] (tset-add t e)))
|
||||
|
||||
(define (tset-count t)
|
||||
(treap-size t))
|
||||
|
||||
(define (tset-empty o)
|
||||
(treap-empty o))
|
||||
|
||||
(define (tset-empty? t)
|
||||
(treap-empty? t))
|
||||
|
||||
(define (tset-add t v)
|
||||
(treap-insert t v #t))
|
||||
|
||||
(define (tset-remove t v)
|
||||
(treap-delete t v))
|
||||
|
||||
(define (tset-union t1 t2)
|
||||
(if (< (treap-size t1) (treap-size t2))
|
||||
(treap-fold t1 treap-insert t2)
|
||||
(treap-fold t2 treap-insert t1)))
|
||||
|
||||
(define (tset-intersect t1 t2)
|
||||
(if (< (treap-size t1) (treap-size t2))
|
||||
(treap-fold t1
|
||||
(lambda (t k v) (if (treap-has-key? t2 k) (treap-insert t k v) t))
|
||||
(treap->empty t1))
|
||||
(treap-fold t2
|
||||
(lambda (t k v) (if (treap-has-key? t1 k) (treap-insert t k v) t))
|
||||
(treap->empty t2))))
|
||||
|
||||
(define (tset-subtract t1 t2)
|
||||
(if (< (treap-size t1) (treap-size t2))
|
||||
(treap-fold t1
|
||||
(lambda (t k v) (if (treap-has-key? t2 k) t (treap-insert t k v)))
|
||||
(treap->empty t1))
|
||||
(treap-fold t2
|
||||
(lambda (t k v) (treap-delete t k))
|
||||
t1)))
|
||||
|
||||
(define (tset->list t)
|
||||
(treap-fold t (lambda (acc k v) (cons k acc)) '()))
|
||||
|
||||
(define (tset-member? t k)
|
||||
(treap-has-key? t k))
|
||||
|
||||
(module+ test
|
||||
(require rackunit)
|
||||
(require data/order)
|
||||
(define (tset . elts) (make-tset datum-order elts))
|
||||
(check-equal? (tset->list (tset 1 2 3 4 5)) '(1 2 3 4 5))
|
||||
(check-equal? (tset->list (tset 5 4 3 2 1)) '(1 2 3 4 5))
|
||||
(check-equal? (tset->list (tset-union (tset 1 2 3) (tset 2 3 4))) '(1 2 3 4))
|
||||
(check-equal? (tset->list (tset-intersect (tset 1 2 3) (tset 2 3 4))) '(2 3))
|
||||
(check-equal? (tset->list (tset-subtract (tset 1 2 3) (tset 2 3 4))) '(1))
|
||||
(check-true (tset-member? (tset 1 2 3) 2))
|
||||
(check-false (tset-member? (tset 1 2 3) 4))
|
||||
(check-true (tset-empty? (tset)))
|
||||
(check-false (tset-empty? (tset 1)))
|
||||
(check-equal? (tset-count (tset 1 2 3)) 3)
|
||||
(check-equal? (tset-count (tset)) 0)
|
||||
(check-equal? (tset-count (tset-union (tset 1 2 3) (tset 2 3 4))) 4)
|
||||
(check-true (tset? (tset-empty datum-order)))
|
||||
(check-true (tset? (tset)))
|
||||
(check-false (tset? 123))
|
||||
(check-false (tset? (list 1 2 3)))
|
||||
(check-false (tset? 'a))
|
||||
)
|
||||
Loading…
Reference in New Issue