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?)
extra-clause ...))
(define-syntax-rule (big-bang-dataspace** width height boot-actions extra-clause ...)
(if (and width height)
(big-bang-dataspace* boot-actions (to-draw render width height) extra-clause ...)
(big-bang-dataspace* boot-actions (to-draw render) extra-clause ...)))
(define-syntax-rule (big-bang-dataspace** width height exit? boot-actions extra-clause ...)
(begin
(if (and width height)
(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]
#:height [height #f]
. boot-actions)
(big-bang-dataspace** width height boot-actions))
(define ((big-bang-dataspace #:width [width #f]
#:height [height #f]
#:exit? [exit? #t])
. boot-actions)
(big-bang-dataspace** width height exit? boot-actions))
(define (big-bang-dataspace/universe #:width [width #f]
#:height [height #f]
#:register [ip LOCALHOST]
#:port [port-number SQPORT]
#:name [world-name (gensym 'syndicate)]
. boot-actions)
(big-bang-dataspace** width height boot-actions
(define ((big-bang-dataspace/universe #:width [width #f]
#:height [height #f]
#:exit? [exit? #t]
#:register [ip LOCALHOST]
#:port [port-number SQPORT]
#:name [world-name (gensym 'syndicate)])
. boot-actions)
(big-bang-dataspace** width height exit? boot-actions
(on-receive (lambda (b sexps)
(inject b (for/list ((m sexps)) (message (from-server m))))))
(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 racket/math)
(define (button #:background [background "grey"]
#:foreground [foreground "white"]
@ -41,16 +40,17 @@
(idle 0 (- mx dx) (- my dy)))))
(actor (idle 0 orig-x orig-y)))
(big-bang-dataspace #:width 640
#:height 480
(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))))
(button #:background "red" 'stop-button 0 0 "Exit"
(lambda () (assert! 'stop #:meta-level 1)))
(draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))
(draggable-shape 's1 100 100 (star 40 "solid" "firebrick")))
(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))))
(button #:background "red" 'stop-button 0 0 "Exit"
(lambda () (assert! 'stop #:meta-level 1)))
(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 racket/math)
(define (button #:background [background "grey"]
#:foreground [foreground "white"]
@ -50,21 +50,22 @@
(mouse-sub name)
(move-to orig-x orig-y))))
(big-bang-dataspace #:width 640
#:height 480
(spawn (lambda (e s)
(match e
[(? patch? p)
(define-values (in out)
(patch-project/set/single p (at-meta (?! (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))
(button #:background "red" 'stop-button 0 0 "Exit"
(lambda () (assert 'stop #:meta-level 1)))
(draggable-shape 'c1 50 50 (circle 30 "solid" "orange"))
(draggable-shape 's1 100 100 (star 40 "solid" "firebrick")))
(spawn (lambda (e s)
(match e
[(? patch? p)
(define-values (in out)
(patch-project/set/single p (at-meta (?! (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))
(button #:background "red" 'stop-button 0 0 "Exit"
(lambda () (assert 'stop #:meta-level 1)))
(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])
activate
require/activate
current-ground-dataspace
(except-out (all-from-out racket/base) #%module-begin)
(all-from-out racket/match)
(all-from-out "main.rkt")
@ -30,6 +31,8 @@
(require module-path ...)
(activate module-path ...))]))
(define current-ground-dataspace (make-parameter #f))
(define-syntax (module-begin stx)
(unless (eq? (syntax-local-context) 'module-begin)
(raise-syntax-error #f "allowed only around a module body" stx))
@ -47,10 +50,12 @@
(when (not activated?)
(set! activated? #t)
boot-actions)))
(module+ main
(current-ground-dataspace run-ground))
#,@(reverse final-forms)
(module+ main
(require (submod ".." syndicate-main))
(run-ground (activate!))))))
((current-ground-dataspace) (activate!))))))
;;(pretty-print (syntax->datum final-stx))
final-stx)
(syntax-case (local-expand (car forms)