Compare commits
26 Commits
sorted_map
...
main
Author | SHA1 | Date |
---|---|---|
Tony Garnock-Jones | a7503d16e4 | |
Tony Garnock-Jones | 5280f1eb5c | |
Tony Garnock-Jones | 457d53fc54 | |
Tony Garnock-Jones | 1ff931eb80 | |
Tony Garnock-Jones | 7858b3aee1 | |
Tony Garnock-Jones | d031b60995 | |
Tony Garnock-Jones | 234ba0d417 | |
Tony Garnock-Jones | b380c9ca64 | |
Tony Garnock-Jones | 33251164b2 | |
Tony Garnock-Jones | 2286c7c617 | |
Tony Garnock-Jones | 5bd30db9b0 | |
Tony Garnock-Jones | 81d2ddedbb | |
Tony Garnock-Jones | 19df097898 | |
Tony Garnock-Jones | cf9920dec5 | |
Tony Garnock-Jones | f189dfdf4f | |
Tony Garnock-Jones | 7ab3f61ef9 | |
Tony Garnock-Jones | e237b49bb0 | |
Tony Garnock-Jones | 9566830bc1 | |
Tony Garnock-Jones | 4ab8accfb1 | |
Tony Garnock-Jones | 1fa2743751 | |
Tony Garnock-Jones | 5cce0db45f | |
Tony Garnock-Jones | 2335a64633 | |
Tony Garnock-Jones | 91246c1471 | |
Tony Garnock-Jones | 2fd7a07fe0 | |
Tony Garnock-Jones | 0a73988d6f | |
Tony Garnock-Jones | 1dc38bd9c1 |
1
info.rkt
1
info.rkt
|
@ -7,5 +7,4 @@
|
||||||
"net-lib"
|
"net-lib"
|
||||||
"profile-lib"
|
"profile-lib"
|
||||||
"rackunit-lib"
|
"rackunit-lib"
|
||||||
"web-server-lib"
|
|
||||||
))
|
))
|
||||||
|
|
|
@ -37,8 +37,8 @@
|
||||||
|
|
||||||
(define-syntax (actor stx)
|
(define-syntax (actor stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ forms ...)
|
[(_actor forms ...)
|
||||||
(analyze-actor #'(forms ...))]))
|
(analyze-actor #'_actor #'(forms ...))]))
|
||||||
|
|
||||||
(define-syntax (observe-gestalt stx) (raise-syntax-error #f "Use of observe-gestalt outside actor form" stx))
|
(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))
|
(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)
|
(struct participator (condition meta-level) #:transparent)
|
||||||
|
|
||||||
(define (analyze-actor forms-stx)
|
(define (analyze-actor actor-form-head-stx forms-stx)
|
||||||
(define actor-name #f)
|
(define actor-name #f)
|
||||||
|
|
||||||
;; (Listof Identifier)
|
;; (Listof Identifier)
|
||||||
|
@ -289,7 +289,7 @@
|
||||||
|
|
||||||
(push! gestalt-updaters
|
(push! gestalt-updaters
|
||||||
#`(begin
|
#`(begin
|
||||||
(define #,gestalt-init #,gestalt-stx)
|
(define #,gestalt-init (label-gestalt #,gestalt-stx #t))
|
||||||
#:update [#,gestalt-name #,gestalt-init]))
|
#:update [#,gestalt-name #,gestalt-init]))
|
||||||
|
|
||||||
(push! gestalt-fragments gestalt-name)
|
(push! gestalt-fragments gestalt-name)
|
||||||
|
@ -436,7 +436,7 @@
|
||||||
#`(#:when #,condition)
|
#`(#:when #,condition)
|
||||||
#'())
|
#'())
|
||||||
(#,(if pub? #'pub #'sub) #,gestalt-stx
|
(#,(if pub? #'pub #'sub) #,gestalt-stx
|
||||||
#:meta-level #,meta-level)))))
|
#:meta-level #,(or meta-level 0))))))
|
||||||
|
|
||||||
(define (push-action! action-stx)
|
(define (push-action! action-stx)
|
||||||
(define-temporaries [temp action-stx])
|
(define-temporaries [temp action-stx])
|
||||||
|
@ -446,7 +446,7 @@
|
||||||
(define (build-result)
|
(define (build-result)
|
||||||
(let ((actor-name (or actor-name #'anonymous-actor)))
|
(let ((actor-name (or actor-name #'anonymous-actor)))
|
||||||
(define state-struct-name
|
(define state-struct-name
|
||||||
(datum->syntax actor-name (string->symbol (format "~a-state" (syntax->datum actor-name)))))
|
(datum->syntax actor-form-head-stx (string->symbol (format "~a-state" (syntax->datum actor-name)))))
|
||||||
(define-temporaries
|
(define-temporaries
|
||||||
[e-stx #'event]
|
[e-stx #'event]
|
||||||
[state-stx #'state]
|
[state-stx #'state]
|
||||||
|
|
|
@ -0,0 +1,105 @@
|
||||||
|
#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)))))
|
|
@ -0,0 +1,40 @@
|
||||||
|
#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))))
|
|
@ -1,51 +1,27 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
;; Generic relay for WebSockets/TCP/etc-based participation in a network.
|
;; Generic relay for WebSockets/TCP/etc-based participation in a network.
|
||||||
|
|
||||||
(provide spawn-websocket-relay)
|
(provide spawn-broker-server)
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require net/rfc6455)
|
(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 json)
|
||||||
|
(require "protocol.rkt")
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
||||||
;; Main: start WebSocket server
|
|
||||||
|
|
||||||
;; Depends on timer driver and websocket driver running at metalevel 1.
|
;; Depends on timer driver and websocket driver running at metalevel 1.
|
||||||
(define (spawn-websocket-relay port [ssl-options #f])
|
(define (spawn-broker-server port [ssl-options #f])
|
||||||
(define server-id (websocket-local-server port ssl-options))
|
(define server-id (websocket-local-server port ssl-options))
|
||||||
(spawn-demand-matcher (websocket-message (?! (websocket-remote-client ?)) server-id ?)
|
(spawn-demand-matcher (websocket-message (?! (websocket-remote-client ?)) server-id ?)
|
||||||
#:meta-level 1
|
#:meta-level 1
|
||||||
(lambda (c) (spawn-connection-handler c server-id))))
|
(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)
|
(define (spawn-connection-handler c server-id)
|
||||||
(actor #:name relay
|
(actor #:name broker-server
|
||||||
#:state [tunnelled-gestalt (gestalt-empty)]
|
#:state [tunnelled-gestalt (gestalt-empty)]
|
||||||
|
|
||||||
(send #:meta-level 1 (set-timer c (ping-interval) 'relative))
|
(send #:meta-level 1 (set-timer c (ping-interval) 'relative))
|
|
@ -8,6 +8,7 @@
|
||||||
(require "gestalt.rkt")
|
(require "gestalt.rkt")
|
||||||
(require "functional-queue.rkt")
|
(require "functional-queue.rkt")
|
||||||
(require "trace.rkt")
|
(require "trace.rkt")
|
||||||
|
(require "tset.rkt")
|
||||||
|
|
||||||
(provide (struct-out routing-update)
|
(provide (struct-out routing-update)
|
||||||
(struct-out message)
|
(struct-out message)
|
||||||
|
@ -462,12 +463,12 @@
|
||||||
[(message body meta-level feedback?)
|
[(message body meta-level feedback?)
|
||||||
(define pids (gestalt-match-value (world-partial-gestalt w) body meta-level feedback?))
|
(define pids (gestalt-match-value (world-partial-gestalt w) body meta-level feedback?))
|
||||||
(define pt (world-process-table w))
|
(define pt (world-process-table w))
|
||||||
(for/fold ([w w]) [(pid (in-set pids))] (step-process e pid (hash-ref pt pid) w))]
|
(for/fold ([w w]) [(pid (in-list (tset->list pids)))] (step-process e pid (hash-ref pt pid) w))]
|
||||||
[(pending-routing-update g affected-subgestalt known-target)
|
[(pending-routing-update g affected-subgestalt known-target)
|
||||||
(define affected-pids (gestalt-match affected-subgestalt g))
|
(define affected-pids (gestalt-match affected-subgestalt g))
|
||||||
(define pt (world-process-table w))
|
(define pt (world-process-table w))
|
||||||
(for/fold ([w w])
|
(for/fold ([w w])
|
||||||
[(pid (in-set (if known-target (set-add affected-pids known-target) affected-pids)))]
|
[(pid (in-list (tset->list (if known-target (tset-add affected-pids known-target) affected-pids))))]
|
||||||
(match (hash-ref pt pid (lambda () #f))
|
(match (hash-ref pt pid (lambda () #f))
|
||||||
[#f w]
|
[#f w]
|
||||||
[p (step-process (routing-update (gestalt-filter g (process-gestalt p))) pid p w)]))]))
|
[p (step-process (routing-update (gestalt-filter g (process-gestalt p))) pid p w)]))]))
|
||||||
|
|
|
@ -0,0 +1,36 @@
|
||||||
|
#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)))))
|
|
@ -3,9 +3,9 @@
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require (prefix-in tcp: racket/tcp))
|
(require (prefix-in tcp: racket/tcp))
|
||||||
(require (only-in racket/port read-bytes-avail!-evt))
|
(require (only-in racket/port read-bytes-avail!-evt))
|
||||||
(require (only-in web-server/private/util exn->string))
|
|
||||||
(require "../main.rkt")
|
(require "../main.rkt")
|
||||||
(require "../demand-matcher.rkt")
|
(require "../demand-matcher.rkt")
|
||||||
|
(require "../exn-util.rkt")
|
||||||
|
|
||||||
(require racket/unit)
|
(require racket/unit)
|
||||||
(require net/tcp-sig)
|
(require net/tcp-sig)
|
||||||
|
@ -89,7 +89,7 @@
|
||||||
|
|
||||||
(define (spawn-tcp-listener server-addr)
|
(define (spawn-tcp-listener server-addr)
|
||||||
(match-define (tcp-listener port) server-addr)
|
(match-define (tcp-listener port) server-addr)
|
||||||
(define listener (tcp:tcp-listen port 4 #t))
|
(define listener (tcp:tcp-listen port 128 #t))
|
||||||
(define control-ch (make-channel))
|
(define control-ch (make-channel))
|
||||||
(thread (lambda () (tcp-listener-thread control-ch listener server-addr)))
|
(thread (lambda () (tcp-listener-thread control-ch listener server-addr)))
|
||||||
(spawn tcp-listener-behavior
|
(spawn tcp-listener-behavior
|
||||||
|
|
|
@ -10,9 +10,12 @@
|
||||||
(require net/tcp-sig)
|
(require net/tcp-sig)
|
||||||
(require net/tcp-unit)
|
(require net/tcp-unit)
|
||||||
(require net/ssl-tcp-unit)
|
(require net/ssl-tcp-unit)
|
||||||
|
(require net/url)
|
||||||
|
|
||||||
(provide (struct-out websocket-remote-client)
|
(provide (struct-out websocket-remote-client)
|
||||||
(struct-out websocket-local-server)
|
(struct-out websocket-local-server)
|
||||||
|
(struct-out websocket-local-client)
|
||||||
|
(struct-out websocket-remote-server)
|
||||||
(struct-out websocket-ssl-options)
|
(struct-out websocket-ssl-options)
|
||||||
(struct-out websocket-message)
|
(struct-out websocket-message)
|
||||||
spawn-websocket-driver)
|
spawn-websocket-driver)
|
||||||
|
@ -22,24 +25,31 @@
|
||||||
|
|
||||||
(struct websocket-remote-client (id) #:prefab)
|
(struct websocket-remote-client (id) #:prefab)
|
||||||
(struct websocket-local-server (port ssl-options) #: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-ssl-options (cert-file key-file) #:prefab)
|
||||||
(struct websocket-message (from to body) #:prefab)
|
(struct websocket-message (from to body) #:prefab)
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Ground-level communication messages
|
;; Ground-level communication messages
|
||||||
|
|
||||||
(struct websocket-accepted (id server-addr connection control-ch) #:prefab)
|
(struct websocket-connection (id local-addr remote-addr connection control-ch) #:prefab)
|
||||||
(struct websocket-incoming-message (id message) #:prefab)
|
(struct websocket-incoming-message (id message) #:prefab)
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Driver
|
;; Driver
|
||||||
|
|
||||||
(define (spawn-websocket-driver)
|
(define (spawn-websocket-driver)
|
||||||
(spawn-demand-matcher (websocket-message ? (?! (websocket-local-server ? ?)) ?)
|
(list
|
||||||
#:demand-is-subscription? #t
|
(spawn-demand-matcher (websocket-message ? (?! (websocket-local-server ? ?)) ?)
|
||||||
#:demand-level 1
|
#:demand-is-subscription? #t
|
||||||
#:supply-level 2
|
#:demand-level 1
|
||||||
spawn-websocket-listener))
|
#:supply-level 2
|
||||||
|
spawn-websocket-listener)
|
||||||
|
(spawn-demand-matcher (websocket-message (?! (websocket-local-client ?))
|
||||||
|
(?! (websocket-remote-server ?))
|
||||||
|
?)
|
||||||
|
spawn-websocket-connection)))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Listener
|
;; Listener
|
||||||
|
@ -54,16 +64,19 @@
|
||||||
(begin (when shutdown-procedure (shutdown-procedure))
|
(begin (when shutdown-procedure (shutdown-procedure))
|
||||||
(transition (struct-copy listener-state state [shutdown-procedure #f]) (quit)))
|
(transition (struct-copy listener-state state [shutdown-procedure #f]) (quit)))
|
||||||
#f)]
|
#f)]
|
||||||
[(message (websocket-accepted id _ c control-ch) 1 #f)
|
[(message (websocket-connection id local-addr remote-addr c control-ch) 1 #f)
|
||||||
(transition state
|
(transition state (spawn-connection local-addr remote-addr id c control-ch))]
|
||||||
(spawn-connection (listener-state-server-addr state) id c control-ch))]
|
|
||||||
[_ #f]))
|
[_ #f]))
|
||||||
|
|
||||||
(define ((connection-handler server-addr) c dummy-state)
|
(define ((connection-handler server-addr) c dummy-state)
|
||||||
(define control-ch (make-channel))
|
(define control-ch (make-channel))
|
||||||
(define c-input-port (ws-conn-base-ip c))
|
|
||||||
(define id (gensym 'ws))
|
(define id (gensym 'ws))
|
||||||
(send-ground-message (websocket-accepted id server-addr c control-ch))
|
(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))
|
||||||
(let loop ((blocked? #t))
|
(let loop ((blocked? #t))
|
||||||
(sync (handle-evt control-ch
|
(sync (handle-evt control-ch
|
||||||
(match-lambda
|
(match-lambda
|
||||||
|
@ -73,7 +86,9 @@
|
||||||
never-evt
|
never-evt
|
||||||
(handle-evt c-input-port
|
(handle-evt c-input-port
|
||||||
(lambda (dummy)
|
(lambda (dummy)
|
||||||
(define msg (ws-recv c #:payload-type 'text))
|
(define msg
|
||||||
|
(with-handlers ([exn:fail:network? (lambda (e) eof)])
|
||||||
|
(ws-recv c #:payload-type 'text)))
|
||||||
(send-ground-message (websocket-incoming-message id msg))
|
(send-ground-message (websocket-incoming-message id msg))
|
||||||
(loop (or blocked? (eof-object? msg))))))))
|
(loop (or blocked? (eof-object? msg))))))))
|
||||||
(ws-close! c))
|
(ws-close! c))
|
||||||
|
@ -96,12 +111,37 @@
|
||||||
(spawn websocket-listener
|
(spawn websocket-listener
|
||||||
(listener-state shutdown-procedure server-addr)
|
(listener-state shutdown-procedure server-addr)
|
||||||
(gestalt-union (pub (websocket-message ? server-addr ?) #:level 2)
|
(gestalt-union (pub (websocket-message ? server-addr ?) #:level 2)
|
||||||
(sub (websocket-accepted ? server-addr ? ?) #:meta-level 1))))
|
(sub (websocket-connection ? 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
|
;; Connection
|
||||||
|
|
||||||
(struct connection-state (seen-peer? local-addr server-addr c control-ch) #:transparent)
|
(struct connection-state (seen-peer? local-addr remote-addr c control-ch) #:transparent)
|
||||||
|
|
||||||
(define (shutdown-connection state)
|
(define (shutdown-connection state)
|
||||||
(transition (match (connection-state-control-ch state)
|
(transition (match (connection-state-control-ch state)
|
||||||
|
@ -110,15 +150,17 @@
|
||||||
(struct-copy connection-state state [control-ch #f])])
|
(struct-copy connection-state state [control-ch #f])])
|
||||||
(quit)))
|
(quit)))
|
||||||
|
|
||||||
(define (websocket-connection e state)
|
(define (websocket-connection-behaviour e state)
|
||||||
(with-handlers [((lambda (exn) #t)
|
(with-handlers [((lambda (exn) #t)
|
||||||
(lambda (exn) (shutdown-connection state)))]
|
(lambda (exn)
|
||||||
|
(shutdown-connection state)
|
||||||
|
(raise exn)))]
|
||||||
(match e
|
(match e
|
||||||
[(message (websocket-incoming-message _ m) 1 #f)
|
[(message (websocket-incoming-message _ m) 1 #f)
|
||||||
(if (eof-object? m)
|
(if (eof-object? m)
|
||||||
(shutdown-connection state)
|
(shutdown-connection state)
|
||||||
(transition state (send (websocket-message (connection-state-local-addr state)
|
(transition state (send (websocket-message (connection-state-remote-addr state)
|
||||||
(connection-state-server-addr state)
|
(connection-state-local-addr state)
|
||||||
m))))]
|
m))))]
|
||||||
[(message (websocket-message _ _ m) 0 #f)
|
[(message (websocket-message _ _ m) 0 #f)
|
||||||
(ws-send! (connection-state-c state) m)
|
(ws-send! (connection-state-c state) m)
|
||||||
|
@ -134,11 +176,10 @@
|
||||||
#f])]
|
#f])]
|
||||||
[#f #f])))
|
[#f #f])))
|
||||||
|
|
||||||
(define (spawn-connection server-addr id c control-ch)
|
(define (spawn-connection local-addr remote-addr id c control-ch)
|
||||||
(define local-addr (websocket-remote-client id))
|
(spawn websocket-connection-behaviour
|
||||||
(spawn websocket-connection
|
(connection-state #f local-addr remote-addr c control-ch)
|
||||||
(connection-state #f local-addr server-addr c control-ch)
|
(gestalt-union (pub (websocket-message remote-addr local-addr ?))
|
||||||
(gestalt-union (pub (websocket-message local-addr server-addr ?))
|
(sub (websocket-message local-addr remote-addr ?))
|
||||||
(sub (websocket-message server-addr local-addr ?))
|
(sub (websocket-message local-addr remote-addr ?) #:level 1)
|
||||||
(sub (websocket-message server-addr local-addr ?) #:level 1)
|
|
||||||
(sub (websocket-incoming-message id ?) #:meta-level 1))))
|
(sub (websocket-incoming-message id ?) #:meta-level 1))))
|
||||||
|
|
|
@ -0,0 +1,22 @@
|
||||||
|
#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)))))
|
|
@ -0,0 +1,15 @@
|
||||||
|
#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))))))
|
|
@ -3,10 +3,10 @@
|
||||||
|
|
||||||
(require minimart/drivers/timer)
|
(require minimart/drivers/timer)
|
||||||
(require minimart/drivers/websocket)
|
(require minimart/drivers/websocket)
|
||||||
(require minimart/relay)
|
(require minimart/broker/server)
|
||||||
|
|
||||||
(spawn-timer-driver)
|
(spawn-timer-driver)
|
||||||
(spawn-websocket-driver)
|
(spawn-websocket-driver)
|
||||||
(spawn-world
|
(spawn-world
|
||||||
(spawn-websocket-relay 8000)
|
(spawn-broker-server 8000)
|
||||||
(spawn-websocket-relay 8443 (websocket-ssl-options "server-cert.pem" "private-key.pem")))
|
(spawn-broker-server 8443 (websocket-ssl-options "server-cert.pem" "private-key.pem")))
|
||||||
|
|
|
@ -18,7 +18,7 @@
|
||||||
(advertise (tcp-channel us them ?) #:meta-level 1)
|
(advertise (tcp-channel us them ?) #:meta-level 1)
|
||||||
(subscribe `(,($ who) says ,($ what))
|
(subscribe `(,($ who) says ,($ what))
|
||||||
(say who "says: ~a" what))
|
(say who "says: ~a" what))
|
||||||
|
|
||||||
(advertise `(,user says ,?))
|
(advertise `(,user says ,?))
|
||||||
(subscribe (tcp-channel them us ($ bs)) #:meta-level 1
|
(subscribe (tcp-channel them us ($ bs)) #:meta-level 1
|
||||||
(send `(,user says ,(string-trim (bytes->string/utf-8 bs)))))
|
(send `(,user says ,(string-trim (bytes->string/utf-8 bs)))))
|
||||||
|
|
|
@ -0,0 +1,35 @@
|
||||||
|
#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"))
|
|
@ -0,0 +1,8 @@
|
||||||
|
#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))))
|
|
@ -3,9 +3,11 @@
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
(require (only-in racket/list make-list))
|
||||||
(require (only-in racket/port with-output-to-string))
|
(require (only-in racket/port with-output-to-string))
|
||||||
|
|
||||||
(require "route.rkt")
|
(require "route.rkt")
|
||||||
|
(require "tset.rkt")
|
||||||
|
|
||||||
(provide (struct-out gestalt)
|
(provide (struct-out gestalt)
|
||||||
(struct-out projection)
|
(struct-out projection)
|
||||||
|
@ -26,14 +28,17 @@
|
||||||
simple-gestalt
|
simple-gestalt
|
||||||
gestalt-empty
|
gestalt-empty
|
||||||
gestalt-empty?
|
gestalt-empty?
|
||||||
|
gestalt-full
|
||||||
gestalt-union*
|
gestalt-union*
|
||||||
gestalt-union
|
gestalt-union
|
||||||
gestalt-filter
|
gestalt-filter
|
||||||
gestalt-match
|
gestalt-match
|
||||||
gestalt-subtract
|
gestalt-subtract
|
||||||
gestalt-transform
|
gestalt-transform
|
||||||
|
gestalt-matcher-transform
|
||||||
strip-gestalt-label
|
strip-gestalt-label
|
||||||
label-gestalt
|
label-gestalt
|
||||||
|
gestalt-level-count
|
||||||
pretty-print-gestalt
|
pretty-print-gestalt
|
||||||
gestalt->pretty-string
|
gestalt->pretty-string
|
||||||
gestalt->jsexpr
|
gestalt->jsexpr
|
||||||
|
@ -72,7 +77,13 @@
|
||||||
;; -- Greg Egan, "Diaspora"
|
;; -- Greg Egan, "Diaspora"
|
||||||
;; http://gregegan.customer.netspace.net.au/DIASPORA/01/Orphanogenesis.html
|
;; 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
|
;; Convention: A GestaltSet is a Gestalt where the Matchers map to #t
|
||||||
;; instead of (NonemptySetof PID) or any other value.
|
;; instead of (NonemptySetof PID) or any other value.
|
||||||
|
@ -129,7 +140,7 @@
|
||||||
(define (gestalt-match-value g body metalevel is-feedback?)
|
(define (gestalt-match-value g body metalevel is-feedback?)
|
||||||
(define extract-matcher (if is-feedback? cdr car)) ;; feedback targets advertisers/publishers
|
(define extract-matcher (if is-feedback? cdr car)) ;; feedback targets advertisers/publishers
|
||||||
(define (pids-at level) (matcher-match-value (extract-matcher level) body))
|
(define (pids-at level) (matcher-match-value (extract-matcher level) body))
|
||||||
(apply set-union (set) (map pids-at (gestalt-metalevel-ref g metalevel))))
|
(foldr tset-union (datum-tset) (map pids-at (gestalt-metalevel-ref g metalevel))))
|
||||||
|
|
||||||
;; project-subs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
|
;; project-subs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
|
||||||
;; project-pubs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
|
;; project-pubs : Projection [#:meta-level Nat] [#:level Nat] -> GestaltProjection
|
||||||
|
@ -226,6 +237,13 @@
|
||||||
(for*/and [(ml (in-list (gestalt-metalevels g))) (l (in-list ml))]
|
(for*/and [(ml (in-list (gestalt-metalevels g))) (l (in-list ml))]
|
||||||
(and (matcher-empty? (car l)) (matcher-empty? (cdr l)))))
|
(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))
|
;; map-zip: ((U 'right-longer 'left-longer) (Listof X) -> (Listof Y))
|
||||||
;; (X X -> Y)
|
;; (X X -> Y)
|
||||||
;; (Y (Listof Y) -> (Listof Y))
|
;; (Y (Listof Y) -> (Listof Y))
|
||||||
|
@ -348,14 +366,14 @@
|
||||||
(match ls2
|
(match ls2
|
||||||
['() acc]
|
['() acc]
|
||||||
[(cons (cons subs2 advs2) lrest2)
|
[(cons (cons subs2 advs2) lrest2)
|
||||||
(loop lrest2 (set-union (matcher-match-matcher subs1 advs2)
|
(loop lrest2 (tset-union (tset-union (matcher-match-matcher subs1 advs2)
|
||||||
(matcher-match-matcher advs1 subs2)
|
(matcher-match-matcher advs1 subs2))
|
||||||
acc))])))
|
acc))])))
|
||||||
|
|
||||||
(lambda (g1 g2)
|
(lambda (g1 g2)
|
||||||
(parameterize ((matcher-match-matcher-successes (lambda (v1 v2 acc) (set-union v2 acc)))
|
(parameterize ((matcher-match-matcher-successes (lambda (v1 v2 acc) (tset-union v2 acc)))
|
||||||
(matcher-match-matcher-unit (set)))
|
(matcher-match-matcher-unit (datum-tset)))
|
||||||
(match-metalevels (gestalt-metalevels g1) (gestalt-metalevels g2) (set))))))
|
(match-metalevels (gestalt-metalevels g1) (gestalt-metalevels g2) (datum-tset))))))
|
||||||
|
|
||||||
;; Gestalt Gestalt -> Gestalt
|
;; Gestalt Gestalt -> Gestalt
|
||||||
;; Erases the g2-subset of g1 from g1, yielding the result.
|
;; Erases the g2-subset of g1 from g1, yielding the result.
|
||||||
|
@ -397,9 +415,14 @@
|
||||||
;; GestaltSet -> Gestalt
|
;; GestaltSet -> Gestalt
|
||||||
;; Relabels g so that all matched keys map to (set pid).
|
;; Relabels g so that all matched keys map to (set pid).
|
||||||
(define (label-gestalt g pid)
|
(define (label-gestalt g pid)
|
||||||
(define pidset (set pid))
|
(define pidset (datum-tset pid))
|
||||||
(gestalt-matcher-transform g (lambda (m) (matcher-relabel m (lambda (v) pidset)))))
|
(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
|
;; Gestalt [OutputPort] -> Void
|
||||||
;; Pretty-prints g on port.
|
;; Pretty-prints g on port.
|
||||||
(define (pretty-print-gestalt g [port (current-output-port)])
|
(define (pretty-print-gestalt g [port (current-output-port)])
|
||||||
|
|
|
@ -15,6 +15,7 @@
|
||||||
wildcard?
|
wildcard?
|
||||||
?!
|
?!
|
||||||
(struct-out capture)
|
(struct-out capture)
|
||||||
|
(struct-out embedded-matcher)
|
||||||
|
|
||||||
matcher? ;; expensive; see implementation
|
matcher? ;; expensive; see implementation
|
||||||
matcher-empty
|
matcher-empty
|
||||||
|
@ -55,6 +56,9 @@
|
||||||
(require (only-in racket/port call-with-output-string with-output-to-string))
|
(require (only-in racket/port call-with-output-string with-output-to-string))
|
||||||
(require (only-in racket/class object?))
|
(require (only-in racket/class object?))
|
||||||
(require "canonicalize.rkt")
|
(require "canonicalize.rkt")
|
||||||
|
(require "treap.rkt")
|
||||||
|
(require "tset.rkt")
|
||||||
|
(require data/order)
|
||||||
|
|
||||||
(require rackunit)
|
(require rackunit)
|
||||||
|
|
||||||
|
@ -68,23 +72,23 @@
|
||||||
(match* (v1 v2)
|
(match* (v1 v2)
|
||||||
[(#t v) v]
|
[(#t v) v]
|
||||||
[(v #t) v]
|
[(v #t) v]
|
||||||
[(v1 v2) (set-union v1 v2)]))))
|
[(v1 v2) (tset-union v1 v2)]))))
|
||||||
|
|
||||||
(define matcher-intersect-successes (make-parameter set-union))
|
(define matcher-intersect-successes (make-parameter tset-union))
|
||||||
|
|
||||||
(define matcher-subtract-successes
|
(define matcher-subtract-successes
|
||||||
(make-parameter
|
(make-parameter
|
||||||
(lambda (s1 s2)
|
(lambda (s1 s2)
|
||||||
(define r (set-subtract s1 s2))
|
(define r (tset-subtract s1 s2))
|
||||||
(if (set-empty? r) #f r))))
|
(if (tset-empty? r) #f r))))
|
||||||
|
|
||||||
(define matcher-match-matcher-successes
|
(define matcher-match-matcher-successes
|
||||||
(make-parameter
|
(make-parameter
|
||||||
(lambda (v1 v2 a)
|
(lambda (v1 v2 a)
|
||||||
(cons (set-union (car a) v1)
|
(cons (tset-union (car a) v1)
|
||||||
(set-union (cdr a) v2)))))
|
(tset-union (cdr a) v2)))))
|
||||||
|
|
||||||
(define matcher-match-matcher-unit (make-parameter (cons (set) (set))))
|
(define matcher-match-matcher-unit (make-parameter (cons (datum-tset) (datum-tset))))
|
||||||
|
|
||||||
;; The project-success function should return #f to signal "no success values".
|
;; The project-success function should return #f to signal "no success values".
|
||||||
(define matcher-project-success (make-parameter values))
|
(define matcher-project-success (make-parameter values))
|
||||||
|
@ -102,13 +106,13 @@
|
||||||
;; - #f, indicating no further matches possible
|
;; - #f, indicating no further matches possible
|
||||||
;; - (success Any), representing a successful match (if the end of
|
;; - (success Any), representing a successful match (if the end of
|
||||||
;; the input has been reached)
|
;; the input has been reached)
|
||||||
;; - (HashTable (U Sigma Wildcard) Matcher), {TODO}
|
;; - (Treap (U Sigma Wildcard) Matcher), {TODO}
|
||||||
;; TODO::: reimplement to use (ordinary-state (Option Matcher) (HashTable Sigma Matcher)), {TODO}
|
;; TODO::: reimplement to use (ordinary-state (Option Matcher) (Treap Sigma Matcher)), {TODO}
|
||||||
;; - (wildcard-sequence Matcher), {TODO}
|
;; - (wildcard-sequence Matcher), {TODO}
|
||||||
;; If, in a hashtable matcher, a wild key is present, it is intended
|
;; If, in a treap matcher, a wild key is present, it is intended
|
||||||
;; to catch all and ONLY those keys not otherwise present in the
|
;; to catch all and ONLY those keys not otherwise present in the
|
||||||
;; table.
|
;; table.
|
||||||
;; INVARIANT: if a key is present in a hashtable, then the
|
;; INVARIANT: if a key is present in a treap, then the
|
||||||
;; corresponding value MUST NOT be equal to the wildcard
|
;; corresponding value MUST NOT be equal to the wildcard
|
||||||
;; continuation, bearing in mind that
|
;; continuation, bearing in mind that
|
||||||
;; - if the wildcard is absent, it is implicitly #f;
|
;; - if the wildcard is absent, it is implicitly #f;
|
||||||
|
@ -127,7 +131,7 @@
|
||||||
;; - ILM, signifying the transition into the cdr position of a pair
|
;; - ILM, signifying the transition into the cdr position of a pair
|
||||||
;; - EOS, signifying the notional close-paren at the end of a compound.
|
;; - EOS, signifying the notional close-paren at the end of a compound.
|
||||||
;; - any other value, representing itself.
|
;; - any other value, representing itself.
|
||||||
;; N.B. hash-tables cannot be Sigmas at present.
|
;; N.B. treaps cannot be Sigmas at present.
|
||||||
(define-singleton-struct SOL start-of-list "<")
|
(define-singleton-struct SOL start-of-list "<")
|
||||||
(define-singleton-struct SOV start-of-vector "<vector")
|
(define-singleton-struct SOV start-of-vector "<vector")
|
||||||
(define-singleton-struct ILM improper-list-marker "|")
|
(define-singleton-struct ILM improper-list-marker "|")
|
||||||
|
@ -162,8 +166,8 @@
|
||||||
(or (eq? x #f)
|
(or (eq? x #f)
|
||||||
(success? x)
|
(success? x)
|
||||||
(wildcard-sequence? x)
|
(wildcard-sequence? x)
|
||||||
(and (hash? x)
|
(and (treap? x)
|
||||||
(for/and ([v (in-hash-values x)])
|
(for/and ([v (treap-values x)])
|
||||||
(matcher? v)))))
|
(matcher? v)))))
|
||||||
|
|
||||||
;; -> Matcher
|
;; -> Matcher
|
||||||
|
@ -192,14 +196,45 @@
|
||||||
(define (rsuccess v)
|
(define (rsuccess v)
|
||||||
(and v (canonicalize (success v))))
|
(and v (canonicalize (success v))))
|
||||||
|
|
||||||
|
;; Order for sigmas. This is complicated by the fact that datum-order
|
||||||
|
;; can't see through opaque structs (SIGH).
|
||||||
|
(define sigma-order
|
||||||
|
(let ((cache (make-weak-hasheq))
|
||||||
|
(counter 0))
|
||||||
|
(struct cache-index (n) #:transparent)
|
||||||
|
(define (cache-index-for x)
|
||||||
|
(hash-ref cache x (lambda ()
|
||||||
|
(define index (cache-index counter))
|
||||||
|
(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)
|
||||||
|
;; The empty branch-matcher
|
||||||
|
(define empty-smap (treap-empty sigma-order))
|
||||||
|
|
||||||
;; (U Sigma Wildcard) Matcher -> Matcher
|
;; (U Sigma Wildcard) Matcher -> Matcher
|
||||||
;; Prepends e to r, if r is non-empty.
|
;; Prepends e to r, if r is non-empty.
|
||||||
(define (rseq e r)
|
(define (rseq e r)
|
||||||
(if (matcher-empty? r) r (canonicalize (hash e r))))
|
(if (matcher-empty? r)
|
||||||
|
r
|
||||||
|
(treap-insert empty-smap e r)))
|
||||||
|
|
||||||
;; [ (U Sigma Wildcard) Matcher ] ... -> Matcher
|
;; [ (U Sigma Wildcard) Matcher ] ... -> Matcher
|
||||||
(define (rseq-multi . ers)
|
(define (rseq-multi . ers)
|
||||||
(canonicalize (apply hash ers)))
|
(let walk ((ers ers))
|
||||||
|
(match ers
|
||||||
|
[(list* e r rest) (treap-insert (walk rest) e r)]
|
||||||
|
[(list) empty-smap])))
|
||||||
|
|
||||||
;; Matcher -> Matcher
|
;; Matcher -> Matcher
|
||||||
;; Prepends the wildcard pseudo-Sigma to r, if r is non-empty.
|
;; Prepends the wildcard pseudo-Sigma to r, if r is non-empty.
|
||||||
|
@ -221,27 +256,27 @@
|
||||||
[_ #f]))
|
[_ #f]))
|
||||||
|
|
||||||
;; Matcher (U Sigma Wildcard) Matcher -> Matcher
|
;; Matcher (U Sigma Wildcard) Matcher -> Matcher
|
||||||
;; r must be a hashtable matcher. Retrieves the continuation after
|
;; r must be a treap matcher. Retrieves the continuation after
|
||||||
;; accepting key. If key is absent, returns wild-edge-value, modified
|
;; accepting key. If key is absent, returns wild-edge-value, modified
|
||||||
;; depending on key.
|
;; depending on key.
|
||||||
(define (rlookup r key wild-edge-value)
|
(define (rlookup r key wild-edge-value)
|
||||||
(hash-ref r key (lambda ()
|
(treap-get r key (lambda ()
|
||||||
(cond
|
(cond
|
||||||
[(key-open? key) (rwildseq wild-edge-value)]
|
[(key-open? key) (rwildseq wild-edge-value)]
|
||||||
[(key-close? key) (runwildseq wild-edge-value)]
|
[(key-close? key) (runwildseq wild-edge-value)]
|
||||||
[else wild-edge-value]))))
|
[else wild-edge-value]))))
|
||||||
|
|
||||||
;; (Option (HashTable (U Sigma Wildcard) Matcher)) Sigma Matcher -> Matcher
|
;; (Option (Treap (U Sigma Wildcard) Matcher)) Sigma Matcher -> Matcher
|
||||||
;; Updates (installs or removes) a continuation in the Matcher r. r
|
;; Updates (installs or removes) a continuation in the Matcher r. r
|
||||||
;; must be either #f or a hashtable matcher. key MUST NOT be ?.
|
;; must be either #f or a treap matcher. key MUST NOT be ?.
|
||||||
;; Preserves invariant that a key is never added if its continuation
|
;; Preserves invariant that a key is never added if its continuation
|
||||||
;; is the same as the wildcard's continuation (which is implicitly #f
|
;; is the same as the wildcard's continuation (which is implicitly #f
|
||||||
;; if absent, of course).
|
;; if absent, of course).
|
||||||
(define (rupdate r0 key k)
|
(define (rupdate r0 key k)
|
||||||
(when (eq? key ?) (error 'rupdate "Internal error: supplied wildcard as key"))
|
(when (eq? key ?) (error 'rupdate "Internal error: supplied wildcard as key"))
|
||||||
(define r (or r0 (hash)))
|
(define r (or r0 empty-smap))
|
||||||
(empty-hash-guard
|
(empty-smap-guard
|
||||||
(let ((old-wild (hash-ref r ? (lambda () #f))))
|
(let ((old-wild (treap-get r ? (lambda () #f))))
|
||||||
(if (cond [(key-open? key)
|
(if (cond [(key-open? key)
|
||||||
(if (wildcard-sequence? k)
|
(if (wildcard-sequence? k)
|
||||||
(requal? (wildcard-sequence-matcher k) old-wild)
|
(requal? (wildcard-sequence-matcher k) old-wild)
|
||||||
|
@ -252,14 +287,14 @@
|
||||||
(matcher-empty? k))]
|
(matcher-empty? k))]
|
||||||
[else
|
[else
|
||||||
(requal? k old-wild)])
|
(requal? k old-wild)])
|
||||||
(hash-remove r key)
|
(treap-delete r key)
|
||||||
(hash-set r key k)))))
|
(treap-insert r key k)))))
|
||||||
|
|
||||||
;; Hash -> Matcher
|
;; Treap -> Matcher
|
||||||
;; If the argument is empty, returns the canonical empty matcher;
|
;; If the argument is empty, returns the canonical empty matcher;
|
||||||
;; otherwise, (canonicalizes and) returns the argument.
|
;; otherwise, returns the argument.
|
||||||
(define (empty-hash-guard h)
|
(define (empty-smap-guard h)
|
||||||
(and (positive? (hash-count h)) (canonicalize h)))
|
(and (positive? (treap-size h)) h))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Pattern compilation
|
;; Pattern compilation
|
||||||
|
@ -285,13 +320,13 @@
|
||||||
[(cons p1 p2) (rseq SOL (walk p1 (walk-pair-chain p2 acc)))]
|
[(cons p1 p2) (rseq SOL (walk p1 (walk-pair-chain p2 acc)))]
|
||||||
[(? vector? v) (rseq SOV (vector-foldr walk (rseq EOS acc) v))]
|
[(? vector? v) (rseq SOV (vector-foldr walk (rseq EOS acc) v))]
|
||||||
[(embedded-matcher m) (matcher-append m (lambda (_mv) acc))]
|
[(embedded-matcher m) (matcher-append m (lambda (_mv) acc))]
|
||||||
|
;; TODO: consider options for treating treaps as compounds
|
||||||
|
;; rather than (useless) atoms
|
||||||
|
[(? treap?) (error 'pattern->matcher "Cannot match on treaps at present")]
|
||||||
[(? non-object-struct?)
|
[(? non-object-struct?)
|
||||||
(rseq (struct->struct-type p)
|
(rseq (struct->struct-type p)
|
||||||
(walk-pair-chain (cdr (vector->list (struct->vector p)))
|
(walk-pair-chain (cdr (vector->list (struct->vector p)))
|
||||||
acc))]
|
acc))]
|
||||||
;; TODO: consider options for treating hash tables as compounds
|
|
||||||
;; rather than (useless) atoms
|
|
||||||
[(? hash?) (error 'pattern->matcher "Cannot match on hash tables at present")]
|
|
||||||
[other (rseq other acc)]))
|
[other (rseq other acc)]))
|
||||||
|
|
||||||
(walk-pair-chain ps0 (rsuccess v)))
|
(walk-pair-chain ps0 (rsuccess v)))
|
||||||
|
@ -328,7 +363,6 @@
|
||||||
(define (matcher-union re1 re2)
|
(define (matcher-union re1 re2)
|
||||||
(matcher-recurse re1
|
(matcher-recurse re1
|
||||||
re2
|
re2
|
||||||
matcher-union
|
|
||||||
(matcher-union-successes)
|
(matcher-union-successes)
|
||||||
values
|
values
|
||||||
values
|
values
|
||||||
|
@ -343,7 +377,6 @@
|
||||||
(define (matcher-intersect re1 re2)
|
(define (matcher-intersect re1 re2)
|
||||||
(matcher-recurse re1
|
(matcher-recurse re1
|
||||||
re2
|
re2
|
||||||
matcher-intersect
|
|
||||||
(matcher-intersect-successes)
|
(matcher-intersect-successes)
|
||||||
(lambda (r) #f)
|
(lambda (r) #f)
|
||||||
(lambda (r) #f)
|
(lambda (r) #f)
|
||||||
|
@ -356,22 +389,23 @@
|
||||||
(define (matcher-subtract re1 re2)
|
(define (matcher-subtract re1 re2)
|
||||||
(matcher-recurse re1
|
(matcher-recurse re1
|
||||||
re2
|
re2
|
||||||
matcher-subtract
|
|
||||||
(matcher-subtract-successes)
|
(matcher-subtract-successes)
|
||||||
(lambda (r) #f)
|
(lambda (r) #f)
|
||||||
values
|
values
|
||||||
(lambda (h) #f)
|
(lambda (h) #f)
|
||||||
values))
|
values))
|
||||||
|
|
||||||
(define (matcher-recurse re1 re2 f vf left-false right-false right-base left-base)
|
(define (matcher-recurse re1 re2 vf left-false right-false right-base left-base)
|
||||||
(match* (re1 re2)
|
(let f ((re1 re1) (re2 re2))
|
||||||
[(#f r) (left-false r)]
|
(match* (re1 re2)
|
||||||
[(r #f) (right-false r)]
|
[(#f r) (left-false r)]
|
||||||
[((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (f r1 r2))]
|
[(r #f) (right-false r)]
|
||||||
[((wildcard-sequence r1) r2) (f (expand-wildseq r1) r2)]
|
[((wildcard-sequence r1) (wildcard-sequence r2)) (rwildseq (f r1 r2))]
|
||||||
[(r1 (wildcard-sequence r2)) (f r1 (expand-wildseq r2))]
|
[((wildcard-sequence r1) r2) (f (expand-wildseq r1) r2)]
|
||||||
[((success v1) (success v2)) (rsuccess (vf v1 v2))]
|
[(r1 (wildcard-sequence r2)) (f r1 (expand-wildseq r2))]
|
||||||
[((? hash? h1) (? hash? h2)) (fold-over-keys h1 h2 f (left-base h1) (right-base h2))]))
|
[((success v1) (success v2)) (rsuccess (vf v1 v2))]
|
||||||
|
[((? treap? h1) (? treap? 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 (fold-over-keys h1 h2 f left-base right-base)
|
||||||
(define w1 (rlookup h1 ? #f))
|
(define w1 (rlookup h1 ? #f))
|
||||||
|
@ -380,35 +414,51 @@
|
||||||
(cond
|
(cond
|
||||||
[(and w1 w2)
|
[(and w1 w2)
|
||||||
(for/fold [(acc (rwild (f w1 w2)))]
|
(for/fold [(acc (rwild (f w1 w2)))]
|
||||||
[(key (set-remove (set-union (hash-keys h1) (hash-keys h2)) ?))]
|
[(key (set-remove (set-union (treap-keys h1) (treap-keys h2)) ?))]
|
||||||
(rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
|
(rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
|
||||||
[w1
|
[w1
|
||||||
(for/fold [(acc left-base)] [(key (in-hash-keys h2))]
|
(for/fold [(acc left-base)] [(key (treap-keys h2))]
|
||||||
(rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
|
(rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
|
||||||
[w2
|
[w2
|
||||||
(for/fold [(acc right-base)] [(key (in-hash-keys h1))]
|
(for/fold [(acc right-base)] [(key (treap-keys h1))]
|
||||||
(rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
|
(rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
|
||||||
[(< (hash-count h1) (hash-count h2))
|
[(< (treap-size h1) (treap-size h2))
|
||||||
(for/fold [(acc right-base)] [(key (in-hash-keys h1))]
|
(for/fold [(acc right-base)] [(key (treap-keys h1))]
|
||||||
(rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
|
(rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))]
|
||||||
[else
|
[else
|
||||||
(for/fold [(acc left-base)] [(key (in-hash-keys h2))]
|
(for/fold [(acc left-base)] [(key (treap-keys h2))]
|
||||||
(rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))])))
|
(rupdate acc key (f (rlookup h1 key w1) (rlookup h2 key w2))))])))
|
||||||
|
|
||||||
;; Matcher -> Matcher
|
;; Matcher -> Matcher
|
||||||
;; When a matcher contains only entries for (EOS -> m') and (★ ->
|
;; When a matcher contains only entries for (EOS -> m') and (★ ->
|
||||||
;; (wildcard-sequence m')), it is equivalent to (wildcard-sequence m')
|
;; (wildcard-sequence m')), it is equivalent to (wildcard-sequence m')
|
||||||
;; itself. Also, if it's just (★ -> (wildcard-sequence m')), that's
|
;; itself. This is the inverse of expand-wildseq.
|
||||||
;; equivalent to (wildcard-sequence m'). This is nearly the inverse of
|
;;
|
||||||
;; expand-wildseq.
|
;; 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 m)
|
||||||
(match m
|
(if (treap? m)
|
||||||
[(hash-table ((== ?) (and w (wildcard-sequence wk)))
|
(case (treap-size m)
|
||||||
((? key-close?) k))
|
[(2)
|
||||||
(if (requal? k wk) w m)]
|
(if (and (treap-has-key? m ?)
|
||||||
[(hash-table ((== ?) (and w (wildcard-sequence wk))))
|
(treap-has-key? m EOS))
|
||||||
w]
|
(let ((w (treap-get m ?))
|
||||||
[_ m]))
|
(k (treap-get m EOS)))
|
||||||
|
(if (and (wildcard-sequence? w)
|
||||||
|
(requal? (wildcard-sequence-matcher w) k))
|
||||||
|
w
|
||||||
|
m))
|
||||||
|
m)]
|
||||||
|
[(1)
|
||||||
|
(if (treap-has-key? m ?)
|
||||||
|
(let ((w (treap-get m ?)))
|
||||||
|
(if (wildcard-sequence? w)
|
||||||
|
w
|
||||||
|
m))
|
||||||
|
m)]
|
||||||
|
[else m])
|
||||||
|
m))
|
||||||
|
|
||||||
;; Sigma -> Boolean
|
;; Sigma -> Boolean
|
||||||
;; True iff k represents the start of a compound datum.
|
;; True iff k represents the start of a compound datum.
|
||||||
|
@ -425,8 +475,7 @@
|
||||||
;; Matcher -> Matcher
|
;; Matcher -> Matcher
|
||||||
;; Unrolls the implicit recursion in a wildcard-sequence.
|
;; Unrolls the implicit recursion in a wildcard-sequence.
|
||||||
(define (expand-wildseq r)
|
(define (expand-wildseq r)
|
||||||
(canonicalize (hash ? (rwildseq r)
|
(treap-insert (treap-insert empty-smap ? (rwildseq r)) EOS r))
|
||||||
EOS r)))
|
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Matching single keys into a multimap
|
;; Matching single keys into a multimap
|
||||||
|
@ -445,7 +494,7 @@
|
||||||
;; Sigmas and runs them through the Matcher r. If v leads to a success
|
;; Sigmas and runs them through the Matcher r. If v leads to a success
|
||||||
;; Matcher, returns the values contained in the success Matcher;
|
;; Matcher, returns the values contained in the success Matcher;
|
||||||
;; otherwise, returns failure-result.
|
;; otherwise, returns failure-result.
|
||||||
(define (matcher-match-value r v [failure-result (set)])
|
(define (matcher-match-value r v [failure-result (datum-tset)])
|
||||||
(let walk ((vs (list v)) (stack '(())) (r r))
|
(let walk ((vs (list v)) (stack '(())) (r r))
|
||||||
(match r
|
(match r
|
||||||
[#f failure-result]
|
[#f failure-result]
|
||||||
|
@ -458,8 +507,8 @@
|
||||||
(null? stack))
|
(null? stack))
|
||||||
result
|
result
|
||||||
failure-result)]
|
failure-result)]
|
||||||
[(? hash?)
|
[(? treap?)
|
||||||
(define (get key) (hash-ref r key (lambda () #f)))
|
(define (get key) (treap-get r key (lambda () #f)))
|
||||||
(match vs
|
(match vs
|
||||||
['()
|
['()
|
||||||
(match stack
|
(match stack
|
||||||
|
@ -498,17 +547,17 @@
|
||||||
[((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc)]
|
[((wildcard-sequence r1) r2) (walk (expand-wildseq r1) r2 acc)]
|
||||||
[(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc)]
|
[(r1 (wildcard-sequence r2)) (walk r1 (expand-wildseq r2) acc)]
|
||||||
[((success v1) (success v2)) ((matcher-match-matcher-successes) v1 v2 acc)]
|
[((success v1) (success v2)) ((matcher-match-matcher-successes) v1 v2 acc)]
|
||||||
[((? hash? h1) (? hash? h2))
|
[((? treap? h1) (? treap? h2))
|
||||||
(define w1 (rlookup h1 ? #f))
|
(define w1 (rlookup h1 ? #f))
|
||||||
(define w2 (rlookup h2 ? #f))
|
(define w2 (rlookup h2 ? #f))
|
||||||
(define r (walk w1 w2 acc))
|
(define r (walk w1 w2 acc))
|
||||||
(for/fold [(r r)]
|
(for/fold [(r r)]
|
||||||
[(key (cond
|
[(key (cond
|
||||||
[(and w1 w2) (set-remove (set-union (hash-keys h1) (hash-keys h2)) ?)]
|
[(and w1 w2) (set-remove (set-union (treap-keys h1) (treap-keys h2)) ?)]
|
||||||
[w1 (hash-keys h2)]
|
[w1 (treap-keys h2)]
|
||||||
[w2 (hash-keys h1)]
|
[w2 (treap-keys h1)]
|
||||||
[(< (hash-count h1) (hash-count h2)) (hash-keys h1)]
|
[(< (treap-size h1) (treap-size h2)) (treap-keys h1)]
|
||||||
[else (hash-keys h2)]))]
|
[else (treap-keys h2)]))]
|
||||||
(walk (rlookup h1 key w1) (rlookup h2 key w2) r))])))
|
(walk (rlookup h1 key w1) (rlookup h2 key w2) r))])))
|
||||||
|
|
||||||
;; Matcher × (Value → Matcher) → Matcher
|
;; Matcher × (Value → Matcher) → Matcher
|
||||||
|
@ -523,11 +572,12 @@
|
||||||
[#f #f]
|
[#f #f]
|
||||||
[(success v) (error 'matcher-append "Ill-formed matcher: ~v" m0)]
|
[(success v) (error 'matcher-append "Ill-formed matcher: ~v" m0)]
|
||||||
[(wildcard-sequence m1) (rwildseq (walk m1))]
|
[(wildcard-sequence m1) (rwildseq (walk m1))]
|
||||||
[(? hash?) (for/fold [(acc (rwild (walk (rlookup m ? #f))))]
|
[(? treap?) (for/fold [(acc (rwild (walk (rlookup m ? #f))))]
|
||||||
[((k v) (in-hash m)) #:when (not (eq? k ?))]
|
[(kv (treap-to-alist m)) #:when (not (eq? (car kv) ?))]
|
||||||
(if (and (key-close? k) (success? v))
|
(match-define (cons k v) kv)
|
||||||
(matcher-union acc (m-tail-fn (success-value v)))
|
(if (and (key-close? k) (success? v))
|
||||||
(rupdate acc k (walk v))))])))
|
(matcher-union acc (m-tail-fn (success-value v)))
|
||||||
|
(rupdate acc k (walk v))))])))
|
||||||
|
|
||||||
;; Matcher (Value -> (Option Value)) -> Matcher
|
;; Matcher (Value -> (Option Value)) -> Matcher
|
||||||
;; Maps f over success values in m.
|
;; Maps f over success values in m.
|
||||||
|
@ -537,9 +587,9 @@
|
||||||
[#f #f]
|
[#f #f]
|
||||||
[(success v) (rsuccess (f v))]
|
[(success v) (rsuccess (f v))]
|
||||||
[(wildcard-sequence m1) (rwildseq (walk m1))]
|
[(wildcard-sequence m1) (rwildseq (walk m1))]
|
||||||
[(? hash?) (for/fold [(acc (rwild (walk (rlookup m ? #f))))]
|
[(? treap?) (for/fold [(acc (rwild (walk (rlookup m ? #f))))]
|
||||||
[((k v) (in-hash m)) #:when (not (eq? k ?))]
|
[(kv (treap-to-alist m)) #:when (not (eq? (car kv) ?))]
|
||||||
(rupdate acc k (walk v)))])))
|
(rupdate acc (car kv) (walk (cdr kv))))])))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; Projection
|
;; Projection
|
||||||
|
@ -561,12 +611,12 @@
|
||||||
[(cons p1 p2) (cons SOL (walk p1 (walk-pair-chain p2 acc)))]
|
[(cons p1 p2) (cons SOL (walk p1 (walk-pair-chain p2 acc)))]
|
||||||
[(? vector? v) (cons SOV (vector-foldr walk (cons EOS acc) v))]
|
[(? vector? v) (cons SOV (vector-foldr walk (cons EOS acc) v))]
|
||||||
[(embedded-matcher m) (error 'compile-projection "Cannot embed matcher in projection")]
|
[(embedded-matcher m) (error 'compile-projection "Cannot embed matcher in projection")]
|
||||||
|
;; TODO: consider options for treating treaps as compounds rather than (useless) atoms
|
||||||
|
[(? treap?) (error 'compile-projection "Cannot match on treaps at present")]
|
||||||
[(? non-object-struct?)
|
[(? non-object-struct?)
|
||||||
(cons (struct->struct-type p)
|
(cons (struct->struct-type p)
|
||||||
(walk-pair-chain (cdr (vector->list (struct->vector p)))
|
(walk-pair-chain (cdr (vector->list (struct->vector p)))
|
||||||
acc))]
|
acc))]
|
||||||
;; TODO: consider options for treating hash tables as compounds rather than (useless) atoms
|
|
||||||
[(? hash?) (error 'compile-projection "Cannot match on hash tables at present")]
|
|
||||||
[other (cons other acc)]))
|
[other (cons other acc)]))
|
||||||
|
|
||||||
(walk-pair-chain ps0 '()))
|
(walk-pair-chain ps0 '()))
|
||||||
|
@ -584,12 +634,12 @@
|
||||||
[(capture sub) sub] ;; TODO: maybe enforce non-nesting here too?
|
[(capture sub) sub] ;; TODO: maybe enforce non-nesting here too?
|
||||||
[(cons p1 p2) (cons (walk p1) (walk p2))]
|
[(cons p1 p2) (cons (walk p1) (walk p2))]
|
||||||
[(? vector? v) (for/vector [(e (in-vector v))] (walk e))]
|
[(? vector? v) (for/vector [(e (in-vector v))] (walk e))]
|
||||||
|
;; TODO: consider options for treating treaps as compounds
|
||||||
|
;; rather than (useless) atoms
|
||||||
|
[(? treap?) (error 'projection->pattern "Cannot match on treaps at present")]
|
||||||
[(? non-object-struct?)
|
[(? non-object-struct?)
|
||||||
(apply (struct-type-make-constructor (struct->struct-type p))
|
(apply (struct-type-make-constructor (struct->struct-type p))
|
||||||
(map walk (cdr (vector->list (struct->vector p)))))]
|
(map walk (cdr (vector->list (struct->vector p)))))]
|
||||||
;; TODO: consider options for treating hash tables as compounds
|
|
||||||
;; rather than (useless) atoms
|
|
||||||
[(? hash?) (error 'projection->pattern "Cannot match on hash tables at present")]
|
|
||||||
[other other])))
|
[other other])))
|
||||||
|
|
||||||
;; Matcher × CompiledProjection -> Matcher
|
;; Matcher × CompiledProjection -> Matcher
|
||||||
|
@ -619,14 +669,14 @@
|
||||||
[(cons (== ?) k)
|
[(cons (== ?) k)
|
||||||
(match m
|
(match m
|
||||||
[(wildcard-sequence _) (add-wild (walk m k))]
|
[(wildcard-sequence _) (add-wild (walk m k))]
|
||||||
[(? hash?)
|
[(? treap?)
|
||||||
(for/fold [(acc (add-wild (walk (rlookup m ? #f) k)))] [((key mk) (in-hash m))]
|
(for/fold [(acc (add-wild (walk (rlookup m ? #f) k)))]
|
||||||
(if (eq? key ?)
|
[(key-mk (treap-to-alist m)) #:when (not (eq? (car key-mk) ?))]
|
||||||
acc
|
(match-define (cons key mk) key-mk)
|
||||||
(add-edge acc key (cond
|
(add-edge acc key (cond
|
||||||
[(key-open? key) (balanced mk (lambda (mk) (walk mk k)))]
|
[(key-open? key) (balanced mk (lambda (mk) (walk mk k)))]
|
||||||
[(key-close? key) #f]
|
[(key-close? key) #f]
|
||||||
[else (walk mk k)]))))]
|
[else (walk mk k)])))]
|
||||||
[_ (matcher-empty)])]
|
[_ (matcher-empty)])]
|
||||||
|
|
||||||
[(cons sigma k)
|
[(cons sigma k)
|
||||||
|
@ -637,21 +687,21 @@
|
||||||
[(key-open? sigma) (walk (rwildseq m) k)]
|
[(key-open? sigma) (walk (rwildseq m) k)]
|
||||||
[(key-close? sigma) (walk mk k)]
|
[(key-close? sigma) (walk mk k)]
|
||||||
[else (walk m k)])]
|
[else (walk m k)])]
|
||||||
[(? hash?) (walk (rlookup m sigma (rlookup m ? #f)) k)]
|
[(? treap?) (walk (rlookup m sigma (rlookup m ? #f)) k)]
|
||||||
[_ (matcher-empty)]))])))
|
[_ (matcher-empty)]))])))
|
||||||
|
|
||||||
(define (general-balanced add-wildseq add-wild add-edge m k)
|
(define (general-balanced add-wildseq add-wild add-edge m k)
|
||||||
(let walk ((m m) (k k))
|
(let walk ((m m) (k k))
|
||||||
(match m
|
(match m
|
||||||
[(wildcard-sequence mk) (add-wildseq (k mk))]
|
[(wildcard-sequence mk) (add-wildseq (k mk))]
|
||||||
[(? hash?)
|
[(? treap?)
|
||||||
(for/fold [(acc (add-wild (walk (rlookup m ? #f) k)))] [((key mk) (in-hash m))]
|
(for/fold [(acc (add-wild (walk (rlookup m ? #f) k)))]
|
||||||
(if (eq? key ?)
|
[(key-mk (treap-to-alist m)) #:when (not (eq? (car key-mk) ?))]
|
||||||
acc
|
(match-define (cons key mk) key-mk)
|
||||||
(add-edge acc key (cond
|
(add-edge acc key (cond
|
||||||
[(key-open? key) (walk mk (lambda (mk) (walk mk k)))]
|
[(key-open? key) (walk mk (lambda (mk) (walk mk k)))]
|
||||||
[(key-close? key) (k mk)]
|
[(key-close? key) (k mk)]
|
||||||
[else (walk mk k)]))))]
|
[else (walk mk k)])))]
|
||||||
[_ (matcher-empty)])))
|
[_ (matcher-empty)])))
|
||||||
|
|
||||||
drop-match))
|
drop-match))
|
||||||
|
@ -679,9 +729,10 @@
|
||||||
(define (walk m k)
|
(define (walk m k)
|
||||||
(match m
|
(match m
|
||||||
[(wildcard-sequence _) #f]
|
[(wildcard-sequence _) #f]
|
||||||
[(? hash?)
|
[(? treap?)
|
||||||
(and (not (hash-has-key? m ?))
|
(and (not (treap-has-key? m ?))
|
||||||
(for/fold [(acc (set))] [((key mk) (in-hash m))]
|
(for/fold [(acc (set))] [(key-mk (treap-to-alist m))]
|
||||||
|
(match-define (cons key mk) key-mk)
|
||||||
(maybe-union
|
(maybe-union
|
||||||
acc
|
acc
|
||||||
(cond
|
(cond
|
||||||
|
@ -702,9 +753,10 @@
|
||||||
(define (walk-seq m k)
|
(define (walk-seq m k)
|
||||||
(match m
|
(match m
|
||||||
[(wildcard-sequence _) #f]
|
[(wildcard-sequence _) #f]
|
||||||
[(? hash?)
|
[(? treap?)
|
||||||
(and (not (hash-has-key? m ?))
|
(and (not (treap-has-key? m ?))
|
||||||
(for/fold [(acc (set))] [((key mk) (in-hash m))]
|
(for/fold [(acc (set))] [(key-mk (treap-to-alist m))]
|
||||||
|
(match-define (cons key mk) key-mk)
|
||||||
(maybe-union acc (cond
|
(maybe-union acc (cond
|
||||||
[(key-close? key) (k (set '()) mk)]
|
[(key-close? key) (k (set '()) mk)]
|
||||||
[else (walk (rseq key mk)
|
[else (walk (rseq key mk)
|
||||||
|
@ -754,12 +806,13 @@
|
||||||
(walk (+ i 5) k)]
|
(walk (+ i 5) k)]
|
||||||
[(success vs)
|
[(success vs)
|
||||||
(d "{")
|
(d "{")
|
||||||
(d vs)
|
(d (if (tset? vs) (cons 'tset (tset->list vs)) vs))
|
||||||
(d "}")]
|
(d "}")]
|
||||||
[(? hash? h)
|
[(? treap? h)
|
||||||
(if (zero? (hash-count h))
|
(if (zero? (treap-size h))
|
||||||
(d " ::: empty hash!")
|
(d " ::: empty treap!")
|
||||||
(for/fold [(need-sep? #f)] [((key k) (in-hash h))]
|
(for/fold [(need-sep? #f)] [(key-k (treap-to-alist h))]
|
||||||
|
(match-define (cons key k) key-k)
|
||||||
(when need-sep?
|
(when need-sep?
|
||||||
(newline port)
|
(newline port)
|
||||||
(d (make-string i #\space)))
|
(d (make-string i #\space)))
|
||||||
|
@ -790,16 +843,18 @@
|
||||||
[#f '()]
|
[#f '()]
|
||||||
[(success v) (list "" (success->jsexpr v))]
|
[(success v) (list "" (success->jsexpr v))]
|
||||||
[(wildcard-sequence m1) (list "...)" (walk m1))]
|
[(wildcard-sequence m1) (list "...)" (walk m1))]
|
||||||
[(? hash?) (for/list [((k v) (in-hash m))]
|
[(? treap?)
|
||||||
(list (match k
|
(for/list [(kv (treap-to-alist m))]
|
||||||
[(== ?) (list "__")]
|
(match-define (cons k v) kv)
|
||||||
[(== SOL) (list "(")]
|
(list (match k
|
||||||
[(== SOV) (list "#(")]
|
[(== ?) (list "__")]
|
||||||
[(== EOS) (list ")")]
|
[(== SOL) (list "(")]
|
||||||
[(? struct-type? t)
|
[(== SOV) (list "#(")]
|
||||||
(list (string-append (symbol->string (struct-type-name t)) "("))]
|
[(== EOS) (list ")")]
|
||||||
[else k])
|
[(? struct-type? t)
|
||||||
(walk v)))])))
|
(list (string-append (symbol->string (struct-type-name t)) "("))]
|
||||||
|
[else k])
|
||||||
|
(walk v)))])))
|
||||||
|
|
||||||
;; String -> String
|
;; String -> String
|
||||||
;; Undoes the encoding of struct-type names used in the JSON serialization of Matchers.
|
;; Undoes the encoding of struct-type names used in the JSON serialization of Matchers.
|
||||||
|
@ -817,38 +872,41 @@
|
||||||
[(list "" vj) (rsuccess (jsexpr->success vj))]
|
[(list "" vj) (rsuccess (jsexpr->success vj))]
|
||||||
[(list "...)" j1) (rwildseq (walk j1))]
|
[(list "...)" j1) (rwildseq (walk j1))]
|
||||||
[(list (list kjs vjs) ...)
|
[(list (list kjs vjs) ...)
|
||||||
(canonicalize
|
(for/fold [(acc empty-smap)]
|
||||||
(for/hash [(kj kjs) (vj vjs)]
|
[(kj kjs) (vj vjs)]
|
||||||
(values (match kj
|
(treap-insert acc
|
||||||
[(list "__") ?]
|
(match kj
|
||||||
[(list "(") SOL]
|
[(list "__") ?]
|
||||||
[(list "#(") SOV]
|
[(list "(") SOL]
|
||||||
[(list ")") EOS]
|
[(list "#(") SOV]
|
||||||
[(list (? string? s))
|
[(list ")") EOS]
|
||||||
(match (deserialize-struct-type-name s)
|
[(list (? string? s))
|
||||||
[#f (error 'jsexpr->matcher
|
(match (deserialize-struct-type-name s)
|
||||||
"Illegal open-parenthesis mark ~v"
|
[#f (error 'jsexpr->matcher
|
||||||
kj)]
|
"Illegal open-parenthesis mark ~v"
|
||||||
[tn (match (struct-type-name->struct-type tn)
|
kj)]
|
||||||
[#f (error 'jsexpr->matcher
|
[tn (match (struct-type-name->struct-type tn)
|
||||||
"Unexpected struct type ~v"
|
[#f (error 'jsexpr->matcher
|
||||||
tn)]
|
"Unexpected struct type ~v"
|
||||||
[t t])])]
|
tn)]
|
||||||
[other other])
|
[t t])])]
|
||||||
(walk vj))))])))
|
[other other])
|
||||||
|
(walk vj)))])))
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(require racket/pretty)
|
(require racket/pretty)
|
||||||
|
|
||||||
(define SA (set 'A))
|
(define tset datum-tset)
|
||||||
(define SB (set 'B))
|
|
||||||
(define SC (set 'C))
|
(define SA (tset 'A))
|
||||||
(define SD (set 'D))
|
(define SB (tset 'B))
|
||||||
(define Sfoo (set 'foo))
|
(define SC (tset 'C))
|
||||||
(define S+ (set '+))
|
(define SD (tset 'D))
|
||||||
(define SX (set 'X))
|
(define Sfoo (tset 'foo))
|
||||||
|
(define S+ (tset '+))
|
||||||
|
(define SX (tset 'X))
|
||||||
(define (E v) (rseq EOS (rsuccess v)))
|
(define (E v) (rseq EOS (rsuccess v)))
|
||||||
(check-equal? (pattern->matcher SA 123) (rseq 123 (E SA)))
|
(check-equal? (pattern->matcher SA 123) (rseq 123 (E SA)))
|
||||||
(check-equal? (pattern->matcher SA (cons 1 2))
|
(check-equal? (pattern->matcher SA (cons 1 2))
|
||||||
|
@ -870,7 +928,7 @@
|
||||||
(define actualset (matcher-match-value matcher message))
|
(define actualset (matcher-match-value matcher message))
|
||||||
(printf "~v ==> ~v\n" message actualset)
|
(printf "~v ==> ~v\n" message actualset)
|
||||||
(check-equal? actualset
|
(check-equal? actualset
|
||||||
(apply set (map (lambda (c) (string->symbol (string c)))
|
(apply tset (map (lambda (c) (string->symbol (string c)))
|
||||||
(string->list expectedstr))))
|
(string->list expectedstr))))
|
||||||
(walk rest)])))
|
(walk rest)])))
|
||||||
|
|
||||||
|
@ -936,7 +994,7 @@
|
||||||
(void (pretty-print-matcher* (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
|
(void (pretty-print-matcher* (matcher-union (pattern->matcher SA (list (list 'a 'b) 'x))
|
||||||
;; Note: this is a largely nonsense matcher,
|
;; Note: this is a largely nonsense matcher,
|
||||||
;; since it expects no input at all
|
;; since it expects no input at all
|
||||||
(rseq EOS (rsuccess (set 'B))))))
|
(rseq EOS (rsuccess (tset 'B))))))
|
||||||
|
|
||||||
(check-matches
|
(check-matches
|
||||||
(pretty-print-matcher*
|
(pretty-print-matcher*
|
||||||
|
@ -976,7 +1034,7 @@
|
||||||
(define ps
|
(define ps
|
||||||
(for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")))
|
(for/list ((c (in-string "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ")))
|
||||||
(define csym (string->symbol (string c)))
|
(define csym (string->symbol (string c)))
|
||||||
(pattern->matcher (set csym) (list csym ?))))
|
(pattern->matcher (tset csym) (list csym ?))))
|
||||||
(matcher-union (foldr matcher-union (matcher-empty) ps)
|
(matcher-union (foldr matcher-union (matcher-empty) ps)
|
||||||
(pattern->matcher S+ (list 'Z (list ? '- ?)))))
|
(pattern->matcher S+ (list 'Z (list ? '- ?)))))
|
||||||
|
|
||||||
|
@ -1143,7 +1201,7 @@
|
||||||
(matcher-intersect (pattern->matcher SA a)
|
(matcher-intersect (pattern->matcher SA a)
|
||||||
(pattern->matcher SB b)))
|
(pattern->matcher SB b)))
|
||||||
|
|
||||||
(define EAB (E (set 'A 'B)))
|
(define EAB (E (tset 'A 'B)))
|
||||||
|
|
||||||
(define (rseq* x . xs)
|
(define (rseq* x . xs)
|
||||||
(let walk ((xs (cons x xs)))
|
(let walk ((xs (cons x xs)))
|
||||||
|
@ -1180,39 +1238,32 @@
|
||||||
|
|
||||||
(check-requal? (intersect (a 'a) (b 'a)) #f)
|
(check-requal? (intersect (a 'a) (b 'a)) #f)
|
||||||
|
|
||||||
(check-exn #px"Cannot match on hash tables at present"
|
(check-exn #px"Cannot match on treaps at present"
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(intersect (canonicalize (hash 'a 1 'b ?))
|
(define (h a b c d)
|
||||||
(canonicalize (hash 'a ? 'b 2)))))
|
(treap-insert (treap-insert empty-smap a b) c d))
|
||||||
;; (check-requal? (intersect (rseq 'a 1 'b ?) (rseq 'a ? 'b 2)) (rseq 'a 1 'b 2))
|
(intersect (h 'a 1 'b ?)
|
||||||
;; (check-requal? (intersect (rseq 'a 1 'b ?) (rseq 'a ?)) (void))
|
(h 'a ? 'b 2))))
|
||||||
;; (check-requal? (intersect (rseq 'a 1 'b ?) (rseq 'a 1 'b ?)) (rseq 'a 1 'b ?))
|
|
||||||
;; (check-requal? (intersect (rseq 'a 1 'b ?) (rseq 'a ? 'c ?)) (void))
|
|
||||||
|
|
||||||
;; (check-requal? (intersect (rseq 'a 1 'b ?) (rseq 'a 1 'b (list 2 ?)))
|
(let ((H rseq-multi))
|
||||||
;; (rseq 'a 1 'b (list 2 ?)))
|
(newline)
|
||||||
;; (check-requal? (intersect (rseq 'a 1 'b (list ? 3)) (rseq 'a 1 'b (list 2 ?)))
|
(printf "Checking that intersection with wildcard is identity-like\n")
|
||||||
;; (rseq 'a 1 'b (list 2 3)))
|
(define m1 (pretty-print-matcher*
|
||||||
|
(foldr matcher-union (matcher-empty)
|
||||||
(let ((H rseq-multi))
|
(list (pattern->matcher SA (list 'a ?))
|
||||||
(newline)
|
(pattern->matcher SB (list 'b ?))
|
||||||
(printf "Checking that intersection with wildcard is identity-like\n")
|
(pattern->matcher SC (list 'b 'c))))))
|
||||||
(define m1 (pretty-print-matcher*
|
(define m2 (pretty-print-matcher* (pattern->matcher SD ?)))
|
||||||
(foldr matcher-union (matcher-empty)
|
(define mi (pretty-print-matcher* (matcher-intersect m1 m2)))
|
||||||
(list (pattern->matcher SA (list 'a ?))
|
(check-requal? mi
|
||||||
(pattern->matcher SB (list 'b ?))
|
(H SOL (H 'a (H ? (H EOS (E (tset 'A 'D))))
|
||||||
(pattern->matcher SC (list 'b 'c))))))
|
'b (H ? (H EOS (E (tset 'B 'D)))
|
||||||
(define m2 (pretty-print-matcher* (pattern->matcher SD ?)))
|
'c (H EOS (E (tset 'B 'C 'D)))))))
|
||||||
(define mi (pretty-print-matcher* (matcher-intersect m1 m2)))
|
(check-requal? (pretty-print-matcher*
|
||||||
(check-requal? mi
|
(parameterize ((matcher-intersect-successes (lambda (v1 v2) v1)))
|
||||||
(H SOL (H 'a (H ? (H EOS (E (set 'A 'D))))
|
(matcher-intersect m1 m2)))
|
||||||
'b (H ? (H EOS (E (set 'B 'D)))
|
m1))
|
||||||
'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)))
|
|
||||||
m1))
|
|
||||||
)
|
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(define (matcher-match-matcher-list m1 m2)
|
(define (matcher-match-matcher-list m1 m2)
|
||||||
|
@ -1227,22 +1278,22 @@
|
||||||
(pattern->matcher SC (list 'c ?))
|
(pattern->matcher SC (list 'c ?))
|
||||||
(pattern->matcher SD (list 'd ?))))))
|
(pattern->matcher SD (list 'd ?))))))
|
||||||
(check-equal? (matcher-match-matcher-list abc abc)
|
(check-equal? (matcher-match-matcher-list abc abc)
|
||||||
(list (set 'A 'B 'C) (set 'A 'B 'C)))
|
(list (tset 'A 'B 'C) (tset 'A 'B 'C)))
|
||||||
(check-equal? (parameterize ((matcher-match-matcher-successes (lambda (v1 v2 a)
|
(check-equal? (parameterize ((matcher-match-matcher-successes (lambda (v1 v2 a)
|
||||||
(set-union v2 a)))
|
(tset-union v2 a)))
|
||||||
(matcher-match-matcher-unit (set)))
|
(matcher-match-matcher-unit (tset)))
|
||||||
(matcher-match-matcher abc abc))
|
(matcher-match-matcher abc abc))
|
||||||
(set 'A 'B 'C))
|
(tset 'A 'B 'C))
|
||||||
(check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (set #t))))
|
(check-equal? (matcher-match-matcher-list abc (matcher-relabel bcd (lambda (old) (tset #t))))
|
||||||
(list (set 'B 'C) (set #t)))
|
(list (tset 'B 'C) (tset #t)))
|
||||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo ?))
|
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo ?))
|
||||||
(list (set 'A 'B 'C) (set 'foo)))
|
(list (tset 'A 'B 'C) (tset 'foo)))
|
||||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? ?)))
|
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? ?)))
|
||||||
(list (set 'A 'B 'C) (set 'foo)))
|
(list (tset 'A 'B 'C) (tset 'foo)))
|
||||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x)))
|
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x)))
|
||||||
(list (set 'A 'B 'C) (set 'foo)))
|
(list (tset 'A 'B 'C) (tset 'foo)))
|
||||||
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x ?)))
|
(check-equal? (matcher-match-matcher-list abc (pattern->matcher Sfoo (list ? 'x ?)))
|
||||||
(list (set) (set)))))
|
(list (tset) (tset)))))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-equal? (compile-projection (cons 'a 'b))
|
(check-equal? (compile-projection (cons 'a 'b))
|
||||||
|
@ -1411,15 +1462,15 @@
|
||||||
(pattern->matcher SD (list ? 3))
|
(pattern->matcher SD (list ? 3))
|
||||||
(pattern->matcher SB (list 3 4)))))
|
(pattern->matcher SB (list 3 4)))))
|
||||||
(S '((("(")
|
(S '((("(")
|
||||||
((("__") ((2 (((")") (((")") ("" ("A")))))))
|
((1 ((2 (((")") (((")") ("" ("A")))))))
|
||||||
(3 (((")") (((")") ("" ("D")))))))))
|
(3 (((")") (((")") ("" ("C" "D")))))))))
|
||||||
(1 ((2 (((")") (((")") ("" ("A")))))))
|
|
||||||
(3 (((")") (((")") ("" ("D" "C")))))))))
|
|
||||||
(3 ((2 (((")") (((")") ("" ("A")))))))
|
(3 ((2 (((")") (((")") ("" ("A")))))))
|
||||||
(3 (((")") (((")") ("" ("D")))))))
|
(3 (((")") (((")") ("" ("D")))))))
|
||||||
(4 (((")") (((")") ("" ("B"))))))))))))))
|
(4 (((")") (((")") ("" ("B")))))))))
|
||||||
(check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (set->list v)))) S)
|
(("__") ((2 (((")") (((")") ("" ("A")))))))
|
||||||
(check-requal? (jsexpr->matcher S (lambda (v) (list->set (map string->symbol v)))) M)))
|
(3 (((")") (((")") ("" ("D"))))))))))))))
|
||||||
|
(check-equal? (matcher->jsexpr M (lambda (v) (map symbol->string (tset->list v)))) S)
|
||||||
|
(check-requal? (jsexpr->matcher S (lambda (v) (make-tset datum-order (map string->symbol v)))) M)))
|
||||||
|
|
||||||
(module+ test
|
(module+ test
|
||||||
(check-requal? (pretty-print-matcher*
|
(check-requal? (pretty-print-matcher*
|
||||||
|
|
|
@ -8,7 +8,7 @@
|
||||||
trace-process-step
|
trace-process-step
|
||||||
trace-internal-step)
|
trace-internal-step)
|
||||||
|
|
||||||
(require (only-in web-server/private/util exn->string))
|
(require "exn-util.rkt")
|
||||||
|
|
||||||
(define trace-logger (make-logger 'minimart-trace))
|
(define trace-logger (make-logger 'minimart-trace))
|
||||||
|
|
||||||
|
|
|
@ -1,13 +1,15 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide set-stderr-trace-flags!)
|
||||||
|
|
||||||
(require racket/set)
|
(require racket/set)
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
(require racket/pretty)
|
(require racket/pretty)
|
||||||
(require (only-in racket/string string-join))
|
(require (only-in racket/string string-join))
|
||||||
(require (only-in web-server/private/util exn->string))
|
|
||||||
(require "../core.rkt")
|
(require "../core.rkt")
|
||||||
(require "../gestalt.rkt")
|
(require "../gestalt.rkt")
|
||||||
(require "../trace.rkt")
|
(require "../trace.rkt")
|
||||||
|
(require "../exn-util.rkt")
|
||||||
|
|
||||||
(define (env-aref varname default alist)
|
(define (env-aref varname default alist)
|
||||||
(define key (or (getenv varname) default))
|
(define key (or (getenv varname) default))
|
||||||
|
@ -19,19 +21,34 @@
|
||||||
|
|
||||||
(define colored-output? (env-aref "MINIMART_COLOR" "true" '(("true" #t) ("false" #f))))
|
(define colored-output? (env-aref "MINIMART_COLOR" "true" '(("true" #t) ("false" #f))))
|
||||||
|
|
||||||
(define flags (for/set [(c (or (getenv "MINIMART_TRACE") "xetpag"))] (string->symbol (string c))))
|
(define flags (set))
|
||||||
|
(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 show-exceptions? (set-member? flags 'x))
|
(define (set-stderr-trace-flags! flags-string)
|
||||||
(define show-routing-update-events? (set-member? flags 'r))
|
(set! flags (for/set [(c flags-string)] (string->symbol (string c))))
|
||||||
(define show-message-events? (set-member? flags 'm))
|
(set! show-exceptions? (set-member? flags 'x))
|
||||||
(define show-events? (set-member? flags 'e))
|
(set! show-routing-update-events? (set-member? flags 'r))
|
||||||
(define show-process-states-pre? (set-member? flags 's))
|
(set! show-message-events? (set-member? flags 'm))
|
||||||
(define show-process-states-post? (set-member? flags 't))
|
(set! show-events? (set-member? flags 'e))
|
||||||
(define show-process-lifecycle? (set-member? flags 'p))
|
(set! show-process-states-pre? (set-member? flags 's))
|
||||||
(define show-routing-update-actions? (set-member? flags 'R))
|
(set! show-process-states-post? (set-member? flags 't))
|
||||||
(define show-message-actions? (set-member? flags 'M))
|
(set! show-process-lifecycle? (set-member? flags 'p))
|
||||||
(define show-actions? (set-member? flags 'a))
|
(set! show-routing-update-actions? (set-member? flags 'R))
|
||||||
(define show-world-gestalt? (set-member? flags 'g))
|
(set! show-message-actions? (set-member? flags 'M))
|
||||||
|
(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 YELLOW-ON-RED ";1;33;41")
|
||||||
(define WHITE-ON-RED ";1;37;41")
|
(define WHITE-ON-RED ";1;37;41")
|
||||||
|
@ -114,7 +131,7 @@
|
||||||
(with-color WHITE-ON-RED
|
(with-color WHITE-ON-RED
|
||||||
(output "Process ~a died with exception:\n~a\n"
|
(output "Process ~a died with exception:\n~a\n"
|
||||||
pidstr
|
pidstr
|
||||||
(exn->string exn))))
|
(exn->string exn))))
|
||||||
(when (or relevant-exn? show-process-states-post?)
|
(when (or relevant-exn? show-process-states-post?)
|
||||||
(when t
|
(when t
|
||||||
(unless (boring-state? (transition-state t))
|
(unless (boring-state? (transition-state t))
|
||||||
|
|
|
@ -0,0 +1,220 @@
|
||||||
|
#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)))])))
|
|
@ -0,0 +1,96 @@
|
||||||
|
#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))
|
||||||
|
)
|
Loading…
Reference in New Issue