eliminated superfluous require for-syntax, refactored and cleaned up; fixed bug in test?

This commit is contained in:
Matthias Felleisen 2011-07-02 13:27:21 -04:00
parent 8aa4ff1b06
commit a1c219a068
9 changed files with 221 additions and 224 deletions

View File

@ -10,10 +10,6 @@
(define PAUSE 1/2) ;; # secs to wait between attempts to connect to server
(define SQPORT 4567) ;; the port on which universe traffic flows
(define (K w . r) w)
(define (False w) #f)
(define (True w) #t)
;
;
;
@ -32,6 +28,10 @@
;; -----------------------------------------------------------------------------
;; Any -> Boolean
(define (nat? x)
(and (number? x) (integer? x) (>= x 0)))
;; Number Symbol Symbol -> Integer
(define (number->integer x [t ""] [p ""])
(check-arg t (and (number? x) (real? x)) "real number" p x)

View File

@ -1,62 +1,63 @@
#lang racket
(provide define-keywords
DEFAULT
;; constraint: the first kw is the original one
;; ---------------------------------------------------------------------------------------------------
;; provides functions for specifying the shape of big-bang and universe clauses:
(provide function-with-arity expr-with-check except err)
;; ... and for checking and processing them
(provide ;; constraint: the first kw is the original one
;; and it is also the name of the field in the class
->args
function-with-arity expr-with-check except err
->kwds-in
clauses-use-kwd
contains-clause?)
(require
(for-syntax "syn-aux-aux.rkt" syntax/parse)
(for-template "syn-aux-aux.rkt"
racket
(rename-in lang/prim (first-order->higher-order f2h))))
(for-syntax syntax/parse)
(for-template "clauses-spec-aux.rkt" racket (rename-in lang/prim (first-order->higher-order f2h))))
(define-syntax (DEFAULT stx)
(raise-syntax-error 'DEFAULT "used out of context" stx))
;; ---------------------------------------------------------------------------------------------------
;; specifying the shape of clauses
(define-syntax (define-keywords stx)
(syntax-parse stx #:literals (DEFAULT)
[(_ the-list super-list define-create
(kw:identifier
(~optional kw-alt:identifier #:defaults ((kw-alt #'kw)))
(~optional (~seq DEFAULT default:expr))
coerce:expr) ...)
(let* ([defs (attribute default)])
#`(begin
;; define and create list of keywords and associated values
(define-for-syntax the-list
(list* (list #'kw #'kw-alt (coerce ''kw) default) ... super-list))
;; define and provide keywords
(provide (rename-out (kw kw-alt) ...))
(provide kw ...)
(define-syntaxes (kw ...)
(values (lambda (x)
(raise-syntax-error 'kw "used out of context" x))
...))
;; a macro for creating functions that instantiate the proper object
;; (define-create para ...) :: additional parameters for the new func
(define-syntax (define-create stx)
(syntax-case stx ()
[(_ para (... ...))
(let*-values
([(kwds defs)
(values (map car the-list) '())]
;; the defaults list defs is no longer needed
[(args) (lambda (para*)
(append para* (foldr cons '() kwds)))]
[(body) (lambda (para*)
(map (lambda (x) `(,x ,x)) (append para* kwds)))])
(let ([para* (syntax->list #'(para (... ...)))])
#`(lambda (%)
(lambda #,(args para*)
(lambda ()
(new % #,@(body para*)))))))]))))]))
(define-syntax (expr-with-check stx)
(syntax-case stx ()
[(_ check> msg)
#`(lambda (tag)
(lambda (p)
(syntax-case p ()
[(_ x) #`(check> #,tag x)]
[_ (err tag p msg)])))]))
(define-syntax function-with-arity
(syntax-rules (except)
[(_ arity)
(lambda (tag)
(lambda (p)
(syntax-case p ()
[(_ 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)]
extra
[_ (err tag p)])))]))
(define (err spec p . xtras)
(raise-syntax-error (cadr spec)
(if (null? xtras)
"illegal specification"
(string-append "illegal specification: " (car xtras)))
p))
;; ---------------------------------------------------------------------------------------------------
;; processing actual clauses
;; KeyWord [Listof Clause] -> Boolean
;; does this list of clauses contain one that starts with kw?
(define (contains-clause? kw clause-list)
(memf (lambda (clause) (free-identifier=? kw (car (syntax->list clause)))) clause-list))
#|
transform the clauses into the initial arguments specification
@ -91,16 +92,25 @@
(if r ((third s) r) (fourth s)))
Spec))
(define (contains-clause? kw clause-list)
(memf (lambda (clause) (free-identifier=? kw (car (syntax->list clause)))) clause-list))
;; check whether rec? occurs, produce list of keyword x clause pairs
(define (clauses-use-kwd stx:list ->rec? legal-clause kwds)
(define kwd-in? (->kwds-in kwds))
(define double (string-append legal-clause ", ~a has been redefined"))
(map (lambda (stx)
(syntax-case stx ()
[(kw . E) (kwd-in? #'kw) (begin (->rec? #'kw #'E) (cons #'kw stx))]
[(kw . E)
(let ([kw (syntax-e #'kw)])
(if (member kw (map syntax-e kwds))
(raise-syntax-error #f (format double kw) stx)
(raise-syntax-error #f legal-clause stx)))]
[_ (raise-syntax-error #f legal-clause stx)]))
stx:list))
;; Syntax -> Syntax
;; eventually: convert syntax to keyword
(define (mk-kwd key)
(define key:id (symbol->string (syntax-e key)))
(define key:wd (string->keyword key:id))
key:wd)
;; [Listof SyntaxIdentifier] -> (Syntax -> Boolean)
(define (->kwds-in kwds)
(lambda (k)
(and (identifier? k) (for/or ([n kwds]) (free-identifier=? k n)))))
;; Symbol Syntax Syntax [Listof Kw] -> true
;; effect: if state0 looks like a clause, raise special error
@ -124,55 +134,3 @@
(if x
(raise-syntax-error tag (format "duplicate ~a clause" id) (cdar x))
(duplicates? (rest lox))))])))
;; check whether rec? occurs, produce list of keyword x clause pairs
(define (clauses-use-kwd stx:list ->rec? legal-clause kwds)
(define kwd-in? (->kwds-in kwds))
(define double (string-append legal-clause ", ~a has been redefined"))
(map (lambda (stx)
(syntax-case stx ()
[(kw . E) (kwd-in? #'kw) (begin (->rec? #'kw #'E) (cons #'kw stx))]
[(kw . E)
(let ([kw (syntax-e #'kw)])
(if (member kw (map syntax-e kwds))
(raise-syntax-error #f (format double kw) stx)
(raise-syntax-error #f legal-clause 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 (expr-with-check stx)
(syntax-case stx ()
[(_ check> msg)
#`(lambda (tag)
(lambda (p)
(syntax-case p ()
[(_ x) #`(check> #,tag x)]
[_ (err tag p msg)])))]))
(define-syntax function-with-arity
(syntax-rules (except)
[(_ arity)
(lambda (tag)
(lambda (p)
(syntax-case p ()
[(_ 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)]
extra
[_ (err tag p)])))]))
(define (err spec p . xtras)
(raise-syntax-error (cadr spec)
(if (null? xtras)
"illegal specification"
(string-append "illegal specification: " (car xtras)))
p))

View File

@ -0,0 +1,48 @@
#lang racket
;; ---------------------------------------------------------------------------------------------------
;; provides constants and functions for specifying the shape of clauses in big-bang and universe
(provide nat> nat? proc> bool> num> ip> string> symbol> any> K False True)
(require htdp/error "check-aux.rkt")
(define (K w . r) w)
(define (False w) #f)
(define (True w) #t)
;; Symbol X -> X
(define (bool> tag x)
(check-arg tag (boolean? x) "boolean" "first" x)
x)
;; Symbol X -> X
(define (string> tag x)
(check-arg tag (string? x) "string" "first" x)
x)
(define ip> string>)
;; Symbol X -> X
(define (symbol> tag x)
(check-arg tag (symbol? x) "symbol" "second" x)
x)
;; Symbol X Nat -> X
(define (proc> tag f ar)
(check-proc tag f ar "first" (if (> ar 1) (format "~a arguments" ar) "one argument"))
f)
;; Symbol X (Number -> Boolean) String String -> X
(define (num> tag x pred? spec which)
(check-arg tag (and (number? x) (pred? x)) spec which x)
x)
;; Symbol X String -> X
(define (nat> tag x spec)
(check-arg tag (nat? x) spec "natural number" x)
x)
;; Symbol X String -> X
(define (any> tag x)
x)

View File

@ -0,0 +1,47 @@
#lang racket
;; ---------------------------------------------------------------------------------------------------
;; provide a mechanism for defining the shape of big-bang and universe clauses
;; to specify individual clauses see syn-aux.rkt
(provide define-keywords DEFAULT)
(require (for-syntax syntax/parse))
(define-syntax (DEFAULT stx)
(raise-syntax-error 'DEFAULT "used out of context" stx))
(define-syntax (define-keywords stx)
(syntax-parse stx #:literals (DEFAULT)
[(_ the-list super-list define-create
(kw:identifier
(~optional kw-alt:identifier #:defaults ((kw-alt #'kw)))
(~optional (~seq DEFAULT default:expr))
coerce:expr) ...)
(let* ([defs (attribute default)])
#`(begin
;; define and create list of keywords and associated values
(define-for-syntax the-list
(list* (list #'kw #'kw-alt (coerce ''kw) default) ... super-list))
;; define and provide keywords
(provide (rename-out (kw kw-alt) ...))
(provide kw ...)
(define-syntaxes (kw ...)
(values (lambda (x) (raise-syntax-error 'kw "used out of context" x)) ...))
;; a macro for creating functions that instantiate the proper object
;; (define-create para ...) :: additional parameters for the new func
(define-syntax (define-create stx)
(syntax-case stx ()
[(_ para (... ...))
(let*-values
([(kwds defs)
(values (map car the-list) '())]
;; the defaults list defs is no longer needed
[(args) (lambda (para*) (append para* (foldr cons '() kwds)))]
[(body) (lambda (para*) (map (lambda (x) `(,x ,x)) (append para* kwds)))])
(let ([para* (syntax->list #'(para (... ...)))])
#`(lambda (%)
(lambda #,(args para*)
(lambda ()
(new % #,@(body para*)))))))]))))]))

View File

@ -1,17 +1,17 @@
Files for constructing universe.ss:
Files for constructing universe.rkt:
world.ss the old world
world% = (clock-mixin ...) -- the basic world
aworld% = (class world% ...) -- the world with recording
world.rkt the old world
world% = (clock-mixin ...) -- the basic world
aworld% = (class world% ...) -- the world with recording
universe.ss the universe server
universe% = (clock-mixin ...) -- the basic universe
universe.rkt the universe server
universe% = (clock-mixin ...) -- the basic universe
timer.ss the clock-mixin
timer.rkt the clock-mixin
check-aux.ss common primitives
image.ss the world image functions
syn-aux.ss syntactic auxiliaries
syn-aux-aux.ss auxiliaries to the syntactic auxiliaries
check-aux.rkt common primitives
image.rkt the world image functions
clauses-spec-and-process.rkt syntactic auxiliaries
clauses-spec-aux.rkt auxiliaries to the syntactic auxiliaries

View File

@ -1,64 +0,0 @@
#lang racket
(require htdp/error "check-aux.rkt")
;
;
;
; ;;; ;;;
; ; ; ; ;
; ; ; ;
; ; ; ; ;;;; ; ; ; ; ; ;
; ;;; ; ; ; ; ;;;;; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;; ; ;
; ;;; ;;;; ; ; ; ; ;; ; ; ;
; ;
; ; ;
; ;;;
(provide nat> nat? proc> bool> num> ip> string> symbol> any>)
;; Any -> Boolean
(define (nat? x)
(and (number? x) (integer? x) (>= x 0)))
;; Symbol X -> X
(define (bool> tag x)
(check-arg tag (boolean? x) "boolean" "first" x)
x)
;; Symbol X -> X
(define (string> tag x)
(check-arg tag (string? x) "string" "first" x)
x)
(define ip> string>)
;; Symbol X -> X
(define (symbol> tag x)
(check-arg tag (symbol? x) "symbol" "second" x)
x)
;; Symbol X Nat -> X
(define (proc> tag f ar)
(check-proc tag f ar "first"
(if (> ar 1)
(format "~a arguments" ar)
"one argument"))
f)
;; Symbol X (Number -> Boolean) String String -> X
(define (num> tag x pred? spec which)
(check-arg tag (and (number? x) (pred? x)) spec which x)
x)
;; Symbol X String -> X
(define (nat> tag x spec)
(check-arg tag (nat? x) spec "natural number" x)
x)
;; Symbol X String -> X
(define (any> tag x)
x)

View File

@ -1,15 +1,34 @@
#lang racket/gui
(require (for-syntax "syn-aux.rkt")
"checked-cell.rkt"
;; ---------------------------------------------------------------------------------------------------
;; provides the universe functionality (distributed worlds)
(require "checked-cell.rkt"
"check-aux.rkt"
"timer.rkt"
"timer.rkt"
"last.rkt"
"clauses-spec-aux.rkt"
htdp/error
(only-in mzlib/etc evcase)
string-constants)
(provide universe%)
(provide
universe%
;; --- sample worlds and function on worlds ---
iworld? ;; Any -> Boolean
iworld=? ;; World World -> Boolean
iworld-name ;; World -> Symbol
iworld1 ;; sample worlds
iworld2
iworld3
;; --- sending 'mail' to worlds ---
;; 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?
)
;
;
@ -205,14 +224,6 @@
;
;
(provide
iworld? ;; Any -> Boolean
iworld=? ;; World World -> Boolean
iworld-name ;; World -> Symbol
iworld1 ;; sample worlds
iworld2
iworld3)
;; --- the server representation of a world ---
(define-struct iworld (in out name info) #; #:transparent)
;; World = (make-iworld IPort OPort Symbol [Listof Sexp])
@ -332,15 +343,6 @@
;
;
(provide
;; 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?
)
(define-struct bundle (state mails bad) #:transparent)
(set! make-bundle

View File

@ -26,7 +26,11 @@
(on-draw draw-number)
(record? dir)))
(sleep 1)
(unless (image=? (bitmap "images0/i1.png") (draw-stop 5))
(define i (bitmap "images0/i1.png"))
(define j (draw-stop 5))
(unless (image=? (crop 0 0 100 100 i) j)
(fprintf (current-error-port)
"this test needs to be revised -- the way 'world' writes images adds an extra pixel -- think! \n"))

View File

@ -1,10 +1,11 @@
#lang racket/gui
;; DONT USE to-draw IN THIS FILE
;; ---------------------------------------------------------------------------------------------------
;; the universe library provides the functionality to create interactive and distributed FPs in HtDP
;; DONT USE ___to-draw___ IN THIS FILE
#| TODO:
-- check that on-release is only defined if on-key is defined
-- run callbacks in user eventspace
-- make timer fire just once; restart after on-tick callback finishes
-- take out counting; replace by 0.25 delay
@ -12,16 +13,18 @@
-- make window resizable :: why
|#
(require (for-syntax "private/syn-aux.rkt"
(require (for-syntax "private/clauses-spec-and-process.rkt"
stepper/private/shared)
"private/syn-aux-aux.rkt"
"private/syn-aux.rkt"
"private/check-aux.rkt"
"private/universe-image.rkt"
"private/define-keywords.rkt"
"private/clauses-spec-aux.rkt"
;; ---
"private/world.rkt"
"private/universe.rkt"
"private/launch-many-worlds.rkt"
"private/stop.rkt"
"private/universe-image.rkt"
;;
(only-in "private/launch-many-worlds.rkt" launch-many-worlds)
(only-in "private/stop.rkt" make-stop-the-world)
(only-in "private/check-aux.rkt" sexp?)
htdp/error
(rename-in lang/prim (first-order->higher-order f2h)))
@ -314,8 +317,7 @@
[(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* ([args
(->args 'universe stx #'u #'(bind ...) UniSpec void "universe")]
(let* ([args (->args 'universe stx #'u #'(bind ...) UniSpec void "universe")]
[dom (syntax->list #'(bind ...))])
(cond
[(not (contains-clause? #'on-new dom))