eliminated superfluous require for-syntax, refactored and cleaned up; fixed bug in test?
This commit is contained in:
parent
8aa4ff1b06
commit
a1c219a068
|
@ -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)
|
||||
|
|
|
@ -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))
|
48
collects/2htdp/private/clauses-spec-aux.rkt
Normal file
48
collects/2htdp/private/clauses-spec-aux.rkt
Normal 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)
|
47
collects/2htdp/private/define-keywords.rkt
Normal file
47
collects/2htdp/private/define-keywords.rkt
Normal 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*)))))))]))))]))
|
|
@ -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
|
||||
|
||||
|
|
|
@ -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)
|
|
@ -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
|
||||
|
|
|
@ -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"))
|
||||
|
||||
|
|
|
@ -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))
|
||||
|
|
Loading…
Reference in New Issue
Block a user