From 07eb91b0d933b846497d384872ee4e0f770fb3d2 Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 30 Jul 2016 13:53:45 -0400 Subject: [PATCH] Update big-bang for split relay and mux. --- racket/syndicate/big-bang.rkt | 66 +++++++++++--------- racket/syndicate/examples/actor/big-bang.rkt | 39 ++++++------ racket/syndicate/examples/big-bang.rkt | 24 +++---- 3 files changed, 66 insertions(+), 63 deletions(-) diff --git a/racket/syndicate/big-bang.rkt b/racket/syndicate/big-bang.rkt index b289743..1cd35b5 100644 --- a/racket/syndicate/big-bang.rkt +++ b/racket/syndicate/big-bang.rkt @@ -43,12 +43,12 @@ (struct active-window (id) #:transparent) (define (update-window id x y image #:z [z 0]) - (patch-seq (retract (window id ? ? ? ?) #:meta-level 1) - (assert (window id x y z (seal image)) #:meta-level 1))) + (patch-seq (retract (outbound (window id ? ? ? ?))) + (assert (outbound (window id x y z (seal image)))))) ;;--------------------------------------------------------------------------- -(struct bb (dataspace windows inbound outbound halted? x y) #:transparent) +(struct bb (proc windows inbound outbound halted? x y) #:transparent) (define window-projection (?! (window ? ? ? ? ?))) @@ -74,7 +74,7 @@ #f)])) (define (deliver b e) - (clean-transition (dataspace-handle-event e (bb-dataspace b)))) + (clean-transition ((process-behavior (bb-proc b)) e (process-state (bb-proc b))))) (define (interpret-actions b txn need-poll?) (match txn @@ -92,8 +92,10 @@ (interpret-actions b (deliver b e) #t))])] [( _ _) (struct-copy bb b [halted? #t])] - [(transition new-dataspace actions) - (let process-actions ((b (struct-copy bb b [dataspace new-dataspace])) (actions actions)) + [(transition new-state actions) + (let process-actions ((b (struct-copy bb b + [proc (update-process-state (bb-proc b) new-state)])) + (actions actions)) (match actions ['() (interpret-actions b #f #t)] [(cons a actions) @@ -131,31 +133,33 @@ (assert (active-window active-id)))) (define-syntax-rule (big-bang-dataspace* boot-actions extra-clause ...) - (big-bang (interpret-actions (bb (make-dataspace boot-actions) - '() - '() - '() - #f - 0 - 0) - #f - #t) - (on-tick (lambda (b) - (inject b (list (message (tick-event)))))) - (on-key (lambda (b k) - (inject b (list (message (key-event k (find-active-window b))))))) - ;; (on-pad (lambda (b p) - ;; (inject b (list (message (pad-event p (find-active-window b))))))) - (on-release (lambda (b k) - (inject b (list (message (release-event k (find-active-window b))))))) - (on-mouse (lambda (b0 x y e) - (define b (struct-copy bb b0 [x x] [y y])) - (define active-id (find-active-window b)) - (inject b (list (patch-seq (retract (mouse-state ? ? ?)) - (assert (mouse-state x y active-id))) - (message (mouse-event x y active-id e)))))) - (stop-when bb-halted?) - extra-clause ...)) + (let-values (((proc initial-transition) + (spawn->process+transition (spawn-dataspace boot-actions)))) + (big-bang (interpret-actions (bb proc + '() + '() + '() + #f + 0 + 0) + initial-transition + #t) + (on-tick (lambda (b) + (inject b (list (message (tick-event)))))) + (on-key (lambda (b k) + (inject b (list (message (key-event k (find-active-window b))))))) + ;; (on-pad (lambda (b p) + ;; (inject b (list (message (pad-event p (find-active-window b))))))) + (on-release (lambda (b k) + (inject b (list (message (release-event k (find-active-window b))))))) + (on-mouse (lambda (b0 x y e) + (define b (struct-copy bb b0 [x x] [y y])) + (define active-id (find-active-window b)) + (inject b (list (patch-seq (retract (mouse-state ? ? ?)) + (assert (mouse-state x y active-id))) + (message (mouse-event x y active-id e)))))) + (stop-when bb-halted?) + extra-clause ...))) (define-syntax-rule (big-bang-dataspace** width height exit? boot-actions extra-clause ...) (begin diff --git a/racket/syndicate/examples/actor/big-bang.rkt b/racket/syndicate/examples/actor/big-bang.rkt index 5da11cd..ce77dfe 100644 --- a/racket/syndicate/examples/actor/big-bang.rkt +++ b/racket/syndicate/examples/actor/big-bang.rkt @@ -9,44 +9,43 @@ name x y label callback) (define label-image (text label font-size foreground)) (actor (forever - (on (message (mouse-event _ _ name "button-down") #:meta-level 1) (callback)) - (assert (window name x y 0 - (seal - (overlay label-image - (rectangle (+ (image-width label-image) 20) - (+ (image-height label-image) 20) - "solid" - background)))) - #:meta-level 1)))) + (on (message (inbound (mouse-event _ _ name "button-down"))) (callback)) + (assert (outbound + (window name x y 0 + (seal + (overlay label-image + (rectangle (+ (image-width label-image) 20) + (+ (image-height label-image) 20) + "solid" + background))))))))) (define (draggable-shape name orig-x orig-y image) (define (window-at x y) (window name x y 10 (seal image))) (define (mouse-left-event-type? t) (member t '("leave" "button-up"))) (define (idle ticks0 x0 y0) (react (field [ticks ticks0] [x x0] [y y0]) - (assert (window-at (x) (y)) #:meta-level 1) - (on (message (tick-event) #:meta-level 1) + (assert (outbound (window-at (x) (y)))) + (on (message (inbound (tick-event))) (ticks (+ (ticks) 1)) (y (+ (y) (* (cos (* (ticks) 10 1/180 pi)) 4)))) - (stop-when (message (mouse-event $mx $my name "button-down") #:meta-level 1) + (stop-when (message (inbound (mouse-event $mx $my name "button-down"))) (dragging mx my (- mx (x)) (- my (y)))))) (define (dragging mx0 my0 dx dy) (react (field [mx mx0] [my my0]) - (assert (window-at (- (mx) dx) (- (my) dy)) #:meta-level 1) - (on (message (mouse-event $nmx $nmy _ "drag") #:meta-level 1) + (assert (outbound (window-at (- (mx) dx) (- (my) dy)))) + (on (message (inbound (mouse-event $nmx $nmy _ "drag"))) (mx nmx) (my nmy)) - (stop-when (message (mouse-event $mx $my _ (? mouse-left-event-type? $t)) #:meta-level 1) + (stop-when (message (inbound (mouse-event $mx $my _ (? mouse-left-event-type? $t)))) (idle 0 (- mx dx) (- my dy))))) (actor (idle 0 orig-x orig-y))) (actor (forever - (during (active-window $id) #:meta-level 1 - (assert (window 'active-window-label 300 0 0 - (seal (text (format "~v" id) 22 "black"))) - #:meta-level 1)))) + (during (inbound (active-window $id)) + (assert (outbound (window 'active-window-label 300 0 0 + (seal (text (format "~v" id) 22 "black")))))))) (button #:background "red" 'stop-button 0 0 "Exit" - (lambda () (assert! 'stop #:meta-level 1))) + (lambda () (assert! (outbound 'stop)))) (draggable-shape 'c1 50 50 (circle 30 "solid" "orange")) (draggable-shape 's1 100 100 (star 40 "solid" "firebrick")) diff --git a/racket/syndicate/examples/big-bang.rkt b/racket/syndicate/examples/big-bang.rkt index 4db2fb8..1ffea5e 100644 --- a/racket/syndicate/examples/big-bang.rkt +++ b/racket/syndicate/examples/big-bang.rkt @@ -9,7 +9,7 @@ name x y label callback) (spawn (lambda (e s) (match e - [(message (at-meta (mouse-event _ _ _ "button-down"))) (transition s (callback))] + [(message (inbound (mouse-event _ _ _ "button-down"))) (transition s (callback))] [_ #f])) (void) (patch-seq @@ -20,33 +20,33 @@ (+ (image-height label-image) 20) "solid" background)))) - (sub (mouse-event ? ? name ?) #:meta-level 1)))) + (sub (inbound (mouse-event ? ? name ?)))))) (define (draggable-shape name orig-x orig-y image) (struct idle (ticks x y) #:transparent) (struct dragging (dx dy) #:transparent) (define (move-to x y) (update-window name x y image #:z 10)) (define (mouse-sub active-pat) - (patch-seq (unsub (mouse-event ? ? ? ?) #:meta-level 1) - (sub (mouse-event ? ? active-pat ?) #:meta-level 1))) + (patch-seq (unsub (inbound (mouse-event ? ? ? ?))) + (sub (inbound (mouse-event ? ? active-pat ?))))) (spawn (match-lambda** - [((message (at-meta (tick-event))) (idle ticks bx by)) + [((message (inbound (tick-event))) (idle ticks bx by)) (define new-ticks (+ ticks 1)) (define displacement (* (cos (* new-ticks 10 1/180 pi)) 4)) (define new-y (+ by displacement)) (transition (idle new-ticks bx new-y) (move-to bx new-y))] - [((message (at-meta (mouse-event mx my _ "button-down"))) (idle _ bx by)) + [((message (inbound (mouse-event mx my _ "button-down"))) (idle _ bx by)) (transition (dragging (- mx bx) (- my by)) (mouse-sub ?))] - [((message (at-meta (mouse-event mx my _ "drag"))) (dragging dx dy)) + [((message (inbound (mouse-event mx my _ "drag"))) (dragging dx dy)) (transition (dragging dx dy) (move-to (- mx dx) (- my dy)))] - [((message (at-meta (mouse-event mx my _ (or "leave" "button-up")))) (dragging dx dy)) + [((message (inbound (mouse-event mx my _ (or "leave" "button-up")))) (dragging dx dy)) (transition (idle 0 (- mx dx) (- my dy)) (list (move-to (- mx dx) (- my dy)) (mouse-sub name)))] [(_ _) #f]) (idle 0 orig-x orig-y) - (patch-seq (sub (tick-event) #:meta-level 1) + (patch-seq (sub (inbound (tick-event))) (mouse-sub name) (move-to orig-x orig-y)))) @@ -54,14 +54,14 @@ (match e [(? patch? p) (define-values (in out) - (patch-project/set/single p (at-meta (?! (active-window ?))))) + (patch-project/set/single p (inbound (?! (active-window ?))))) (transition s (update-window 'active-window-label 300 0 (text (format "~v" in) 22 "black")))] [_ #f])) (void) - (sub (active-window ?) #:meta-level 1)) + (sub (inbound (active-window ?)))) (button #:background "red" 'stop-button 0 0 "Exit" - (lambda () (assert 'stop #:meta-level 1))) + (lambda () (assert (outbound 'stop)))) (draggable-shape 'c1 50 50 (circle 30 "solid" "orange")) (draggable-shape 's1 100 100 (star 40 "solid" "firebrick"))