311 lines
12 KiB
Scheme
Executable File
311 lines
12 KiB
Scheme
Executable File
#lang scheme/gui
|
|
|
|
#| TODO:
|
|
-- make window resizable :: why?
|
|
|#
|
|
|
|
(require (for-syntax "private/syn-aux.ss")
|
|
"private/syn-aux-aux.ss"
|
|
"private/syn-aux.ss"
|
|
"private/check-aux.ss"
|
|
"private/image.ss"
|
|
"private/world.ss"
|
|
"private/universe.ss"
|
|
htdp/error
|
|
(rename-in lang/prim (first-order->higher-order f2h))
|
|
(only-in mzlib/etc evcase))
|
|
|
|
(provide (all-from-out "private/image.ss"))
|
|
|
|
(provide
|
|
sexp? ;; Any -> Boolean
|
|
scene? ;; Any -> Boolean
|
|
)
|
|
|
|
;; Spec = (on-tick Expr)
|
|
;; | (on-tick Expr Expr)
|
|
;; -- on-tick must specify a tick handler; it may specify a clock-tick rate
|
|
|
|
(define-keywords AllSpec
|
|
[on-tick (function-with-arity
|
|
1
|
|
except
|
|
[(x rate)
|
|
#'(list (proc> 'on-tick (f2h x) 1)
|
|
(num> 'on-tick rate positive? "pos. number" "rate"))])])
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ;;; ; ;; ; ;;;;
|
|
; ; ; ; ; ;; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;
|
|
; ;; ;; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;; ; ;; ;;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
(provide big-bang ;; <syntax> : see below
|
|
make-package ;; World Sexp -> Package
|
|
package? ;; Any -> Boolean
|
|
run-movie ;; [Listof Image] -> true
|
|
|
|
;; A MouseEventType is one of:
|
|
;; - 'button-down
|
|
;; - 'button-up
|
|
;; - 'drag
|
|
;; - 'move
|
|
;; - 'enter
|
|
;; - 'leave
|
|
|
|
mouse-event? ;; Any -> Boolean
|
|
mouse=? ;; MouseEventType MouseEventType -> Boolean
|
|
|
|
;; KeyEvent is one of:
|
|
;; -- Char
|
|
;; -- Symbol
|
|
|
|
key-event? ;; Any -> Boolean
|
|
key=? ;; KeyEvent KeyEvent -> Boolean
|
|
|
|
;; IP : a string that points to a machine on the net
|
|
LOCALHOST ;; IP
|
|
)
|
|
|
|
(provide-higher-order-primitive
|
|
run-simulation (create-scene) ; (Number Number Number (Nat -> Scene) -> true)
|
|
)
|
|
|
|
;; Expr = (big-bang Expr WorldSpec ...)
|
|
;; WorldSpec = AllSpec
|
|
;; | (on-draw Expr)
|
|
;; | (on-draw Expr Expr Expr)
|
|
;; -- on-draw must specify a rendering function; it may specify canvas dimensions
|
|
;; | (on-key Expr)
|
|
;; -- on-key must specify a key event handler
|
|
;; | (on-mouse Expr)
|
|
;; -- on-mouse must specify a mouse event handler
|
|
;; | (stop-when Expr)
|
|
;; -- stop-when must specify a boolean-valued function
|
|
;; | (register Expr)
|
|
;; | (register Expr Expr)
|
|
;; -- register must specify the internet address of a host (including LOCALHOST)
|
|
;; -- it may specify a world's name
|
|
;; | (record? Expr)
|
|
;; -- should the session be recorded and turned into PNGs and an animated GIF
|
|
;; | (on-receive Expr)
|
|
;; -- on-receive must specify a receive handler
|
|
|
|
(define-keywords WldSpec
|
|
[on-draw (function-with-arity
|
|
1
|
|
except
|
|
[(f width height)
|
|
#'(list (proc> 'on-draw (f2h f) 1)
|
|
(nat> 'on-draw width "width")
|
|
(nat> 'on-draw height "height"))])]
|
|
[on-mouse (function-with-arity 4)]
|
|
[on-key (function-with-arity 2)]
|
|
[on-receive (function-with-arity 2)]
|
|
[stop-when (function-with-arity 1)]
|
|
[register (lambda (tag)
|
|
(lambda (p)
|
|
(syntax-case p ()
|
|
[(host) #`(ip> #,tag host)]
|
|
[(ip name) #`(list (ip> #,tag ip) (symbol> #,tag name))]
|
|
[_ (err tag p)])))]
|
|
[record? (lambda (tag)
|
|
(lambda (p)
|
|
(syntax-case p ()
|
|
[(b) #`(bool> #,tag b)]
|
|
[_ (err tag p)])))])
|
|
|
|
(define-syntax (big-bang stx)
|
|
(syntax-case stx ()
|
|
[(big-bang) (raise-syntax-error #f "bad world description" stx)]
|
|
[(big-bang w s ...)
|
|
(let* ([Spec (append AllSpec WldSpec)]
|
|
[kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))]
|
|
[rec? #'#f]
|
|
[spec (map (lambda (stx)
|
|
(syntax-case stx ()
|
|
[(kw . E)
|
|
(and (identifier? #'kw)
|
|
(for/or ([n kwds]) (free-identifier=? #'kw n)))
|
|
(begin
|
|
(when (free-identifier=? #'kw #'record?)
|
|
(syntax-case #'E ()
|
|
[(V) (set! rec? #'V)]
|
|
[_ (err 'record? stx)]))
|
|
(cons (syntax-e #'kw) (syntax E)))]
|
|
[_ (raise-syntax-error
|
|
'big-bang "not a legal big-bang clause" stx)]))
|
|
(syntax->list (syntax (s ...))))]
|
|
;; assert: all bind = (kw . E) and kw is constrained via Bind
|
|
[args (map (lambda (x)
|
|
(define kw (car x))
|
|
(define co (assq kw Spec))
|
|
(list kw ((cadr co) (cdr x))))
|
|
spec)])
|
|
#`(send (new (if #,rec? aworld% world%) [world0 w] #,@args) last))]))
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ; ; ;;;
|
|
; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ;
|
|
; ; ; ;;; ; ;; ; ;;;; ; ; ; ; ; ;
|
|
; ; ; ; ; ;; ; ; ; ; ;;;;; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;; ;; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ;; ; ;
|
|
; ; ; ;;; ; ;; ;;;; ; ; ;; ; ; ;
|
|
;
|
|
;
|
|
;
|
|
|
|
(define (run-simulation f)
|
|
(check-proc 'run-simulation f 1 "first" "one argument")
|
|
(big-bang 1 (on-tick add1) (on-draw f)))
|
|
|
|
(define (run-movie r m*)
|
|
(check-arg 'run-movie (positive? r) "positive number" "first" r)
|
|
(check-arg 'run-movie (list? m*) "list (of images)" "second" m*)
|
|
(for-each (lambda (m) (check-image 'run-movie m "first" "list of images")) m*)
|
|
(let* ([fst (car m*)]
|
|
[wdt (image-width fst)]
|
|
[hgt (image-height fst)])
|
|
(big-bang
|
|
m*
|
|
(on-tick rest r)
|
|
(on-draw (lambda (m) (if (empty? m) (text "The End" 22 'red) (first m))))
|
|
(stop-when empty?))))
|
|
|
|
(define (mouse-event? a)
|
|
(pair? (member a '(button-down button-up drag move enter leave))))
|
|
|
|
(define (mouse=? k m)
|
|
(check-arg 'mouse=? (mouse-event? k) 'MouseEvent "first" k)
|
|
(check-arg 'mouse=? (mouse-event? m) 'MouseEvent "second" m)
|
|
(eq? k m))
|
|
|
|
(define (key-event? k)
|
|
(or (char? k) (symbol? k)))
|
|
|
|
(define (key=? k m)
|
|
(check-arg 'key=? (key-event? k) 'KeyEvent "first" k)
|
|
(check-arg 'key=? (key-event? m) 'KeyEvent "second" m)
|
|
(eqv? k m))
|
|
|
|
(define LOCALHOST "127.0.0.1")
|
|
|
|
;; -----------------------------------------------------------------------------
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ;
|
|
; ; ; ;
|
|
; ; ;
|
|
; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;;
|
|
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ; ; ; ; ;;; ; ;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
(provide
|
|
;; type World
|
|
world? ;; Any -> Boolean
|
|
world=? ;; World World -> Boolean
|
|
world1 ;; sample worlds
|
|
world2
|
|
world3
|
|
;; type Bundle = (make-bundle Universe [Listof Mail])
|
|
;; type Mail = (make-mail World S-expression)
|
|
make-bundle ;; Universe [Listof Mail] -> Bundle
|
|
bundle? ;; is this a bundle?
|
|
make-mail ;; World S-expression -> Mail
|
|
mail? ;; is this a real mail?
|
|
universe ;; <syntax> : see below
|
|
universe2 ;; (World World -> U) (U World Message) -> U
|
|
)
|
|
|
|
;; Expr = (universe Expr UniSpec)
|
|
;; UniSpec = AllSepc
|
|
;; | (on-new Expr)
|
|
;; -- on-new must specify a 'new world" handler; what happens when a world joins
|
|
;; | (on-msg Expr)
|
|
;; -- on-msg must specify a 'message' handler
|
|
;; | (on-disconnect Expr)
|
|
;; -- on-disconnect may specify a handler for the event that a world is leaving
|
|
;; | (to-string Expr)
|
|
;; -- to-string specifies how to render the universe as a string for display
|
|
;; in the console
|
|
|
|
(define-keywords UniSpec
|
|
[on-new (function-with-arity 2)]
|
|
[on-msg (function-with-arity 3)]
|
|
[on-disconnect (function-with-arity 2)]
|
|
[to-string (function-with-arity 1)])
|
|
|
|
(define-syntax (universe stx)
|
|
(syntax-case stx ()
|
|
[(universe) (raise-syntax-error #f "not a legal universe description" stx)]
|
|
[(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
|
|
[(universe u bind ...)
|
|
(let* ([Spec (append AllSpec UniSpec)]
|
|
[kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))]
|
|
[spec (map (lambda (stx)
|
|
(syntax-case stx ()
|
|
[(kw . E)
|
|
(and (identifier? #'kw)
|
|
(for/or ([n kwds]) (free-identifier=? #'kw n)))
|
|
(cons (syntax-e #'kw) (syntax E))]
|
|
[(kw E)
|
|
(and (identifier? #'kw)
|
|
(for/or ([n kwds]) (free-identifier=? #'kw n)))
|
|
(list (syntax-e #'kw) (syntax E))]
|
|
[_ (raise-syntax-error
|
|
'universe "not a legal universe clause" stx)]))
|
|
(syntax->list (syntax (bind ...))))]
|
|
;; assert: all bind = (kw . E) and kw is constrained via Bind
|
|
[args (map (lambda (x)
|
|
(define kw (car x))
|
|
(define co (assq kw Spec))
|
|
(list kw ((cadr co) (cdr x))))
|
|
spec)]
|
|
[domain (map car args)])
|
|
(cond
|
|
[(not (memq 'on-new domain))
|
|
(raise-syntax-error #f "missing on-new clause" stx)]
|
|
[(not (memq 'on-msg domain))
|
|
(raise-syntax-error #f "missing on-msg clause" stx)]
|
|
[else ; (and (memq #'on-new domain) (memq #'on-msg domain))
|
|
#`(send (new universe% [universe0 u] #,@args) last)]))]))
|
|
|
|
;; (World World -> U) (U World Msg) -> U
|
|
(define (universe2 create process)
|
|
;; UniState = '() | (list World) | Universe
|
|
;; UniState World -> (cons UniState [Listof (list World S-expression)])
|
|
(define (nu s p)
|
|
(cond
|
|
[(null? s) (make-bundle (list p) '())]
|
|
[(not (pair? s)) (make-bundle s '())]
|
|
[(null? (rest s)) (create (first s) p)]
|
|
[else (error 'create "a third world is signing up!")]))
|
|
(universe '()
|
|
(on-new nu)
|
|
(on-msg process)
|
|
#;
|
|
(on-tick (lambda (u) (printf "hello!\n") (list u)) 1))) |