suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

some clean up

Browse Source 
svn: r15866
This commit is contained in:
Matthias Felleisen 2009-09-03 10:47:31 +00:00
parent a422185219
commit 1a571f09fb
5 changed files with 174 additions and 232 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
collects/2htdp/private/checked-cell.ss
View File

@ -1,6 +1,6 @@
#lang scheme/gui
(require htdp/error)
(require htdp/error mzlib/pconvert)
(provide checked-cell%)
@ -36,7 +36,19 @@
(define/private (show-state)
(define xbox (box #f)) ;; x coordinate (throw away)
(define ybox (box 0)) ;; y coordinate for next snip
(define s (pretty-format value 80))
(define s
(pretty-format
(parameterize ([constructor-style-printing #t]
[booleans-as-true/false #t]
[abbreviate-cons-as-list
#t
;; is this beginner or beginner+quote
#;
(let ([o (open-output-string)])
(print '(1) o)
(regexp-match #rx"list" (get-output-string o)))])
(print-convert value))
40))
;; turn s into lines and display them in pb
(send pb erase)
(if (is-a? value snip%)

59
collects/2htdp/private/syn-aux.ss
View File

@ -1,19 +1,60 @@
#lang scheme
(provide define-keywords function-with-arity expr-with-check except err)
(provide define-keywords function-with-arity expr-with-check except err
->args
->kwds-in
clauses-use-kwd)
(require
(for-template "syn-aux-aux.ss"
scheme
(rename-in lang/prim (first-order->higher-order f2h))))
#|
transform the clauses into the initial arguments specification
for a new expression that instantiates the appropriate class
ensure that all clauses mention only keywords specified in AllSpec or PartSpec
move the contracts from AppSpecl and PartSpec to the clauses
run ->rec? over all used keywords to discover the presence of special clauses
if anything fails, use the legal keyword to specialize the error message
|#
(define (->args stx clauses AllSpec PartSpec ->rec? legal)
(define msg (format "not a legal clause in a ~a description" legal))
(define Spec (append AllSpec PartSpec))
(define kwds (map (compose (curry datum->syntax stx) car) Spec))
(define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg (->kwds-in kwds)))
(map (lambda (x)
(define kw (car x))
(define-values (key coercion)
(let loop ([kwds kwds][Spec Spec])
(if (free-identifier=? (car kwds) kw)
(values (car kwds) (cadar Spec))
(loop (cdr kwds) (cdr Spec)))))
(list key (coercion (cdr x))))
spec))
(define (clauses-use-kwd stx:list ->rec? legal-clause kwd-in?)
(map (lambda (stx)
(syntax-case stx ()
[(kw . E) (kwd-in? #'kw) (begin (->rec? #'kw) (cons #'kw stx))]
[_ (raise-syntax-error #f legal-clause stx)]))
stx:list))
;; [Listof SyntaxIdentifier] -> (Syntax -> Boolean)
(define (->kwds-in kwds)
(lambda (k)
(and (identifier? k) (for/or ([n kwds]) (free-identifier=? k n)))))
(define-syntax-rule (define-keywords the-list (kw coerce) ...)
(begin
(provide kw ...)
(define-syntax (kw x)
(raise-syntax-error 'kw "used out of context" x))
...
(define-for-syntax the-list (list (list 'kw (coerce ''kw)) ...))))
(define-for-syntax the-list (list (list #'kw (coerce ''kw)) ...))))
(define-syntax (expr-with-check stx)
(syntax-case stx ()
@ -21,7 +62,7 @@
#`(lambda (tag)
(lambda (p)
(syntax-case p ()
[(x) #`(check> #,tag x)]
[(_ x) #`(check> #,tag x)]
[_ (err tag p msg)])))]))
(define-syntax function-with-arity
@ -30,20 +71,20 @@
(lambda (tag)
(lambda (p)
(syntax-case p ()
[(x) #`(proc> #,tag (f2h x) arity)]
[(_ x) #`(proc> #,tag (f2h x) arity)]
[_ (err tag p)])))]
[(_ arity except extra)
(lambda (tag)
(lambda (p)
(syntax-case p ()
[(x) #`(proc> #,tag (f2h x) arity)]
[(_ x) #`(proc> #,tag (f2h x) arity)]
extra
[_ (err tag p)])))]))
(define (err spec p . extra-spec)
(printf "~s\n" p)
(define (err spec p . xtras)
(printf ">> ~s\n" p)
(raise-syntax-error (cadr spec)
(if (null? extra-spec)
(if (null? xtras)
"illegal specification"
(string-append "illegal specification: " (car extra-spec)))
(string-append "illegal specification: " (car xtras)))
p))

4
collects/2htdp/uchat/chatter.ss
View File

@ -1,7 +1,7 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname chatter) (read-case-sensitive #t) (teachpacks ((lib "universe.ss" "teachpack" "2htdp"))) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ((lib "universe.ss" "teachpack" "2htdp")))))
;(require 2htdp/universe)
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname chatter) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t constructor repeating-decimal #f #t none #f ())))
(require 2htdp/universe)
(require "auxiliaries.ss")
#|

323
collects/2htdp/universe.ss
View File

@ -2,9 +2,14 @@
#| TODO:
-- make window resizable :: why
-- what if clauses are repeated in world and/or universe descriptions?
-- what if the initial world or universe state is omitted? the error message is bad then.
|#
(require (for-syntax "private/syn-aux.ss")
(require (for-syntax "private/syn-aux.ss"
scheme/function
#;
(rename-in lang/prim (first-order->higher-order f2h)))
"private/syn-aux-aux.ss"
"private/syn-aux.ss"
"private/check-aux.ss"
@ -13,17 +18,14 @@
"private/universe.ss"
"private/launch-many-worlds.ss"
htdp/error
(rename-in lang/prim (first-order->higher-order f2h))
(for-syntax (rename-in lang/prim (first-order->higher-order f2h)))
(only-in mzlib/etc evcase))
(rename-in lang/prim (first-order->higher-order f2h)))
(provide (all-from-out "private/image.ss"))
(provide
launch-many-worlds
;; (launch-many-worlds e1 ... e2)
;; run expressions e1 through e2 in parallel,
;; produce all values
;; run expressions e1 through e2 in parallel, produce all values in same order
)
(provide
@ -31,28 +33,17 @@
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
;; = (check-with Expr)
;; -- check-with must specify a predicate
;; | (state Expr)
;; -- state specifies whether to display the world's or universe's current state
(define-keywords AllSpec
;; -- on-tick must specify a tick handler; it may specify a clock-tick rate
[on-tick (function-with-arity
1
except
[(x rate)
[(_ x rate)
#'(list (proc> 'on-tick (f2h x) 1)
(num> 'on-tick rate positive? "pos. number" "rate"))])]
[state (expr-with-check bool> "expected a boolean (show state or not)")
#;
(lambda (tag)
(lambda (p)
(syntax-case p ()
[(b) #`(bool> #,tag b)]
[_ (err tag p "expected a boolean (show state or not)")])))]
;; -- state specifies whether to display the current state
[state (expr-with-check bool> "expected a boolean (show state or not)")]
;; -- check-with must specify a predicate
[check-with (function-with-arity 1)])
;
@ -75,161 +66,28 @@
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
mouse-event? ;; Any -> Boolean : MOUSE-EVTS
mouse=? ;; MOUSE-EVTS MOUSE-EVTS -> Boolean
key-event? ;; Any -> Boolean : KEY-EVTS
key=? ;; KEY-EVTS KEY-EVTS -> 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 dimension
;; | (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 Expr Expr)
;; -- stop-when must specify a predicate; it may specify a rendering function
;; | (register Expr)
;; -- register must specify the internet address of a host (including LOCALHOST)
;; | (name Expr)
;; -- the 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 MOUSE-EVTS
'("button-down"
"button-up"
"drag"
"move"
"enter"
"leave"))
(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
except
[(stop? last-picture)
#'(list (proc> 'stop-when (f2h stop?) 1)
(proc> 'stop-when (f2h last-picture) 1))])]
[record? (expr-with-check bool> "expected a boolean (to record? or not)")]
[name (expr-with-check string> "expected a name (string) for the world")]
[register (expr-with-check ip> "expected a host (ip address)")])
(define-syntax (big-bang stx)
(syntax-case stx ()
[(big-bang)
(raise-syntax-error #f "big-bang needs at least an initial world;" stx)]
[(big-bang w (k s ...) ...)
(let* (;; [Listof (list Keyword Contract)]
[Spec (append AllSpec WldSpec)]
[kwds (map (lambda (x) (datum->syntax #'here x)) (map car Spec))]
[rec? #'#f]
;; [Listof (cons Keyword Value)]
[wrld (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 #'kw #'E))]
[_ (raise-syntax-error
'big-bang "not a legal big-bang clause" stx)]))
(syntax->list (syntax ((k s ...) ...))))]
;; assert: all items of wrld have shape (kw . E)
;; and all kw are guaranted in the domain of Spec
;; now bring together the coercion-contracts and the values,
;; PLUS use the 'local' version of the keyword because it is
;; also the name of the class
[args (map (lambda (x)
(define kw (car x))
(define-values (key coercion)
(let loop ([kwds kwds][Spec Spec])
(if (free-identifier=? (car kwds) kw)
(values (car kwds) (cadar Spec))
(loop (cdr kwds) (cdr Spec)))))
(list key (coercion (cdr x))))
wrld)])
#`(parameterize ([current-eventspace (make-eventspace)])
(let ([o (new (if #,rec? aworld% world%) [world0 w] #,@args)])
(send o 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 ME (map symbol->string '(button-down button-up drag move enter leave)))
(define (mouse-event? a) (and (string? a) (pair? (member a ME))))
(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 KEYS
(define KEY-EVTS
'("left"
"right"
"up"
@ -264,18 +122,85 @@
"wheel-up"
"wheel-down"))
(define-keywords WldSpec
;; -- on-draw must specify a rendering function; it may specify dimensions
[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 must specify a mouse event handler
[on-mouse (function-with-arity 4)]
;; -- on-key must specify a key event handler
[on-key (function-with-arity 2)]
;; -- on-receive must specify a receive handler
[on-receive (function-with-arity 2)]
;; -- stop-when must specify a predicate; it may specify a rendering function
[stop-when (function-with-arity
1
except
[(_ stop? last-picture)
#'(list (proc> 'stop-when (f2h stop?) 1)
(proc> 'stop-when (f2h last-picture) 1))])]
;; -- should the session be recorded and turned into PNGs and an animated GIF
[record? (expr-with-check bool> "expected a boolean (to record? or not)")]
[name (expr-with-check string> "expected a name (string) for the world")]
;; -- register must specify the internet address of a host (including LOCALHOST)
[register (expr-with-check ip> "expected a host (ip address)")])
(define-syntax (big-bang stx)
(define world0 "big-bang needs at least an initial world")
(syntax-case stx ()
[(big-bang) (raise-syntax-error #f world0 stx)]
[(big-bang w clause ...)
(let* ([rec? #'#f]
[->rec?
(lambda (kw)
(when (free-identifier=? kw #'record?)
(syntax-case #'E ()
[(V) (set! rec? #'V)]
[_ (err 'record? stx)])))]
[args (->args stx (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
#`(parameterize ([current-eventspace (make-eventspace)])
(let ([o (new (if #,rec? aworld% world%) [world0 w] #,@args)])
(send o 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) (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) (member k KEYS))))
(and (string? k) (or (= (string-length k) 1) (member k KEY-EVTS))))
(define (key=? k m)
(check-arg 'key=? (key-event? k) 'KeyEvent "first" k)
(check-arg 'key=? (key-event? m) 'KeyEvent "second" 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")
;; -----------------------------------------------------------------------------
;
;
;
@ -292,7 +217,7 @@
;
;
(provide
(provide
;; type World
iworld? ;; Any -> Boolean
iworld=? ;; World World -> Boolean
@ -309,60 +234,24 @@
universe ;; <syntax> : see below
)
;; 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 must specify what happens when a world joins the universe
[on-new (function-with-arity 2)]
;; -- on-msg must specify what happens to a message from a world
[on-msg (function-with-arity 3)]
;; -- on-disconnect may specify what happens when a world drops out
[on-disconnect (function-with-arity 2)]
;; -- to-string specifies how to render the universe as a string for display
[to-string (function-with-arity 1)])
(define-syntax (universe stx)
(define legal "not a legal clause in a universe description")
(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 #'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 ;; patch from Jay to allow rename on import
(findf (lambda (n) (free-identifier=? kw (car n)))
(map (lambda (k s) (cons k (cdr s)))
kwds Spec)))
(list (syntax-e (car co)) ((cadr co) (cdr x))))
spec)]
#;
[args (map (lambda (x)
(define kw (car x))
(define co (assq kw Spec))
(list kw ((cadr co) (cdr x))))
spec)]
[domain (map car args)])
(let* ([args (->args stx (syntax (bind ...)) AllSpec UniSpec void "universe")]
[domain (map (compose syntax-e car) args)])
(cond
[(not (memq 'on-new domain))
(raise-syntax-error #f "missing on-new clause" stx)]

4
collects/2htdp/utest/shared.ss
View File

@ -23,7 +23,7 @@
5 85
(empty-scene width HEIGHT)))
;; -----------------------------------------------------------------------------
;; ----------------------------------------------------------------
;; World Number -> Message
;; on receiving a message from server, place the ball at lower end or stop
#|
@ -59,7 +59,7 @@
(big-bang WORLD0
(on-draw draw)
(on-receive receive)
(on-tick move)
(on-tick move .01)
(name t)
(check-with (lambda (w) (or (symbol? w) (number? w))))
(register LOCALHOST))))