#lang syndicate/monolithic, integrated with incremental

racket/syndicate/core.rkt

@@ -39,6 +39,7 @@
          meta-label?
 
          prepend-at-meta
+         observe-at-meta
          assert
          retract
          sub

racket/syndicate/examples/bank-account-monolithic.rkt

@@ -0,0 +1,24 @@
+#lang syndicate/monolithic
+;; Hello-worldish "bank account" example.
+
+(struct account (balance) #:prefab)
+(struct deposit (amount) #:prefab)
+
+(define (manager e balance)
+  (match-event e
+    [(message (deposit amount))
+     (transition (+ balance amount)
+                 (scn (assertion (account (+ balance amount)))))]))
+
+(define (observer e _)
+  (when (scn? e) (for [(balance (project-assertions (scn-trie e) (account (?!))))]
+                   (printf "Balance changed to ~a\n" balance))))
+
+(define (updater e _)
+  (when (and (scn? e) (trie-non-empty? (scn-trie e)))
+    (quit (list (message (deposit +100))
+                (message (deposit -30))))))
+
+(spawn manager 0 (scn/union (assertion (observe (deposit ?))) (assertion (account 0))))
+(spawn observer (void) (scn (assertion (observe (account ?)))))
+(spawn updater (void) (scn (assertion (observe (observe (deposit ?))))))

racket/syndicate/monolithic.rkt

@@ -0,0 +1,15 @@
+#lang racket/base
+
+(module reader syntax/module-reader
+  syndicate/monolithic)
+
+(require (except-in "lang.rkt"
+                    event?
+                    action?
+                    clean-transition
+                    spawn))
+(require "monolithic/scn.rkt")
+(require "monolithic/core.rkt")
+(provide (all-from-out "lang.rkt")
+         (all-from-out "monolithic/scn.rkt")
+         (all-from-out "monolithic/core.rkt"))

racket/syndicate/monolithic/core.rkt

@@ -0,0 +1,138 @@
+#lang racket/base
+;; Monolithic Syndicate adapter.
+
+(provide event?
+         action?
+         clean-transition
+
+         assertion
+         subscription
+         advertisement
+
+         assertion-set-union
+         assertion-set-union*
+         scn/union
+
+         (struct-out monolithic-wrapper)
+         wrap-monolithic-state
+         wrap-monolithic-behaviour
+         (rename-out [spawn-monolithic spawn]))
+
+(require racket/match)
+(require (only-in racket/list flatten))
+
+(require "scn.rkt")
+(require "../trie.rkt")
+(require (except-in "../core.rkt"
+                    event?
+                    action?
+                    clean-transition))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (event? x) (or (scn? x) (message? x)))
+(define (action? x) (or (event? x) (spawn? x) (quit-dataspace? x)))
+
+(define (clean-transition t)
+  (match t
+    [#f #f]
+    [(<quit> exn actions) (quit exn (clean-actions actions))]
+    [(transition state actions) (transition state (clean-actions actions))]
+    [(? void?) #f]))
+
+(define (clean-actions actions)
+  (filter action? (flatten actions)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (assertion pattern #:meta-level [level 0])
+  (pattern->trie '<assertion> (prepend-at-meta pattern level)))
+
+(define (subscription pattern #:meta-level [level 0])
+  (observe-at-meta pattern level))
+
+(define (advertisement pattern #:meta-level [level 0])
+  (assertion (advertise pattern) #:meta-level level))
+
+(define (assertion-set-union . tries)
+  (assertion-set-union* tries))
+
+(define (assertion-set-union* tries)
+  (match tries
+    ['() trie-empty]
+    [(cons t1 rest)
+     (for/fold [(t1 t1)] [(t2 (in-list rest))]
+       (trie-union t1 t2 #:combiner (lambda (a b) (trie-success '<assertion-set-union*>))))]))
+
+(define (scn/union . tries)
+  (scn (assertion-set-union* tries)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(struct monolithic-wrapper (state assertions-in assertions-out) #:prefab)
+
+(define (wrap-monolithic-state underlying-state)
+  (monolithic-wrapper underlying-state trie-empty trie-empty))
+
+(define (integrate-incoming incremental-e wrapped-state)
+  (match incremental-e
+    [(? patch? p)
+     (define new-assertions-in
+       (update-interests (monolithic-wrapper-assertions-in wrapped-state) p))
+     (values (struct-copy monolithic-wrapper wrapped-state
+                          [assertions-in new-assertions-in])
+             (scn new-assertions-in))]
+    [(or (? message?) #f)
+     (values wrapped-state incremental-e)]))
+
+(define (differentiate-outgoing wrapped-state monolithic-actions)
+  (let loop ((assertions-out (monolithic-wrapper-assertions-out wrapped-state))
+             (actions-remaining monolithic-actions)
+             (incremental-actions-rev '()))
+    (match actions-remaining
+      ['()
+       (transition (struct-copy monolithic-wrapper wrapped-state
+                                [assertions-out assertions-out])
+                   (reverse incremental-actions-rev))]
+      [(cons monolithic-action rest)
+       (match monolithic-action
+         [(scn new-interests)
+          (loop new-interests
+                rest
+                (cons (compute-patch assertions-out new-interests) incremental-actions-rev))]
+         [other
+          (loop assertions-out
+                rest
+                (cons other incremental-actions-rev))])])))
+
+(define (wrap-monolithic-behaviour underlying-behavior)
+  (lambda (incremental-e wrapped-state0)
+    (define-values (wrapped-state monolithic-e) (integrate-incoming incremental-e wrapped-state0))
+    (match (clean-transition
+            (underlying-behavior monolithic-e (monolithic-wrapper-state wrapped-state)))
+      [#f (if (eq? wrapped-state wrapped-state0)
+              #f
+              (transition wrapped-state '()))]
+      [(<quit> exn monolithic-actions)
+       (match-define (transition _ignored-final-state incremental-actions)
+         (differentiate-outgoing wrapped-state monolithic-actions))
+       (<quit> exn incremental-actions)]
+      [(transition new-underlying-state monolithic-actions)
+       (differentiate-outgoing (struct-copy monolithic-wrapper wrapped-state
+                                            [state new-underlying-state])
+                               monolithic-actions)])))
+
+(define-syntax spawn-monolithic
+  (syntax-rules ()
+    [(_ #:name name-exp behavior-exp initial-state-exp initial-action-tree-exp)
+     (<spawn> (lambda ()
+                (list (wrap-monolithic-behaviour behavior-exp)
+                      (differentiate-outgoing (wrap-monolithic-state initial-state-exp)
+                                              (clean-actions initial-action-tree-exp))
+                      name-exp)))]
+    [(_ behavior-exp initial-state-exp initial-action-tree-exp)
+     (<spawn> (lambda ()
+                (list (wrap-monolithic-behaviour behavior-exp)
+                      (differentiate-outgoing (wrap-monolithic-state initial-state-exp)
+                                              (clean-actions initial-action-tree-exp))
+                      #f)))]))

racket/syndicate/monolithic/scn.rkt

@@ -0,0 +1,36 @@
+#lang racket/base
+;; State Change Notifications, and assorted protocol constructors
+
+(provide (struct-out scn)
+         lift-scn
+         drop-scn
+         strip-scn
+         label-scn)
+
+(require racket/set)
+(require racket/match)
+(require "../trie.rkt")
+(require "../patch.rkt")
+(require "../pretty.rkt")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; State Change Notifications
+(struct scn (trie) #:transparent
+  #:methods gen:syndicate-pretty-printable
+  [(define (syndicate-pretty-print d [p (current-output-port)])
+     (pretty-print-trie (scn-trie d) p))])
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (lift-scn s)
+  (scn (pattern->trie '<lift-scn> (at-meta (embedded-trie (scn-trie s))))))
+
+(define (drop-scn s)
+  (scn (drop-interests (scn-trie s))))
+
+(define (strip-scn s)
+  (scn (strip-interests (scn-trie s))))
+
+(define (label-scn s label)
+  (scn (label-interests (scn-trie s) label)))

racket/syndicate/patch.rkt

@@ -13,6 +13,7 @@
          patch/added?
          patch/removed?
          lift-patch
+         drop-interests
          drop-patch
          strip-interests
          label-interests