2017-02-22 22:42:06 +00:00
|
|
|
#lang racket
|
|
|
|
|
|
|
|
(provide (struct-out upside-down)
|
|
|
|
upside-down-parenthesis
|
2017-03-07 17:59:39 +00:00
|
|
|
spawn-upside-down
|
|
|
|
upside-down-relay)
|
2017-02-22 22:42:06 +00:00
|
|
|
|
|
|
|
(require "core.rkt")
|
|
|
|
(require "trie.rkt")
|
2017-03-07 17:59:39 +00:00
|
|
|
(require "protocol/standard-relay.rkt")
|
2017-02-22 22:42:06 +00:00
|
|
|
|
|
|
|
#|
|
|
|
|
A module that takes actors to ... the upside down [1]. Actors in the upside down
|
|
|
|
may communicate with each other, but not the outside world. However, the outside
|
|
|
|
world can see what actors in the upside-down are saying. The intention is to use
|
|
|
|
this facility for testing.
|
|
|
|
|
|
|
|
[1] (http://strangerthings.wikia.com/wiki/Upside_Down).
|
|
|
|
|#
|
|
|
|
|
|
|
|
(struct upside-down (v) #:transparent)
|
|
|
|
(define upside-down-parenthesis (open-parenthesis 1 struct:upside-down))
|
|
|
|
|
2017-03-07 17:59:39 +00:00
|
|
|
;; during assertions (upside-down (outbound X)) assert (outbound X)
|
|
|
|
;; on messages (message (upside-down (outbound X))) send (message (outbound X))
|
|
|
|
;; during assertions (upside-down (observe (inbound X))) assert
|
|
|
|
;; (observe (inbound X))
|
|
|
|
(define upside-down-relay
|
|
|
|
(actor (lambda (e s)
|
|
|
|
(define (upside-down-relay-trie t)
|
|
|
|
(define outbounds (trie-project t (?! (outbound ?))))
|
|
|
|
(define subscriptions
|
|
|
|
(trie-project t (upside-down (?! (observe (inbound ?))))))
|
|
|
|
(trie-union outbounds subscriptions))
|
|
|
|
(match e
|
|
|
|
[(message (upside-down (outbound x)))
|
|
|
|
(transition #f (list (message (outbound x))))]
|
|
|
|
[(patch added removed)
|
|
|
|
(transition #f (list (patch (upside-down-relay-trie added)
|
|
|
|
(upside-down-relay-trie removed))))]
|
|
|
|
[_ #f]))
|
|
|
|
#f
|
|
|
|
(list (patch-seq (sub (upside-down (outbound ?)))
|
|
|
|
(sub (upside-down (observe (inbound ?))))))))
|
|
|
|
|
2017-02-22 22:42:06 +00:00
|
|
|
(define (spawn-upside-down inner-spawn)
|
|
|
|
(make-actor (lambda ()
|
|
|
|
(define-values (proc initial-transition)
|
2017-08-05 23:36:15 +00:00
|
|
|
(boot->process+transition (actor-boot inner-spawn)))
|
2017-02-22 22:42:06 +00:00
|
|
|
(list (upside-down-behavior (process-behavior proc))
|
|
|
|
(upside-down-transition initial-transition)
|
2017-08-05 23:36:15 +00:00
|
|
|
(process-name proc)))
|
|
|
|
(actor-initial-assertions inner-spawn)))
|
2017-02-22 22:42:06 +00:00
|
|
|
|
|
|
|
;; Transition -> Transition
|
|
|
|
(define (upside-down-transition t)
|
|
|
|
(match t
|
|
|
|
[(<quit> exn actions)
|
|
|
|
(<quit> exn (upside-down-actions actions))]
|
|
|
|
[(transition st actions)
|
|
|
|
(transition st (upside-down-actions actions))]
|
|
|
|
[(or #f (? void?))
|
|
|
|
t]))
|
|
|
|
|
|
|
|
(define ((upside-down-behavior b) e s)
|
|
|
|
(define rightside-up-e
|
|
|
|
(turn-event-rightside-up e))
|
|
|
|
(upside-down-transition (b rightside-up-e s)))
|
|
|
|
|
|
|
|
(define (upside-down-actions acs)
|
|
|
|
(filter-map turn-action-upside-down (clean-actions acs)))
|
|
|
|
|
|
|
|
;; Action -> Action
|
|
|
|
(define (turn-action-upside-down a)
|
|
|
|
(match a
|
|
|
|
[#f #f]
|
|
|
|
[(message v)
|
|
|
|
(message (upside-down v))]
|
|
|
|
[(patch added removed)
|
|
|
|
(patch (turn-trie-upside-down added)
|
|
|
|
(turn-trie-upside-down removed))]
|
2017-02-24 03:22:43 +00:00
|
|
|
[(? actor? a) (spawn-upside-down a)]))
|
2017-02-22 22:42:06 +00:00
|
|
|
|
|
|
|
;; Event -> Event
|
|
|
|
(define (turn-event-rightside-up e)
|
|
|
|
(match e
|
|
|
|
[#f #f]
|
|
|
|
[(patch added removed)
|
2017-03-07 17:59:39 +00:00
|
|
|
(patch (turn-trie-rightside-up added)
|
|
|
|
(turn-trie-rightside-up removed))]
|
2017-02-22 22:42:06 +00:00
|
|
|
[(message (upside-down v))
|
2017-03-07 17:59:39 +00:00
|
|
|
(message v)]
|
|
|
|
[(message (inbound v))
|
|
|
|
(message (inbound v))]))
|
2017-02-22 22:42:06 +00:00
|
|
|
|
|
|
|
;; Trie -> Trie
|
|
|
|
;; x ∈ T => (upside-down x) ∈ T'
|
|
|
|
;; ?x ∈ T => ?(upside-down x) ∈ T'
|
2017-03-07 17:59:39 +00:00
|
|
|
;; (outbound x) ∈ T => (outbound x) ∈ T'
|
|
|
|
;; (observe (inbound x)) ∈ T => (observe (inbound x)) ∈ T'
|
2017-02-22 22:42:06 +00:00
|
|
|
(define (turn-trie-upside-down t)
|
|
|
|
(define subscriptions (trie-project t (observe (?!))))
|
2017-03-07 17:59:39 +00:00
|
|
|
(define outgoing (trie-project t (?! (outbound ?))))
|
|
|
|
(define inbound-interest (trie-project t (?! (observe (inbound ?)))))
|
|
|
|
(trie-union-all (list (trie-prepend upside-down-parenthesis t)
|
|
|
|
(trie-prepend observe-parenthesis
|
|
|
|
(trie-prepend upside-down-parenthesis
|
|
|
|
subscriptions))
|
|
|
|
outgoing
|
|
|
|
inbound-interest)))
|
|
|
|
|
|
|
|
(define (turn-trie-rightside-up t)
|
|
|
|
(define upside-downs (trie-project t (upside-down (?!))))
|
|
|
|
(define inbounds (trie-project t (?! (inbound ?))))
|
2017-08-05 23:36:15 +00:00
|
|
|
(trie-union upside-downs inbounds))
|