95679bdab5
This is used by the `function-with-arity' macro, and the use of `except' looks like something that is better done with a keyword. I think that this change should be fine since it's a private function.
429 lines
15 KiB
Racket
429 lines
15 KiB
Racket
#lang racket/gui
|
|
|
|
;; ---------------------------------------------------------------------------------------------------
|
|
;; the universe library provides the functionality to create interactive and distributed FPs in HtDP
|
|
|
|
;; DONT USE ___to-draw___ IN THIS FILE
|
|
|
|
#| TODO:
|
|
-- run callbacks in user eventspace
|
|
-- make timer fire just once; restart after on-tick callback finishes
|
|
[on-tick tick-handler tick-producer tick-limit]
|
|
tick-producer: World -> PositiveNumber
|
|
allow the time span to be a function of the world state
|
|
-- take out counting; replace by 0.25 delay
|
|
|
|
-- make window resizable :: why
|
|
|#
|
|
|
|
(require (for-syntax "private/clauses-spec-and-process.rkt"
|
|
stepper/private/syntax-property)
|
|
"private/define-keywords.rkt"
|
|
"private/clauses-spec-aux.rkt"
|
|
;; ---
|
|
"private/world.rkt"
|
|
"private/universe.rkt"
|
|
"private/universe-image.rkt"
|
|
;;
|
|
(only-in "private/launch-many-worlds.rkt" launch-many-worlds launch-many-worlds/proc)
|
|
(only-in "private/stop.rkt" make-stop-the-world)
|
|
(only-in "private/check-aux.rkt" sexp?)
|
|
(only-in "private/pad.rkt" pad-event? pad=?)
|
|
htdp/error
|
|
(rename-in lang/prim (first-order->higher-order f2h)))
|
|
|
|
(define-primitive stop-with make-stop-the-world)
|
|
|
|
(provide stop-with) ;; World -> STOP
|
|
|
|
(provide
|
|
;; (launch-many-worlds e1 ... e2)
|
|
;; run expressions e1 through e2 in parallel, produce all values in same order
|
|
launch-many-worlds
|
|
;; launch-many-worlds/proc : (-> Any) *-> [Listof Any]
|
|
launch-many-worlds/proc
|
|
)
|
|
|
|
(provide-primitive
|
|
sexp? ;; Any -> Boolean
|
|
)
|
|
|
|
(define new-world (create-world world0))
|
|
(define new-universe (create-universe universe0))
|
|
|
|
(define-keywords AllSpec '() define-all
|
|
;; -- on-tick must specify a tick handler: World -> World
|
|
;; it may specify a clock-tick rate
|
|
[on-tick DEFAULT #'#f
|
|
(function-with-arity
|
|
1
|
|
#:except
|
|
[(_ f rate)
|
|
#'(list
|
|
(proc> 'on-tick (f2h f) 1)
|
|
(num> 'on-tick rate (lambda (x) (and (real? x) (positive? x)))
|
|
"positive number" "rate"))]
|
|
[(_ f rate limit)
|
|
#'(list
|
|
(proc> 'on-tick (f2h f) 1)
|
|
(num> 'on-tick rate (lambda (x) (and (real? x) (positive? x)))
|
|
"positive number" "rate")
|
|
(num> 'on-tick limit (lambda (x) (and (integer? x) (positive? x)))
|
|
"positive integer" "limit"))])]
|
|
;; -- state specifies whether to display the current state
|
|
[state DEFAULT #'#f (expr-with-check any> "expected a boolean or a string")]
|
|
;; Any -> Boolean
|
|
;; -- check-with: all states should specify this predicate
|
|
[check-with DEFAULT #'True (function-with-arity 1)])
|
|
|
|
; (create-world world0)
|
|
(define-keywords WldSpec AllSpec create-world
|
|
;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
|
|
;; on-draw must specify a rendering function;
|
|
;; it may specify dimensions
|
|
[on-draw to-draw DEFAULT #'#f
|
|
(function-with-arity
|
|
1
|
|
#:except
|
|
[(_ f width height)
|
|
#'(list (proc> 'to-draw (f2h f) 1)
|
|
(nat> 'to-draw width "width")
|
|
(nat> 'to-draw height "height"))])]
|
|
;; World Nat Nat MouseEvent -> World
|
|
;; on-mouse must specify a mouse event handler
|
|
[on-mouse DEFAULT #f (function-with-arity 4)]
|
|
;; (U #f (World KeyEvent -> World))
|
|
;; on-key must specify a key event handler
|
|
[on-key DEFAULT #f (function-with-arity 2)]
|
|
;; (U #f (World PadEvent -> World))
|
|
;; on-pad must specify a pad event handler
|
|
[on-pad DEFAULT #f (function-with-arity 2)]
|
|
;; (U #f (World KeyEvent -> World))
|
|
;; on-release must specify a release event handler
|
|
[on-release DEFAULT #f (function-with-arity 2)]
|
|
;; (World S-expression -> World)
|
|
;; -- on-receive must specify a receive handler
|
|
[on-receive DEFAULT #'(lambda (w m) w) (function-with-arity 2)]
|
|
;; World -> Boolean
|
|
;; -- stop-when must specify a predicate; it may specify a rendering function
|
|
[stop-when DEFAULT #'False
|
|
(function-with-arity
|
|
1
|
|
#:except
|
|
[(_ stop? last-picture)
|
|
#'(list (proc> 'stop-when (f2h stop?) 1)
|
|
(proc> 'stop-when (f2h last-picture) 1))])]
|
|
;; (U #f Any)
|
|
;; -- should the session be recorded and turned into PNGs and an animated GIF
|
|
;; -- if the value is a string and is the name of a local directory, use it!
|
|
[record? DEFAULT #'#f (expr-with-check any> "")]
|
|
;; (U #f String)
|
|
;; -- name specifies one string
|
|
[name DEFAULT #'#f (expr-with-check string-or-symbol> "expected a string")]
|
|
;; (U #f IP)
|
|
;; -- register must specify the internet address of a host (e.g., LOCALHOST)
|
|
[register DEFAULT #'#f (expr-with-check ip> "expected a host (ip address)")])
|
|
|
|
; (create-universe universe0)
|
|
(define-keywords UniSpec AllSpec create-universe
|
|
;; -- on-new must specify what happens when a world joins the universe
|
|
[on-new
|
|
DEFAULT #'"my-bad"
|
|
(function-with-arity 2)]
|
|
;; -- on-msg must specify what happens to a message from a world
|
|
[on-msg
|
|
DEFAULT #'"my-bad"
|
|
(function-with-arity 3)]
|
|
;; -- on-disconnect may specify what happens when a world drops out
|
|
[on-disconnect
|
|
;; ******************************************************************
|
|
DEFAULT #'(lambda (u w) (make-bundle u '() '()))
|
|
;; this is the wrong default function
|
|
;; instead of K there should be a function that produces a bundle
|
|
(function-with-arity 2)
|
|
;; ******************************************************************
|
|
]
|
|
;; -- to-string specifies how to render the universe as a string for display
|
|
[to-string
|
|
DEFAULT #'#f
|
|
(function-with-arity 1)])
|
|
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ; ;
|
|
; ; ; ;;; ; ;; ; ;;;;
|
|
; ; ; ; ; ;; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ;
|
|
; ;; ;; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;
|
|
; ; ; ;;; ; ;; ;;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
(provide
|
|
big-bang ;; <syntax> : see below
|
|
pad-handler ;; <syntax> : see below
|
|
)
|
|
|
|
(provide-primitives
|
|
make-package ;; World Sexp -> Package
|
|
package? ;; Any -> Boolean
|
|
run-movie ;; [r Positive] [m [Listof Image]] -> true
|
|
;; run movie m at rate r images per second
|
|
mouse-event? ;; Any -> Boolean : MOUSE-EVTS
|
|
mouse=? ;; MOUSE-EVTS MOUSE-EVTS -> Boolean
|
|
key-event? ;; Any -> Boolean : KEY-EVTS
|
|
key=? ;; KEY-EVTS KEY-EVTS -> Boolean
|
|
pad-event? ;; KeyEvent -> Boolean
|
|
;; is the given key-event also a pad-event?
|
|
pad=? ;; PadEvent PadEvent -> Boolean
|
|
;; ---
|
|
;; IP : a string that points to a machine on the net
|
|
)
|
|
|
|
(provide LOCALHOST ;; IP
|
|
)
|
|
|
|
(provide-higher-order-primitive
|
|
run-simulation (create-scene) ; (Nat -> Scene) -> Nat
|
|
)
|
|
|
|
(provide-higher-order-primitive
|
|
animate (create-scene) ; (Nat -> Scene) -> Nat
|
|
)
|
|
|
|
(define MOUSE-EVTS
|
|
'("button-down"
|
|
"button-up"
|
|
"drag"
|
|
"move"
|
|
"enter"
|
|
"leave"))
|
|
|
|
(define KEY-EVTS
|
|
'("left"
|
|
"right"
|
|
"up"
|
|
"down"
|
|
"start"
|
|
"cancel"
|
|
"clear"
|
|
"shift"
|
|
"rshift"
|
|
"control"
|
|
"rcontrol"
|
|
"menu"
|
|
"pause"
|
|
"capital"
|
|
"prior"
|
|
"next"
|
|
"end"
|
|
"home"
|
|
"escape"
|
|
"select"
|
|
"print"
|
|
"execute"
|
|
"snapshot"
|
|
"insert"
|
|
"help"
|
|
"numpad0" "numpad1" "numpad2" "numpad3" "numpad4"
|
|
"numpad5" "numpad6" "numpad7" "numpad8" "numpad9"
|
|
"numpad-enter" "multiply" "add" "separator" "subtract" "decimal" "divide"
|
|
"f1" "f2" "f3" "f4" "f5" "f6" "f7" "f8" "f9" "f10" "f11" "f12" "f13"
|
|
"f14" "f15" "f16" "f17" "f18" "f19" "f20" "f21" "f22" "f23" "f24"
|
|
"numlock"
|
|
"scroll"
|
|
"wheel-up"
|
|
"wheel-down"
|
|
"wheel-left"
|
|
"wheel-right"
|
|
))
|
|
|
|
(define-syntax (big-bang stx)
|
|
(define world0 "expects an expression for the initial world and at least one clause")
|
|
(syntax-case stx ()
|
|
[(big-bang) (raise-syntax-error #f world0 stx)]
|
|
[(big-bang w clause ...)
|
|
(let* ([rec? #'#f]
|
|
[->rec?
|
|
(lambda (kw E)
|
|
(when (free-identifier=? kw #'record?)
|
|
(syntax-case E ()
|
|
[(V) (set! rec? #'V)]
|
|
[_ (err '#'record? stx)])))]
|
|
[args
|
|
(->args 'big-bang stx #'w #'(clause ...) WldSpec ->rec?)]
|
|
[dom (syntax->list #'(clause ...))])
|
|
(cond
|
|
[(and (not (contains-clause? #'to-draw dom)) (not (contains-clause? #'on-draw dom)))
|
|
(raise-syntax-error #f "expects a [to-draw handler] clause, missing" stx)]
|
|
[else
|
|
(syntax-property
|
|
(stepper-syntax-property
|
|
#`(run-it ((new-world (if #,rec? aworld% world%)) w #,@args))
|
|
'stepper-skip-completely #t)
|
|
'disappeared-use (map (lambda (x) (car (syntax->list x))) dom))]))]))
|
|
|
|
(define-keywords Pad1Specs '() _init-not-needed
|
|
[up DEFAULT #'#f (function-with-arity 1)]
|
|
[down DEFAULT #'#f (function-with-arity 1)]
|
|
[left DEFAULT #'#f (function-with-arity 1)]
|
|
[right DEFAULT #'#f (function-with-arity 1)]
|
|
[space DEFAULT #'#f (function-with-arity 1)]
|
|
[shift DEFAULT #'#f (function-with-arity 1)])
|
|
|
|
(define-syntax (pad-handler stx)
|
|
(syntax-case stx ()
|
|
[(pad1 clause ...)
|
|
(let* ([args (->args 'pad-one-player stx #'w #'(clause ...) Pad1Specs void)]
|
|
; [_ (displayln args)]
|
|
[keys (map (lambda (x)
|
|
(syntax-case x ()
|
|
[(proc> (quote s) _f _d) (symbol->string (syntax-e #'s))]
|
|
[else "not present"]))
|
|
(filter values args))]
|
|
[doms (map (lambda (x) (car (syntax->list x))) (syntax->list #'(clause ...)))])
|
|
(syntax-property
|
|
(stepper-syntax-property
|
|
#`(produce-handler '#,keys (list #,@args))
|
|
'stepper-skip-completely #t)
|
|
'disappeared-use doms))]))
|
|
|
|
(define (produce-handler keys args)
|
|
(define (check k one other)
|
|
(or (and (string=? k one) (not (member other keys)))
|
|
(and (string=? k other) (not (member one keys)))))
|
|
(define quasi-methods
|
|
(for/fold ((m '())) ((k keys) (a args))
|
|
(cond
|
|
[(check k "w" "up") (list* (cons "w" a) (cons "up" a) m)]
|
|
[(check k "s" "down") (list* (cons "s" a) (cons "down" a) m)]
|
|
[(check k "a" "left") (list* (cons "a" a) (cons "left" a) m)]
|
|
[(check k "d" "right") (list* (cons "d" a) (cons "right" a) m)]
|
|
[(check k "shift" "rshift") (list* (cons "shift" a) (cons "rshift" a) m)]
|
|
[else (cons (cons "space" a) m)])))
|
|
(define quasi-object (make-immutable-hash quasi-methods))
|
|
(define (the-handler* world key-event)
|
|
((hash-ref quasi-object key-event (lambda () values)) world))
|
|
the-handler*)
|
|
|
|
(define (run-simulation f)
|
|
(check-proc 'run-simulation f 1 "first" "one argument")
|
|
(big-bang 0 (on-draw f) (on-tick add1)))
|
|
|
|
(define animate run-simulation)
|
|
|
|
(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) (and (string? a) (pair? (member a MOUSE-EVTS))))
|
|
|
|
(define (mouse=? k m)
|
|
(check-arg 'mouse=? (mouse-event? k) 'MouseEvent "first" k)
|
|
(check-arg 'mouse=? (mouse-event? m) 'MouseEvent "second" m)
|
|
(string=? k m))
|
|
|
|
(define (key-event? k)
|
|
(and (string? k) (or (= (string-length k) 1) (pair? (member k KEY-EVTS)))))
|
|
|
|
(define (key=? k m)
|
|
(check-arg 'key=? (key-event? k) 'KEY-EVTS "first" k)
|
|
(check-arg 'key=? (key-event? m) 'KEY-EVTS "second" m)
|
|
(string=? k m))
|
|
|
|
(define LOCALHOST "127.0.0.1")
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ; ;
|
|
; ; ; ;
|
|
; ; ;
|
|
; ; ; ;;;; ; ; ; ;;; ; ;; ;;; ;;;
|
|
; ; ; ; ; ; ; ; ; ; ;; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ;;;;; ; ; ;;; ;;;;;
|
|
; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
|
; ;;; ; ; ; ; ;;; ; ;;; ;;;
|
|
;
|
|
;
|
|
;
|
|
|
|
(provide-primitives
|
|
;; type World
|
|
iworld? ;; Any -> Boolean
|
|
iworld=? ;; World World -> Boolean
|
|
iworld-name ;; World -> Symbol
|
|
;; type Bundle = (make-bundle [Listof World] Universe [Listof Mail])
|
|
;; type Mail = (make-mail World S-expression)
|
|
make-bundle ;; [Listof World] Universe [Listof Mail] -> Bundle
|
|
bundle? ;; is this a bundle?
|
|
make-mail ;; World S-expression -> Mail
|
|
mail? ;; is this a real mail?
|
|
)
|
|
|
|
(provide
|
|
iworld1 ;; sample worlds
|
|
iworld2
|
|
iworld3
|
|
universe ;; <syntax> : see below
|
|
)
|
|
|
|
(define-syntax (universe stx)
|
|
(syntax-case stx ()
|
|
[(universe) (raise-syntax-error #f "expects an expression for the initial world" stx)]
|
|
[(universe u) (raise-syntax-error #f "expects at least an on-new and an on-msg clause after the initial world" stx)]
|
|
[(universe u bind ...)
|
|
(let* ([args (->args 'universe stx #'u #'(bind ...) UniSpec void)]
|
|
[dom (syntax->list #'(bind ...))])
|
|
(cond
|
|
[(not (contains-clause? #'on-new dom))
|
|
(raise-syntax-error #f "expects a on-new clause, but found none" stx)]
|
|
[(not (contains-clause? #'on-msg dom))
|
|
(raise-syntax-error #f "expects a on-msg clause, but found none" stx)]
|
|
[else ; (and (memq #'on-new dom) (memq #'on-msg dom))
|
|
(syntax-property
|
|
#`(run-it ((new-universe universe%) u #,@args))
|
|
'disappeared-use (map (lambda (x) (car (syntax->list x))) dom))]))]))
|
|
|
|
;
|
|
;
|
|
;
|
|
; ; ;;;
|
|
; ;
|
|
; ;;; ;; ;; ;;;;;; ;; ;;; ;;;;
|
|
; ; ;; ; ; ;; ; ;
|
|
; ; ; ; ; ; ;;;;;
|
|
; ; ; ; ; ; ; ;
|
|
; ; ; ; ; ; ; ;;
|
|
; ;;;;; ;;; ;;; ;;;;;; ;;;;; ;;; ;;
|
|
;
|
|
;
|
|
;
|
|
;
|
|
|
|
;; (-> Object) -> Any
|
|
(define (run-it o)
|
|
(define esp (make-eventspace))
|
|
(define thd (eventspace-handler-thread esp))
|
|
(with-handlers ((exn:break? (lambda (x) (break-thread thd))))
|
|
(define obj:ch (make-channel))
|
|
(parameterize ([current-eventspace esp])
|
|
(queue-callback (lambda () (channel-put obj:ch (o)))))
|
|
(send (channel-get obj:ch) last)))
|