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

Support current-ground-dataspace for big-bang and friends

This commit is contained in:
Tony Garnock-Jones 2016-07-16 16:07:34 -04:00
parent b6c679afa6
commit 4496258d0e
4 changed files with 60 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -157,23 +157,27 @@
(stop-when bb-halted?) (stop-when bb-halted?)
extra-clause ...)) extra-clause ...))
(define-syntax-rule (big-bang-dataspace** width height boot-actions extra-clause ...) (define-syntax-rule (big-bang-dataspace** width height exit? boot-actions extra-clause ...)
(if (and width height) (begin
(big-bang-dataspace* boot-actions (to-draw render width height) extra-clause ...) (if (and width height)
(big-bang-dataspace* boot-actions (to-draw render) extra-clause ...))) (big-bang-dataspace* boot-actions (to-draw render width height) extra-clause ...)
(big-bang-dataspace* boot-actions (to-draw render) extra-clause ...))
(when exit? (exit 0))))
(define (big-bang-dataspace #:width [width #f] (define ((big-bang-dataspace #:width [width #f]
#:height [height #f] #:height [height #f]
. boot-actions) #:exit? [exit? #t])
(big-bang-dataspace** width height boot-actions)) . boot-actions)
(big-bang-dataspace** width height exit? boot-actions))
(define (big-bang-dataspace/universe #:width [width #f] (define ((big-bang-dataspace/universe #:width [width #f]
#:height [height #f] #:height [height #f]
#:register [ip LOCALHOST] #:exit? [exit? #t]
#:port [port-number SQPORT] #:register [ip LOCALHOST]
#:name [world-name (gensym 'syndicate)] #:port [port-number SQPORT]
. boot-actions) #:name [world-name (gensym 'syndicate)])
(big-bang-dataspace** width height boot-actions . boot-actions)
(big-bang-dataspace** width height exit? boot-actions
(on-receive (lambda (b sexps) (on-receive (lambda (b sexps)
(inject b (for/list ((m sexps)) (message (from-server m)))))) (inject b (for/list ((m sexps)) (message (from-server m))))))
(register ip) (register ip)

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

@ -1,8 +1,7 @@
#lang racket ;; -*- racket -*- #lang syndicate/actor
(require (only-in syndicate seal))
(require syndicate/actor)
(require syndicate/big-bang) (require syndicate/big-bang)
(require racket/math)
(define (button #:background [background "grey"] (define (button #:background [background "grey"]
#:foreground [foreground "white"] #:foreground [foreground "white"]
@ -41,16 +40,17 @@
(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)))
(big-bang-dataspace #:width 640 (actor (forever
#:height 480 (during (active-window $id) #:meta-level 1
(actor (forever (assert (window 'active-window-label 300 0 0
(during (active-window $id) #:meta-level 1 (seal (text (format "~v" id) 22 "black")))
(assert (window 'active-window-label 300 0 0 #:meta-level 1))))
(seal (text (format "~v" id) 22 "black"))) (button #:background "red" 'stop-button 0 0 "Exit"
#:meta-level 1)))) (lambda () (assert! 'stop #:meta-level 1)))
(button #:background "red" 'stop-button 0 0 "Exit" (draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))
(lambda () (assert! 'stop #:meta-level 1))) (draggable-shape 's1 100 100 (star 40 "solid" "firebrick"))
(draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))
(draggable-shape 's1 100 100 (star 40 "solid" "firebrick")))
(exit 0) (module+ main
(current-ground-dataspace
(big-bang-dataspace #:width 640
#:height 480)))

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

@ -1,7 +1,7 @@
#lang racket #lang syndicate
(require "../main.rkt")
(require "../big-bang.rkt") (require "../big-bang.rkt")
(require racket/math)
(define (button #:background [background "grey"] (define (button #:background [background "grey"]
#:foreground [foreground "white"] #:foreground [foreground "white"]
@ -50,21 +50,22 @@
(mouse-sub name) (mouse-sub name)
(move-to orig-x orig-y)))) (move-to orig-x orig-y))))
(big-bang-dataspace #:width 640 (spawn (lambda (e s)
#:height 480 (match e
(spawn (lambda (e s) [(? patch? p)
(match e (define-values (in out)
[(? patch? p) (patch-project/set/single p (at-meta (?! (active-window ?)))))
(define-values (in out) (transition s (update-window 'active-window-label 300 0
(patch-project/set/single p (at-meta (?! (active-window ?))))) (text (format "~v" in) 22 "black")))]
(transition s (update-window 'active-window-label 300 0 [_ #f]))
(text (format "~v" in) 22 "black")))] (void)
[_ #f])) (sub (active-window ?) #:meta-level 1))
(void) (button #:background "red" 'stop-button 0 0 "Exit"
(sub (active-window ?) #:meta-level 1)) (lambda () (assert 'stop #:meta-level 1)))
(button #:background "red" 'stop-button 0 0 "Exit" (draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))
(lambda () (assert 'stop #:meta-level 1))) (draggable-shape 's1 100 100 (star 40 "solid" "firebrick"))
(draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))
(draggable-shape 's1 100 100 (star 40 "solid" "firebrick")))
(exit 0) (module+ main
(current-ground-dataspace
(big-bang-dataspace #:width 640
#:height 480)))

7
racket/syndicate/lang.rkt
View File

@ -9,6 +9,7 @@
(provide (rename-out [module-begin #%module-begin]) (provide (rename-out [module-begin #%module-begin])
activate activate
require/activate require/activate
current-ground-dataspace
(except-out (all-from-out racket/base) #%module-begin) (except-out (all-from-out racket/base) #%module-begin)
(all-from-out racket/match) (all-from-out racket/match)
(all-from-out "main.rkt") (all-from-out "main.rkt")
@ -30,6 +31,8 @@
(require module-path ...) (require module-path ...)
(activate module-path ...))])) (activate module-path ...))]))
(define current-ground-dataspace (make-parameter #f))
(define-syntax (module-begin stx) (define-syntax (module-begin stx)
(unless (eq? (syntax-local-context) 'module-begin) (unless (eq? (syntax-local-context) 'module-begin)
(raise-syntax-error #f "allowed only around a module body" stx)) (raise-syntax-error #f "allowed only around a module body" stx))
@ -47,10 +50,12 @@
(when (not activated?) (when (not activated?)
(set! activated? #t) (set! activated? #t)
boot-actions))) boot-actions)))
(module+ main
(current-ground-dataspace run-ground))
#,@(reverse final-forms) #,@(reverse final-forms)
(module+ main (module+ main
(require (submod ".." syndicate-main)) (require (submod ".." syndicate-main))
(run-ground (activate!)))))) ((current-ground-dataspace) (activate!))))))
;;(pretty-print (syntax->datum final-stx)) ;;(pretty-print (syntax->datum final-stx))
final-stx) final-stx)
(syntax-case (local-expand (car forms) (syntax-case (local-expand (car forms)