syndicate-lang
/
minimart-2014
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Adjust projection to yield multiple values instead of a vector

This commit is contained in:
Tony Garnock-Jones 2014-05-28 20:10:55 -04:00
parent 96b92cf2d4
commit 58a0af38a6
4 changed files with 72 additions and 55 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
minimart/demand-matcher.rkt
View File

@ -55,8 +55,8 @@
(define new-d (struct-copy demand-matcher d (define new-d (struct-copy demand-matcher d
[current-demand new-demand] [current-demand new-demand]
[current-supply new-supply])) [current-supply new-supply]))
(let* ((s (for/fold [(s s)] [(k (in-set demand+))] (apply inc-h s (vector->list k)))) (let* ((s (for/fold [(s s)] [(captures (in-set demand+))] (apply inc-h s captures)))
(s (for/fold [(s s)] [(k (in-set supply-))] (apply dec-h s (vector->list k))))) (s (for/fold [(s s)] [(captures (in-set supply-))] (apply dec-h s captures))))
(values new-d s))) (values new-d s)))
(define (demand-matcher-handle-event e d) (define (demand-matcher-handle-event e d)

8
minimart/gestalt.rkt
View File

@ -9,6 +9,7 @@
(provide (struct-out gestalt) (provide (struct-out gestalt)
gestalt-match-value gestalt-match-value
compile-gestalt-projection compile-gestalt-projection
compile-gestalt-projection*
gestalt-project gestalt-project
drop-gestalt drop-gestalt
lift-gestalt lift-gestalt
@ -85,8 +86,11 @@
(define matcher ((if is-feedback? cdr car) level)) ;; feedback targets advertisers/publishers (define matcher ((if is-feedback? cdr car) level)) ;; feedback targets advertisers/publishers
(set-union (matcher-match-value matcher body) acc))) (set-union (matcher-match-value matcher body) acc)))
(define (compile-gestalt-projection spec) (define (compile-gestalt-projection* specs)
(compile-projection spec)) (compile-projection* specs))
(define (compile-gestalt-projection . specs)
(compile-gestalt-projection* specs))
;; Gestalt × Natural × Natural × Boolean × CompiledSpec → Matcher ;; Gestalt × Natural × Natural × Boolean × CompiledSpec → Matcher
(define (gestalt-project g metalevel level get-advertisements? capture-spec) (define (gestalt-project g metalevel level get-advertisements? capture-spec)

2
minimart/ground.rkt
View File

@ -24,7 +24,7 @@
;; process be identified and terminated? ;; process be identified and terminated?
(when (not es) (error 'extract-active-events "User program subscribed to wildcard event")) (when (not es) (error 'extract-active-events "User program subscribed to wildcard event"))
(for/list [(ev (in-set es))] (for/list [(ev (in-set es))]
(match-define (vector e) ev) (match-define (list e) ev)
(event-handler e))) (event-handler e)))
(define idle-handler (define idle-handler

113
minimart/route.rkt
View File

@ -12,6 +12,7 @@
?! ?!
(struct-out capture) (struct-out capture)
pattern->matcher pattern->matcher
pattern->matcher*
matcher? ;; expensive; see implementation matcher? ;; expensive; see implementation
matcher-empty matcher-empty
matcher-empty? matcher-empty?
@ -23,6 +24,7 @@
matcher-append matcher-append
matcher-relabel matcher-relabel
compile-projection compile-projection
compile-projection*
projection->pattern projection->pattern
matcher-project matcher-project
matcher-key-set matcher-key-set
@ -131,15 +133,17 @@
(for/fold [(acc knil)] [(elem (in-vector v (- (vector-length v) 1) -1 -1))] (for/fold [(acc knil)] [(elem (in-vector v (- (vector-length v) 1) -1 -1))]
(kons elem acc))) (kons elem acc)))
(define (pattern->matcher v p) (define (pattern->matcher* v ps)
(let walk ((p p) (acc (rseq EOS (rsuccess v)))) (define (walk-list ps acc)
(match ps
['() (rseq EOS acc)]
[(cons p ps) (walk p (walk-list ps acc))]
[other (rseq ILM (walk other (rseq EOS acc)))]))
(define (walk p acc)
(match p (match p
[(== ?) (rwild acc)] [(== ?) (rwild acc)]
[(cons p1 p2) (rseq SOL (walk p1 (let walk-list ((p p2)) [(cons p1 p2) (rseq SOL (walk p1 (walk-list p2 acc)))]
(match p
['() (rseq EOS acc)]
[(cons p1 p2) (walk p1 (walk-list p2))]
[other (rseq ILM (walk other (rseq EOS acc)))]))))]
[(? vector? v) (rseq SOV (vector-foldr walk (rseq EOS acc) v))] [(? vector? v) (rseq SOV (vector-foldr walk (rseq EOS acc) v))]
[(embedded-matcher m) (matcher-append m (lambda (mv) acc))] [(embedded-matcher m) (matcher-append m (lambda (mv) acc))]
[(? non-object-struct?) [(? non-object-struct?)
@ -149,7 +153,12 @@
(rseq t (foldr walk (rseq EOS acc) fs))] (rseq t (foldr walk (rseq EOS acc) fs))]
;; TODO: consider options for treating hash tables as compounds rather than (useless) atoms ;; TODO: consider options for treating hash tables as compounds rather than (useless) atoms
[(? hash?) (error 'pattern->matcher "Cannot match on hash tables at present")] [(? hash?) (error 'pattern->matcher "Cannot match on hash tables at present")]
[other (rseq other acc)]))) [other (rseq other acc)]))
(walk-list ps (rsuccess v)))
(define (pattern->matcher v . ps)
(pattern->matcher* v ps))
(define (rlookup r key) (define (rlookup r key)
(hash-ref r key (lambda () #f))) (hash-ref r key (lambda () #f)))
@ -473,19 +482,18 @@
[(wildcard-sequence m1) (rwildseq (walk m1))] [(wildcard-sequence m1) (rwildseq (walk m1))]
[(? hash?) (for/fold [(acc #f)] [((k v) (in-hash m))] (rupdate acc k (walk v)))]))) [(? hash?) (for/fold [(acc #f)] [((k v) (in-hash m))] (rupdate acc k (walk v)))])))
(define (compile-projection p) (define (compile-projection* ps)
;; Extremely similar to pattern->matcher. Besides use of conses (define (walk-list ps acc)
;; rather than chained hashtables, the only interesting difference (match ps
;; is how ?! is treated. ['() (cons EOS acc)]
(let walk ((p p) (acc (cons EOS '()))) [(cons p ps) (walk p (walk-list ps acc))]
[other (cons ILM (walk other (cons EOS acc)))]))
(define (walk p acc)
(match p (match p
[(capture sub) (cons SOC (walk sub (cons EOC acc)))] ;; TODO: enforce non-nesting here [(capture sub) (cons SOC (walk sub (cons EOC acc)))] ;; TODO: enforce non-nesting here
[(== ?) (cons ? acc)] [(== ?) (cons ? acc)]
[(cons p1 p2) (cons SOL (walk p1 (let walk-list ((p p2)) [(cons p1 p2) (cons SOL (walk p1 (walk-list p2 acc)))]
(match p
['() (cons EOS acc)]
[(cons p1 p2) (walk p1 (walk-list p2))]
[other (cons ILM (walk other (cons EOS acc)))]))))]
[(? vector? v) (cons SOV (vector-foldr walk (cons EOS acc) v))] [(? vector? v) (cons SOV (vector-foldr walk (cons EOS acc) v))]
[(embedded-matcher m) (error 'compile-projection "Cannot embed matcher in projection")] [(embedded-matcher m) (error 'compile-projection "Cannot embed matcher in projection")]
[(? non-object-struct?) [(? non-object-struct?)
@ -495,7 +503,12 @@
(cons t (foldr walk (cons EOS acc) fs))] (cons t (foldr walk (cons EOS acc) fs))]
;; TODO: consider options for treating hash tables as compounds rather than (useless) atoms ;; TODO: consider options for treating hash tables as compounds rather than (useless) atoms
[(? hash?) (error 'compile-projection "Cannot match on hash tables at present")] [(? hash?) (error 'compile-projection "Cannot match on hash tables at present")]
[other (cons other acc)]))) [other (cons other acc)]))
(walk-list ps '()))
(define (compile-projection . ps)
(compile-projection* ps))
(define (projection->pattern p) (define (projection->pattern p)
(let walk ((p p)) (let walk ((p p))
@ -553,7 +566,7 @@
['() ['()
(when capturing? (error 'matcher-project "Bad specification: unclosed capture")) (when capturing? (error 'matcher-project "Bad specification: unclosed capture"))
(match m (match m
[(success v) (rseq EOS (rseq EOS (rsuccess ((matcher-project-success) v))))] [(success v) (rseq EOS (rsuccess ((matcher-project-success) v)))]
[_ (matcher-empty)])] [_ (matcher-empty)])]
[(cons (== EOC) k) [(cons (== EOC) k)
@ -609,7 +622,7 @@
[_ (matcher-empty)]))])) [_ (matcher-empty)]))]))
(lambda (m spec) (lambda (m spec)
(rseq SOV (walk #f m spec))))) (walk #f m spec))))
(define (untransform-list-value vs) (define (untransform-list-value vs)
(match vs (match vs
@ -618,7 +631,7 @@
[(cons (== ILM) _) (error 'untransform-list-value "Illegal use of ILM" vs)] [(cons (== ILM) _) (error 'untransform-list-value "Illegal use of ILM" vs)]
[(cons v vs) (cons v (untransform-list-value vs))])) [(cons v vs) (cons v (untransform-list-value vs))]))
;; Matcher → (Option (Setof Value)) ;; Matcher → (Option (Setof (Listof Value)))
;; Multiplies out unions. Returns #f if any dimension of m is infinite. ;; Multiplies out unions. Returns #f if any dimension of m is infinite.
(define matcher-key-set (define matcher-key-set
(let () (let ()
@ -662,7 +675,7 @@
(k (for/set [(vs (in-set vss))] (k (for/set [(vs (in-set vss))]
(cons v vs)) (cons v vs))
vsk)))))]))))] vsk)))))]))))]
[_ (k (set) #f)])) ;; TODO: ?? [_ (k (set) #f)]))
;; (Listof Value) Sigma -> Value ;; (Listof Value) Sigma -> Value
(define (transform-seqs vs opener) (define (transform-seqs vs opener)
@ -675,7 +688,7 @@
(define (maybe-union s1 s2) (and s1 s2 (set-union s1 s2))) (define (maybe-union s1 s2) (and s1 s2 (set-union s1 s2)))
(lambda (m) (lambda (m)
(walk m (lambda (v k) (set v)))))) (walk-seq m (lambda (vss vsk) vss)))))
(define (struct-type-name st) (define (struct-type-name st)
(define-values (name x2 x3 x4 x5 x6 x7 x8) (struct-type-info st)) (define-values (name x2 x3 x4 x5 x6 x7 x8) (struct-type-info st))
@ -1153,32 +1166,32 @@
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a 'b))) (pattern->matcher SB (list 'a 'b)))
(compile-projection (list 'a (?!)))) (compile-projection (list 'a (?!))))
(matcher-union (pattern->matcher #t (vector 'a)) (matcher-union (pattern->matcher #t 'a)
(pattern->matcher #t (vector 'b)))) (pattern->matcher #t 'b)))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b 'c 'd)))) (pattern->matcher SB (list 'a (vector 'b 'c 'd))))
(compile-projection (list 'a (?!)))) (compile-projection (list 'a (?!))))
(matcher-union (pattern->matcher #t (vector 'a)) (matcher-union (pattern->matcher #t 'a)
(pattern->matcher #t (vector (vector 'b 'c 'd))))) (pattern->matcher #t (vector 'b 'c 'd))))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b ? 'd)))) (pattern->matcher SB (list 'a (vector 'b ? 'd))))
(compile-projection (list 'a (?!)))) (compile-projection (list 'a (?!))))
(matcher-union (pattern->matcher #t (vector 'a)) (matcher-union (pattern->matcher #t 'a)
(pattern->matcher #t (vector (vector 'b ? 'd))))) (pattern->matcher #t (vector 'b ? 'd))))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a 'b))) (pattern->matcher SB (list 'a 'b)))
(compile-projection (list 'a (?!))))) (compile-projection (list 'a (?!)))))
(set '#(a) '#(b))) (set '(a) '(b)))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b 'c 'd)))) (pattern->matcher SB (list 'a (vector 'b 'c 'd))))
(compile-projection (list 'a (?!))))) (compile-projection (list 'a (?!)))))
(set '#(a) '#(#(b c d)))) (set '(a) '(#(b c d))))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
@ -1190,13 +1203,13 @@
(matcher-project (matcher-union (pattern->matcher SA (list 'a 'a)) (matcher-project (matcher-union (pattern->matcher SA (list 'a 'a))
(pattern->matcher SB (list 'a (vector 'b ? 'd)))) (pattern->matcher SB (list 'a (vector 'b ? 'd))))
(compile-projection (list 'a (?! 'a))))) (compile-projection (list 'a (?! 'a)))))
(set '#(a))) (set '(a)))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA (cons 1 2)) (check-equal? (matcher-project (matcher-union (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 3 4))) (pattern->matcher SB (cons 3 4)))
(compile-projection (cons (?!) (?!)))) (compile-projection (cons (?!) (?!))))
(matcher-union (pattern->matcher #t (vector 1 2)) (matcher-union (pattern->matcher #t 1 2)
(pattern->matcher #t (vector 3 4)))) (pattern->matcher #t 3 4)))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
@ -1204,9 +1217,9 @@
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?!) (?!)))) (compile-projection (cons (?!) (?!))))
(foldr matcher-union (matcher-empty) (foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (vector 1 2)) (list (pattern->matcher #t 1 2)
(pattern->matcher #t (vector 1 4)) (pattern->matcher #t 1 4)
(pattern->matcher #t (vector 3 4))))) (pattern->matcher #t 3 4))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
@ -1214,9 +1227,9 @@
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (?! (cons ? ?)))) (compile-projection (?! (cons ? ?))))
(foldr matcher-union (matcher-empty) (foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (vector (cons 1 2))) (list (pattern->matcher #t (cons 1 2))
(pattern->matcher #t (vector (cons 1 4))) (pattern->matcher #t (cons 1 4))
(pattern->matcher #t (vector (cons 3 4)))))) (pattern->matcher #t (cons 3 4)))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
@ -1224,8 +1237,8 @@
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (?! (cons 1 ?)))) (compile-projection (?! (cons 1 ?))))
(foldr matcher-union (matcher-empty) (foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (vector (cons 1 2))) (list (pattern->matcher #t (cons 1 2))
(pattern->matcher #t (vector (cons 1 4)))))) (pattern->matcher #t (cons 1 4)))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
@ -1233,8 +1246,8 @@
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?! 1) (?!)))) (compile-projection (cons (?! 1) (?!))))
(foldr matcher-union (matcher-empty) (foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (vector 1 2)) (list (pattern->matcher #t 1 2)
(pattern->matcher #t (vector 1 4))))) (pattern->matcher #t 1 4))))
(check-equal? (matcher-project (foldr matcher-union (matcher-empty) (check-equal? (matcher-project (foldr matcher-union (matcher-empty)
(list (pattern->matcher SA (cons 1 2)) (list (pattern->matcher SA (cons 1 2))
@ -1242,8 +1255,8 @@
(pattern->matcher SC (cons 3 4)))) (pattern->matcher SC (cons 3 4))))
(compile-projection (cons (?!) (?! 4)))) (compile-projection (cons (?!) (?! 4))))
(foldr matcher-union (matcher-empty) (foldr matcher-union (matcher-empty)
(list (pattern->matcher #t (vector 1 4)) (list (pattern->matcher #t 1 4)
(pattern->matcher #t (vector 3 4))))) (pattern->matcher #t 3 4))))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (foldr matcher-union (matcher-empty) (matcher-project (foldr matcher-union (matcher-empty)
@ -1259,18 +1272,18 @@
(pattern->matcher SC (cons 1 3)) (pattern->matcher SC (cons 1 3))
(pattern->matcher SB (cons 3 4)))) (pattern->matcher SB (cons 3 4))))
(compile-projection (cons ? (?!))))) (compile-projection (cons ? (?!)))))
(set '#(2) '#(3) '#(4))) (set '(2) '(3) '(4)))
(check-equal? (matcher-key-set (check-equal? (matcher-key-set
(matcher-project (matcher-union (pattern->matcher SA (cons 1 2)) (matcher-project (matcher-union (pattern->matcher SA (cons 1 2))
(pattern->matcher SB (cons 3 4))) (pattern->matcher SB (cons 3 4)))
(compile-projection (cons (?!) (?!))))) (compile-projection (cons (?!) (?!)))))
(set '#(1 2) '#(3 4)))) (set '(1 2) '(3 4))))
(check-equal? (matcher-project (matcher-union (pattern->matcher SA ?) (check-equal? (matcher-project (matcher-union (pattern->matcher SA ?)
(pattern->matcher SB (list 'a))) (pattern->matcher SB (list 'a)))
(compile-projection (?! (list (list ?))))) (compile-projection (?! (list (list ?)))))
(pattern->matcher SA (vector (list (list ?))))) (pattern->matcher SA (list (list ?))))
(check-equal? (projection->pattern (list 'a 'b)) (list 'a 'b)) (check-equal? (projection->pattern (list 'a 'b)) (list 'a 'b))
(check-equal? (projection->pattern (list 'a ?)) (list 'a ?)) (check-equal? (projection->pattern (list 'a ?)) (list 'a ?))