From c415fdac65e966f72d1551b10b2b96dc68da3b31 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 10 May 2014 19:25:32 -0400 Subject: [PATCH] Make gestalts list-based instead of mixed vectors and lists --- minimart/gestalt.rkt | 139 +++++++++++++++++++++++++++++++------------ 1 file changed, 100 insertions(+), 39 deletions(-) diff --git a/minimart/gestalt.rkt b/minimart/gestalt.rkt index e439937..5442c22 100644 --- a/minimart/gestalt.rkt +++ b/minimart/gestalt.rkt @@ -7,22 +7,28 @@ (require "route.rkt") (provide (struct-out gestalt) + gestalt-ref + gestalt-project drop-gestalt lift-gestalt simple-gestalt gestalt-empty gestalt-combine gestalt-union + gestalt-intersect + gestalt-filter + gestalt-match strip-gestalt-label label-gestalt) -;; A Gestalt is a (gestalt (Listof (Vectorof (Pairof Matcher +;; 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 vectors 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. +;; 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 few standardised subsystems, identical from citizen to ;; citizen. Two of these were channels for incoming data — one for @@ -38,6 +44,25 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define (safe-list-ref xs n [fail-thunk (lambda () (error 'safe-list-ref "No such index ~v" n))]) + (let loop ((xs xs) (n n)) + (match xs + ['() (fail-thunk)] + [(cons x xs) (if (zero? n) x (loop 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 (gestalt-project g metalevel level get-advertisements? capture-spec) + (matcher-project (gestalt-ref g metalevel level get-advertisements?) capture-spec)) + (define (drop-gestalt g) (match-define (gestalt metalevels) g) (if (null? metalevels) g (gestalt (cdr metalevels)))) @@ -45,46 +70,82 @@ (define (lift-gestalt g) (gestalt (cons '#() (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) - (define leaf (cons subs advs)) - (define vec (make-vector (+ level 1) (cons #f #f))) - (vector-set! vec level leaf) - (let loop ((n metalevel) (acc (list vec))) - (if (zero? n) - (gestalt acc) - (loop (- n 1) (cons '#() acc))))) + (gestalt (prepend metalevel '() (list (prepend level '(#f . #f) (list (cons subs advs))))))) (define (gestalt-empty) (gestalt '())) -(define (gestalt-combine g1 g2 matcher-combiner) - (define (zu sa1 sa2) - (cons (matcher-combiner (car sa1) (car sa2)) - (matcher-combiner (cdr sa1) (cdr sa2)))) - (define (yu ls1 ls2) - (define vl1 (vector-length ls1)) - (define vl2 (vector-length ls2)) - (define one-bigger? (> vl1 vl2)) - (define maxlen (max vl1 vl2)) - (define minlen (min vl1 vl2)) - (define result (make-vector maxlen #f)) - (for ((i (in-range 0 minlen))) - (vector-set! result i (zu (vector-ref ls1 i) (vector-ref ls2 i)))) - (for ((i (in-range minlen maxlen))) - (vector-set! result i (vector-ref (if one-bigger? vl1 vl2) i))) - result) - (define (xu mls1 mls2) - (match* (mls1 mls2) - [('() mls) mls] - [(mls '()) mls] - [((cons m1 mls1) (cons m2 mls2)) (cons (yu m1 m2) (xu mls1 mls2))])) +(define (map-zip imbalance-handler item-handler ls1 ls2) + (let walk ((ls1 ls1) (ls2 ls2)) + (match* (ls1 ls2) + [('() '()) '()] + [('() ls) (imbalance-handler ls)] + [(ls '()) (imbalance-handler ls)] + [((cons l1 ls1) (cons l2 ls2)) (cons (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 ls1 ls2)) + (define (xu mls1 mls2) (map-zip imbalance-handler yu mls1 mls2)) (gestalt (xu (gestalt-metalevels g1) (gestalt-metalevels g2)))) -(define (gestalt-union g1 g2) (gestalt-combine g1 g2 matcher-union)) +(define (gestalt-combine-straight g1 g2 imbalance-handler matcher-combiner) + (gestalt-combine g1 g2 + imbalance-handler + (lambda (sa1 sa2) + (cons (matcher-combiner (car sa1) (car sa2)) + (matcher-combiner (cdr sa1) (cdr sa2)))))) + +(define (gestalt-combine-crossed g1 g2 imbalance-handler matcher-combiner) + (gestalt-combine g1 g2 + imbalance-handler + (lambda (sa1 sa2) + (cons (matcher-combiner (car sa1) (cdr sa2)) + (matcher-combiner (car sa2) (cdr sa1)))))) + +(define (gestalt-union g1 g2) (gestalt-combine-straight g1 g2 + (lambda (x) x) + matcher-union)) + +(define (gestalt-intersect g1 g2) (gestalt-combine-straight g1 g2 + (lambda (x) '()) + matcher-intersect)) + +;; 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 (x) '()) + (lambda (g1 g2) (matcher-intersect g1 g2 + (lambda (v1 v2) v1))))) + +(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))) (define (gestalt-matcher-transform g f) (define (zu sa) (cons (f (car sa)) (f (cdr sa)))) - (define (yu ls) (for/vector [(z (in-vector ls))] (zu z))) + (define (yu ls) (map zu ls)) (define (xu mls) (map yu mls)) (gestalt (xu (gestalt-metalevels g)))) @@ -100,8 +161,8 @@ (require rackunit) (check-equal? (simple-gestalt 'a 'b 0 0) - (gestalt (list (vector (cons 'a 'b))))) + (gestalt (list (list (cons 'a 'b))))) (check-equal? (simple-gestalt 'a 'b 2 2) - (gestalt (list '#() '#() (vector (cons #f #f) - (cons #f #f) - (cons 'a 'b)))))) + (gestalt (list '() '() (list '(#f . #f) + '(#f . #f) + (cons 'a 'b))))))