syndicate-lang
/
syndicate-2017
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Update big-bang for split relay and mux.

This commit is contained in:
Tony Garnock-Jones 2016-07-30 13:53:45 -04:00
parent 17db697690
commit 07eb91b0d9
3 changed files with 66 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
racket/syndicate/big-bang.rkt
View File

@ -43,12 +43,12 @@
(struct active-window (id) #:transparent) (struct active-window (id) #:transparent)
(define (update-window id x y image #:z [z 0]) (define (update-window id x y image #:z [z 0])
(patch-seq (retract (window id ? ? ? ?) #:meta-level 1) (patch-seq (retract (outbound (window id ? ? ? ?)))
(assert (window id x y z (seal image)) #:meta-level 1))) (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 ? ? ? ? ?))) (define window-projection (?! (window ? ? ? ? ?)))
@ -74,7 +74,7 @@
#f)])) #f)]))
(define (deliver b e) (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?) (define (interpret-actions b txn need-poll?)
(match txn (match txn
@ -92,8 +92,10 @@
(interpret-actions b (deliver b e) #t))])] (interpret-actions b (deliver b e) #t))])]
[(<quit> _ _) [(<quit> _ _)
(struct-copy bb b [halted? #t])] (struct-copy bb b [halted? #t])]
[(transition new-dataspace actions) [(transition new-state actions)
(let process-actions ((b (struct-copy bb b [dataspace new-dataspace])) (actions actions)) (let process-actions ((b (struct-copy bb b
[proc (update-process-state (bb-proc b) new-state)]))
(actions actions))
(match actions (match actions
['() (interpret-actions b #f #t)] ['() (interpret-actions b #f #t)]
[(cons a actions) [(cons a actions)
@ -131,31 +133,33 @@
(assert (active-window active-id)))) (assert (active-window active-id))))
(define-syntax-rule (big-bang-dataspace* boot-actions extra-clause ...) (define-syntax-rule (big-bang-dataspace* boot-actions extra-clause ...)
(big-bang (interpret-actions (bb (make-dataspace boot-actions) (let-values (((proc initial-transition)
'() (spawn->process+transition (spawn-dataspace boot-actions))))
'() (big-bang (interpret-actions (bb proc
'() '()
#f '()
0 '()
0) #f
#f 0
#t) 0)
(on-tick (lambda (b) initial-transition
(inject b (list (message (tick-event)))))) #t)
(on-key (lambda (b k) (on-tick (lambda (b)
(inject b (list (message (key-event k (find-active-window b))))))) (inject b (list (message (tick-event))))))
;; (on-pad (lambda (b p) (on-key (lambda (b k)
;; (inject b (list (message (pad-event p (find-active-window b))))))) (inject b (list (message (key-event k (find-active-window b)))))))
(on-release (lambda (b k) ;; (on-pad (lambda (b p)
(inject b (list (message (release-event k (find-active-window b))))))) ;; (inject b (list (message (pad-event p (find-active-window b)))))))
(on-mouse (lambda (b0 x y e) (on-release (lambda (b k)
(define b (struct-copy bb b0 [x x] [y y])) (inject b (list (message (release-event k (find-active-window b)))))))
(define active-id (find-active-window b)) (on-mouse (lambda (b0 x y e)
(inject b (list (patch-seq (retract (mouse-state ? ? ?)) (define b (struct-copy bb b0 [x x] [y y]))
(assert (mouse-state x y active-id))) (define active-id (find-active-window b))
(message (mouse-event x y active-id e)))))) (inject b (list (patch-seq (retract (mouse-state ? ? ?))
(stop-when bb-halted?) (assert (mouse-state x y active-id)))
extra-clause ...)) (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 ...) (define-syntax-rule (big-bang-dataspace** width height exit? boot-actions extra-clause ...)
(begin (begin

39
racket/syndicate/examples/actor/big-bang.rkt
View File

@ -9,44 +9,43 @@
name x y label callback) name x y label callback)
(define label-image (text label font-size foreground)) (define label-image (text label font-size foreground))
(actor (forever (actor (forever
(on (message (mouse-event _ _ name "button-down") #:meta-level 1) (callback)) (on (message (inbound (mouse-event _ _ name "button-down"))) (callback))
(assert (window name x y 0 (assert (outbound
(seal (window name x y 0
(overlay label-image (seal
(rectangle (+ (image-width label-image) 20) (overlay label-image
(+ (image-height label-image) 20) (rectangle (+ (image-width label-image) 20)
"solid" (+ (image-height label-image) 20)
background)))) "solid"
#:meta-level 1)))) background)))))))))
(define (draggable-shape name orig-x orig-y image) (define (draggable-shape name orig-x orig-y image)
(define (window-at x y) (window name x y 10 (seal 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 (mouse-left-event-type? t) (member t '("leave" "button-up")))
(define (idle ticks0 x0 y0) (define (idle ticks0 x0 y0)
(react (field [ticks ticks0] [x x0] [y y0]) (react (field [ticks ticks0] [x x0] [y y0])
(assert (window-at (x) (y)) #:meta-level 1) (assert (outbound (window-at (x) (y))))
(on (message (tick-event) #:meta-level 1) (on (message (inbound (tick-event)))
(ticks (+ (ticks) 1)) (ticks (+ (ticks) 1))
(y (+ (y) (* (cos (* (ticks) 10 1/180 pi)) 4)))) (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)))))) (dragging mx my (- mx (x)) (- my (y))))))
(define (dragging mx0 my0 dx dy) (define (dragging mx0 my0 dx dy)
(react (field [mx mx0] [my my0]) (react (field [mx mx0] [my my0])
(assert (window-at (- (mx) dx) (- (my) dy)) #:meta-level 1) (assert (outbound (window-at (- (mx) dx) (- (my) dy))))
(on (message (mouse-event $nmx $nmy _ "drag") #:meta-level 1) (on (message (inbound (mouse-event $nmx $nmy _ "drag")))
(mx nmx) (mx nmx)
(my nmy)) (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))))) (idle 0 (- mx dx) (- my dy)))))
(actor (idle 0 orig-x orig-y))) (actor (idle 0 orig-x orig-y)))
(actor (forever (actor (forever
(during (active-window $id) #:meta-level 1 (during (inbound (active-window $id))
(assert (window 'active-window-label 300 0 0 (assert (outbound (window 'active-window-label 300 0 0
(seal (text (format "~v" id) 22 "black"))) (seal (text (format "~v" id) 22 "black"))))))))
#:meta-level 1))))
(button #:background "red" 'stop-button 0 0 "Exit" (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 'c1 50 50 (circle 30 "solid" "orange"))
(draggable-shape 's1 100 100 (star 40 "solid" "firebrick")) (draggable-shape 's1 100 100 (star 40 "solid" "firebrick"))

24
racket/syndicate/examples/big-bang.rkt
View File

@ -9,7 +9,7 @@
name x y label callback) name x y label callback)
(spawn (lambda (e s) (spawn (lambda (e s)
(match e (match e
[(message (at-meta (mouse-event _ _ _ "button-down"))) (transition s (callback))] [(message (inbound (mouse-event _ _ _ "button-down"))) (transition s (callback))]
[_ #f])) [_ #f]))
(void) (void)
(patch-seq (patch-seq
@ -20,33 +20,33 @@
(+ (image-height label-image) 20) (+ (image-height label-image) 20)
"solid" "solid"
background)))) background))))
(sub (mouse-event ? ? name ?) #:meta-level 1)))) (sub (inbound (mouse-event ? ? name ?))))))
(define (draggable-shape name orig-x orig-y image) (define (draggable-shape name orig-x orig-y image)
(struct idle (ticks x y) #:transparent) (struct idle (ticks x y) #:transparent)
(struct dragging (dx dy) #:transparent) (struct dragging (dx dy) #:transparent)
(define (move-to x y) (update-window name x y image #:z 10)) (define (move-to x y) (update-window name x y image #:z 10))
(define (mouse-sub active-pat) (define (mouse-sub active-pat)
(patch-seq (unsub (mouse-event ? ? ? ?) #:meta-level 1) (patch-seq (unsub (inbound (mouse-event ? ? ? ?)))
(sub (mouse-event ? ? active-pat ?) #:meta-level 1))) (sub (inbound (mouse-event ? ? active-pat ?)))))
(spawn (match-lambda** (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 new-ticks (+ ticks 1))
(define displacement (* (cos (* new-ticks 10 1/180 pi)) 4)) (define displacement (* (cos (* new-ticks 10 1/180 pi)) 4))
(define new-y (+ by displacement)) (define new-y (+ by displacement))
(transition (idle new-ticks bx new-y) (transition (idle new-ticks bx new-y)
(move-to 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 ?))] (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)))] (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)) (transition (idle 0 (- mx dx) (- my dy))
(list (move-to (- mx dx) (- my dy)) (list (move-to (- mx dx) (- my dy))
(mouse-sub name)))] (mouse-sub name)))]
[(_ _) #f]) [(_ _) #f])
(idle 0 orig-x orig-y) (idle 0 orig-x orig-y)
(patch-seq (sub (tick-event) #:meta-level 1) (patch-seq (sub (inbound (tick-event)))
(mouse-sub name) (mouse-sub name)
(move-to orig-x orig-y)))) (move-to orig-x orig-y))))
@ -54,14 +54,14 @@
(match e (match e
[(? patch? p) [(? patch? p)
(define-values (in out) (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 (transition s (update-window 'active-window-label 300 0
(text (format "~v" in) 22 "black")))] (text (format "~v" in) 22 "black")))]
[_ #f])) [_ #f]))
(void) (void)
(sub (active-window ?) #:meta-level 1)) (sub (inbound (active-window ?))))
(button #:background "red" 'stop-button 0 0 "Exit" (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 'c1 50 50 (circle 30 "solid" "orange"))
(draggable-shape 's1 100 100 (star 40 "solid" "firebrick")) (draggable-shape 's1 100 100 (star 40 "solid" "firebrick"))