Adapt route.rkt to use sorted-map; doesn't work, because they don't have canonical forms

info.rkt

@@ -7,4 +7,5 @@
 	       "net-lib"
 	       "profile-lib"
 	       "rackunit-lib"
+	       "web-server-lib"
 	       ))

minimart/actor.rkt

@@ -37,8 +37,8 @@
 
 (define-syntax (actor stx)
   (syntax-case stx ()
-    [(_actor forms ...)
+    [(_ forms ...)
-     (analyze-actor #'_actor #'(forms ...))]))
+     (analyze-actor #'(forms ...))]))
 
 (define-syntax (observe-gestalt stx) (raise-syntax-error #f "Use of observe-gestalt outside actor form" stx))
 (define-syntax (observe-subscribers stx) (raise-syntax-error #f "Use of observe-subscribers outside actor form" stx))
@@ -137,7 +137,7 @@
 
  (struct participator (condition meta-level) #:transparent)
 
- (define (analyze-actor actor-form-head-stx forms-stx)
+ (define (analyze-actor forms-stx)
    (define actor-name #f)
 
    ;; (Listof Identifier)
@@ -289,7 +289,7 @@
 
      (push! gestalt-updaters
 	    #`(begin
-		(define #,gestalt-init (label-gestalt #,gestalt-stx #t))
+		(define #,gestalt-init #,gestalt-stx)
 		#:update [#,gestalt-name #,gestalt-init]))
 
      (push! gestalt-fragments gestalt-name)
@@ -436,7 +436,7 @@
 				       #`(#:when #,condition)
 				       #'())
 				(#,(if pub? #'pub #'sub) #,gestalt-stx
-				 #:meta-level #,(or meta-level 0))))))
+				 #:meta-level #,meta-level)))))
 
    (define (push-action! action-stx)
      (define-temporaries [temp action-stx])
@@ -446,7 +446,7 @@
    (define (build-result)
      (let ((actor-name (or actor-name #'anonymous-actor)))
        (define state-struct-name
-	 (datum->syntax actor-form-head-stx (string->symbol (format "~a-state" (syntax->datum actor-name)))))
+	 (datum->syntax actor-name (string->symbol (format "~a-state" (syntax->datum actor-name)))))
        (define-temporaries
 	 [e-stx #'event]
 	 [state-stx #'state]

minimart/broker/client.rkt

@@ -1,105 +0,0 @@
-#lang racket/base
-;; Remote VM link.
-
-(provide spawn-broker-client)
-
-(require racket/match)
-(require net/rfc6455)
-(require "../main.rkt")
-(require "../route.rkt")
-(require "../gestalt.rkt")
-(require "../drivers/timer.rkt")
-(require "../drivers/websocket.rkt")
-(require "../deduplicator.rkt")
-(require json)
-(require "protocol.rkt")
-
-(define (collect-matchers label advertisements? level g)
-  (define projector (if advertisements? project-pubs project-subs))
-  (define extract-metalevels (projector (list label (?!) ?) #:level level))
-  (define mls (gestalt-project/single g extract-metalevels))
-  (for/fold [(result (gestalt-empty))] [(metalevel mls)]
-    (define m (gestalt-project g (projector (list label metalevel (?!)))))
-    (gestalt-union result (simple-gestalt advertisements? (embedded-matcher m) level metalevel))))
-
-(define (lift-matcher-into-labelled-space m label metalevel)
-  (pattern->matcher #t (list label metalevel (embedded-matcher m))))
-
-(define (lift-gestalt-into-labelled-space g label)
-  (gestalt-transform g (lambda (ml l matchers)
-			 (cons (lift-matcher-into-labelled-space (car matchers) label ml)
-			       (lift-matcher-into-labelled-space (cdr matchers) label ml)))))
-
-(define (spawn-broker-client label url)
-  (define client-id (websocket-local-client (list 'broker-client label)))
-  (define server-id (websocket-remote-server url))
-  (actor #:name broker-client
-	 #:state [local-gestalt (gestalt-empty)]
-	 #:state [peer-gestalt (gestalt-empty)]
-	 #:state [deduplicator (make-deduplicator)]
-	 #:state [seen-remote? #f]
-
-	 (send (set-timer client-id (ping-interval) 'relative))
-	 (subscribe (timer-expired client-id ?)
-	   (send (set-timer client-id (ping-interval) 'relative))
-	   (send-action 'ping))
-
-	 (advertise (websocket-message client-id server-id ?))
-	 (subscribe (websocket-message server-id client-id ($ data))
-	   #:run-transition
-	   (match (drop-json-event (string->jsexpr data))
-	     [(routing-update new-peer-gestalt)
-	      (begin-transition
-		#:run-transition (if (equal? peer-gestalt new-peer-gestalt)
-				     (begin-transition)
-				     (begin-transition
-				       #:update [peer-gestalt new-peer-gestalt]
-				       #:update-routes)))]
-	     [(? message? m (message body meta-level feedback?))
-	      (begin-transition
-		(define-values (fresh? d) (deduplicator-accept deduplicator m))
-		#:update [deduplicator d]
-		(when fresh? (message (list label meta-level body) 0 feedback?)))]
-	     ['ping
-	      (begin-transition (send-action 'pong))]
-	     ['pong
-	      (begin-transition)]))
-
-	 (observe-advertisers (websocket-message server-id client-id ?)
-	   #:presence peer-connected?
-	   (when (and seen-remote? (not peer-connected?)) (quit)) ;; TODO: reconnect
-	   #:update [seen-remote? (or seen-remote? peer-connected?)])
-
-	 (observe-gestalt
-	     (gestalt-union (pub (list label ? ?) #:level 10)
-			    (sub (list label ? ?) #:level 10)
-			    ;; TODO: ^ level 10 is ad-hoc; support
-			    ;; infinity at some point in future
-			    (lift-gestalt-into-labelled-space peer-gestalt label))
-	   [(routing-update g)
-	    (local-require "../trace.rkt")
-	    (define current-pid (car (trace-pid-stack))) ;; EWWWWW
-	    ;; TODO: gross - erasing by pid!
-	    (define level-count (gestalt-level-count g 0))
-	    (define to-subtract (label-gestalt (gestalt-full 1 level-count) current-pid))
-	    #:run-transition
-	    (let ((g (gestalt-subtract g to-subtract)))
-	      (define new-local-gestalt
-		(for/fold [(new-local-gestalt (gestalt-empty))] [(level level-count)]
-		  (gestalt-union new-local-gestalt
-				 (collect-matchers label #f level g)
-				 (collect-matchers label #t level g))))
-	      (if (equal? local-gestalt new-local-gestalt)
-		  (begin-transition)
-		  (begin-transition
-		    #:update [local-gestalt new-local-gestalt]
-		    (send-action (routing-update local-gestalt)))))]
-	   [(message (list (== label) meta-level body) 0 feedback?)
-	    (define m (message body meta-level feedback?))
-	    (define-values (fresh? d) (deduplicator-accept deduplicator m))
-	    #:update [deduplicator d]
-	    (when fresh? (send-action m))])
-
-	 (define (send-action e)
-	   (define s (jsexpr->string (lift-json-action e)))
-	   (send (websocket-message client-id server-id s)))))

minimart/broker/protocol.rkt

@@ -1,40 +0,0 @@
-#lang racket/base
-;; Generic protocol for WebSockets/TCP/etc-based participation in a network.
-
-(provide drop-json-action
-	 lift-json-event
-	 lift-json-action
-	 drop-json-event
-	 ping-interval)
-
-(require net/rfc6455)
-(require racket/set)
-(require racket/match)
-(require "../main.rkt")
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Wire protocol representation of events and actions
-
-(define (drop j)
-  (match j
-    ["ping" 'ping]
-    ["pong" 'pong]
-    [`("routes" ,gj) (routing-update (jsexpr->gestalt gj (lambda (v) (set 'peer))))]
-    [`("message" ,body ,meta-level ,feedback?) (message body meta-level feedback?)]))
-
-(define (lift j)
-  (match j
-    ['ping "ping"]
-    ['pong "pong"]
-    [(routing-update g) `("routes" ,(gestalt->jsexpr g (lambda (v) #t)))]
-    [(message body meta-level feedback?) `("message" ,body ,meta-level ,feedback?)]))
-
-(define drop-json-action drop)
-(define lift-json-event lift)
-(define lift-json-action lift)
-(define drop-json-event drop)
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Connections
-
-(define (ping-interval) (* 1000 (max (- (ws-idle-timeout) 10) (* (ws-idle-timeout) 0.8))))

minimart/core.rkt

@@ -8,7 +8,6 @@
 (require "gestalt.rkt")
 (require "functional-queue.rkt")
 (require "trace.rkt")
-(require "tset.rkt")
 
 (provide (struct-out routing-update)
 	 (struct-out message)
@@ -463,12 +462,12 @@
     [(message body meta-level feedback?)
      (define pids (gestalt-match-value (world-partial-gestalt w) body meta-level feedback?))
      (define pt (world-process-table w))
-     (for/fold ([w w]) [(pid (in-list (tset->list pids)))] (step-process e pid (hash-ref pt pid) w))]
+     (for/fold ([w w]) [(pid (in-set pids))] (step-process e pid (hash-ref pt pid) w))]
     [(pending-routing-update g affected-subgestalt known-target)
      (define affected-pids (gestalt-match affected-subgestalt g))
      (define pt (world-process-table w))
      (for/fold ([w w])
-	 [(pid (in-list (tset->list (if known-target (tset-add affected-pids known-target) affected-pids))))]
+	 [(pid (in-set (if known-target (set-add affected-pids known-target) affected-pids)))]
        (match (hash-ref pt pid (lambda () #f))
 	 [#f w]
 	 [p (step-process (routing-update (gestalt-filter g (process-gestalt p))) pid p w)]))]))

minimart/deduplicator.rkt

@@ -1,36 +0,0 @@
-#lang racket/base
-
-(provide (struct-out deduplicator)
-	 make-deduplicator
-	 deduplicator-accept
-	 deduplicator-expire)
-
-(require racket/set)
-(require racket/match)
-(require "functional-queue.rkt")
-
-(struct deduplicator (queue table ttl) #:transparent)
-
-(define (make-deduplicator [ttl 10000])
-  (deduplicator (make-queue) (set) ttl))
-
-(define (deduplicator-expire d)
-  (define now (current-inexact-milliseconds))
-  (let loop ((d d))
-    (match-define (deduplicator queue table ttl) d)
-    (if (queue-empty? queue)
-	d
-	(let-values (((v q1) (dequeue queue)))
-	  (if (<= (car v) now)
-	      (loop (deduplicator q1 (set-remove table (cdr v)) ttl))
-	      d)))))
-
-(define (deduplicator-accept d incoming)
-  (let* ((d (deduplicator-expire d)))
-    (match-define (deduplicator queue table ttl) d)
-    (if (set-member? table incoming)
-	(values #f d)
-	(values #t (deduplicator (enqueue queue
-					  (cons (+ (current-inexact-milliseconds) ttl) incoming))
-				 (set-add table incoming)
-				 ttl)))))

minimart/drivers/tcp.rkt

@@ -3,9 +3,9 @@
 (require racket/match)
 (require (prefix-in tcp: racket/tcp))
 (require (only-in racket/port read-bytes-avail!-evt))
+(require (only-in web-server/private/util exn->string))
 (require "../main.rkt")
 (require "../demand-matcher.rkt")
-(require "../exn-util.rkt")
 
 (require racket/unit)
 (require net/tcp-sig)
@@ -89,7 +89,7 @@
 
 (define (spawn-tcp-listener server-addr)
   (match-define (tcp-listener port) server-addr)
-  (define listener (tcp:tcp-listen port 128 #t))
+  (define listener (tcp:tcp-listen port 4 #t))
   (define control-ch (make-channel))
   (thread (lambda () (tcp-listener-thread control-ch listener server-addr)))
   (spawn tcp-listener-behavior

minimart/drivers/websocket.rkt

@@ -10,12 +10,9 @@
 (require net/tcp-sig)
 (require net/tcp-unit)
 (require net/ssl-tcp-unit)
-(require net/url)
 
 (provide (struct-out websocket-remote-client)
 	 (struct-out websocket-local-server)
-	 (struct-out websocket-local-client)
-	 (struct-out websocket-remote-server)
 	 (struct-out websocket-ssl-options)
 	 (struct-out websocket-message)
 	 spawn-websocket-driver)
@@ -25,31 +22,24 @@
 
 (struct websocket-remote-client (id) #:prefab)
 (struct websocket-local-server (port ssl-options) #:prefab)
-(struct websocket-local-client (id) #:prefab)
-(struct websocket-remote-server (url) #:prefab)
 (struct websocket-ssl-options (cert-file key-file) #:prefab)
 (struct websocket-message (from to body) #:prefab)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Ground-level communication messages
 
-(struct websocket-connection (id local-addr remote-addr connection control-ch) #:prefab)
+(struct websocket-accepted (id server-addr connection control-ch) #:prefab)
 (struct websocket-incoming-message (id message) #:prefab)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Driver
 
 (define (spawn-websocket-driver)
-  (list
+  (spawn-demand-matcher (websocket-message ? (?! (websocket-local-server ? ?)) ?)
-   (spawn-demand-matcher (websocket-message ? (?! (websocket-local-server ? ?)) ?)
+			#:demand-is-subscription? #t
-			 #:demand-is-subscription? #t
+			#:demand-level 1
-			 #:demand-level 1
+			#:supply-level 2
-			 #:supply-level 2
+			spawn-websocket-listener))
-			 spawn-websocket-listener)
-   (spawn-demand-matcher (websocket-message (?! (websocket-local-client ?))
-					    (?! (websocket-remote-server ?))
-					    ?)
-			 spawn-websocket-connection)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Listener
@@ -64,19 +54,16 @@
 	 (begin (when shutdown-procedure (shutdown-procedure))
 		(transition (struct-copy listener-state state [shutdown-procedure #f]) (quit)))
 	 #f)]
-    [(message (websocket-connection id local-addr remote-addr c control-ch) 1 #f)
+    [(message (websocket-accepted id _ c control-ch) 1 #f)
-     (transition state (spawn-connection local-addr remote-addr id c control-ch))]
+     (transition state
+		 (spawn-connection (listener-state-server-addr state) id c control-ch))]
     [_ #f]))
 
 (define ((connection-handler server-addr) c dummy-state)
   (define control-ch (make-channel))
-  (define id (gensym 'ws))
-  (send-ground-message
-   (websocket-connection id server-addr (websocket-remote-client id) c control-ch))
-  (connection-thread-loop control-ch c id))
-
-(define (connection-thread-loop control-ch c id)
   (define c-input-port (ws-conn-base-ip c))
+  (define id (gensym 'ws))
+  (send-ground-message (websocket-accepted id server-addr c control-ch))
   (let loop ((blocked? #t))
     (sync (handle-evt control-ch
 		      (match-lambda
@@ -86,9 +73,7 @@
 	      never-evt
 	      (handle-evt c-input-port
 			  (lambda (dummy)
-			    (define msg
+			    (define msg (ws-recv c #:payload-type 'text))
-			      (with-handlers ([exn:fail:network? (lambda (e) eof)])
-				(ws-recv c #:payload-type 'text)))
 			    (send-ground-message (websocket-incoming-message id msg))
 			    (loop (or blocked? (eof-object? msg))))))))
   (ws-close! c))
@@ -111,37 +96,12 @@
   (spawn websocket-listener
 	 (listener-state shutdown-procedure server-addr)
 	 (gestalt-union (pub (websocket-message ? server-addr ?) #:level 2)
-			(sub (websocket-connection ? server-addr ? ? ?) #:meta-level 1))))
+			(sub (websocket-accepted ? server-addr ? ?) #:meta-level 1))))
-
-(define (spawn-websocket-connection local-addr remote-addr)
-  (match-define (websocket-remote-server url) remote-addr)
-  (define id (gensym 'ws))
-  (define control-ch (make-channel))
-  (thread
-   (lambda ()
-     (log-info "Connecting to ~a ~a" url (current-inexact-milliseconds))
-     (define c (with-handlers [(exn? values)] (ws-connect (string->url url))))
-     (log-info "Connected to ~a ~a" url (current-inexact-milliseconds))
-     (send-ground-message
-      (websocket-connection id local-addr remote-addr c control-ch))
-     (when (not (exn? c))
-       (connection-thread-loop control-ch c id))))
-  (actor #:state [buffered-messages-rev '()]
-
-	 (subscribe (websocket-connection id local-addr remote-addr ($ c) control-ch)
-	   #:meta-level 1
-	   (list (when (not (exn? c))
-		   (for [(m (reverse buffered-messages-rev))] (ws-send! c m))
-		   (spawn-connection local-addr remote-addr id c control-ch))
-		 (quit)))
-
-	 (subscribe (websocket-message local-addr remote-addr ($ m))
-	   #:update [buffered-messages-rev (cons m buffered-messages-rev)])))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Connection
 
-(struct connection-state (seen-peer? local-addr remote-addr c control-ch) #:transparent)
+(struct connection-state (seen-peer? local-addr server-addr c control-ch) #:transparent)
 
 (define (shutdown-connection state)
   (transition (match (connection-state-control-ch state)
@@ -150,17 +110,15 @@
 		    (struct-copy connection-state state [control-ch #f])])
 	      (quit)))
 
-(define (websocket-connection-behaviour e state)
+(define (websocket-connection e state)
   (with-handlers [((lambda (exn) #t)
-		   (lambda (exn)
+		   (lambda (exn) (shutdown-connection state)))]
-		     (shutdown-connection state)
-		     (raise exn)))]
     (match e
       [(message (websocket-incoming-message _ m) 1 #f)
        (if (eof-object? m)
 	   (shutdown-connection state)
-	   (transition state (send (websocket-message (connection-state-remote-addr state)
+	   (transition state (send (websocket-message (connection-state-local-addr state)
-						      (connection-state-local-addr state)
+						      (connection-state-server-addr state)
 						      m))))]
       [(message (websocket-message _ _ m) 0 #f)
        (ws-send! (connection-state-c state) m)
@@ -176,10 +134,11 @@
 	 #f])]
       [#f #f])))
 
-(define (spawn-connection local-addr remote-addr id c control-ch)
+(define (spawn-connection server-addr id c control-ch)
-  (spawn websocket-connection-behaviour
+  (define local-addr (websocket-remote-client id))
-	 (connection-state #f local-addr remote-addr c control-ch)
+  (spawn websocket-connection
-	 (gestalt-union (pub (websocket-message remote-addr local-addr ?))
+	 (connection-state #f local-addr server-addr c control-ch)
-			(sub (websocket-message local-addr remote-addr ?))
+	 (gestalt-union (pub (websocket-message local-addr server-addr ?))
-			(sub (websocket-message local-addr remote-addr ?) #:level 1)
+			(sub (websocket-message server-addr local-addr ?))
+			(sub (websocket-message server-addr local-addr ?) #:level 1)
 			(sub (websocket-incoming-message id ?) #:meta-level 1))))

minimart/examples/broker-client-ping.rkt

@@ -1,22 +0,0 @@
-#lang minimart
-;; Connects to the generic broker; use with broker.rkt and broker-client-pong.rkt.
-
-(require minimart/drivers/timer)
-(require minimart/drivers/websocket)
-(require minimart/broker/client)
-
-(spawn-timer-driver)
-(spawn-websocket-driver)
-(spawn-broker-client "broker" "ws://localhost:8000/")
-
-(actor (advertise `("broker" 0 ("ping" ,?)))
-       (subscribe `("broker" 0 ("pong" ,?))
-	 (log-info "Got pong - sending ping")
-	 (send `("broker" 0 ("ping" ,(current-inexact-milliseconds))))))
-
-(actor (observe-subscribers `("broker" 0 ("ping" ,?))
-	 #:presence time-to-start?
-	 (when time-to-start?
-	   (log-info "---------------------------------------- KICKING OFF")
-	   (list (send `("broker" 0 ("ping" ,(current-inexact-milliseconds))))
-		 (quit)))))

minimart/examples/broker-client-pong.rkt

@@ -1,15 +0,0 @@
-#lang minimart
-;; Connects to the generic broker; use with broker.rkt and broker-client-ping.rkt.
-
-(require minimart/drivers/timer)
-(require minimart/drivers/websocket)
-(require minimart/broker/client)
-
-(spawn-timer-driver)
-(spawn-websocket-driver)
-(spawn-broker-client "broker" "ws://localhost:8000/")
-
-(actor (advertise `("broker" 0 ("pong" ,?)))
-       (subscribe `("broker" 0 ("ping" ,?))
-	 (log-info "Got ping - sending pong")
-	 (send `("broker" 0 ("pong" ,(current-inexact-milliseconds))))))

minimart/examples/broker.rkt

@@ -3,10 +3,10 @@
 
 (require minimart/drivers/timer)
 (require minimart/drivers/websocket)
-(require minimart/broker/server)
+(require minimart/relay)
 
 (spawn-timer-driver)
 (spawn-websocket-driver)
 (spawn-world
- (spawn-broker-server 8000)
+ (spawn-websocket-relay 8000)
- (spawn-broker-server 8443 (websocket-ssl-options "server-cert.pem" "private-key.pem")))
+ (spawn-websocket-relay 8443 (websocket-ssl-options "server-cert.pem" "private-key.pem")))

minimart/examples/chat-actor.rkt

@@ -18,7 +18,7 @@
 	 (advertise (tcp-channel us them ?) #:meta-level 1)
 	 (subscribe `(,($ who) says ,($ what))
 	   (say who "says: ~a" what))
-
+	 
 	 (advertise `(,user says ,?))
 	 (subscribe (tcp-channel them us ($ bs)) #:meta-level 1
 	   (send `(,user says ,(string-trim (bytes->string/utf-8 bs)))))

minimart/examples/toy-file-server.rkt

@@ -1,35 +0,0 @@
-#lang minimart
-
-(struct save (filename body) #:prefab)
-(struct contents (filename body) #:prefab)
-
-(actor #:name file-server
-       #:state [files (hash)]
-
-       (subscribe (save ($ filename) ($ body))
-         #:update [files (hash-set files filename body)]
-         #:update-routes)
-
-       (observe-subscribers (contents ($ filename) ?)
-         #:level 1
-         #:name observed-filenames
-         #:set filename)
-
-       (for/advertise [(filename observed-filenames)
-                       #:when (hash-has-key? files filename)]
-         (contents filename (hash-ref files filename))))
-
-(define (spawn-file-watcher filename)
-  (actor #:name observer-of-files
-         (observe-advertisers (contents filename ($ file-contents))
-           #:name file-contents
-           #:set file-contents
-           (printf "Contents of ~a: ~v\n" filename file-contents))))
-
-(spawn-file-watcher 'a)
-(spawn-file-watcher 'b)
-(spawn-file-watcher 'c)
-(send (save 'a "first file"))
-(send (save 'b "second file"))
-(send (save 'c "third file"))
-(send (save 'b "second file, second version"))

minimart/exn-util.rkt

@@ -1,8 +0,0 @@
-#lang racket/base
-
-(provide exn->string)
-
-(define (exn->string exn)
-  (parameterize ([current-error-port (open-output-string)])
-    ((error-display-handler) (exn-message exn) exn)
-    (get-output-string (current-error-port))))

minimart/gestalt.rkt

@@ -3,11 +3,9 @@
 
 (require racket/set)
 (require racket/match)
-(require (only-in racket/list make-list))
 (require (only-in racket/port with-output-to-string))
 
 (require "route.rkt")
-(require "tset.rkt")
 
 (provide (struct-out gestalt)
 	 (struct-out projection)
@@ -28,17 +26,14 @@
 	 simple-gestalt
 	 gestalt-empty
 	 gestalt-empty?
-	 gestalt-full
 	 gestalt-union*
 	 gestalt-union
 	 gestalt-filter
 	 gestalt-match
 	 gestalt-subtract
 	 gestalt-transform
-	 gestalt-matcher-transform
 	 strip-gestalt-label
 	 label-gestalt
-	 gestalt-level-count
 	 pretty-print-gestalt
 	 gestalt->pretty-string
 	 gestalt->jsexpr
@@ -77,13 +72,7 @@
 ;;      -- Greg Egan, "Diaspora"
 ;;         http://gregegan.customer.netspace.net.au/DIASPORA/01/Orphanogenesis.html
 ;;
-(struct gestalt (metalevels)
+(struct gestalt (metalevels))
-	#:transparent
-	#:methods gen:custom-write
-	[(define (write-proc g port mode)
-	   (display "{{{" port)
-	   (pretty-print-gestalt g port)
-	   (display "}}}" port))])
 
 ;; Convention: A GestaltSet is a Gestalt where the Matchers map to #t
 ;; instead of (NonemptySetof PID) or any other value.
@@ -140,7 +129,7 @@
 (define (gestalt-match-value g body metalevel is-feedback?)
   (define extract-matcher (if is-feedback? cdr car)) ;; feedback targets advertisers/publishers
   (define (pids-at level) (matcher-match-value (extract-matcher level) body))
-  (foldr tset-union (datum-tset) (map pids-at (gestalt-metalevel-ref g metalevel))))
+  (apply set-union (set) (map pids-at (gestalt-metalevel-ref g metalevel))))
 
 ;; project-subs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
 ;; project-pubs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
@@ -237,13 +226,6 @@
   (for*/and [(ml (in-list (gestalt-metalevels g))) (l (in-list ml))]
     (and (matcher-empty? (car l)) (matcher-empty? (cdr l)))))
 
-;; Nat Nat -> GestaltSet
-;; Produces a "full" gestalt including the wildcard matcher at each of
-;; the n metalevels and m levels.
-(define (gestalt-full n m)
-  (define w (pattern->matcher #t ?))
-  (gestalt (make-list n (make-list m (cons w w)))))
-
 ;; map-zip: ((U 'right-longer 'left-longer) (Listof X) -> (Listof Y))
 ;;          (X X -> Y)
 ;;          (Y (Listof Y) -> (Listof Y))
@@ -366,14 +348,14 @@
 	(match ls2
 	  ['() acc]
 	  [(cons (cons subs2 advs2) lrest2)
-	   (loop lrest2 (tset-union (tset-union (matcher-match-matcher subs1 advs2)
+	   (loop lrest2 (set-union (matcher-match-matcher subs1 advs2)
-                                                (matcher-match-matcher advs1 subs2))
+				   (matcher-match-matcher advs1 subs2)
-                                    acc))])))
+				   acc))])))
 
     (lambda (g1 g2)
-      (parameterize ((matcher-match-matcher-successes (lambda (v1 v2 acc) (tset-union v2 acc)))
+      (parameterize ((matcher-match-matcher-successes (lambda (v1 v2 acc) (set-union v2 acc)))
-		     (matcher-match-matcher-unit (datum-tset)))
+		     (matcher-match-matcher-unit (set)))
-	(match-metalevels (gestalt-metalevels g1) (gestalt-metalevels g2) (datum-tset))))))
+	(match-metalevels (gestalt-metalevels g1) (gestalt-metalevels g2) (set))))))
 
 ;; Gestalt Gestalt -> Gestalt
 ;; Erases the g2-subset of g1 from g1, yielding the result.
@@ -415,14 +397,9 @@
 ;; GestaltSet -> Gestalt
 ;; Relabels g so that all matched keys map to (set pid).
 (define (label-gestalt g pid)
-  (define pidset (datum-tset pid))
+  (define pidset (set pid))
   (gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (v) pidset)))))
 
-;; Gestalt Nat -> Nat
-;; Returns the number of "interesting" levels in g at metalevel n.
-(define (gestalt-level-count g n)
-  (length (gestalt-metalevel-ref g n)))
-
 ;; Gestalt [OutputPort] -> Void
 ;; Pretty-prints g on port.
 (define (pretty-print-gestalt g [port (current-output-port)])

minimart/memoize.rkt

@@ -0,0 +1,52 @@
+#lang racket/base
+;; Poor-man's memoization.
+
+(provide memoize1)
+
+(define sentinel (cons #f #f))
+
+(define (memoize1 f)
+  (define results (make-weak-hash))
+  (lambda (arg)
+    (hash-ref results arg (lambda ()
+			    (define val (f arg))
+			    (hash-set! results arg val)
+			    val))))
+
+(module+ test
+  (require rackunit)
+
+  (define call-counter 0)
+
+  (define (raw x)
+    (set! call-counter (+ call-counter 1))
+    (gensym 'raw-result))
+
+  (define cooked (memoize1 raw))
+
+  ;; These tests will *likely* pass, but if garbage collection strikes
+  ;; at an inopportune moment, they may fail.
+
+  (collect-garbage)
+
+  (define v (cons 1 2))
+
+  (check-equal? call-counter 0)
+  (check-eq? (cooked v) (cooked v))
+  (check-equal? call-counter 1)
+
+  (set! v (cons 1 2))
+
+  (check-equal? call-counter 1)
+  (check-equal? (cooked v) (cooked v))
+  (check-equal? call-counter 1)
+
+  (set! v (cons 1 2))
+
+  (collect-garbage)
+  (collect-garbage)
+  (collect-garbage)
+
+  (check-equal? call-counter 1)
+  (check-equal? (cooked v) (cooked v))
+  (check-equal? call-counter 2))

minimart/relay.rkt

@@ -1,27 +1,51 @@
 #lang racket/base
 ;; Generic relay for WebSockets/TCP/etc-based participation in a network.
 
-(provide spawn-broker-server)
+(provide spawn-websocket-relay)
 
 (require racket/set)
 (require racket/match)
 (require net/rfc6455)
-(require "../main.rkt")
+(require "main.rkt")
-(require "../demand-matcher.rkt")
+(require "demand-matcher.rkt")
-(require "../drivers/timer.rkt")
+(require "drivers/timer.rkt")
-(require "../drivers/websocket.rkt")
+(require "drivers/websocket.rkt")
 (require json)
-(require "protocol.rkt")
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Main: start WebSocket server
 
 ;; Depends on timer driver and websocket driver running at metalevel 1.
-(define (spawn-broker-server port [ssl-options #f])
+(define (spawn-websocket-relay port [ssl-options #f])
   (define server-id (websocket-local-server port ssl-options))
   (spawn-demand-matcher (websocket-message (?! (websocket-remote-client ?)) server-id ?)
 			#:meta-level 1
 			(lambda (c) (spawn-connection-handler c server-id))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Wire protocol representation of events and actions
+
+(define (drop-json-action j)
+  (match j
+    ["ping" 'ping]
+    ["pong" 'pong]
+    [`("routes" ,gj) (routing-update (jsexpr->gestalt gj (lambda (v) (set 'peer))))]
+    [`("message" ,body ,meta-level ,feedback?) (message body meta-level feedback?)]))
+
+(define (lift-json-event j)
+  (match j
+    ['ping "ping"]
+    ['pong "pong"]
+    [(routing-update g) `("routes" ,(gestalt->jsexpr g (lambda (v) #t)))]
+    [(message body meta-level feedback?) `("message" ,body ,meta-level ,feedback?)]))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Connections
+
+(define (ping-interval) (* 1000 (max (- (ws-idle-timeout) 10) (* (ws-idle-timeout) 0.8))))
+
 (define (spawn-connection-handler c server-id)
-  (actor #:name broker-server
+  (actor #:name relay
 	 #:state [tunnelled-gestalt (gestalt-empty)]
 
 	 (send #:meta-level 1 (set-timer c (ping-interval) 'relative))

minimart/route.rkt

@@ -15,7 +15,6 @@
 	 wildcard?
 	 ?!
 	 (struct-out capture)
-	 (struct-out embedded-matcher)
 
 	 matcher? ;; expensive; see implementation
 	 matcher-empty
@@ -56,8 +55,7 @@
 (require (only-in racket/port call-with-output-string with-output-to-string))
 (require (only-in racket/class object?))
 (require "canonicalize.rkt")
-(require "treap.rkt")
+(require "sorted-map.rkt")
-(require "tset.rkt")
 (require data/order)
 
 (require rackunit)
@@ -72,23 +70,23 @@
      (match* (v1 v2)
        [(#t v) v]
        [(v #t) v]
-       [(v1 v2) (tset-union v1 v2)]))))
+       [(v1 v2) (set-union v1 v2)]))))
 
-(define matcher-intersect-successes (make-parameter tset-union))
+(define matcher-intersect-successes (make-parameter set-union))
 
 (define matcher-subtract-successes
   (make-parameter
    (lambda (s1 s2)
-     (define r (tset-subtract s1 s2))
+     (define r (set-subtract s1 s2))
-     (if (tset-empty? r) #f r))))
+     (if (set-empty? r) #f r))))
 
 (define matcher-match-matcher-successes
   (make-parameter
    (lambda (v1 v2 a)
-     (cons (tset-union (car a) v1)
+     (cons (set-union (car a) v1)
-	   (tset-union (cdr a) v2)))))
+	   (set-union (cdr a) v2)))))
 
-(define matcher-match-matcher-unit (make-parameter (cons (datum-tset) (datum-tset))))
+(define matcher-match-matcher-unit (make-parameter (cons (set) (set))))
 
 ;; The project-success function should return #f to signal "no success values".
 (define matcher-project-success (make-parameter values))
@@ -106,13 +104,13 @@
 ;; - #f, indicating no further matches possible
 ;; - (success Any), representing a successful match (if the end of
 ;;   the input has been reached)
-;; - (Treap (U Sigma Wildcard) Matcher), {TODO}
+;; - (SortedMap (U Sigma Wildcard) Matcher), {TODO}
-;; TODO::: reimplement to use (ordinary-state (Option Matcher) (Treap Sigma Matcher)), {TODO}
+;; TODO::: reimplement to use (ordinary-state (Option Matcher) (SortedMap Sigma Matcher)), {TODO}
 ;; - (wildcard-sequence Matcher), {TODO}
-;; If, in a treap matcher, a wild key is present, it is intended
+;; If, in a sorted-map matcher, a wild key is present, it is intended
 ;; to catch all and ONLY those keys not otherwise present in the
 ;; table.
-;; INVARIANT: if a key is present in a treap, then the
+;; INVARIANT: if a key is present in a sorted-map, then the
 ;;            corresponding value MUST NOT be equal to the wildcard
 ;;            continuation, bearing in mind that
 ;;             - if the wildcard is absent, it is implicitly #f;
@@ -131,7 +129,7 @@
 ;;  - ILM, signifying the transition into the cdr position of a pair
 ;;  - EOS, signifying the notional close-paren at the end of a compound.
 ;;  - any other value, representing itself.
-;; N.B. treaps cannot be Sigmas at present.
+;; N.B. sorted-maps cannot be Sigmas at present.
 (define-singleton-struct SOL start-of-list "<")
 (define-singleton-struct SOV start-of-vector "<vector")
 (define-singleton-struct ILM improper-list-marker "|")
@@ -166,8 +164,8 @@
   (or (eq? x #f)
       (success? x)
       (wildcard-sequence? x)
-      (and (treap? x)
+      (and (sorted-map? x)
-	   (for/and ([v (treap-values x)])
+	   (for/and ([v (sorted-map-values x)])
 	     (matcher? v)))))
 
 ;; -> Matcher
@@ -196,44 +194,32 @@
 (define (rsuccess v)
   (and v (canonicalize (success v))))
 
-;; Order for sigmas. This is complicated by the fact that datum-order
+;; Order for sigmas
-;; can't see through opaque structs (SIGH).
+(define (sigma-order a b)
-(define sigma-order
+  (define sta? (struct-type? a))
-  (let ((cache (make-weak-hasheq))
+  (define stb? (struct-type? b))
-        (counter 0))
+  (cond
-    (struct cache-index (n) #:transparent)
+   [(and sta? stb?) (datum-order (struct-type-name a) (struct-type-name b))]
-    (define (cache-index-for x)
+   [sta? '<]
-      (hash-ref cache x (lambda ()
+   [stb? '>]
-                          (define index (cache-index counter))
+   [else (datum-order a b)]))
-                          (set! counter (+ counter 1))
-                          (hash-set! cache x index)
-                          index)))
-    (lambda (a b)
-      (define sta? (struct-type? a))
-      (define stb? (struct-type? b))
-      (cond
-        [(and sta? stb?) (datum-order (struct-type-name a) (struct-type-name b))]
-        [sta? '<]
-        [stb? '>]
-        [else (datum-order (if (evt? a) (cache-index-for a) a)
-                           (if (evt? b) (cache-index-for b) b))]))))
 
-;; (Treap (U Sigma Wildcard) Matcher)
+;; (SortedMap (U Sigma Wildcard) Matcher)
 ;; The empty branch-matcher
-(define empty-smap (treap-empty sigma-order))
+(define empty-smap (sorted-map-empty sigma-order))
 
 ;; (U Sigma Wildcard) Matcher -> Matcher
 ;; Prepends e to r, if r is non-empty.
 (define (rseq e r)
   (if (matcher-empty? r)
       r
-      (treap-insert empty-smap e r)))
+      (sorted-map-insert empty-smap e r)))
 
 ;; [ (U Sigma Wildcard) Matcher ] ... -> Matcher
 (define (rseq-multi . ers)
   (let walk ((ers ers))
     (match ers
-      [(list* e r rest) (treap-insert (walk rest) e r)]
+      [(list* e r rest) (sorted-map-insert (walk rest) e r)]
       [(list) empty-smap])))
 
 ;; Matcher -> Matcher
@@ -256,19 +242,19 @@
     [_ #f]))
 
 ;; Matcher (U Sigma Wildcard) Matcher -> Matcher
-;; r must be a treap matcher. Retrieves the continuation after
+;; r must be a sorted-map matcher. Retrieves the continuation after
 ;; accepting key. If key is absent, returns wild-edge-value, modified
 ;; depending on key.
 (define (rlookup r key wild-edge-value)
-  (treap-get r key (lambda ()
+  (sorted-map-get r key (lambda ()
 			  (cond
 			   [(key-open? key) (rwildseq wild-edge-value)]
 			   [(key-close? key) (runwildseq wild-edge-value)]
 			   [else wild-edge-value]))))
 
-;; (Option (Treap (U Sigma Wildcard) Matcher)) Sigma Matcher -> Matcher
+;; (Option (SortedMap (U Sigma Wildcard) Matcher)) Sigma Matcher -> Matcher
 ;; Updates (installs or removes) a continuation in the Matcher r. r
-;; must be either #f or a treap matcher. key MUST NOT be ?.
+;; must be either #f or a sorted-map matcher. key MUST NOT be ?.
 ;; Preserves invariant that a key is never added if its continuation
 ;; is the same as the wildcard's continuation (which is implicitly #f
 ;; if absent, of course).
@@ -276,7 +262,7 @@
   (when (eq? key ?) (error 'rupdate "Internal error: supplied wildcard as key"))
   (define r (or r0 empty-smap))
   (empty-smap-guard
-   (let ((old-wild (treap-get r ? (lambda () #f))))
+   (let ((old-wild (sorted-map-get r ? (lambda () #f))))
      (if (cond [(key-open? key)
 		(if (wildcard-sequence? k)
 		    (requal? (wildcard-sequence-matcher k) old-wild)
@@ -287,14 +273,14 @@
 		    (matcher-empty? k))]
 	       [else
 		(requal? k old-wild)])
-	 (treap-delete r key)
+	 (sorted-map-delete r key)
-	 (treap-insert r key k)))))
+	 (sorted-map-insert r key k)))))
 
-;; Treap -> Matcher
+;; SortedMap -> Matcher
 ;; If the argument is empty, returns the canonical empty matcher;
 ;; otherwise, returns the argument.
 (define (empty-smap-guard h)
-  (and (positive? (treap-size h)) h))
+  (and (positive? (sorted-map-size h)) h))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Pattern compilation
@@ -320,9 +306,9 @@
       [(cons p1 p2) (rseq SOL (walk p1 (walk-pair-chain p2 acc)))]
       [(? vector? v) (rseq SOV (vector-foldr walk (rseq EOS acc) v))]
       [(embedded-matcher m) (matcher-append m (lambda (_mv) acc))]
-      ;; TODO: consider options for treating treaps as compounds
+      ;; TODO: consider options for treating sorted-maps as compounds
       ;; rather than (useless) atoms
-      [(? treap?) (error 'pattern->matcher "Cannot match on treaps at present")]
+      [(? sorted-map?) (error 'pattern->matcher "Cannot match on sorted-maps at present")]
       [(? non-object-struct?)
        (rseq (struct->struct-type p)
 	     (walk-pair-chain (cdr (vector->list (struct->vector p)))
@@ -363,6 +349,7 @@
 (define (matcher-union re1 re2)
   (matcher-recurse re1
 		   re2
+		   matcher-union
 		   (matcher-union-successes)
 		   values
 		   values
@@ -377,6 +364,7 @@
 (define (matcher-intersect re1 re2)
   (matcher-recurse re1
 		   re2
+		   matcher-intersect
 		   (matcher-intersect-successes)
 		   (lambda (r) #f)
 		   (lambda (r) #f)
@@ -389,23 +377,23 @@
 (define (matcher-subtract re1 re2)
   (matcher-recurse re1
 		   re2
+		   matcher-subtract
 		   (matcher-subtract-successes)
 		   (lambda (r) #f)
 		   values
 		   (lambda (h) #f)
 		   values))
 
-(define (matcher-recurse re1 re2 vf left-false right-false right-base left-base)
+(define (matcher-recurse re1 re2 f vf left-false right-false right-base left-base)
-  (let f ((re1 re1) (re2 re2))
+  (match* (re1 re2)
-    (match* (re1 re2)
+    [(#f r) (left-false r)]
-      [(#f r) (left-false r)]
+    [(r #f) (right-false r)]
-      [(r #f) (right-false r)]
+    [((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (f r1 r2))]
-      [((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (f r1 r2))]
+    [((wildcard-sequence r1) r2) (f (expand-wildseq r1) r2)]
-      [((wildcard-sequence r1) r2) (f (expand-wildseq r1) r2)]
+    [(r1 (wildcard-sequence r2)) (f r1 (expand-wildseq r2))]
-      [(r1 (wildcard-sequence r2)) (f r1 (expand-wildseq r2))]
+    [((success v1) (success v2)) (rsuccess (vf v1 v2))]
-      [((success v1) (success v2)) (rsuccess (vf v1 v2))]
+    [((? sorted-map? h1) (? sorted-map? h2))
-      [((? treap? h1) (? treap? h2))
+     (fold-over-keys h1 h2 f (left-base h1) (right-base h2))]))
-       (fold-over-keys h1 h2 f (left-base h1) (right-base h2))])))
 
 (define (fold-over-keys h1 h2 f left-base right-base)
   (define w1 (rlookup h1 ? #f))
@@ -414,19 +402,19 @@
    (cond
     [(and w1 w2)
      (for/fold [(acc (rwild (f w1 w2)))]
-	 [(key (set-remove (set-union (treap-keys h1) (treap-keys h2)) ?))]
+	 [(key (set-remove (set-union (sorted-map-keys h1) (sorted-map-keys h2)) ?))]
        (rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
     [w1
-     (for/fold [(acc left-base)] [(key (treap-keys h2))]
+     (for/fold [(acc left-base)] [(key (sorted-map-keys h2))]
        (rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
     [w2
-     (for/fold [(acc right-base)] [(key (treap-keys h1))]
+     (for/fold [(acc right-base)] [(key (sorted-map-keys h1))]
        (rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
-    [(< (treap-size h1) (treap-size h2))
+    [(< (sorted-map-size h1) (sorted-map-size h2))
-     (for/fold [(acc right-base)] [(key (treap-keys h1))]
+     (for/fold [(acc right-base)] [(key (sorted-map-keys h1))]
        (rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
     [else
-     (for/fold [(acc left-base)] [(key (treap-keys h2))]
+     (for/fold [(acc left-base)] [(key (sorted-map-keys h2))]
        (rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))])))
 
 ;; Matcher -> Matcher
@@ -437,28 +425,25 @@
 ;; In addition, we rewrite (★ -> (wildcard-sequence m')) to
 ;; (wildcard-sequence m'), since matcher-match-value will fall back to
 ;; ★ if EOS is missing, and rlookup adjusts appropriately.
-(define (collapse-wildcard-sequences m)
+(define collapse-wildcard-sequences
-  (if (treap? m)
+  (let ((expanded-keys1 (set ? EOS))
-      (case (treap-size m)
+	(expanded-keys2 (set ?)))
-	[(2)
+    (lambda (m)
-	 (if (and (treap-has-key? m ?)
+      (if (sorted-map? m)
-		  (treap-has-key? m EOS))
+	  (let ((keys (sorted-map-keys m)))
-	     (let ((w (treap-get m ?))
+	    (cond
-		   (k (treap-get m EOS)))
+	     [(equal? keys expanded-keys1)
-	       (if (and (wildcard-sequence? w)
+	      (define w (sorted-map-get m ?))
-			(requal? (wildcard-sequence-matcher w) k))
+	      (define k (sorted-map-get m EOS))
-		   w
+	      (if (and (wildcard-sequence? w) (requal? k (wildcard-sequence-matcher w)))
-		   m))
+		  w
-	     m)]
+		  m)]
-	[(1)
+	     [(equal? keys expanded-keys2)
-	 (if (treap-has-key? m ?)
+	      (define w (sorted-map-get m ?))
-	     (let ((w (treap-get m ?)))
+	      (if (wildcard-sequence? w) w m)]
-	       (if (wildcard-sequence? w)
+	     [else
-		   w
+	      m]))
-		   m))
+	  m))))
-	     m)]
-	[else m])
-      m))
 
 ;; Sigma -> Boolean
 ;; True iff k represents the start of a compound datum.
@@ -475,7 +460,7 @@
 ;; Matcher -> Matcher
 ;; Unrolls the implicit recursion in a wildcard-sequence.
 (define (expand-wildseq r)
-  (treap-insert (treap-insert empty-smap ? (rwildseq r)) EOS r))
+  (sorted-map-insert (sorted-map-insert empty-smap ? (rwildseq r)) EOS r))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Matching single keys into a multimap
@@ -494,7 +479,7 @@
 ;; Sigmas and runs them through the Matcher r. If v leads to a success
 ;; Matcher, returns the values contained in the success Matcher;
 ;; otherwise, returns failure-result.
-(define (matcher-match-value r v [failure-result (datum-tset)])
+(define (matcher-match-value r v [failure-result (set)])
   (let walk ((vs (list v)) (stack '(())) (r r))
     (match r
       [#f failure-result]
@@ -507,8 +492,8 @@
 		(null? stack))
 	   result
 	   failure-result)]
-      [(? treap?)
+      [(? sorted-map?)
-       (define (get key) (treap-get r key (lambda () #f)))
+       (define (get key) (sorted-map-get r key (lambda () #f)))
        (match vs
 	 ['()
 	  (match stack
@@ -547,17 +532,17 @@
       [((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc)]
       [(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc)]
       [((success v1) (success v2)) ((matcher-match-matcher-successes) v1 v2 acc)]
-      [((? treap? h1) (? treap? h2))
+      [((? sorted-map? h1) (? sorted-map? h2))
        (define w1 (rlookup h1 ? #f))
        (define w2 (rlookup h2 ? #f))
        (define r (walk w1 w2 acc))
        (for/fold [(r r)]
 	   [(key (cond
-		  [(and w1 w2) (set-remove (set-union (treap-keys h1) (treap-keys h2)) ?)]
+		  [(and w1 w2) (set-remove (set-union (sorted-map-keys h1) (sorted-map-keys h2)) ?)]
-		  [w1 (treap-keys h2)]
+		  [w1 (sorted-map-keys h2)]
-		  [w2 (treap-keys h1)]
+		  [w2 (sorted-map-keys h1)]
-		  [(< (treap-size h1) (treap-size h2)) (treap-keys h1)]
+		  [(< (sorted-map-size h1) (sorted-map-size h2)) (sorted-map-keys h1)]
-		  [else (treap-keys h2)]))]
+		  [else (sorted-map-keys h2)]))]
 	 (walk (rlookup h1 key w1) (rlookup h2 key w2) r))])))
 
 ;; Matcher × (Value → Matcher) → Matcher
@@ -572,8 +557,8 @@
       [#f #f]
       [(success v) (error 'matcher-append "Ill-formed matcher: ~v" m0)]
       [(wildcard-sequence m1) (rwildseq (walk m1))]
-      [(? treap?) (for/fold [(acc (rwild (walk (rlookup m ? #f))))]
+      [(? sorted-map?) (for/fold [(acc (rwild (walk (rlookup m ? #f))))]
-			   [(kv (treap-to-alist m)) #:when (not (eq? (car kv) ?))]
+			   [(kv (sorted-map-to-alist m)) #:when (not (eq? (car kv) ?))]
 			 (match-define (cons k v) kv)
 			 (if (and (key-close? k) (success? v))
 			     (matcher-union acc (m-tail-fn (success-value v)))
@@ -587,8 +572,8 @@
       [#f #f]
       [(success v) (rsuccess (f v))]
       [(wildcard-sequence m1) (rwildseq (walk m1))]
-      [(? treap?) (for/fold [(acc (rwild (walk (rlookup m ? #f))))]
+      [(? sorted-map?) (for/fold [(acc (rwild (walk (rlookup m ? #f))))]
-			   [(kv (treap-to-alist m)) #:when (not (eq? (car kv) ?))]
+			   [(kv (sorted-map-to-alist m)) #:when (not (eq? (car kv) ?))]
 			 (rupdate acc (car kv) (walk (cdr kv))))])))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -611,8 +596,8 @@
       [(cons p1 p2) (cons SOL (walk p1 (walk-pair-chain p2 acc)))]
       [(? vector? v) (cons SOV (vector-foldr walk (cons EOS acc) v))]
       [(embedded-matcher m) (error 'compile-projection "Cannot embed matcher in projection")]
-      ;; TODO: consider options for treating treaps as compounds rather than (useless) atoms
+      ;; TODO: consider options for treating sorted-maps as compounds rather than (useless) atoms
-      [(? treap?) (error 'compile-projection "Cannot match on treaps at present")]
+      [(? sorted-map?) (error 'compile-projection "Cannot match on sorted-maps at present")]
       [(? non-object-struct?)
        (cons (struct->struct-type p)
 	     (walk-pair-chain (cdr (vector->list (struct->vector p)))
@@ -634,9 +619,9 @@
       [(capture sub) sub] ;; TODO: maybe enforce non-nesting here too?
       [(cons p1 p2) (cons (walk p1) (walk p2))]
       [(? vector? v) (for/vector [(e (in-vector v))] (walk e))]
-      ;; TODO: consider options for treating treaps as compounds
+      ;; TODO: consider options for treating sorted-maps as compounds
       ;; rather than (useless) atoms
-      [(? treap?) (error 'projection->pattern "Cannot match on treaps at present")]
+      [(? sorted-map?) (error 'projection->pattern "Cannot match on sorted-maps at present")]
       [(? non-object-struct?)
        (apply (struct-type-make-constructor (struct->struct-type p))
 	      (map walk (cdr (vector->list (struct->vector p)))))]
@@ -669,9 +654,9 @@
 	  [(cons (== ?) k)
 	   (match m
 	     [(wildcard-sequence _) (add-wild (walk m k))]
-	     [(? treap?)
+	     [(? sorted-map?)
 	      (for/fold [(acc (add-wild (walk (rlookup m ? #f) k)))]
-		  [(key-mk (treap-to-alist m)) #:when (not (eq? (car key-mk) ?))]
+		  [(key-mk (sorted-map-to-alist m)) #:when (not (eq? (car key-mk) ?))]
 		(match-define (cons key mk) key-mk)
 		(add-edge acc key (cond
 				   [(key-open? key) (balanced mk (lambda (mk) (walk mk k)))]
@@ -687,16 +672,16 @@
 			  [(key-open? sigma) (walk (rwildseq m) k)]
 			  [(key-close? sigma) (walk mk k)]
 			  [else (walk m k)])]
-			[(? treap?) (walk (rlookup m sigma (rlookup m ? #f)) k)]
+			[(? sorted-map?) (walk (rlookup m sigma (rlookup m ? #f)) k)]
 			[_ (matcher-empty)]))])))
 
     (define (general-balanced add-wildseq add-wild add-edge m k)
       (let walk ((m m) (k k))
 	(match m
 	  [(wildcard-sequence mk) (add-wildseq (k mk))]
-	  [(? treap?)
+	  [(? sorted-map?)
 	   (for/fold [(acc (add-wild (walk (rlookup m ? #f) k)))]
-	       [(key-mk (treap-to-alist m)) #:when (not (eq? (car key-mk) ?))]
+	       [(key-mk (sorted-map-to-alist m)) #:when (not (eq? (car key-mk) ?))]
 	     (match-define (cons key mk) key-mk)
 	     (add-edge acc key (cond
 				[(key-open? key) (walk mk (lambda (mk) (walk mk k)))]
@@ -729,9 +714,9 @@
     (define (walk m k)
       (match m
 	[(wildcard-sequence _) #f]
-	[(? treap?)
+	[(? sorted-map?)
-	 (and (not (treap-has-key? m ?))
+	 (and (not (sorted-map-has-key? m ?))
-	      (for/fold [(acc (set))] [(key-mk (treap-to-alist m))]
+	      (for/fold [(acc (set))] [(key-mk (sorted-map-to-alist m))]
 		(match-define (cons key mk) key-mk)
 		(maybe-union
 		 acc
@@ -753,9 +738,9 @@
     (define (walk-seq m k)
       (match m
 	[(wildcard-sequence _) #f]
-	[(? treap?)
+	[(? sorted-map?)
-	 (and (not (treap-has-key? m ?))
+	 (and (not (sorted-map-has-key? m ?))
-	      (for/fold [(acc (set))] [(key-mk (treap-to-alist m))]
+	      (for/fold [(acc (set))] [(key-mk (sorted-map-to-alist m))]
 		(match-define (cons key mk) key-mk)
 		(maybe-union acc (cond
 				  [(key-close? key) (k (set '()) mk)]
@@ -806,12 +791,12 @@
        (walk (+ i 5) k)]
       [(success vs)
        (d "{")
-       (d (if (tset? vs) (cons 'tset (tset->list vs)) vs))
+       (d vs)
        (d "}")]
-      [(? treap? h)
+      [(? sorted-map? h)
-       (if (zero? (treap-size h))
+       (if (zero? (sorted-map-size h))
-	   (d " ::: empty treap!")
+	   (d " ::: empty sorted-map!")
-	   (for/fold [(need-sep? #f)] [(key-k (treap-to-alist h))]
+	   (for/fold [(need-sep? #f)] [(key-k (sorted-map-to-alist h))]
 	     (match-define (cons key k) key-k)
 	     (when need-sep?
 	       (newline port)
@@ -843,8 +828,8 @@
       [#f '()]
       [(success v) (list "" (success->jsexpr v))]
       [(wildcard-sequence m1) (list "...)" (walk m1))]
-      [(? treap?)
+      [(? sorted-map?)
-       (for/list [(kv (treap-to-alist m))]
+       (for/list [(kv (sorted-map-to-alist m))]
 	 (match-define (cons k v) kv)
 	 (list (match k
 		 [(== ?) (list "__")]
@@ -874,7 +859,7 @@
       [(list (list kjs vjs) ...)
        (for/fold [(acc empty-smap)]
 	   [(kj kjs) (vj vjs)]
-	 (treap-insert acc
+	 (sorted-map-insert acc
 			    (match kj
 			      [(list "__") ?]
 			      [(list "(") SOL]
@@ -898,15 +883,13 @@
 (module+ test
   (require racket/pretty)
 
-  (define tset datum-tset)
+  (define SA (set 'A))
-
+  (define SB (set 'B))
-  (define SA (tset 'A))
+  (define SC (set 'C))
-  (define SB (tset 'B))
+  (define SD (set 'D))
-  (define SC (tset 'C))
+  (define Sfoo (set 'foo))
-  (define SD (tset 'D))
+  (define S+ (set '+))
-  (define Sfoo (tset 'foo))
+  (define SX (set 'X))
-  (define S+ (tset '+))
-  (define SX (tset 'X))
   (define (E v) (rseq EOS (rsuccess v)))
   (check-equal? (pattern->matcher SA 123) (rseq 123 (E SA)))
   (check-equal? (pattern->matcher SA (cons 1 2))
@@ -928,7 +911,7 @@
 	 (define actualset (matcher-match-value matcher message))
 	 (printf "~v ==> ~v\n" message actualset)
 	 (check-equal? actualset
-		       (apply tset (map (lambda (c) (string->symbol (string c)))
+		       (apply set (map (lambda (c) (string->symbol (string c)))
 				       (string->list expectedstr))))
 	 (walk rest)])))
 
@@ -994,7 +977,7 @@
   (void (pretty-print-matcher* (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
 					      ;; Note: this is a largely nonsense matcher,
 					      ;; since it expects no input at all
-					      (rseq EOS (rsuccess (tset 'B))))))
+					      (rseq EOS (rsuccess (set 'B))))))
 
   (check-matches
    (pretty-print-matcher*
@@ -1034,7 +1017,7 @@
     (define ps
       (for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")))
 	(define csym (string->symbol (string c)))
-	(pattern->matcher (tset csym) (list csym ?))))
+	(pattern->matcher (set csym) (list csym ?))))
     (matcher-union (foldr matcher-union (matcher-empty) ps)
 		   (pattern->matcher S+ (list 'Z (list ? '- ?)))))
 
@@ -1201,7 +1184,7 @@
     (matcher-intersect (pattern->matcher SA a)
 		       (pattern->matcher SB b)))
 
-  (define EAB (E (tset 'A 'B)))
+  (define EAB (E (set 'A 'B)))
 
   (define (rseq* x . xs)
     (let walk ((xs (cons x xs)))
@@ -1238,10 +1221,10 @@
 
   (check-requal? (intersect (a 'a) (b 'a)) #f)
 
-  (check-exn #px"Cannot match on treaps at present"
+  (check-exn #px"Cannot match on sorted-maps at present"
 	     (lambda ()
 	       (define (h a b c d)
-		 (treap-insert (treap-insert empty-smap a b) c d))
+		 (sorted-map-insert (sorted-map-insert empty-smap a b) c d))
 	       (intersect (h 'a 1 'b ?)
 			  (h 'a ? 'b 2))))
 
@@ -1256,9 +1239,9 @@
     (define m2 (pretty-print-matcher* (pattern->matcher SD ?)))
     (define mi (pretty-print-matcher* (matcher-intersect m1 m2)))
     (check-requal? mi
-		   (H SOL (H 'a (H  ? (H EOS (E (tset 'A 'D))))
+		   (H SOL (H 'a (H  ? (H EOS (E (set 'A 'D))))
-			     'b (H  ? (H EOS (E (tset 'B 'D)))
+			     'b (H  ? (H EOS (E (set 'B 'D)))
-				    'c (H EOS (E (tset 'B 'C 'D)))))))
+				    'c (H EOS (E (set 'B 'C 'D)))))))
     (check-requal? (pretty-print-matcher*
 		    (parameterize ((matcher-intersect-successes (lambda (v1 v2) v1)))
 		      (matcher-intersect m1 m2)))
@@ -1278,22 +1261,22 @@
 			  (pattern->matcher SC (list 'c ?))
 			  (pattern->matcher SD (list 'd ?))))))
     (check-equal? (matcher-match-matcher-list abc abc)
-		  (list (tset 'A 'B 'C) (tset 'A 'B 'C)))
+		  (list (set 'A 'B 'C) (set 'A 'B 'C)))
     (check-equal? (parameterize ((matcher-match-matcher-successes (lambda (v1 v2 a)
-								    (tset-union v2 a)))
+								    (set-union v2 a)))
-				 (matcher-match-matcher-unit (tset)))
+				 (matcher-match-matcher-unit (set)))
 		    (matcher-match-matcher abc abc))
-		  (tset 'A 'B 'C))
+		  (set 'A 'B 'C))
-    (check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (tset #t))))
+    (check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (set #t))))
-		  (list (tset 'B 'C) (tset #t)))
+		  (list (set 'B 'C) (set #t)))
     (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo ?))
-		  (list (tset 'A 'B 'C) (tset 'foo)))
+		  (list (set 'A 'B 'C) (set 'foo)))
     (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? ?)))
-		  (list (tset 'A 'B 'C) (tset 'foo)))
+		  (list (set 'A 'B 'C) (set 'foo)))
     (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x)))
-		  (list (tset 'A 'B 'C) (tset 'foo)))
+		  (list (set 'A 'B 'C) (set 'foo)))
     (check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x ?)))
-		  (list (tset) (tset)))))
+		  (list (set) (set)))))
 
 (module+ test
   (check-equal? (compile-projection (cons 'a 'b))
@@ -1463,14 +1446,14 @@
 			(pattern->matcher SB (list 3 4)))))
 	(S '((("(")
 	      ((1      ((2 (((")") (((")") ("" ("A")))))))
-			(3 (((")") (((")") ("" ("C" "D")))))))))
+			(3 (((")") (((")") ("" ("D" "C")))))))))
 	       (3      ((2 (((")") (((")") ("" ("A")))))))
 			(3 (((")") (((")") ("" ("D")))))))
 			(4 (((")") (((")") ("" ("B")))))))))
 	       (("__") ((2 (((")") (((")") ("" ("A")))))))
 			(3 (((")") (((")") ("" ("D"))))))))))))))
-    (check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (tset->list v)))) S)
+    (check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (set->list v)))) S)
-    (check-requal? (jsexpr->matcher S (lambda (v) (make-tset datum-order (map string->symbol v)))) M)))
+    (check-requal? (jsexpr->matcher S (lambda (v) (list->set (map string->symbol v)))) M)))
 
 (module+ test
   (check-requal? (pretty-print-matcher*

minimart/sorted-map.rkt

@@ -0,0 +1,478 @@
+#lang racket/base
+;; Matt Might's red-black tree code from
+;; http://matt.might.net/articles/red-black-delete/code/sorted-map.rkt
+;;
+;; Modified by Tony Garnock-Jones, July 2014:
+;;  - trees are hashconsed
+;;  - sorted-map-size is made constant-time
+
+(provide (struct-out sorted-map)
+	 sorted-map-empty
+	 sorted-map-modify-at
+	 sorted-map-insert
+	 sorted-map-insert*
+	 sorted-map-to-tree
+	 sorted-map-to-alist
+	 sorted-map-submap?
+	 sorted-map-get
+	 sorted-map-size
+	 sorted-map-max
+	 sorted-map-delete
+	 sorted-map-has-key?
+	 sorted-map-keys
+	 sorted-map-values
+	 )
+
+(require "canonicalize.rkt")
+(require "memoize.rkt")
+(require racket/set)
+
+; A purely functional sorted-map library.
+
+; Provides logarithmic insert, update, get & delete.
+
+; Based on Okasaki's red-black trees
+; with purely functional red-black delete.
+
+; Author: Matthew Might
+; Site:   http://matt.might.net/
+; Page:   http://matt.might.net/articles/red-black-delete/
+
+(require (except-in racket/match define/match))
+  
+; Syntactic sugar for define forms
+; with match as their body:
+(define-syntax define/match 
+  (syntax-rules ()
+    [(_ (id name) clause ...)
+     ; =>
+     (define (id name)
+       (match name clause ...))]))
+  
+(define-syntax define/match*
+  (syntax-rules ()
+    [(_ (id name ...) clause ...)
+     ; =>
+     (define (id name ...)
+       (match* (name ...)
+               clause ...))]))
+
+; A form for matching the result of a comparison:
+;; tonyg 20140718: changed to use the order? convention from data/order
+(define-syntax switch-compare 
+  (syntax-rules (= < >)
+    [(_ (cmp v1 v2)
+        [< action1 ...] 
+        [= action2 ...]
+        [> action3 ...])
+     ; =>
+     (let ((dir (cmp v1 v2)))
+       (case dir
+         [(<) action1 ...]
+         [(=) action2 ...]
+         [(>) action3 ...]))]))
+    
+;; tonyg 20140718: for hash-consing, we have to be able to compare
+;; trees using equal?, which necessitates use of #:transparent in our
+;; struct definitions.
+
+; Struct definition for sorted-map:
+(define-struct sorted-map (compare) #:transparent)
+
+;  Internal nodes:
+(define-struct (T sorted-map)
+  (color left key value right) #:transparent)
+
+;  Leaf nodes:
+(define-struct (L sorted-map) () #:transparent)
+
+;  Double-black leaf nodes:
+(define-struct (BBL sorted-map) () #:transparent)
+
+  
+; Color manipulators.
+
+; Turns a node black.
+(define/match (blacken node)
+  [(T cmp _ l k v r)  (canonicalize (T cmp 'B l k v r))]
+  [(BBL cmp)          (canonicalize (L cmp))]
+  [(L _)              node])
+
+; Turns a node red.
+(define/match (redden node)
+  [(T cmp _ l k v r)   (canonicalize (T cmp 'R l k v r))]
+  [(L _)               (error "Can't redden leaf.")])
+
+
+; Color arithmetic.
+(define/match (black+1 color-or-node)
+  [(T cmp c l k v r)  (canonicalize (T cmp (black+1 c) l k v r))]
+  [(L cmp)            (canonicalize (BBL cmp))]
+  ['-B 'R]
+  ['R  'B]
+  ['B  'BB])
+
+(define/match (black-1 color-or-node)
+  [(T cmp c l k v r)  (canonicalize (T cmp (black-1 c) l k v r))]
+  [(BBL cmp)          (canonicalize (L cmp))]
+  ['R   '-B]
+  ['B    'R]
+  ['BB   'B])
+
+
+
+; Creates an empty map:
+(define (sorted-map-empty compare)
+  (canonicalize (L compare)))
+
+
+;; Custom patterns.
+   
+; Matches internal nodes:
+(define-match-expander T!
+  (syntax-rules ()
+    [(_)            (T _ _ _ _ _ _)]
+    [(_ l r)        (T _ _ l _ _ r)]
+    [(_ c l r)      (T _ c l _ _ r)]
+    [(_ l k v r)    (T _ _ l k v r)]
+    [(_ c l k v r)  (T _ c l k v r)]))
+
+; Matches leaf nodes: 
+(define-match-expander L!
+  (syntax-rules ()
+    [(_)     (L _)]))
+
+; Matches black nodes (leaf or internal):
+(define-match-expander B
+  (syntax-rules ()
+    [(_)              (or (T _ 'B _ _ _ _)
+                          (L _))]
+    [(_ cmp)          (or (T cmp 'B _ _ _ _)
+                          (L cmp))]
+    [(_ l r)          (T _ 'B l _ _ r)]
+    [(_ l k v r)      (T _ 'B l k v r)]
+    [(_ cmp l k v r)  (T cmp 'B l k v r)]))
+
+; Matches red nodes:
+(define-match-expander R
+  (syntax-rules ()
+    [(_)              (T _ 'R _ _ _ _)]
+    [(_ cmp)          (T cmp 'R _ _ _ _)]
+    [(_ l r)          (T _ 'R l _ _ r)]
+    [(_ l k v r)      (T _ 'R l k v r)]
+    [(_ cmp l k v r)  (T cmp 'R l k v r)]))
+
+; Matches negative black nodes:
+(define-match-expander -B
+  (syntax-rules ()
+    [(_)                (T _ '-B _ _ _ _)]
+    [(_ cmp)            (T cmp '-B _ _ _ _)]
+    [(_ l k v r)        (T _ '-B l k v r)]
+    [(_ cmp l k v r)    (T cmp '-B l k v r)]))
+
+; Matches double-black nodes (leaf or internal):
+(define-match-expander BB
+  (syntax-rules ()
+    [(_)              (or (T _ 'BB _ _ _ _)
+                          (BBL _))]
+    [(_ cmp)          (or (T cmp 'BB _ _ _ _)
+                          (BBL _))]
+    [(_ l k v r)      (T _ 'BB l k v r)]
+    [(_ cmp l k v r)  (T cmp 'BB l k v r)]))
+
+(define/match (double-black? node)
+  [(BB) #t]
+  [_    #f])
+
+
+; Turns a black-balanced tree with invalid colors
+; into a black-balanced tree with valid colors:
+(define (balance-node node)
+  (define cmp (sorted-map-compare node))
+  (match node
+    [(or (T! (or 'B 'BB) (R (R a xk xv b) yk yv c) zk zv d)
+         (T! (or 'B 'BB) (R a xk xv (R b yk yv c)) zk zv d)
+         (T! (or 'B 'BB) a xk xv (R (R b yk yv c) zk zv d))
+         (T! (or 'B 'BB) a xk xv (R b yk yv (R c zk zv d))))
+     ; =>
+     (canonicalize (T cmp
+		      (black-1 (T-color node))
+		      (canonicalize (T cmp 'B a xk xv b))
+		      yk
+		      yv
+		      (canonicalize (T cmp 'B c zk zv d))))]
+    
+    [(BB a xk xv (-B (B b yk yv c) zk zv (and d (B))))
+     ; =>
+     (canonicalize (T cmp
+		      'B
+		      (canonicalize (T cmp 'B a xk xv b))
+		      yk
+		      yv
+		      (balance cmp 'B c zk zv (redden d))))]
+    
+    [(BB (-B (and a (B)) xk xv (B b yk yv c)) zk zv d)
+     ; =>
+     (canonicalize (T cmp
+		      'B
+		      (balance cmp 'B (redden a) xk xv b)
+		      yk
+		      yv
+		      (canonicalize (T cmp 'B c zk zv d))))]
+    
+    [else     node]))
+  
+(define (balance cmp c l k v r)
+  (balance-node (canonicalize (T cmp c l k v r))))
+
+
+; Moves to a location in the map and
+; peformes an update with the function:
+;; tonyg 20140718 added on-missing argument
+(define (sorted-map-modify-at node key f [on-missing (lambda () #f)])
+  
+  (define (internal-modify-at node key f)
+    (match node 
+      [(T cmp c l k v r)
+       ; =>
+       (switch-compare (cmp key k)
+        [<  (balance cmp c (internal-modify-at l key f) k v r)]
+        [=  (canonicalize (T cmp c l k (f k v) r))]
+        [>  (balance cmp c l k v (internal-modify-at r key f))])]
+      
+      [(L cmp)
+       ; =>
+       (canonicalize (T cmp 'R node key (f key (on-missing)) node))]))
+
+  (blacken (internal-modify-at node key f)))
+
+  
+; Inserts an element into the map
+(define (sorted-map-insert node key value)
+  (sorted-map-modify-at node key (lambda (k v) value)))
+
+  
+; Inserts several elements into the map:
+(define (sorted-map-insert* node keys values)
+  (if (or (not (pair? keys))
+          (not (pair? values)))
+      node
+      (sorted-map-insert* 
+       (sorted-map-insert node (car keys) (car values)) 
+       (cdr keys) (cdr values))))
+
+
+; Coverts a sorted map into a tree:
+(define/match (sorted-map-to-tree node)
+  [(L!)             'L]
+  [(T! c l k v r)   `(,c ,(sorted-map-to-tree l) ,k ,v ,(sorted-map-to-tree r))]
+  [else              node])
+
+
+; Converts a sorted map into an alist:
+(define (sorted-map-to-alist node)
+  
+  (define (sorted-map-prepend-as-alist node alist)
+    (match node
+      [(T! l k v r)
+       ; =>
+       (sorted-map-prepend-as-alist 
+        l
+        (cons (cons k v)
+              (sorted-map-prepend-as-alist r alist)))]
+            
+      [(L _)
+       ; =>
+       alist]))
+  
+  (sorted-map-prepend-as-alist node '()))
+  
+
+; Tests whether this map is a submap of another map:
+(define (sorted-map-submap? map1 map2 #:by [by equal?])
+  (define amap1 (sorted-map-to-alist map1))
+  (define amap2 (sorted-map-to-alist map2))
+  (define cmp   (sorted-map-compare map1))
+  
+  (define (compare-alists amap1 amap2)
+    (match* (amap1 amap2)
+      [(`((,k1 . ,v1) . ,rest1)
+        `((,k2 . ,v2) . ,rest2))
+       ; =>
+       (switch-compare (cmp k1 k2)
+          [< #f]
+          [= (and (by v1 v2) (compare-alists rest1 rest2))]
+          [> (compare-alists amap1 rest2)])]
+      
+      [('() '())   #t]
+      
+      [(_ '())     #f]
+      
+      [('() _)     #t]))
+  
+  (compare-alists amap1 amap2))
+
+
+; Gets an element from a sorted map:
+;; tonyg 20140718 add on-missing argument
+(define (sorted-map-get node key [on-missing (lambda () #f)])
+  (let walk ((node node))
+    (match node
+      [(L!)    (on-missing)]
+    
+      [(T cmp c l k v r)
+       ; =>
+       (switch-compare (cmp key k)
+	  [<   (walk l)]
+	  [=   v]
+	  [>   (walk r)])])))
+
+
+; Returns the size of the sorted map:
+;; tonyg 20140718 this is memoized to run in O(1) for every smap
+(define sorted-map-size
+  (memoize1
+   (lambda (smap)
+     (match smap
+       [(T! l r)   (+ 1 (sorted-map-size l)
+		        (sorted-map-size r))]
+       [(L!)       0]))))
+
+
+; Returns the maxium (key . value) pair:
+(define/match (sorted-map-max node)
+  [(T! _ k v (L!))   (cons k v)]
+  [(T! _     r)      (sorted-map-max r)])
+
+
+; Performs a check to see if both invariants are met:
+(define (sorted-map-is-legal? node)
+  
+  ; Calculates the max black nodes on path:
+  (define/match (max-black-height node)
+    [(T! c l r)
+     ; =>
+     (+ (if (eq? c 'B) 1 0) (max (max-black-height l) 
+                                 (max-black-height r)))]
+    
+    [(L!)     1])
+  
+  ; Calculates the min black nodes on a path:
+  (define/match (min-black-height node)
+    [(T! c l r)
+     ; =>
+     (+ (if (eq? c 'B) 1 0) (min (min-black-height l) 
+                                 (min-black-height r)))]
+    
+    [(L!)     1])
+  
+  ; Is this tree black-balanced?
+  (define (black-balanced? node)
+    (= (max-black-height node)
+       (min-black-height node)))
+  
+  ; Does this tree contain a red child of red?
+  (define/match (no-red-red? node)
+    [(or (B l r)
+         (R (and l (B)) (and r (B))))
+     ; =>
+     (and (no-red-red? l) (no-red-red? r))]
+    
+    [(L!)    #t]
+    [else    #f])
+  
+  (let ((colored?  (no-red-red? node))
+        (balanced? (black-balanced? node)))
+    (and colored? balanced?)))
+    
+
+; Deletes a key from this map:
+(define (sorted-map-delete node key)
+    
+  (define cmp (sorted-map-compare node))
+  
+  ; Finds the node to be removed:
+  (define/match (del node)
+    [(T! c l k v r)
+     ; =>
+     (switch-compare (cmp key k)
+       [<   (bubble c (del l) k v r)]
+       [=   (remove node)]
+       [>   (bubble c l k v (del r))])]
+    
+    [else     node])
+
+  ; Removes this node; it might
+  ; leave behind a double-black node:
+  (define/match (remove node)
+    ; Leaves are easiest to kill:
+    [(R (L!) (L!))     (canonicalize (L cmp))]
+    [(B (L!) (L!))     (canonicalize (BBL cmp))]
+    
+    ; Killing a node with one child;
+    ; parent or child is red:
+    [(or (R child (L!))
+         (R (L!)  child))
+     ; =>
+     child]
+    
+    [(or (B (R l k v r) (L!))
+         (B (L!) (R l k v r)))
+     ; =>
+     (canonicalize (T cmp 'B l k v r))]
+    
+    ; Killing a black node with one black child:
+    [(or (B (L!) (and child (B)))
+         (B (and child (B)) (L!)))
+     ; =>
+     (black+1 child)]
+    
+    ; Killing a node with two sub-trees:
+    [(T! c (and l (T!)) (and r (T!)))
+     ; =>
+     (match-let (((cons k v) (sorted-map-max l))
+                 (l*         (remove-max l)))
+       (bubble c l* k v r))])
+  
+  ; Kills a double-black, or moves it to the top:
+  (define (bubble c l k v r)
+    (cond
+      [(or (double-black? l) (double-black? r))
+       ; =>
+       (balance cmp (black+1 c) (black-1 l) k v (black-1 r))]
+      
+      [else (canonicalize (T cmp c l k v r))]))
+  
+  ; Removes the max node:
+  (define/match (remove-max node)
+    [(T!   l     (L!))  (remove node)]
+    [(T! c l k v r   )  (bubble c l k v (remove-max r))])
+   
+  ; Delete the key, and color the new root black:
+  (blacken (del node)))
+
+
+;; tonyg 20140718 True iff key is in node
+(define (sorted-map-has-key? node key)
+  (let walk ((node node))
+    (match node
+      [(L!)    #f]
+      [(T cmp c l k v r)
+       (switch-compare (cmp key k)
+	  [<   (walk l)]
+	  [=   #t]
+	  [>   (walk r)])])))
+
+;; tonyg 20140718 Retrieve a set of the keys of smap
+(define (sorted-map-keys smap [empty-set (set)])
+  (let walk ((node smap) (acc empty-set))
+    (match node
+      [(T! l k v r) (walk l (set-add (walk r acc) k))]
+      [(L _) acc])))
+
+;; tonyg 20140718 Retrieve a list of the values of smap
+(define (sorted-map-values smap)
+  (let walk ((node smap) (acc '()))
+    (match node
+      [(T! l k v r) (walk l (cons v (walk r acc)))]
+      [(L _) acc])))

minimart/trace.rkt

@@ -8,7 +8,7 @@
 	 trace-process-step
 	 trace-internal-step)
 
-(require "exn-util.rkt")
+(require (only-in web-server/private/util exn->string))
 
 (define trace-logger (make-logger 'minimart-trace))
 

minimart/trace/stderr.rkt

@@ -1,15 +1,13 @@
 #lang racket/base
 
-(provide set-stderr-trace-flags!)
-
 (require racket/set)
 (require racket/match)
 (require racket/pretty)
 (require (only-in racket/string string-join))
+(require (only-in web-server/private/util exn->string))
 (require "../core.rkt")
 (require "../gestalt.rkt")
 (require "../trace.rkt")
-(require "../exn-util.rkt")
 
 (define (env-aref varname default alist)
   (define key (or (getenv varname) default))
@@ -21,34 +19,19 @@
 
 (define colored-output? (env-aref "MINIMART_COLOR" "true" '(("true" #t) ("false" #f))))
 
-(define flags (set))
+(define flags (for/set [(c (or (getenv "MINIMART_TRACE") "xetpag"))] (string->symbol (string c))))
-(define show-exceptions? #f)
-(define show-routing-update-events? #f)
-(define show-message-events? #f)
-(define show-events? #f)
-(define show-process-states-pre? #f)
-(define show-process-states-post? #f)
-(define show-process-lifecycle? #f)
-(define show-routing-update-actions? #f)
-(define show-message-actions? #f)
-(define show-actions? #f)
-(define show-world-gestalt? #f)
 
-(define (set-stderr-trace-flags! flags-string)
+(define show-exceptions? (set-member? flags 'x))
-  (set! flags (for/set [(c flags-string)] (string->symbol (string c))))
+(define show-routing-update-events? (set-member? flags 'r))
-  (set! show-exceptions? (set-member? flags 'x))
+(define show-message-events? (set-member? flags 'm))
-  (set! show-routing-update-events? (set-member? flags 'r))
+(define show-events? (set-member? flags 'e))
-  (set! show-message-events? (set-member? flags 'm))
+(define show-process-states-pre? (set-member? flags 's))
-  (set! show-events? (set-member? flags 'e))
+(define show-process-states-post? (set-member? flags 't))
-  (set! show-process-states-pre? (set-member? flags 's))
+(define show-process-lifecycle? (set-member? flags 'p))
-  (set! show-process-states-post? (set-member? flags 't))
+(define show-routing-update-actions? (set-member? flags 'R))
-  (set! show-process-lifecycle? (set-member? flags 'p))
+(define show-message-actions? (set-member? flags 'M))
-  (set! show-routing-update-actions? (set-member? flags 'R))
+(define show-actions? (set-member? flags 'a))
-  (set! show-message-actions? (set-member? flags 'M))
+(define show-world-gestalt? (set-member? flags 'g))
-  (set! show-actions? (set-member? flags 'a))
-  (set! show-world-gestalt? (set-member? flags 'g)))
-
-(set-stderr-trace-flags! (or (getenv "MINIMART_TRACE") ""))
 
 (define YELLOW-ON-RED ";1;33;41")
 (define WHITE-ON-RED ";1;37;41")
@@ -131,7 +114,7 @@
 	   (with-color WHITE-ON-RED
 		       (output "Process ~a died with exception:\n~a\n"
 			       pidstr
-                               (exn->string exn))))
+			       (exn->string exn))))
 	 (when (or relevant-exn? show-process-states-post?)
 	   (when t
 	     (unless (boring-state? (transition-state t))

minimart/treap.rkt

@@ -1,220 +0,0 @@
-#lang racket/base
-;; Treaps, which have the lovely property of *canonical representation*.
-;;
-;; We take care to preserve an additional invariant:
-;;  - if n is a left child of m, then n's priority <= m's priority, and
-;;  - if n is a right child of m, then n's priority < m's priority.
-;;
-;; Further, we explicitly canonicalize N instances, so eq? works to compare treaps by value.
-
-(provide treap?
-         treap-order
-         treap-size
-         treap-empty
-         treap-empty?
-         treap->empty
-         treap-insert
-         treap-delete
-         treap-get
-         treap-keys
-         treap-values
-         treap-fold
-         treap-to-alist
-         treap-has-key?
-
-         treap-height)
-
-(require racket/set)
-(require racket/match)
-
-(require "canonicalize.rkt")
-;; (define canonicalize values)
-
-(struct N (key value priority left right) #:transparent
-	#:methods gen:equal+hash
-	[(define (equal-proc a b =?)
-	   (match-define (N ak av ap al ar) a)
-	   (match-define (N bk bv bp bl br) b)
-	   (and (eq? al bl)
-		(eq? ar br)
-		(= ap bp)
-		(=? ak bk)
-		(=? av bv)))
-	 (define (hash-proc a h)
-	   (match-define (N ak av ap al ar) a)
-	   (+ (eq-hash-code al)
-	      (eq-hash-code ar)
-	      (h ap)
-	      (h ak)
-	      (h av)))
-	 (define (hash2-proc a h)
-	   (match-define (N ak av ap al ar) a)
-	   (bitwise-xor (eq-hash-code al)
-			(eq-hash-code ar)
-			(h ap)
-			(h ak)
-			(h av)))])
-
-(struct L () #:transparent)
-
-(struct treap (order root size) #:transparent)
-
-;; The singleton "empty" leaf sentinel
-(define L0 (L))
-
-(define (treap-empty o) (treap o L0 0))
-
-(define (treap-empty? t) (zero? (treap-size t)))
-
-(define (treap->empty t) (treap-empty (treap-order t)))
-
-(define (default-priority key)
-  ;; Loosely based on a restriction of murmur32 v3
-  (define c1 #xcc9e2d51)
-  (define c2 #x1b873593)
-  (define r1 15)
-  (define r2 13)
-  (define m 5)
-  (define n #xe6546b64)
-  (define k (* (equal-hash-code key) c1))
-  (define hash0 (* c2 (bitwise-ior (arithmetic-shift k r1) (arithmetic-shift k (- 32 r1)))))
-  (define hash1
-    (+ n (* m (bitwise-ior (arithmetic-shift hash0 r2) (arithmetic-shift hash0 (- 32 r2))))))
-  (define hash2
-    (bitwise-and #xffffffff (* #x85ebca6b (bitwise-xor hash1 (arithmetic-shift hash1 -16)))))
-  (define hash3
-    (bitwise-and #xffffffff (* #xc2b2ae35 (bitwise-xor hash2 (arithmetic-shift hash2 -13)))))
-  (bitwise-xor hash3 (arithmetic-shift hash3 -16)))
-
-(define (treap-insert t key value [priority (default-priority key)])
-  (match-define (treap order root oldsize) t)
-  (define newsize (+ oldsize 1)) ;; WARNING: mutated below!
-  (define newroot
-    (let walk ((n root))
-      (match n
-        [(L)
-         (canonicalize (N key value priority L0 L0))]
-        [(N k v p left right)
-         (case (order key k)
-           [(<) (match (walk left)  [(N K V P l r) (rotate K V P k v p l r right)])]
-           [(>) (match (walk right) [(N K V P l r) (rotate k v p K V P left l r)])]
-           [(=)
-            (set! newsize (- newsize 1)) ;; we are *REPLACING* an existing value
-            (let merge ((left left) (right right))
-              (cond
-               [(priority>= priority left)
-                (if (priority> priority right)
-                    (canonicalize (N key value priority left right))
-                    (replace-left right (merge left (N-left right))))]
-               [(priority> priority right)
-                (replace-right left (merge (N-right left) right))]
-               [else
-                (if (priority> (N-priority left) right)
-                    (replace-right left (merge (N-right left) right))
-                    (replace-left right (merge left (N-left right))))]))])])))
-  (canonicalize (treap order newroot newsize)))
-
-(define (replace-left n x)
-  (canonicalize
-   (match n
-     [(N k v p _ r)
-      (N k v p x r)])))
-
-(define (replace-right n x)
-  (canonicalize
-   (match n
-     [(N k v p l _)
-      (N k v p l x)])))
-
-(define (priority> p1 n)
-  (match n
-    [(L) #t]
-    [(N _ _ p2 _ _) (> p1 p2)]))
-
-(define (priority>= p1 n)
-  (match n
-    [(L) #t]
-    [(N _ _ p2 _ _) (>= p1 p2)]))
-
-(define (rotate k1 v1 p1 k2 v2 p2 tl tm tr)
-  (if (> p1 p2)
-      (canonicalize (N k1 v1 p1 tl (canonicalize (N k2 v2 p2 tm tr))))
-      (canonicalize (N k2 v2 p2 (canonicalize (N k1 v1 p1 tl tm)) tr))))
-
-(define (treap-delete t key)
-  (match-define (treap order root oldsize) t)
-  (define newsize oldsize)
-  (define newroot
-    (let walk ((n root))
-      (match n
-        [(L) L0]
-        [(N k v p left right)
-         (case (order key k)
-           [(<) (canonicalize (N k v p (walk left) right))]
-           [(>) (canonicalize (N k v p left (walk right)))]
-           [(=)
-            (set! newsize (- newsize 1)) ;; we found the value to remove
-            (let merge ((left left) (right right))
-              (cond
-               [(L? left) right]
-               [(L? right) left]
-               [else
-                (match-define (N lk lv lp ll lr) left)
-                (match-define (N rk rv rp rl rr) right)
-                (canonicalize
-                 (if (< lp rp)
-                     (N lk lv lp ll (merge lr right))
-                     (N rk rv rp (merge left rl) rr)))]))])])))
-  (canonicalize (treap order newroot newsize)))
-
-(define (treap-get t key [on-missing (lambda () #f)])
-  (define order (treap-order t))
-  (let walk ((n (treap-root t)))
-    (match n
-      [(L) (on-missing)]
-      [(N k v _ left right)
-       (case (order key k)
-         [(<) (walk left)]
-         [(>) (walk right)]
-         [(=) v])])))
-
-(define (treap-keys t #:empty-set [empty-set (set)])
-  (let walk ((n (treap-root t)) (acc empty-set))
-    (match n
-      [(L) acc]
-      [(N k _ _ left right) (walk left (walk right (set-add acc k)))])))
-
-(define (treap-values t)
-  (let walk ((n (treap-root t)) (acc '()))
-    (match n
-      [(L) acc]
-      [(N k _ _ left right) (walk left (cons k (walk right acc)))])))
-
-(define (treap-fold t f seed)
-  (let walk ((n (treap-root t)) (acc seed))
-    (match n
-      [(L) acc]
-      [(N k v _ left right) (walk left (f (walk right acc) k v))])))
-
-(define (treap-to-alist t)
-  (let walk ((n (treap-root t)) (acc '()))
-    (match n
-      [(L) acc]
-      [(N k v _ left right) (walk left (cons (cons k v) (walk right acc)))])))
-
-(define (treap-has-key? t key)
-  (define order (treap-order t))
-  (let walk ((n (treap-root t)))
-    (match n
-      [(L) #f]
-      [(N k v _ left right)
-       (case (order key k)
-         [(<) (walk left)]
-         [(>) (walk right)]
-         [(=) #t])])))
-
-(define (treap-height t)
-  (let walk ((n (treap-root t)))
-    (match n
-      [(L) 0]
-      [(N _ _ _ l r) (+ 1 (max (walk l) (walk r)))])))

minimart/tset.rkt

@@ -1,96 +0,0 @@
-#lang racket/base
-
-(require "treap.rkt")
-
-(provide tset?
-         datum-tset
-         make-tset
-         tset-count
-         tset-empty
-         tset-empty?
-         tset-add
-         tset-remove
-         tset-union
-         tset-intersect
-         tset-subtract
-         tset->list
-         tset-member?
-         )
-
-(require data/order)
-
-(define (tset? t)
-  (treap? t))
-
-(define (datum-tset . elts)
-  (make-tset datum-order elts))
-
-(define (make-tset o elts)
-  (for/fold [(t (tset-empty o))] [(e elts)] (tset-add t e)))
-
-(define (tset-count t)
-  (treap-size t))
-
-(define (tset-empty o)
-  (treap-empty o))
-
-(define (tset-empty? t)
-  (treap-empty? t))
-
-(define (tset-add t v)
-  (treap-insert t v #t))
-
-(define (tset-remove t v)
-  (treap-delete t v))
-
-(define (tset-union t1 t2)
-  (if (< (treap-size t1) (treap-size t2))
-      (treap-fold t1 treap-insert t2)
-      (treap-fold t2 treap-insert t1)))
-
-(define (tset-intersect t1 t2)
-  (if (< (treap-size t1) (treap-size t2))
-      (treap-fold t1
-                  (lambda (t k v) (if (treap-has-key? t2 k) (treap-insert t k v) t))
-                  (treap->empty t1))
-      (treap-fold t2
-                  (lambda (t k v) (if (treap-has-key? t1 k) (treap-insert t k v) t))
-                  (treap->empty t2))))
-
-(define (tset-subtract t1 t2)
-  (if (< (treap-size t1) (treap-size t2))
-      (treap-fold t1
-                  (lambda (t k v) (if (treap-has-key? t2 k) t (treap-insert t k v)))
-                  (treap->empty t1))
-      (treap-fold t2
-                  (lambda (t k v) (treap-delete t k))
-                  t1)))
-
-(define (tset->list t)
-  (treap-fold t (lambda (acc k v) (cons k acc)) '()))
-
-(define (tset-member? t k)
-  (treap-has-key? t k))
-
-(module+ test
-  (require rackunit)
-  (require data/order)
-  (define (tset . elts) (make-tset datum-order elts))
-  (check-equal? (tset->list (tset 1 2 3 4 5)) '(1 2 3 4 5))
-  (check-equal? (tset->list (tset 5 4 3 2 1)) '(1 2 3 4 5))
-  (check-equal? (tset->list (tset-union (tset 1 2 3) (tset 2 3 4))) '(1 2 3 4))
-  (check-equal? (tset->list (tset-intersect (tset 1 2 3) (tset 2 3 4))) '(2 3))
-  (check-equal? (tset->list (tset-subtract (tset 1 2 3) (tset 2 3 4))) '(1))
-  (check-true (tset-member? (tset 1 2 3) 2))
-  (check-false (tset-member? (tset 1 2 3) 4))
-  (check-true (tset-empty? (tset)))
-  (check-false (tset-empty? (tset 1)))
-  (check-equal? (tset-count (tset 1 2 3)) 3)
-  (check-equal? (tset-count (tset)) 0)
-  (check-equal? (tset-count (tset-union (tset 1 2 3) (tset 2 3 4))) 4)
-  (check-true (tset? (tset-empty datum-order)))
-  (check-true (tset? (tset)))
-  (check-false (tset? 123))
-  (check-false (tset? (list 1 2 3)))
-  (check-false (tset? 'a))
-  )