From 0a6cce2d3d47b60a102dddc2747b22870b511f95 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Sun, 24 Jan 2016 00:03:59 -0500
Subject: [PATCH] on-claim fix for incremental, on-claim impl for monolithic

---
 prospect-monolithic/demand-matcher.rkt | 41 +++++++++++++++++++++++++-
 prospect/demand-matcher.rkt            |  4 +--
 2 files changed, 42 insertions(+), 3 deletions(-)

diff --git a/prospect-monolithic/demand-matcher.rkt b/prospect-monolithic/demand-matcher.rkt
index c6835bb..17558c6 100644
--- a/prospect-monolithic/demand-matcher.rkt
+++ b/prospect-monolithic/demand-matcher.rkt
@@ -10,7 +10,8 @@
 (provide (except-out (struct-out demand-matcher) demand-matcher)
 	 (rename-out [make-demand-matcher demand-matcher])
 	 demand-matcher-update
-	 spawn-demand-matcher)
+	 spawn-demand-matcher
+         on-claim)
 
 ;; A DemandMatcher keeps track of demand for services based on some
 ;; Projection over a Trie, as well as a collection of functions
@@ -110,6 +111,44 @@
                     (subscription (projection->pattern supply-spec) #:meta-level meta-level)
                     (advertisement (projection->pattern supply-spec) #:meta-level meta-level))))
 
+;; (Trie (Option (Setof (Listof Value))) ... -> (Option (Constreeof Action)))
+;;    Trie Projection ...
+;; -> Action
+;; Spawns a process that observes the given projections. Any time the
+;; environment's interests change in a relevant way, calls
+;; check-and-maybe-spawn-fn with the aggregate interests and the
+;; projection results. If check-and-maybe-spawn-fn returns #f,
+;; continues to wait; otherwise, takes the action(s) returned, and
+;; quits.
+(define (on-claim #:timeout-msec [timeout-msec #f]
+                  #:on-timeout [timeout-handler (lambda () '())]
+                  check-and-maybe-spawn-fn
+                  base-interests
+                  . projections)
+  (define timer-id (gensym 'on-claim))
+  (define (on-claim-handler e state)
+    (match e
+      [(scn new-aggregate)
+       (define projection-results
+         (map (lambda (p) (trie-project/set new-aggregate (compile-projection p))) projections))
+       (define maybe-spawn (apply check-and-maybe-spawn-fn
+                                  new-aggregate
+                                  projection-results))
+       (if maybe-spawn
+           (quit maybe-spawn)
+           #f)]
+      [(message (timer-expired (== timer-id) _))
+       (quit (timeout-handler))]
+      [_ #f]))
+  (list
+   (when timeout-msec (message (set-timer timer-id timeout-msec 'relative)))
+   (spawn on-claim-handler
+          (void)
+          (scn/union base-interests
+                     (assertion-set-union*
+                      (map (lambda (p) (subscription (projection->pattern p))) projections))
+                     (subscription (timer-expired timer-id ?))))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define (pretty-print-demand-matcher s [p (current-output-port)])
diff --git a/prospect/demand-matcher.rkt b/prospect/demand-matcher.rkt
index 81a2029..5762601 100644
--- a/prospect/demand-matcher.rkt
+++ b/prospect/demand-matcher.rkt
@@ -127,7 +127,7 @@
       [(? patch? p)
        (define new-aggregate (update-interests current-aggregate p))
        (define projection-results
-         (map (lambda (p) (trie-project/set new-aggregate p)) projections))
+         (map (lambda (p) (trie-project/set new-aggregate (compile-projection p))) projections))
        (define maybe-spawn (apply check-and-maybe-spawn-fn
                                   new-aggregate
                                   projection-results))
@@ -142,7 +142,7 @@
    (spawn on-claim-handler
           (trie-empty)
           (patch-seq (patch base-interests (trie-empty))
-                     (patch-seq* (map projection->pattern projections))
+                     (patch-seq* (map (lambda (p) (sub projection->pattern)) projections))
                      (sub (timer-expired timer-id ?))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;