From 75aee96e1a7f3840ca322bf456467d9401c56bd5 Mon Sep 17 00:00:00 2001
From: Tony Garnock-Jones <tonygarnockjones@gmail.com>
Date: Tue, 1 Aug 2017 17:45:19 -0400
Subject: [PATCH] query-count

---
 racket/syndicate/actor.rkt | 31 +++++++++++++++++++++++++++++++
 1 file changed, 31 insertions(+)

diff --git a/racket/syndicate/actor.rkt b/racket/syndicate/actor.rkt
index 6de0c72..2092a22 100644
--- a/racket/syndicate/actor.rkt
+++ b/racket/syndicate/actor.rkt
@@ -38,14 +38,17 @@
          query-set
          query-hash
          query-hash-set
+         query-count
          query-value*
          query-set*
          query-hash*
          query-hash-set*
+         query-count*
          define/query-value
          define/query-set
          define/query-hash
          define/query-hash-set
+         define/query-count
          immediate-query
 
          send!
@@ -681,10 +684,38 @@
                  (F (hashset-remove (F) K V)))))
          F))]))
 
+(define-syntax (query-count stx)
+  (syntax-parse stx
+    [(_ field-name args ...)
+     (quasisyntax/loc stx
+       (let ()
+         (field [field-name (hash)])
+         (query-count* field-name args ...)))]))
+
+(define-syntax (query-count* stx)
+  (syntax-parse stx
+    [(_ field-name P expr on-add:on-add on-remove:on-remove)
+     (quasisyntax/loc stx
+       (let ((F field-name))
+         (on (asserted P) #:priority *query-priority*
+             (let ((E expr))
+               #,@(schedule-query-handler-stxs (attribute on-add.expr))
+               (F (hash-set (F) E (+ 1 (hash-ref (F) E 0))))))
+         (on (retracted P) #:priority *query-priority-high*
+             (let ((E expr))
+               #,@(schedule-query-handler-stxs (attribute on-remove.expr))
+               (let ((F0 (F)))
+                 (F (match (hash-ref F0 E 0)
+                      [0 F0] ;; huh
+                      [1 (hash-remove F0 E)]
+                      [n (hash-set F0 E (- n 1))])))))
+         F))]))
+
 (define-syntax-rule (define/query-value id ae P x ...) (define id (query-value id ae P x ...)))
 (define-syntax-rule (define/query-set id P x ...) (define id (query-set id P x ...)))
 (define-syntax-rule (define/query-hash id P x ...) (define id (query-hash id P x ...)))
 (define-syntax-rule (define/query-hash-set id P x ...) (define id (query-hash-set id P x ...)))
+(define-syntax-rule (define/query-count id P x ...) (define id (query-count id P x ...)))
 
 (define-syntax (immediate-query stx)
   (syntax-case stx ()