Support current-ground-dataspace for big-bang and friends
This commit is contained in:
parent
b6c679afa6
commit
4496258d0e
|
@ -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)
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)))
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue