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 PAUSE 1/2) ;; # secs to wait between attempts to connect to server
|
||||||
(define SQPORT 4567) ;; the port on which universe traffic flows
|
(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
|
;; Number Symbol Symbol -> Integer
|
||||||
(define (number->integer x [t ""] [p ""])
|
(define (number->integer x [t ""] [p ""])
|
||||||
(check-arg t (and (number? x) (real? x)) "real number" p x)
|
(check-arg t (and (number? x) (real? x)) "real number" p x)
|
||||||
|
|
|
@ -1,62 +1,63 @@
|
||||||
#lang racket
|
#lang racket
|
||||||
|
|
||||||
(provide define-keywords
|
;; ---------------------------------------------------------------------------------------------------
|
||||||
DEFAULT
|
;; provides functions for specifying the shape of big-bang and universe clauses:
|
||||||
;; constraint: the first kw is the original one
|
|
||||||
|
(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
|
;; and it is also the name of the field in the class
|
||||||
->args
|
->args
|
||||||
function-with-arity expr-with-check except err
|
|
||||||
->kwds-in
|
|
||||||
clauses-use-kwd
|
|
||||||
contains-clause?)
|
contains-clause?)
|
||||||
|
|
||||||
(require
|
(require
|
||||||
(for-syntax "syn-aux-aux.rkt" syntax/parse)
|
(for-syntax syntax/parse)
|
||||||
(for-template "syn-aux-aux.rkt"
|
(for-template "clauses-spec-aux.rkt" racket (rename-in lang/prim (first-order->higher-order f2h))))
|
||||||
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)
|
(define-syntax (expr-with-check 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 ()
|
(syntax-case stx ()
|
||||||
[(_ para (... ...))
|
[(_ check> msg)
|
||||||
(let*-values
|
#`(lambda (tag)
|
||||||
([(kwds defs)
|
(lambda (p)
|
||||||
(values (map car the-list) '())]
|
(syntax-case p ()
|
||||||
;; the defaults list defs is no longer needed
|
[(_ x) #`(check> #,tag x)]
|
||||||
[(args) (lambda (para*)
|
[_ (err tag p msg)])))]))
|
||||||
(append para* (foldr cons '() kwds)))]
|
|
||||||
[(body) (lambda (para*)
|
(define-syntax function-with-arity
|
||||||
(map (lambda (x) `(,x ,x)) (append para* kwds)))])
|
(syntax-rules (except)
|
||||||
(let ([para* (syntax->list #'(para (... ...)))])
|
[(_ arity)
|
||||||
#`(lambda (%)
|
(lambda (tag)
|
||||||
(lambda #,(args para*)
|
(lambda (p)
|
||||||
(lambda ()
|
(syntax-case p ()
|
||||||
(new % #,@(body para*)))))))]))))]))
|
[(_ 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
|
transform the clauses into the initial arguments specification
|
||||||
|
@ -91,16 +92,25 @@
|
||||||
(if r ((third s) r) (fourth s)))
|
(if r ((third s) r) (fourth s)))
|
||||||
Spec))
|
Spec))
|
||||||
|
|
||||||
(define (contains-clause? kw clause-list)
|
;; check whether rec? occurs, produce list of keyword x clause pairs
|
||||||
(memf (lambda (clause) (free-identifier=? kw (car (syntax->list clause)))) clause-list))
|
(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)
|
||||||
;; Syntax -> Syntax
|
(define (->kwds-in kwds)
|
||||||
;; eventually: convert syntax to keyword
|
(lambda (k)
|
||||||
(define (mk-kwd key)
|
(and (identifier? k) (for/or ([n kwds]) (free-identifier=? k n)))))
|
||||||
(define key:id (symbol->string (syntax-e key)))
|
|
||||||
(define key:wd (string->keyword key:id))
|
|
||||||
key:wd)
|
|
||||||
|
|
||||||
;; Symbol Syntax Syntax [Listof Kw] -> true
|
;; Symbol Syntax Syntax [Listof Kw] -> true
|
||||||
;; effect: if state0 looks like a clause, raise special error
|
;; effect: if state0 looks like a clause, raise special error
|
||||||
|
@ -124,55 +134,3 @@
|
||||||
(if x
|
(if x
|
||||||
(raise-syntax-error tag (format "duplicate ~a clause" id) (cdar x))
|
(raise-syntax-error tag (format "duplicate ~a clause" id) (cdar x))
|
||||||
(duplicates? (rest lox))))])))
|
(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.rkt the old world
|
||||||
world% = (clock-mixin ...) -- the basic world
|
world% = (clock-mixin ...) -- the basic world
|
||||||
aworld% = (class world% ...) -- the world with recording
|
aworld% = (class world% ...) -- the world with recording
|
||||||
|
|
||||||
universe.ss the universe server
|
universe.rkt the universe server
|
||||||
universe% = (clock-mixin ...) -- the basic universe
|
universe% = (clock-mixin ...) -- the basic universe
|
||||||
|
|
||||||
timer.ss the clock-mixin
|
timer.rkt the clock-mixin
|
||||||
|
|
||||||
check-aux.ss common primitives
|
check-aux.rkt common primitives
|
||||||
image.ss the world image functions
|
image.rkt the world image functions
|
||||||
syn-aux.ss syntactic auxiliaries
|
clauses-spec-and-process.rkt syntactic auxiliaries
|
||||||
syn-aux-aux.ss auxiliaries to the 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
|
#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"
|
"check-aux.rkt"
|
||||||
"timer.rkt"
|
"timer.rkt"
|
||||||
"last.rkt"
|
"last.rkt"
|
||||||
|
"clauses-spec-aux.rkt"
|
||||||
htdp/error
|
htdp/error
|
||||||
(only-in mzlib/etc evcase)
|
(only-in mzlib/etc evcase)
|
||||||
string-constants)
|
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 ---
|
;; --- the server representation of a world ---
|
||||||
(define-struct iworld (in out name info) #; #:transparent)
|
(define-struct iworld (in out name info) #; #:transparent)
|
||||||
;; World = (make-iworld IPort OPort Symbol [Listof Sexp])
|
;; 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)
|
(define-struct bundle (state mails bad) #:transparent)
|
||||||
|
|
||||||
(set! make-bundle
|
(set! make-bundle
|
||||||
|
|
|
@ -26,7 +26,11 @@
|
||||||
(on-draw draw-number)
|
(on-draw draw-number)
|
||||||
(record? dir)))
|
(record? dir)))
|
||||||
(sleep 1)
|
(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)
|
(fprintf (current-error-port)
|
||||||
"this test needs to be revised -- the way 'world' writes images adds an extra pixel -- think! \n"))
|
"this test needs to be revised -- the way 'world' writes images adds an extra pixel -- think! \n"))
|
||||||
|
|
||||||
|
|
|
@ -1,10 +1,11 @@
|
||||||
#lang racket/gui
|
#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:
|
#| TODO:
|
||||||
-- check that on-release is only defined if on-key is defined
|
|
||||||
|
|
||||||
-- run callbacks in user eventspace
|
-- run callbacks in user eventspace
|
||||||
-- make timer fire just once; restart after on-tick callback finishes
|
-- make timer fire just once; restart after on-tick callback finishes
|
||||||
-- take out counting; replace by 0.25 delay
|
-- take out counting; replace by 0.25 delay
|
||||||
|
@ -12,16 +13,18 @@
|
||||||
-- make window resizable :: why
|
-- make window resizable :: why
|
||||||
|#
|
|#
|
||||||
|
|
||||||
(require (for-syntax "private/syn-aux.rkt"
|
(require (for-syntax "private/clauses-spec-and-process.rkt"
|
||||||
stepper/private/shared)
|
stepper/private/shared)
|
||||||
"private/syn-aux-aux.rkt"
|
"private/define-keywords.rkt"
|
||||||
"private/syn-aux.rkt"
|
"private/clauses-spec-aux.rkt"
|
||||||
"private/check-aux.rkt"
|
;; ---
|
||||||
"private/universe-image.rkt"
|
|
||||||
"private/world.rkt"
|
"private/world.rkt"
|
||||||
"private/universe.rkt"
|
"private/universe.rkt"
|
||||||
"private/launch-many-worlds.rkt"
|
"private/universe-image.rkt"
|
||||||
"private/stop.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
|
htdp/error
|
||||||
(rename-in lang/prim (first-order->higher-order f2h)))
|
(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) (raise-syntax-error #f "not a legal universe description" stx)]
|
||||||
[(universe u) (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 ...)
|
[(universe u bind ...)
|
||||||
(let* ([args
|
(let* ([args (->args 'universe stx #'u #'(bind ...) UniSpec void "universe")]
|
||||||
(->args 'universe stx #'u #'(bind ...) UniSpec void "universe")]
|
|
||||||
[dom (syntax->list #'(bind ...))])
|
[dom (syntax->list #'(bind ...))])
|
||||||
(cond
|
(cond
|
||||||
[(not (contains-clause? #'on-new dom))
|
[(not (contains-clause? #'on-new dom))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user