Compare commits
1 Commits
Author | SHA1 | Date |
---|---|---|
Tony Garnock-Jones | 97245973fa |
|
@ -0,0 +1,151 @@
|
||||||
|
#lang racket/base
|
||||||
|
;; Set of small integers stored in bytes.
|
||||||
|
|
||||||
|
(provide bitset
|
||||||
|
bitset?
|
||||||
|
list->bitset
|
||||||
|
bitset-count
|
||||||
|
bitset-empty
|
||||||
|
bitset-empty?
|
||||||
|
bitset-add
|
||||||
|
bitset-remove
|
||||||
|
bitset-union
|
||||||
|
bitset-intersect
|
||||||
|
bitset-subtract
|
||||||
|
bitset->list
|
||||||
|
bitset-member?
|
||||||
|
)
|
||||||
|
|
||||||
|
(require racket/performance-hint)
|
||||||
|
|
||||||
|
(define (bitset . vs)
|
||||||
|
(list->bitset vs))
|
||||||
|
|
||||||
|
(define (bitset? x)
|
||||||
|
(bytes? x))
|
||||||
|
|
||||||
|
(define (length-to-include v)
|
||||||
|
(define-values (y i) (quotient/remainder v 8))
|
||||||
|
(+ y 1))
|
||||||
|
|
||||||
|
(define (list->bitset vs)
|
||||||
|
(define limit (apply max 0 vs))
|
||||||
|
(foldr bitset-add!* (make-bytes (length-to-include limit)) vs))
|
||||||
|
|
||||||
|
;; Cribbed from data/bit-vector.rkt
|
||||||
|
(require (for-syntax racket/base
|
||||||
|
(only-in data/private/count-bits-in-fixnum fxpopcount)))
|
||||||
|
(define popcount-table
|
||||||
|
(let ()
|
||||||
|
(define-syntax (make-table stx)
|
||||||
|
(with-syntax ([(elt ...)
|
||||||
|
(for/list ([i (in-range 256)])
|
||||||
|
(fxpopcount i))])
|
||||||
|
;; Literal immutable vector allocated once (?)
|
||||||
|
#'(quote #(elt ...))))
|
||||||
|
(make-table)))
|
||||||
|
|
||||||
|
(require (only-in racket/unsafe/ops unsafe-vector-ref))
|
||||||
|
(define (bitset-count bs)
|
||||||
|
(for/sum [(b (in-bytes bs))]
|
||||||
|
(unsafe-vector-ref popcount-table b)))
|
||||||
|
|
||||||
|
(define (bitset-empty)
|
||||||
|
(bytes))
|
||||||
|
|
||||||
|
(define (bitset-empty? bs)
|
||||||
|
(for/and ((b (in-bytes bs))) (zero? b)))
|
||||||
|
|
||||||
|
(define (bitset-copy/extend bs v)
|
||||||
|
(define minsize (length-to-include v))
|
||||||
|
(if (>= (bytes-length bs) minsize)
|
||||||
|
(bytes-copy bs)
|
||||||
|
(let ((result (make-bytes minsize)))
|
||||||
|
(bytes-copy! result 0 bs)
|
||||||
|
result)))
|
||||||
|
|
||||||
|
(define (bitset-add bs v)
|
||||||
|
(bitset-add!* v (bitset-copy/extend bs v)))
|
||||||
|
|
||||||
|
(define (bitset-trim bs)
|
||||||
|
(define len (bytes-length bs))
|
||||||
|
(let loop ((y (- len 1)))
|
||||||
|
(cond
|
||||||
|
[(negative? y) (bytes)]
|
||||||
|
[(zero? (bytes-ref bs y)) (loop (- y 1))]
|
||||||
|
[(= y (- len 1)) bs]
|
||||||
|
[else (subbytes bs 0 (+ y 1))])))
|
||||||
|
|
||||||
|
(define (bitset-remove bs v)
|
||||||
|
(bitset-trim (bitset-remove! (bytes-copy bs) v)))
|
||||||
|
|
||||||
|
(define (bitset-for-merge bs1 bs2)
|
||||||
|
(make-bytes (max (bytes-length bs1) (bytes-length bs2))))
|
||||||
|
|
||||||
|
(define-inline (bitset-merge* bs bs-short bs-long combiner)
|
||||||
|
(for ((y (in-range (bytes-length bs-short))))
|
||||||
|
(bytes-set! bs y (combiner (bytes-ref bs-short y) (bytes-ref bs-long y))))
|
||||||
|
(for ((y (in-range (bytes-length bs-short) (bytes-length bs-long))))
|
||||||
|
(bytes-set! bs y (combiner 0 (bytes-ref bs-long y))))
|
||||||
|
bs)
|
||||||
|
|
||||||
|
(define-inline (bitset-merge bs1 bs2 combiner)
|
||||||
|
(define bs (bitset-for-merge bs1 bs2))
|
||||||
|
(if (< (bytes-length bs1) (bytes-length bs2))
|
||||||
|
(bitset-merge* bs bs1 bs2 combiner)
|
||||||
|
(bitset-merge* bs bs2 bs1 (lambda (b a) (combiner a b)))))
|
||||||
|
|
||||||
|
(define (bitset-union bs1 bs2) (bitset-merge bs1 bs2 bitwise-ior))
|
||||||
|
(define (bitset-intersect bs1 bs2) (bitset-trim (bitset-merge bs1 bs2 bitwise-and)))
|
||||||
|
(define (bitset-subtract bs1 bs2)
|
||||||
|
(bitset-trim (bitset-merge bs1 bs2 (lambda (a b) (bitwise-and a (bitwise-not b))))))
|
||||||
|
|
||||||
|
(define (bitset->list bs)
|
||||||
|
(for/fold [(acc '())]
|
||||||
|
[(b (in-bytes bs)) (byte-index (in-naturals))]
|
||||||
|
(if (zero? b)
|
||||||
|
acc
|
||||||
|
(for/fold [(acc acc)] [(bit-index (in-range 8))]
|
||||||
|
(if (bitwise-bit-set? b bit-index)
|
||||||
|
(cons (+ (* byte-index 8) bit-index) acc)
|
||||||
|
acc)))))
|
||||||
|
|
||||||
|
(define (bitset-member? bs v)
|
||||||
|
(define-values (y i) (quotient/remainder v 8))
|
||||||
|
(and (> (bytes-length bs) y)
|
||||||
|
(bitwise-bit-set? (bytes-ref bs y) i)))
|
||||||
|
|
||||||
|
(define (bitset-add!* v bs)
|
||||||
|
(define-values (y i) (quotient/remainder v 8))
|
||||||
|
(bytes-set! bs y (bitwise-ior (bytes-ref bs y) (arithmetic-shift 1 i)))
|
||||||
|
bs)
|
||||||
|
|
||||||
|
(define (bitset-remove! bs v)
|
||||||
|
(define-values (y i) (quotient/remainder v 8))
|
||||||
|
(bytes-set! bs y (bitwise-and (bytes-ref bs y) (bitwise-not (arithmetic-shift 1 i))))
|
||||||
|
bs)
|
||||||
|
|
||||||
|
(module+ test
|
||||||
|
(require rackunit)
|
||||||
|
(require racket/set)
|
||||||
|
(define-syntax-rule (check-set-equal? actual expected)
|
||||||
|
(check-equal? (list->set actual) (list->set expected)))
|
||||||
|
(check-set-equal? (bitset->list (bitset 1 2 3 4 5)) '(1 2 3 4 5))
|
||||||
|
(check-set-equal? (bitset->list (bitset 10 20 30 40 50)) '(10 20 30 40 50))
|
||||||
|
(check-set-equal? (bitset->list (bitset 5 4 3 2 1)) '(1 2 3 4 5))
|
||||||
|
(check-set-equal? (bitset->list (bitset-union (bitset 1 2 3) (bitset 2 3 4))) '(1 2 3 4))
|
||||||
|
(check-set-equal? (bitset->list (bitset-intersect (bitset 1 2 3) (bitset 2 3 4))) '(2 3))
|
||||||
|
(check-set-equal? (bitset->list (bitset-subtract (bitset 1 2 3) (bitset 2 3 4))) '(1))
|
||||||
|
(check-true (bitset-member? (bitset 1 2 3) 2))
|
||||||
|
(check-false (bitset-member? (bitset 1 2 3) 4))
|
||||||
|
(check-true (bitset-empty? (bitset)))
|
||||||
|
(check-false (bitset-empty? (bitset 1)))
|
||||||
|
(check-equal? (bitset-count (bitset 1 2 3)) 3)
|
||||||
|
(check-equal? (bitset-count (bitset)) 0)
|
||||||
|
(check-equal? (bitset-count (bitset-union (bitset 1 2 3) (bitset 2 3 4))) 4)
|
||||||
|
(check-true (bitset? (bitset-empty)))
|
||||||
|
(check-true (bitset? (bitset)))
|
||||||
|
(check-false (bitset? 123))
|
||||||
|
(check-false (bitset? (list 1 2 3)))
|
||||||
|
(check-false (bitset? 'a))
|
||||||
|
)
|
|
@ -30,8 +30,6 @@
|
||||||
event?
|
event?
|
||||||
action?
|
action?
|
||||||
|
|
||||||
meta-label?
|
|
||||||
|
|
||||||
prepend-at-meta
|
prepend-at-meta
|
||||||
assert
|
assert
|
||||||
retract
|
retract
|
||||||
|
@ -89,8 +87,8 @@
|
||||||
(struct transition (state actions) #:transparent)
|
(struct transition (state actions) #:transparent)
|
||||||
(struct quit (actions) #:prefab)
|
(struct quit (actions) #:prefab)
|
||||||
|
|
||||||
;; A PID is a Nat.
|
;; A PID is a non-zero Nat.
|
||||||
;; A Label is a PID or 'meta.
|
;; A Label is a PID or 0, representing meta.
|
||||||
|
|
||||||
;; VM private states
|
;; VM private states
|
||||||
(struct world (mux ;; Multiplexer
|
(struct world (mux ;; Multiplexer
|
||||||
|
@ -237,7 +235,7 @@
|
||||||
|
|
||||||
(define (make-world boot-actions)
|
(define (make-world boot-actions)
|
||||||
(world (mux)
|
(world (mux)
|
||||||
(list->queue (for/list ((a (in-list (clean-actions boot-actions)))) (cons 'meta a)))
|
(list->queue (for/list ((a (in-list (clean-actions boot-actions)))) (cons meta-label a)))
|
||||||
(set)
|
(set)
|
||||||
(hash)
|
(hash)
|
||||||
(hash)))
|
(hash)))
|
||||||
|
@ -276,8 +274,8 @@
|
||||||
(define ((inject-event e) w)
|
(define ((inject-event e) w)
|
||||||
(transition (match e
|
(transition (match e
|
||||||
[#f w]
|
[#f w]
|
||||||
[(? patch? delta) (enqueue-actions w 'meta (list (lift-patch delta)))]
|
[(? patch? delta) (enqueue-actions w meta-label (list (lift-patch delta)))]
|
||||||
[(message body) (enqueue-actions w 'meta (list (message (at-meta body))))])
|
[(message body) (enqueue-actions w meta-label (list (message (at-meta body))))])
|
||||||
'()))
|
'()))
|
||||||
|
|
||||||
(define (perform-actions w)
|
(define (perform-actions w)
|
||||||
|
@ -361,7 +359,8 @@
|
||||||
(fprintf p " - ~a live processes (~a with claims)\n"
|
(fprintf p " - ~a live processes (~a with claims)\n"
|
||||||
(hash-count states)
|
(hash-count states)
|
||||||
(hash-count (mux-interest-table mux)))
|
(hash-count (mux-interest-table mux)))
|
||||||
(fprintf p " - next pid: ~a\n" (mux-next-pid mux))
|
(fprintf p " - stream count: ~a\n" (mux-stream-count mux))
|
||||||
|
(fprintf p " - free pids: ~a\n" (mux-free-pids mux))
|
||||||
(fprintf p " - routing table:\n")
|
(fprintf p " - routing table:\n")
|
||||||
(pretty-print-matcher (mux-routing-table mux) p)
|
(pretty-print-matcher (mux-routing-table mux) p)
|
||||||
(for ([pid (set-union (hash-keys (mux-interest-table mux)) (hash-keys states))])
|
(for ([pid (set-union (hash-keys (mux-interest-table mux)) (hash-keys states))])
|
||||||
|
|
|
@ -8,7 +8,7 @@
|
||||||
(require "core.rkt")
|
(require "core.rkt")
|
||||||
(require "trace.rkt")
|
(require "trace.rkt")
|
||||||
(require "trace/stderr.rkt")
|
(require "trace/stderr.rkt")
|
||||||
(require "tset.rkt")
|
(require "bitset.rkt")
|
||||||
|
|
||||||
(provide (struct-out external-event)
|
(provide (struct-out external-event)
|
||||||
send-ground-message
|
send-ground-message
|
||||||
|
@ -92,7 +92,7 @@
|
||||||
[(cons a actions)
|
[(cons a actions)
|
||||||
(match a
|
(match a
|
||||||
[(? patch? p)
|
[(? patch? p)
|
||||||
(process-actions actions (apply-patch interests (label-patch p (datum-tset 'root))))]
|
(process-actions actions (apply-patch interests (label-patch p (bitset 1))))]
|
||||||
[_
|
[_
|
||||||
(log-warning "run-ground: ignoring useless meta-action ~v" a)
|
(log-warning "run-ground: ignoring useless meta-action ~v" a)
|
||||||
(process-actions actions interests)])]))])))))
|
(process-actions actions interests)])]))])))))
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
;; General multiplexer.
|
;; General multiplexer.
|
||||||
|
|
||||||
(provide meta-label?
|
(provide meta-label
|
||||||
|
meta-label?
|
||||||
(except-out (struct-out mux) mux)
|
(except-out (struct-out mux) mux)
|
||||||
(rename-out [mux <mux>] [make-mux mux])
|
(rename-out [mux <mux>] [make-mux mux])
|
||||||
mux-add-stream
|
mux-add-stream
|
||||||
|
@ -9,42 +10,59 @@
|
||||||
mux-update-stream
|
mux-update-stream
|
||||||
mux-route-message
|
mux-route-message
|
||||||
mux-interests-of
|
mux-interests-of
|
||||||
compute-affected-pids)
|
compute-affected-pids
|
||||||
|
|
||||||
|
mux-alloc-pid ;; for testing/debugging -- see trace/stderr.rkt
|
||||||
|
)
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "route.rkt")
|
(require "route.rkt")
|
||||||
(require "patch.rkt")
|
(require "patch.rkt")
|
||||||
(require "trace.rkt")
|
(require "trace.rkt")
|
||||||
(require "tset.rkt")
|
(require "bitset.rkt")
|
||||||
|
|
||||||
;; A PID is a Nat.
|
;; A PID is a non-zero Nat.
|
||||||
;; A Label is a PID or 'meta.
|
;; A Label is a PID or 0, representing meta.
|
||||||
;; Multiplexer private states
|
;; Multiplexer private states
|
||||||
(struct mux (next-pid ;; PID
|
(struct mux (free-pids ;; (Listof PID)
|
||||||
|
stream-count ;; Nat
|
||||||
routing-table ;; (Matcherof (Setof Label))
|
routing-table ;; (Matcherof (Setof Label))
|
||||||
interest-table ;; (HashTable Label Matcher)
|
interest-table ;; (HashTable Label Matcher)
|
||||||
) #:transparent)
|
) #:transparent)
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(define (meta-label? x) (eq? x 'meta))
|
|
||||||
|
|
||||||
(define (make-mux)
|
(define (make-mux)
|
||||||
(mux 0 (matcher-empty) (hash)))
|
(mux '() 0 (matcher-empty) (hash)))
|
||||||
|
|
||||||
|
(define (mux-alloc-pid m)
|
||||||
|
(match (mux-free-pids m)
|
||||||
|
[(cons pid rest)
|
||||||
|
(values pid
|
||||||
|
(struct-copy mux m
|
||||||
|
[free-pids rest]
|
||||||
|
[stream-count (+ (mux-stream-count m) 1)]))]
|
||||||
|
['()
|
||||||
|
(values (+ (mux-stream-count m) 1) ;; avoid zero -- used for meta-label.
|
||||||
|
(struct-copy mux m
|
||||||
|
[stream-count (+ (mux-stream-count m) 1)]))]))
|
||||||
|
|
||||||
|
(define (mux-free-pid m pid)
|
||||||
|
(struct-copy mux m
|
||||||
|
[free-pids (cons pid (mux-free-pids m))]
|
||||||
|
[stream-count (- (mux-stream-count m) 1)]))
|
||||||
|
|
||||||
(define (mux-add-stream m initial-patch)
|
(define (mux-add-stream m initial-patch)
|
||||||
(define new-pid (mux-next-pid m))
|
(define-values (new-pid m1) (mux-alloc-pid m))
|
||||||
(mux-update-stream (struct-copy mux m [next-pid (+ new-pid 1)])
|
(mux-update-stream m1 new-pid initial-patch))
|
||||||
new-pid
|
|
||||||
initial-patch))
|
|
||||||
|
|
||||||
(define (mux-remove-stream m label)
|
(define (mux-remove-stream m label)
|
||||||
(mux-update-stream m label (patch (matcher-empty) (pattern->matcher #t ?))))
|
(mux-update-stream (mux-free-pid m label) label (patch (matcher-empty) (pattern->matcher #t ?))))
|
||||||
|
|
||||||
(define (mux-update-stream m label delta-orig)
|
(define (mux-update-stream m label delta-orig)
|
||||||
(define old-interests (mux-interests-of m label))
|
(define old-interests (mux-interests-of m label))
|
||||||
(define delta (limit-patch (label-patch delta-orig (datum-tset label)) old-interests))
|
(define delta (limit-patch (label-patch delta-orig (bitset label)) old-interests))
|
||||||
(define new-interests (apply-patch old-interests delta))
|
(define new-interests (apply-patch old-interests delta))
|
||||||
(let* ((m (struct-copy mux m
|
(let* ((m (struct-copy mux m
|
||||||
[interest-table
|
[interest-table
|
||||||
|
@ -57,10 +75,10 @@
|
||||||
(define new-routing-table (apply-patch old-routing-table delta))
|
(define new-routing-table (apply-patch old-routing-table delta))
|
||||||
(define delta-aggregate (compute-aggregate-patch delta label old-routing-table))
|
(define delta-aggregate (compute-aggregate-patch delta label old-routing-table))
|
||||||
(define affected-pids (let ((pids (compute-affected-pids old-routing-table delta)))
|
(define affected-pids (let ((pids (compute-affected-pids old-routing-table delta)))
|
||||||
(tset-remove (tset-add pids label) 'meta))) ;; TODO: removing meta is weird
|
(bitset-remove (bitset-add pids label) meta-label))) ;; TODO: removing meta is weird
|
||||||
(values (struct-copy mux m [routing-table new-routing-table])
|
(values (struct-copy mux m [routing-table new-routing-table])
|
||||||
label
|
label
|
||||||
(for/list [(pid (tset->list affected-pids))]
|
(for/list [(pid (bitset->list affected-pids))]
|
||||||
(cond [(equal? pid label)
|
(cond [(equal? pid label)
|
||||||
(define feedback
|
(define feedback
|
||||||
(patch-union
|
(patch-union
|
||||||
|
@ -79,10 +97,10 @@
|
||||||
(define cover (matcher-union (patch-added delta) (patch-removed delta)))
|
(define cover (matcher-union (patch-added delta) (patch-removed delta)))
|
||||||
(matcher-match-matcher cover
|
(matcher-match-matcher cover
|
||||||
(matcher-step routing-table struct:observe)
|
(matcher-step routing-table struct:observe)
|
||||||
#:seed (datum-tset)
|
#:seed (bitset)
|
||||||
#:combiner (lambda (v1 v2 acc) (tset-union v2 acc))
|
#:combiner (lambda (v1 v2 acc) (bitset-union v2 acc))
|
||||||
#:left-short (lambda (v r acc)
|
#:left-short (lambda (v r acc)
|
||||||
(tset-union acc (success-value (matcher-step r EOS))))))
|
(bitset-union acc (success-value (matcher-step r EOS))))))
|
||||||
|
|
||||||
(define (mux-route-message m label body)
|
(define (mux-route-message m label body)
|
||||||
(when (observe? body)
|
(when (observe? body)
|
||||||
|
@ -96,7 +114,7 @@
|
||||||
(at-meta? body)) ;; it relates to envt, not local
|
(at-meta? body)) ;; it relates to envt, not local
|
||||||
(values #t '())]
|
(values #t '())]
|
||||||
[else
|
[else
|
||||||
(values #f (tset->list (matcher-match-value (mux-routing-table m) (observe body) (datum-tset))))]))
|
(values #f (bitset->list (matcher-match-value (mux-routing-table m) (observe body) (bitset))))]))
|
||||||
|
|
||||||
(define (mux-interests-of m label)
|
(define (mux-interests-of m label)
|
||||||
(hash-ref (mux-interest-table m) label (matcher-empty)))
|
(hash-ref (mux-interest-table m) label (matcher-empty)))
|
||||||
|
|
|
@ -5,6 +5,8 @@
|
||||||
(struct-out observe)
|
(struct-out observe)
|
||||||
(struct-out at-meta)
|
(struct-out at-meta)
|
||||||
(struct-out advertise)
|
(struct-out advertise)
|
||||||
|
meta-label
|
||||||
|
meta-label?
|
||||||
empty-patch
|
empty-patch
|
||||||
patch-empty?
|
patch-empty?
|
||||||
patch-non-empty?
|
patch-non-empty?
|
||||||
|
@ -39,7 +41,7 @@
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require "route.rkt")
|
(require "route.rkt")
|
||||||
(require "tset.rkt")
|
(require "bitset.rkt")
|
||||||
(module+ test (require rackunit))
|
(module+ test (require rackunit))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
@ -56,6 +58,9 @@
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
|
(define meta-label 0)
|
||||||
|
(define (meta-label? x) (equal? x meta-label))
|
||||||
|
|
||||||
(define at-meta-proj (compile-projection (at-meta (?!))))
|
(define at-meta-proj (compile-projection (at-meta (?!))))
|
||||||
|
|
||||||
(define (patch-empty? p)
|
(define (patch-empty? p)
|
||||||
|
@ -117,7 +122,7 @@
|
||||||
(match-define (patch in out) p)
|
(match-define (patch in out) p)
|
||||||
(patch (matcher-subtract in bound)
|
(patch (matcher-subtract in bound)
|
||||||
(matcher-intersect out bound
|
(matcher-intersect out bound
|
||||||
#:combiner (lambda (v1 v2) (empty-tset-guard (tset-intersect v1 v2))))))
|
#:combiner (lambda (v1 v2) (empty-bitset-guard (bitset-intersect v1 v2))))))
|
||||||
|
|
||||||
;; Entries labelled with `label` may already exist in `base`; the
|
;; Entries labelled with `label` may already exist in `base`; the
|
||||||
;; patch `p` MUST already have been limited to add only where no
|
;; patch `p` MUST already have been limited to add only where no
|
||||||
|
@ -137,7 +142,7 @@
|
||||||
;; peers, the overall effect will be nil.
|
;; peers, the overall effect will be nil.
|
||||||
;;
|
;;
|
||||||
;; If `remove-meta?` is true, then in addition to ignoring existing
|
;; If `remove-meta?` is true, then in addition to ignoring existing
|
||||||
;; `label` interests, we also ignore existing `'meta`-labelled
|
;; `label` interests, we also ignore existing meta-labelled
|
||||||
;; interests. This is used when computing an outbound/dropped patch.
|
;; interests. This is used when computing an outbound/dropped patch.
|
||||||
;;
|
;;
|
||||||
;; PRECONDITION: `p` is (set label)-labelled
|
;; PRECONDITION: `p` is (set label)-labelled
|
||||||
|
@ -156,8 +161,8 @@
|
||||||
;;
|
;;
|
||||||
;; ...except when `remove-meta?` is true. In that case, we need to
|
;; ...except when `remove-meta?` is true. In that case, we need to
|
||||||
;; keep the point in the case that the only interest present is
|
;; keep the point in the case that the only interest present is
|
||||||
;; `'meta`-labeled interest.
|
;; meta-labeled interest.
|
||||||
(if (and remove-meta? (equal? v2 (datum-tset 'meta)))
|
(if (and remove-meta? (equal? v2 (bitset meta-label)))
|
||||||
v1
|
v1
|
||||||
#f))
|
#f))
|
||||||
(define (rem-combiner v1 v2)
|
(define (rem-combiner v1 v2)
|
||||||
|
@ -170,14 +175,14 @@
|
||||||
;; ...and again, for `remove-meta?`, the condition is slightly
|
;; ...and again, for `remove-meta?`, the condition is slightly
|
||||||
;; different. We need to keep the point in that case when either
|
;; different. We need to keep the point in that case when either
|
||||||
;; only label interest exists (which by precondition is always the
|
;; only label interest exists (which by precondition is always the
|
||||||
;; case), or when exactly `label` and `'meta` interest exists, and
|
;; case), or when exactly `label` and meta interest exists, and
|
||||||
;; in no other case.
|
;; in no other case.
|
||||||
(if (= (tset-count v2) 1)
|
(if (= (bitset-count v2) 1)
|
||||||
v1 ;; only `label` interest (previously established) exists here.
|
v1 ;; only `label` interest (previously established) exists here.
|
||||||
(if (and remove-meta?
|
(if (and remove-meta?
|
||||||
(= (tset-count v2) 2)
|
(= (bitset-count v2) 2)
|
||||||
(tset-member? v2 'meta))
|
(bitset-member? v2 meta-label))
|
||||||
v1 ;; remove-meta? is true, and exactly `label` and `'meta` interest exists here.
|
v1 ;; remove-meta? is true, and exactly `label` and meta interest exists here.
|
||||||
#f))) ;; other interest exists here, so we should discard this removed-point.
|
#f))) ;; other interest exists here, so we should discard this removed-point.
|
||||||
(patch (matcher-subtract (patch-added p) base #:combiner add-combiner)
|
(patch (matcher-subtract (patch-added p) base #:combiner add-combiner)
|
||||||
(matcher-subtract (patch-removed p) base #:combiner rem-combiner)))
|
(matcher-subtract (patch-removed p) base #:combiner rem-combiner)))
|
||||||
|
@ -263,12 +268,19 @@
|
||||||
(define (project-routing-table R label-set)
|
(define (project-routing-table R label-set)
|
||||||
(matcher-intersect R
|
(matcher-intersect R
|
||||||
(pattern->matcher label-set ?)
|
(pattern->matcher label-set ?)
|
||||||
#:combiner (lambda (v1 v2) (empty-tset-guard (tset-intersect v1 v2)))))
|
#:combiner (lambda (v1 v2) (empty-bitset-guard (bitset-intersect v1 v2)))))
|
||||||
|
|
||||||
(define tset datum-tset)
|
(define (symbol->small-integer s)
|
||||||
|
(define str (symbol->string s))
|
||||||
|
(if (= (string-length str) 1)
|
||||||
|
(char->integer (string-ref str 0))
|
||||||
|
(error 'symbol->small-integer "Symbol too long: ~v" s)))
|
||||||
|
|
||||||
|
(define (bitset* . syms)
|
||||||
|
(apply bitset (map symbol->small-integer syms)))
|
||||||
|
|
||||||
(define (sanity-check-examples)
|
(define (sanity-check-examples)
|
||||||
(define SP (tset 'P))
|
(define SP (bitset* 'P))
|
||||||
(define m0 (matcher-empty))
|
(define m0 (matcher-empty))
|
||||||
(define ma (pattern->matcher SP 'a))
|
(define ma (pattern->matcher SP 'a))
|
||||||
(define mb (pattern->matcher SP 'b))
|
(define mb (pattern->matcher SP 'b))
|
||||||
|
@ -366,11 +378,11 @@
|
||||||
(let* ((pre-patch-a-keys (set 1 3 5 7))
|
(let* ((pre-patch-a-keys (set 1 3 5 7))
|
||||||
(pre-patch-b-keys (set 2 3 6 7))
|
(pre-patch-b-keys (set 2 3 6 7))
|
||||||
(pre-patch-keys (set 1 2 3 5 6 7))
|
(pre-patch-keys (set 1 2 3 5 6 7))
|
||||||
(ma (set->matcher (tset 'a) pre-patch-a-keys))
|
(ma (set->matcher (bitset* 'a) pre-patch-a-keys))
|
||||||
(mb (set->matcher (tset 'b) pre-patch-b-keys))
|
(mb (set->matcher (bitset* 'b) pre-patch-b-keys))
|
||||||
(R (matcher-union ma mb))
|
(R (matcher-union ma mb))
|
||||||
(pa-raw (patch (set->matcher (tset 'a) (set 0 1 2 3 ))
|
(pa-raw (patch (set->matcher (bitset* 'a) (set 0 1 2 3 ))
|
||||||
(set->matcher (tset 'a) (set 4 5 6 7))))
|
(set->matcher (bitset* 'a) (set 4 5 6 7))))
|
||||||
(pa1 (limit-patch pa-raw ma))
|
(pa1 (limit-patch pa-raw ma))
|
||||||
(pa2 (limit-patch/routing-table pa-raw R))
|
(pa2 (limit-patch/routing-table pa-raw R))
|
||||||
(post-patch-a-keys (set 0 1 2 3 ))
|
(post-patch-a-keys (set 0 1 2 3 ))
|
||||||
|
@ -382,26 +394,26 @@
|
||||||
(p-aggregate2 (compute-aggregate-patch pa2 'a R))
|
(p-aggregate2 (compute-aggregate-patch pa2 'a R))
|
||||||
(R1 (apply-patch R pa1))
|
(R1 (apply-patch R pa1))
|
||||||
(R2 (apply-patch R pa2))
|
(R2 (apply-patch R pa2))
|
||||||
(R-relabeled (matcher-relabel R (lambda (v) (tset 'x))))
|
(R-relabeled (matcher-relabel R (lambda (v) (bitset* 'x))))
|
||||||
(R1-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate1) (tset 'x))))
|
(R1-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate1) (bitset* 'x))))
|
||||||
(R2-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate2) (tset 'x)))))
|
(R2-relabeled (apply-patch R-relabeled (label-patch (strip-patch p-aggregate2) (bitset* 'x)))))
|
||||||
(check-equal? pa1 pa2)
|
(check-equal? pa1 pa2)
|
||||||
(check-equal? (matcher-match-value R 0 (tset)) (tset))
|
(check-equal? (matcher-match-value R 0 (bitset)) (bitset))
|
||||||
(check-equal? (matcher-match-value R 1 (tset)) (tset 'a))
|
(check-equal? (matcher-match-value R 1 (bitset)) (bitset* 'a))
|
||||||
(check-equal? (matcher-match-value R 2 (tset)) (tset 'b))
|
(check-equal? (matcher-match-value R 2 (bitset)) (bitset* 'b))
|
||||||
(check-equal? (matcher-match-value R 3 (tset)) (tset 'a 'b))
|
(check-equal? (matcher-match-value R 3 (bitset)) (bitset* 'a 'b))
|
||||||
(check-equal? (matcher-match-value R 4 (tset)) (tset))
|
(check-equal? (matcher-match-value R 4 (bitset)) (bitset))
|
||||||
(check-equal? (matcher-match-value R 5 (tset)) (tset 'a))
|
(check-equal? (matcher-match-value R 5 (bitset)) (bitset* 'a))
|
||||||
(check-equal? (matcher-match-value R 6 (tset)) (tset 'b))
|
(check-equal? (matcher-match-value R 6 (bitset)) (bitset* 'b))
|
||||||
(check-equal? (matcher-match-value R 7 (tset)) (tset 'a 'b))
|
(check-equal? (matcher-match-value R 7 (bitset)) (bitset* 'a 'b))
|
||||||
(check-equal? (matcher-key-set/single (project-routing-table R (tset 'a))) pre-patch-a-keys)
|
(check-equal? (matcher-key-set/single (project-routing-table R (bitset* 'a))) pre-patch-a-keys)
|
||||||
(check-equal? (matcher-key-set/single (project-routing-table R (tset 'b))) pre-patch-b-keys)
|
(check-equal? (matcher-key-set/single (project-routing-table R (bitset* 'b))) pre-patch-b-keys)
|
||||||
(check-equal? (matcher-key-set/single R) pre-patch-keys)
|
(check-equal? (matcher-key-set/single R) pre-patch-keys)
|
||||||
(check-equal? (matcher-key-set/single R-relabeled) pre-patch-keys)
|
(check-equal? (matcher-key-set/single R-relabeled) pre-patch-keys)
|
||||||
|
|
||||||
(define (post-checks R* R*-relabeled p-aggregate)
|
(define (post-checks R* R*-relabeled p-aggregate)
|
||||||
(check-equal? (matcher-key-set/single (project-routing-table R* (tset 'a))) post-patch-a-keys)
|
(check-equal? (matcher-key-set/single (project-routing-table R* (bitset* 'a))) post-patch-a-keys)
|
||||||
(check-equal? (matcher-key-set/single (project-routing-table R* (tset 'b))) post-patch-b-keys)
|
(check-equal? (matcher-key-set/single (project-routing-table R* (bitset* 'b))) post-patch-b-keys)
|
||||||
(check-equal? (matcher-key-set/single R*) post-patch-keys)
|
(check-equal? (matcher-key-set/single R*) post-patch-keys)
|
||||||
(check-equal? (matcher-key-set/single R*-relabeled) post-patch-keys)
|
(check-equal? (matcher-key-set/single R*-relabeled) post-patch-keys)
|
||||||
(check-equal? (matcher-key-set/single (patch-added p-aggregate)) aggregate-added)
|
(check-equal? (matcher-key-set/single (patch-added p-aggregate)) aggregate-added)
|
||||||
|
@ -411,9 +423,9 @@
|
||||||
(post-checks R2 R2-relabeled p-aggregate2)
|
(post-checks R2 R2-relabeled p-aggregate2)
|
||||||
)
|
)
|
||||||
|
|
||||||
(let* ((ma (set->matcher (tset 'a) (set 1)))
|
(let* ((ma (set->matcher (bitset* 'a) (set 1)))
|
||||||
(mb (set->matcher (tset 'b) (set 1)))
|
(mb (set->matcher (bitset* 'b) (set 1)))
|
||||||
(mmeta (set->matcher (tset 'meta) (set 1)))
|
(mmeta (set->matcher (bitset meta-label) (set 1)))
|
||||||
(R0 (matcher-empty))
|
(R0 (matcher-empty))
|
||||||
(R1 mmeta)
|
(R1 mmeta)
|
||||||
(R2 mb)
|
(R2 mb)
|
||||||
|
@ -423,8 +435,8 @@
|
||||||
(R6 (matcher-union ma mb))
|
(R6 (matcher-union ma mb))
|
||||||
(R7 (matcher-union (matcher-union ma mb) mmeta))
|
(R7 (matcher-union (matcher-union ma mb) mmeta))
|
||||||
(p0 empty-patch)
|
(p0 empty-patch)
|
||||||
(p+ (patch (set->matcher (tset 'a) (set 1)) (matcher-empty)))
|
(p+ (patch (set->matcher (bitset* 'a) (set 1)) (matcher-empty)))
|
||||||
(p- (patch (matcher-empty) (set->matcher (tset 'a) (set 1)))))
|
(p- (patch (matcher-empty) (set->matcher (bitset* 'a) (set 1)))))
|
||||||
(check-equal? (compute-aggregate-patch p0 'a R0) p0)
|
(check-equal? (compute-aggregate-patch p0 'a R0) p0)
|
||||||
(check-equal? (compute-aggregate-patch p0 'a R1) p0)
|
(check-equal? (compute-aggregate-patch p0 'a R1) p0)
|
||||||
(check-equal? (compute-aggregate-patch p0 'a R2) p0)
|
(check-equal? (compute-aggregate-patch p0 'a R2) p0)
|
||||||
|
|
|
@ -25,7 +25,7 @@
|
||||||
pattern->matcher*
|
pattern->matcher*
|
||||||
matcher-union
|
matcher-union
|
||||||
matcher-intersect
|
matcher-intersect
|
||||||
empty-tset-guard
|
empty-bitset-guard
|
||||||
matcher-subtract-combiner
|
matcher-subtract-combiner
|
||||||
matcher-subtract
|
matcher-subtract
|
||||||
matcher-match-value
|
matcher-match-value
|
||||||
|
@ -63,7 +63,7 @@
|
||||||
(require (only-in racket/class object?))
|
(require (only-in racket/class object?))
|
||||||
(require "canonicalize.rkt")
|
(require "canonicalize.rkt")
|
||||||
(require "treap.rkt")
|
(require "treap.rkt")
|
||||||
(require "tset.rkt")
|
(require "bitset.rkt")
|
||||||
(require data/order)
|
(require data/order)
|
||||||
|
|
||||||
(require rackunit)
|
(require rackunit)
|
||||||
|
@ -334,7 +334,7 @@
|
||||||
|
|
||||||
;; Matcher Matcher -> Matcher
|
;; Matcher Matcher -> Matcher
|
||||||
;; Computes the union of the multimaps passed in.
|
;; Computes the union of the multimaps passed in.
|
||||||
(define (matcher-union re1 re2 #:combiner [combiner tset-union])
|
(define (matcher-union re1 re2 #:combiner [combiner bitset-union])
|
||||||
(matcher-recurse re1
|
(matcher-recurse re1
|
||||||
re2
|
re2
|
||||||
combiner
|
combiner
|
||||||
|
@ -351,7 +351,7 @@
|
||||||
;; Matcher Matcher -> Matcher
|
;; Matcher Matcher -> Matcher
|
||||||
;; Computes the intersection of the multimaps passed in.
|
;; Computes the intersection of the multimaps passed in.
|
||||||
(define (matcher-intersect re1 re2
|
(define (matcher-intersect re1 re2
|
||||||
#:combiner [combiner tset-union]
|
#:combiner [combiner bitset-union]
|
||||||
#:left-short [left-short default-short]
|
#:left-short [left-short default-short]
|
||||||
#:right-short [right-short default-short])
|
#:right-short [right-short default-short])
|
||||||
(matcher-recurse re1
|
(matcher-recurse re1
|
||||||
|
@ -364,11 +364,11 @@
|
||||||
left-short
|
left-short
|
||||||
right-short))
|
right-short))
|
||||||
|
|
||||||
(define (empty-tset-guard s)
|
(define (empty-bitset-guard s)
|
||||||
(if (tset-empty? s) #f s))
|
(if (bitset-empty? s) #f s))
|
||||||
|
|
||||||
(define (matcher-subtract-combiner s1 s2)
|
(define (matcher-subtract-combiner s1 s2)
|
||||||
(empty-tset-guard (tset-subtract s1 s2)))
|
(empty-bitset-guard (bitset-subtract s1 s2)))
|
||||||
|
|
||||||
;; Matcher Matcher -> Matcher
|
;; Matcher Matcher -> Matcher
|
||||||
;; Removes re2's mappings from re1.
|
;; Removes re2's mappings from re1.
|
||||||
|
@ -535,8 +535,8 @@
|
||||||
(define (matcher-match-matcher re1 re2
|
(define (matcher-match-matcher re1 re2
|
||||||
#:seed seed
|
#:seed seed
|
||||||
#:combiner [combiner (lambda (v1 v2 a)
|
#:combiner [combiner (lambda (v1 v2 a)
|
||||||
(cons (tset-union (car a) v1)
|
(cons (bitset-union (car a) v1)
|
||||||
(tset-union (cdr a) v2)))]
|
(bitset-union (cdr a) v2)))]
|
||||||
#:left-short [left-short (lambda (v r acc) acc)]
|
#:left-short [left-short (lambda (v r acc) acc)]
|
||||||
#:right-short [right-short (lambda (v r acc) acc)])
|
#:right-short [right-short (lambda (v r acc) acc)])
|
||||||
(let walk ((re1 re1) (re2 re2) (acc seed))
|
(let walk ((re1 re1) (re2 re2) (acc seed))
|
||||||
|
@ -716,7 +716,7 @@
|
||||||
|
|
||||||
(lambda (m spec
|
(lambda (m spec
|
||||||
#:project-success [project-success values]
|
#:project-success [project-success values]
|
||||||
#:combiner [combiner tset-union])
|
#:combiner [combiner bitset-union])
|
||||||
(define (drop-match m spec) (general-match values drop-edge drop-sigma drop-bal m spec
|
(define (drop-match m spec) (general-match values drop-edge drop-sigma drop-bal m spec
|
||||||
project-success drop-match take-match))
|
project-success drop-match take-match))
|
||||||
(define (take-match m spec) (general-match rwild rupdate rseq take-bal m spec
|
(define (take-match m spec) (general-match rwild rupdate rseq take-bal m spec
|
||||||
|
@ -835,7 +835,7 @@
|
||||||
(walk (+ i 5) k)]
|
(walk (+ i 5) k)]
|
||||||
[(success vs)
|
[(success vs)
|
||||||
(d "{")
|
(d "{")
|
||||||
(d (if (tset? vs) (cons 'tset (tset->list vs)) vs))
|
(d (if (bitset? vs) (cons 'bitset (bitset->list vs)) vs))
|
||||||
(d "}")]
|
(d "}")]
|
||||||
[(? treap? h)
|
[(? treap? h)
|
||||||
(if (zero? (treap-size h))
|
(if (zero? (treap-size h))
|
||||||
|
@ -927,15 +927,25 @@
|
||||||
(module+ test
|
(module+ test
|
||||||
(require racket/pretty)
|
(require racket/pretty)
|
||||||
|
|
||||||
(define tset datum-tset)
|
(define (small-integer->string i)
|
||||||
|
(string (integer->char i)))
|
||||||
|
|
||||||
(define SA (tset 'A))
|
(define (symbol->small-integer s)
|
||||||
(define SB (tset 'B))
|
(define str (symbol->string s))
|
||||||
(define SC (tset 'C))
|
(if (= (string-length str) 1)
|
||||||
(define SD (tset 'D))
|
(char->integer (string-ref str 0))
|
||||||
(define Sfoo (tset 'foo))
|
(error 'symbol->small-integer "Symbol too long: ~v" s)))
|
||||||
(define S+ (tset '+))
|
|
||||||
(define SX (tset 'X))
|
(define (bitset* . syms)
|
||||||
|
(apply bitset (map symbol->small-integer syms)))
|
||||||
|
|
||||||
|
(define SA (bitset* 'A))
|
||||||
|
(define SB (bitset* 'B))
|
||||||
|
(define SC (bitset* 'C))
|
||||||
|
(define SD (bitset* 'D))
|
||||||
|
(define Sfoo (bitset* 'f))
|
||||||
|
(define S+ (bitset* '+))
|
||||||
|
(define SX (bitset* 'X))
|
||||||
(define (E v) (rseq EOS (rsuccess v)))
|
(define (E v) (rseq EOS (rsuccess v)))
|
||||||
(check-equal? (pattern->matcher SA 123) (rseq 123 (E SA)))
|
(check-equal? (pattern->matcher SA 123) (rseq 123 (E SA)))
|
||||||
(check-equal? (pattern->matcher SA (cons 1 2))
|
(check-equal? (pattern->matcher SA (cons 1 2))
|
||||||
|
@ -954,17 +964,17 @@
|
||||||
(match tests
|
(match tests
|
||||||
['() (void)]
|
['() (void)]
|
||||||
[(list* message expectedstr rest)
|
[(list* message expectedstr rest)
|
||||||
(define actualset (matcher-match-value matcher message (tset)))
|
(define actualset (matcher-match-value matcher message (bitset)))
|
||||||
(printf "~v ==> ~v\n" message actualset)
|
(printf "~v ==> ~v\n" message actualset)
|
||||||
(check-equal? actualset
|
(check-equal? actualset
|
||||||
(apply tset (map (lambda (c) (string->symbol (string c)))
|
(apply bitset* (map (lambda (c) (string->symbol (string c)))
|
||||||
(string->list expectedstr))))
|
(string->list expectedstr))))
|
||||||
(walk rest)])))
|
(walk rest)])))
|
||||||
|
|
||||||
(check-matches
|
(check-matches
|
||||||
#f
|
#f
|
||||||
(list 'z 'x) ""
|
(list 'z 'x) ""
|
||||||
'foo ""
|
'f ""
|
||||||
(list (list 'z (list 'z))) "")
|
(list (list 'z (list 'z))) "")
|
||||||
|
|
||||||
(define (pretty-print-matcher* m)
|
(define (pretty-print-matcher* m)
|
||||||
|
@ -1023,7 +1033,7 @@
|
||||||
(void (pretty-print-matcher* (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
|
(void (pretty-print-matcher* (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
|
||||||
;; Note: this is a largely nonsense matcher,
|
;; Note: this is a largely nonsense matcher,
|
||||||
;; since it expects no input at all
|
;; since it expects no input at all
|
||||||
(rseq EOS (rsuccess (tset 'B))))))
|
(rseq EOS (rsuccess (bitset* 'B))))))
|
||||||
|
|
||||||
(check-matches
|
(check-matches
|
||||||
(pretty-print-matcher*
|
(pretty-print-matcher*
|
||||||
|
@ -1063,7 +1073,7 @@
|
||||||
(define ps
|
(define ps
|
||||||
(for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")))
|
(for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")))
|
||||||
(define csym (string->symbol (string c)))
|
(define csym (string->symbol (string c)))
|
||||||
(pattern->matcher (tset csym) (list csym ?))))
|
(pattern->matcher (bitset* csym) (list csym ?))))
|
||||||
(matcher-union (foldr matcher-union (matcher-empty) ps)
|
(matcher-union (foldr matcher-union (matcher-empty) ps)
|
||||||
(pattern->matcher S+ (list 'Z (list ? '- ?)))))
|
(pattern->matcher S+ (list 'Z (list ? '- ?)))))
|
||||||
|
|
||||||
|
@ -1230,7 +1240,7 @@
|
||||||
(matcher-intersect (pattern->matcher SA a)
|
(matcher-intersect (pattern->matcher SA a)
|
||||||
(pattern->matcher SB b)))
|
(pattern->matcher SB b)))
|
||||||
|
|
||||||
(define EAB (E (tset 'A 'B)))
|
(define EAB (E (bitset* 'A 'B)))
|
||||||
|
|
||||||
(define (rseq* x . xs)
|
(define (rseq* x . xs)
|
||||||
(let walk ((xs (cons x xs)))
|
(let walk ((xs (cons x xs)))
|
||||||
|
@ -1285,23 +1295,23 @@
|
||||||
(define m2 (pretty-print-matcher* (pattern->matcher SD ?)))
|
(define m2 (pretty-print-matcher* (pattern->matcher SD ?)))
|
||||||
(define mi (pretty-print-matcher* (matcher-intersect m1 m2)))
|
(define mi (pretty-print-matcher* (matcher-intersect m1 m2)))
|
||||||
(check-requal? mi
|
(check-requal? mi
|
||||||
(H SOL (H 'a (H ? (H EOS (E (tset 'A 'D))))
|
(H SOL (H 'a (H ? (H EOS (E (bitset* 'A 'D))))
|
||||||
'b (H ? (H EOS (E (tset 'B 'D)))
|
'b (H ? (H EOS (E (bitset* 'B 'D)))
|
||||||
'c (H EOS (E (tset 'B 'C 'D)))))))
|
'c (H EOS (E (bitset* 'B 'C 'D)))))))
|
||||||
(check-requal? (pretty-print-matcher* (matcher-intersect m1 m2 #:combiner (lambda (v1 v2) v1)))
|
(check-requal? (pretty-print-matcher* (matcher-intersect m1 m2 #:combiner (lambda (v1 v2) v1)))
|
||||||
m1))
|
m1))
|
||||||
)
|
)
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(define (matcher-match-matcher-list m1 m2)
|
(define (matcher-match-matcher-list m1 m2)
|
||||||
(match-define (cons s1 s2) (matcher-match-matcher m1 m2 #:seed (cons (tset) (tset))))
|
(match-define (cons s1 s2) (matcher-match-matcher m1 m2 #:seed (cons (bitset) (bitset))))
|
||||||
(list s1 s2))
|
(list s1 s2))
|
||||||
(define (matcher-union* a b)
|
(define (matcher-union* a b)
|
||||||
(matcher-union a b #:combiner (lambda (v1 v2)
|
(matcher-union a b #:combiner (lambda (v1 v2)
|
||||||
(match* (v1 v2)
|
(match* (v1 v2)
|
||||||
[(#t v) v]
|
[(#t v) v]
|
||||||
[(v #t) v]
|
[(v #t) v]
|
||||||
[(v1 v2) (tset-union v1 v2)]))))
|
[(v1 v2) (bitset-union v1 v2)]))))
|
||||||
(let ((abc (foldr matcher-union* (matcher-empty)
|
(let ((abc (foldr matcher-union* (matcher-empty)
|
||||||
(list (pattern->matcher SA (list 'a ?))
|
(list (pattern->matcher SA (list 'a ?))
|
||||||
(pattern->matcher SB (list 'b ?))
|
(pattern->matcher SB (list 'b ?))
|
||||||
|
@ -1311,21 +1321,21 @@
|
||||||
(pattern->matcher SC (list 'c ?))
|
(pattern->matcher SC (list 'c ?))
|
||||||
(pattern->matcher SD (list 'd ?))))))
|
(pattern->matcher SD (list 'd ?))))))
|
||||||
(check-equal? (matcher-match-matcher-list abc abc)
|
(check-equal? (matcher-match-matcher-list abc abc)
|
||||||
(list (tset 'A 'B 'C) (tset 'A 'B 'C)))
|
(list (bitset* 'A 'B 'C) (bitset* 'A 'B 'C)))
|
||||||
(check-equal? (matcher-match-matcher abc abc
|
(check-equal? (matcher-match-matcher abc abc
|
||||||
#:seed (tset)
|
#:seed (bitset)
|
||||||
#:combiner (lambda (v1 v2 a) (tset-union v2 a)))
|
#:combiner (lambda (v1 v2 a) (bitset-union v2 a)))
|
||||||
(tset 'A 'B 'C))
|
(bitset* 'A 'B 'C))
|
||||||
(check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (tset #t))))
|
(check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (bitset 0))))
|
||||||
(list (tset 'B 'C) (tset #t)))
|
(list (bitset* 'B 'C) (bitset 0)))
|
||||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo ?))
|
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo ?))
|
||||||
(list (tset 'A 'B 'C) (tset 'foo)))
|
(list (bitset* 'A 'B 'C) (bitset* 'f)))
|
||||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? ?)))
|
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? ?)))
|
||||||
(list (tset 'A 'B 'C) (tset 'foo)))
|
(list (bitset* 'A 'B 'C) (bitset* 'f)))
|
||||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x)))
|
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x)))
|
||||||
(list (tset 'A 'B 'C) (tset 'foo)))
|
(list (bitset* 'A 'B 'C) (bitset* 'f)))
|
||||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x ?)))
|
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x ?)))
|
||||||
(list (tset) (tset)))))
|
(list (bitset) (bitset)))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (compile-projection (cons 'a 'b))
|
(check-equal? (compile-projection (cons 'a 'b))
|
||||||
|
@ -1476,16 +1486,16 @@
|
||||||
(printf "Checking that subtraction from union is identity-like\n")
|
(printf "Checking that subtraction from union is identity-like\n")
|
||||||
|
|
||||||
(let ((A (pattern->matcher SA ?))
|
(let ((A (pattern->matcher SA ?))
|
||||||
(B (pattern->matcher SB (list (list (list (list 'foo)))))))
|
(B (pattern->matcher SB (list (list (list (list 'f)))))))
|
||||||
(check-requal? (pretty-print-matcher* (matcher-subtract (matcher-union A B) B))
|
(check-requal? (pretty-print-matcher* (matcher-subtract (matcher-union A B) B))
|
||||||
A))
|
A))
|
||||||
(let ((A (pattern->matcher SA ?))
|
(let ((A (pattern->matcher SA ?))
|
||||||
(B (matcher-union (pattern->matcher SB (list (list (list (list 'foo)))))
|
(B (matcher-union (pattern->matcher SB (list (list (list (list 'f)))))
|
||||||
(pattern->matcher SB (list (list (list (list 'bar))))))))
|
(pattern->matcher SB (list (list (list (list 'bar))))))))
|
||||||
(check-requal? (pretty-print-matcher* (matcher-subtract (matcher-union A B) B))
|
(check-requal? (pretty-print-matcher* (matcher-subtract (matcher-union A B) B))
|
||||||
A))
|
A))
|
||||||
(let ((A (pattern->matcher SA ?))
|
(let ((A (pattern->matcher SA ?))
|
||||||
(B (matcher-union (pattern->matcher SB (list (list (list (list 'foo)))))
|
(B (matcher-union (pattern->matcher SB (list (list (list (list 'f)))))
|
||||||
(pattern->matcher SB (list (list (list (list 'bar))))))))
|
(pattern->matcher SB (list (list (list (list 'bar))))))))
|
||||||
(check-requal? (pretty-print-matcher* (matcher-subtract (matcher-union A B) A))
|
(check-requal? (pretty-print-matcher* (matcher-subtract (matcher-union A B) A))
|
||||||
B)))
|
B)))
|
||||||
|
@ -1498,14 +1508,14 @@
|
||||||
(pattern->matcher SB (list 3 4)))))
|
(pattern->matcher SB (list 3 4)))))
|
||||||
(S '((("(")
|
(S '((("(")
|
||||||
((1 ((2 (((")") (((")") ("" ("A")))))))
|
((1 ((2 (((")") (((")") ("" ("A")))))))
|
||||||
(3 (((")") (((")") ("" ("C" "D")))))))))
|
(3 (((")") (((")") ("" ("D" "C")))))))))
|
||||||
(3 ((2 (((")") (((")") ("" ("A")))))))
|
(3 ((2 (((")") (((")") ("" ("A")))))))
|
||||||
(3 (((")") (((")") ("" ("D")))))))
|
(3 (((")") (((")") ("" ("D")))))))
|
||||||
(4 (((")") (((")") ("" ("B")))))))))
|
(4 (((")") (((")") ("" ("B")))))))))
|
||||||
(("__") ((2 (((")") (((")") ("" ("A")))))))
|
(("__") ((2 (((")") (((")") ("" ("A")))))))
|
||||||
(3 (((")") (((")") ("" ("D"))))))))))))))
|
(3 (((")") (((")") ("" ("D"))))))))))))))
|
||||||
(check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (tset->list v)))) S)
|
(check-equal? (matcher->jsexpr M (lambda (v) (map small-integer->string (bitset->list v)))) S)
|
||||||
(check-requal? (jsexpr->matcher S (lambda (v) (make-tset datum-order (map string->symbol v)))) M)))
|
(check-requal? (jsexpr->matcher S (lambda (v) (apply bitset* (map string->symbol v)))) M)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-requal? (pretty-print-matcher*
|
(check-requal? (pretty-print-matcher*
|
||||||
|
|
|
@ -187,7 +187,7 @@
|
||||||
(match a
|
(match a
|
||||||
[(? spawn?)
|
[(? spawn?)
|
||||||
(when (or show-process-lifecycle? show-actions?)
|
(when (or show-process-lifecycle? show-actions?)
|
||||||
(define newpid (mux-next-pid (world-mux old-w)))
|
(define-values (newpid _old-w-mux*) (mux-alloc-pid (world-mux old-w)))
|
||||||
(define newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid
|
(define newpidstr (format-pids (cons newpid (cdr pids)))) ;; replace parent pid
|
||||||
(define interests (mux-interests-of (world-mux new-w) newpid))
|
(define interests (mux-interests-of (world-mux new-w) newpid))
|
||||||
(define behavior (hash-ref (world-behaviors new-w) newpid))
|
(define behavior (hash-ref (world-behaviors new-w) newpid))
|
||||||
|
|
Loading…
Reference in New Issue