From ff00fefb2d020597626f6dc40f219fe4d7c1af69 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 02:54:55 +0000 Subject: [PATCH 01/78] Core implementation of new contract datatypes. svn: r17684 --- collects/scheme/contract/private/blame.ss | 77 +++++++++ collects/scheme/contract/private/prop.ss | 188 ++++++++++++++++++++++ 2 files changed, 265 insertions(+) create mode 100644 collects/scheme/contract/private/blame.ss create mode 100644 collects/scheme/contract/private/prop.ss diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss new file mode 100644 index 0000000000..9896bfaa3e --- /dev/null +++ b/collects/scheme/contract/private/blame.ss @@ -0,0 +1,77 @@ +#lang scheme/base + +(require unstable/srcloc scheme/pretty) + +(provide blame? + make-blame + blame-source + blame-guilty + blame-innocent + blame-contract + blame-value + blame-positive + blame-negative + blame-swapped? + blame-swap + + raise-blame-error + current-blame-format + (struct-out exn:fail:contract:blame)) + +(define-struct blame [source value contract positive negative swapped?]) + +(define (blame-guilty b) + (if (blame-swapped? b) + (blame-negative b) + (blame-positive b))) + +(define (blame-innocent b) + (if (blame-swapped? b) + (blame-positive b) + (blame-negative b))) + +(define (blame-swap b) + (struct-copy blame b [swapped? (not (blame-swapped? b))])) + +(define-struct (exn:fail:contract:blame exn:fail:contract) [object] + #:transparent) + +(define (raise-blame-error b x fmt . args) + (raise + (make-exn:fail:contract:blame + ((current-blame-format) b x (apply format fmt args)) + (current-continuation-marks) + b))) + +(define (default-blame-format b x custom-message) + (let* ([source-message (source-location->prefix (blame-source b))] + [guilty-message (show (blame-guilty b))] + [contract-message (show (blame-contract b))] + [value-message (if (blame-value b) + (format " on ~a" (show (blame-value b))) + "")]) + (format "~a~a broke the contract ~a~a; ~a" + source-message + guilty-message + contract-message + value-message + custom-message))) + +(define (show v) + (let* ([line + (parameterize ([pretty-print-columns 'infinity]) + (pretty-format v))]) + (if (< (string-length line) 30) + line + (parameterize ([pretty-print-print-line show-line-break] + [pretty-print-columns 50]) + (pretty-format v))))) + +(define (show-line-break line port len cols) + (newline port) + (if line + (begin (display " " port) 2) + 0)) + +(define current-blame-format + (make-parameter default-blame-format)) diff --git a/collects/scheme/contract/private/prop.ss b/collects/scheme/contract/private/prop.ss new file mode 100644 index 0000000000..8bcd992fd9 --- /dev/null +++ b/collects/scheme/contract/private/prop.ss @@ -0,0 +1,188 @@ +#lang scheme/base + +(require "blame.ss") + +(provide prop:contract + contract-struct? + contract-struct-name + contract-struct-first-order + contract-struct-projection + contract-struct-stronger? + + prop:flat-contract + flat-contract-struct? + + contract-property? + build-contract-property + + flat-contract-property? + build-flat-contract-property + + simple-contract + simple-flat-contract) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Contract Property +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-struct contract-property [ name first-order projection stronger ] + #:omit-define-syntaxes) + +(define build-contract-property + (build-property make-contract-property 'anonymous-contract)) + +(define (contract-property-guard prop info) + (unless (contract-property? prop) + (raise + (make-exn:fail:contract + (format "~a: expected a contract property; got: ~e" + 'prop:contract + prop) + (current-continuation-marks)))) + prop) + +(define-values [ prop:contract contract-struct? contract-struct-property ] + (make-struct-type-property 'prop:contract contract-property-guard)) + +(define (contract-struct-name c) + (let* ([prop (contract-struct-property c)] + [get-name (contract-property-name prop)] + [name (get-name c)]) + name)) + +(define (contract-struct-first-order c) + (let* ([prop (contract-struct-property c)] + [get-first-order (contract-property-first-order prop)] + [first-order (get-first-order c)]) + first-order)) + +(define (contract-struct-projection c) + (let* ([prop (contract-struct-property c)] + [get-projection (contract-property-projection prop)] + [projection (get-projection c)]) + projection)) + +(define (contract-struct-stronger? a b) + (let* ([prop (contract-struct-property a)] + [stronger (contract-property-stronger prop)]) + (stronger a b))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Flat Contract Property +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-struct flat-contract-property [implementation] + #:omit-define-syntaxes) + +(define build-flat-contract-property + (build-property (compose make-flat-contract-property make-contract-property) + 'anonymous-flat-contract)) + +(define (flat-contract-property-guard prop info) + (unless (flat-contract-property? prop) + (raise + (make-exn:fail:contract + (format "~a: expected a flat contract property; got: ~e" + 'prop:flat-contract + prop) + (current-continuation-marks)))) + prop) + +(define flat-contract-property->contract-property + flat-contract-property-implementation) + +(define (flat-contract-property->procedure-property prop) + (let* ([impl (flat-contract-property-implementation prop)] + [get-predicate (contract-property-first-order impl)]) + (lambda (c x) ((get-predicate c) x)))) + +(define-values [ prop:flat-contract + flat-contract-struct? + flat-contract-struct-property ] + (make-struct-type-property + 'prop:flat-contract + flat-contract-property-guard + (list (cons prop:contract flat-contract-property->contract-property) + (cons prop:procedure flat-contract-property->procedure-property)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Friendly Property Construction +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define ((build-property mk default-name) + #:name [get-name #f] + #:first-order [get-first-order #f] + #:projection [get-projection #f] + #:stronger [stronger #f]) + + (let* ([get-name (or get-name (lambda (c) default-name))] + [get-first-order (or get-first-order get-any?)] + [get-projection (or get-projection + (get-first-order-projection + get-name get-first-order))] + [stronger (or stronger weakest)]) + + (mk get-name get-first-order get-projection stronger))) + +(define (get-any? c) any?) +(define (any? x) #t) + +(define (weakest a b) #f) + +(define ((get-first-order-projection get-name get-first-order) c) + (first-order-projection (get-name c) (get-first-order c))) + +(define (((first-order-projection name first-order) b) x) + (if (first-order x) + x + (raise-blame-error b x "expected <~a>, given: ~e" name x))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Simple Contract Construction +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-struct simple-contract [ name first-order projection stronger ] + #:omit-define-syntaxes + #:property prop:contract + (make-contract-property + (lambda (c) (simple-contract-name c)) + (lambda (c) (simple-contract-first-order c)) + (lambda (c) (simple-contract-projection c)) + (lambda (a b) ((simple-contract-stronger a) a b)))) + +(define simple-contract + (build-contract make-simple-contract 'simple-contract)) + +(define-struct simple-flat-contract [ name first-order projection stronger ] + #:omit-define-syntaxes + #:property prop:flat-contract + (make-flat-contract-property + (make-contract-property + (lambda (c) (simple-flat-contract-name c)) + (lambda (c) (simple-flat-contract-first-order c)) + (lambda (c) (simple-flat-contract-projection c)) + (lambda (a b) ((simple-flat-contract-stronger a) a b))))) + +(define simple-flat-contract + (build-contract make-simple-flat-contract 'simple-flat-contract)) + +(define ((build-contract mk default-name) + #:name [name #f] + #:first-order [first-order #f] + #:projection [projection #f] + #:stronger [stronger #f]) + + (let* ([name (or name default-name)] + [first-order (or first-order any?)] + [projection (or projection (first-order-projection name first-order))] + [stronger (or stronger weakest)]) + + (mk name first-order projection stronger))) From 05c4296eca7074077721d729f51baf23c934b2e4 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 03:36:17 +0000 Subject: [PATCH 02/78] Fixed evaluation order. svn: r17685 --- collects/scheme/contract/private/prop.ss | 26 ++++++++++++------------ 1 file changed, 13 insertions(+), 13 deletions(-) diff --git a/collects/scheme/contract/private/prop.ss b/collects/scheme/contract/private/prop.ss index 8bcd992fd9..37f5636ad9 100644 --- a/collects/scheme/contract/private/prop.ss +++ b/collects/scheme/contract/private/prop.ss @@ -30,9 +30,6 @@ (define-struct contract-property [ name first-order projection stronger ] #:omit-define-syntaxes) -(define build-contract-property - (build-property make-contract-property 'anonymous-contract)) - (define (contract-property-guard prop info) (unless (contract-property? prop) (raise @@ -78,10 +75,6 @@ (define-struct flat-contract-property [implementation] #:omit-define-syntaxes) -(define build-flat-contract-property - (build-property (compose make-flat-contract-property make-contract-property) - 'anonymous-flat-contract)) - (define (flat-contract-property-guard prop info) (unless (flat-contract-property? prop) (raise @@ -130,6 +123,13 @@ (mk get-name get-first-order get-projection stronger))) +(define build-contract-property + (build-property make-contract-property 'anonymous-contract)) + +(define build-flat-contract-property + (build-property (compose make-flat-contract-property make-contract-property) + 'anonymous-flat-contract)) + (define (get-any? c) any?) (define (any? x) #t) @@ -158,9 +158,6 @@ (lambda (c) (simple-contract-projection c)) (lambda (a b) ((simple-contract-stronger a) a b)))) -(define simple-contract - (build-contract make-simple-contract 'simple-contract)) - (define-struct simple-flat-contract [ name first-order projection stronger ] #:omit-define-syntaxes #:property prop:flat-contract @@ -171,9 +168,6 @@ (lambda (c) (simple-flat-contract-projection c)) (lambda (a b) ((simple-flat-contract-stronger a) a b))))) -(define simple-flat-contract - (build-contract make-simple-flat-contract 'simple-flat-contract)) - (define ((build-contract mk default-name) #:name [name #f] #:first-order [first-order #f] @@ -186,3 +180,9 @@ [stronger (or stronger weakest)]) (mk name first-order projection stronger))) + +(define simple-contract + (build-contract make-simple-contract 'simple-contract)) + +(define simple-flat-contract + (build-contract make-simple-flat-contract 'simple-flat-contract)) From 1d9b4a79b7c63943e575407746237ae3173a8377 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 03:36:56 +0000 Subject: [PATCH 03/78] Reimplemented guts based on new properties. svn: r17686 --- collects/scheme/contract/private/guts.ss | 414 +++++++---------------- 1 file changed, 119 insertions(+), 295 deletions(-) diff --git a/collects/scheme/contract/private/guts.ss b/collects/scheme/contract/private/guts.ss index cf5e50b4f6..431f0f1601 100644 --- a/collects/scheme/contract/private/guts.ss +++ b/collects/scheme/contract/private/guts.ss @@ -1,17 +1,14 @@ #lang scheme/base (require "helpers.ss" + "blame.ss" + "prop.ss" scheme/pretty) (require (for-syntax scheme/base "helpers.ss")) -(provide raise-contract-error - guilty-party - exn:fail:contract2? - exn:fail:contract2-srclocs - - contract-violation->string +(provide (all-from-out "blame.ss" "prop.ss") coerce-contract coerce-contracts @@ -34,21 +31,13 @@ contract? contract-name - contract-proc - make-proj-contract + contract-projection contract-stronger? - + + contract-first-order contract-first-order-passes? - proj-prop proj-pred? proj-get - name-prop name-pred? name-get - stronger-prop stronger-pred? stronger-get - flat-prop flat-pred? flat-get - flat-proj - first-order-prop - first-order-get - ;; for opters check-flat-contract check-flat-named-contract @@ -57,48 +46,26 @@ (define-syntax (any stx) (raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx)) -(define-values (proj-prop proj-pred? raw-proj-get) - (make-struct-type-property 'contract-projection)) -(define-values (name-prop name-pred? name-get) - (make-struct-type-property 'contract-name)) -(define-values (stronger-prop stronger-pred? stronger-get) - (make-struct-type-property 'contract-stronger-than)) -(define-values (flat-prop flat-pred? flat-get) - (make-struct-type-property 'contract-flat)) - -(define-values (first-order-prop first-order-pred? raw-first-order-get) - (make-struct-type-property 'contract-first-order)) - -(define (first-order-get stct) - (cond - [(flat-pred? stct) (flat-get stct)] - [else (raw-first-order-get stct)])) +(define (contract-first-order c) + (contract-struct-first-order + (coerce-contract 'contract-first-order-passes? c))) (define (contract-first-order-passes? c v) - (let ([ctc (coerce-contract 'contract-first-order-passes? c)]) - (cond - [(first-order-pred? ctc) (((first-order-get ctc) ctc) v)] - [(flat-pred? c) (((flat-get c) c) v)] - [else #t]))) - -(define (proj-get ctc) - (cond - [(proj-pred? ctc) - (raw-proj-get ctc)] - [else (error 'proj-get "unknown ~e" ctc)])) + ((contract-struct-first-order + (coerce-contract 'contract-first-order-passes? c)) + v)) ;; contract-stronger? : contract contract -> boolean ;; indicates if one contract is stronger (ie, likes fewer values) than another ;; this is not a total order. (define (contract-stronger? a b) - (let ([a-ctc (coerce-contract 'contract-stronger? a)] - [b-ctc (coerce-contract 'contract-stronger? b)]) - ((stronger-get a-ctc) a-ctc b-ctc))) + (contract-struct-stronger? (coerce-contract 'contract-stronger? a) + (coerce-contract 'contract-stronger? b))) ;; coerce-flat-contract : symbol any/c -> contract (define (coerce-flat-contract name x) (let ([ctc (coerce-contract/f x)]) - (unless (flat-pred? ctc) + (unless (flat-contract-struct? ctc) (error name "expected a flat contract or a value that can be coerced into one, got ~e" x)) @@ -113,7 +80,7 @@ [(null? xs) '()] [else (let ([fst (coerce-contract/f (car xs))]) - (unless (flat-pred? fst) + (unless (flat-contract-struct? fst) (error name "expected all of the arguments to be flat contracts, but argument ~a was not, got ~e" i @@ -147,7 +114,7 @@ ;; returns #f if the argument could not be coerced to a contract (define (coerce-contract/f x) (cond - [(proj-pred? x) x] + [(contract-struct? x) x] [(and (procedure? x) (procedure-arity-includes? x 1)) (make-predicate-contract (or (object-name x) '???) x)] [(or (symbol? x) (boolean? x) (char? x) (null? x)) (make-eq-contract x)] @@ -155,114 +122,6 @@ [(number? x) (make-=-contract x)] [(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)] [else #f])) - -(define-values (make-exn:fail:contract2 - exn:fail:contract2? - exn:fail:contract2-srclocs - guilty-party) - (let-values ([(exn:fail:contract2 - make-exn:fail:contract2 - exn:fail:contract2? - get - set) - (parameterize ([current-inspector (make-inspector)]) - (make-struct-type 'exn:fail:contract2 - struct:exn:fail:contract - 2 - 0 - #f - (list (cons prop:exn:srclocs - (lambda (x) - (exn:fail:contract2-srclocs x))))))]) - (values - make-exn:fail:contract2 - exn:fail:contract2? - (lambda (x) (get x 0)) - (lambda (x) (get x 1))))) - -(define (default-contract-violation->string val src-info to-blame contract-sexp msg) - (let ([blame-src (src-info-as-string src-info)] - [formatted-contract-sexp - (let ([one-line - (let ([sp (open-output-string)]) - (parameterize ([pretty-print-columns 'infinity]) - (pretty-print contract-sexp sp) - (get-output-string sp)))]) - (if (< (string-length one-line) 30) - one-line - (let ([sp (open-output-string)]) - (newline sp) - (parameterize ([pretty-print-print-line print-contract-liner] - [pretty-print-columns 50]) - (pretty-print contract-sexp sp)) - (get-output-string sp))))] - [specific-blame - (cond - [(syntax? src-info) - (let ([datum (syntax->datum src-info)]) - (if (symbol? datum) - (format " on ~a" datum) - ""))] - [(pair? src-info) - (format " on ~a" (list-ref src-info 1))] - [else ""])]) - (string-append (format "~a~a broke the contract ~a~a; " - blame-src - (cond - [(not to-blame) "<>"] - [(and (pair? to-blame) - (pair? (cdr to-blame)) - (null? (cddr to-blame)) - (equal? 'quote (car to-blame))) - (format "'~s" (cadr to-blame))] - [else (format "~s" to-blame)]) - formatted-contract-sexp - specific-blame) - msg))) - -(define contract-violation->string (make-parameter default-contract-violation->string)) - -(define (raise-contract-error val src-info blame contract-sexp fmt . args) - (let ([blame (unpack-blame blame)]) - (raise - (make-exn:fail:contract2 - (string->immutable-string - ((contract-violation->string) val - src-info - blame - contract-sexp - (apply format fmt args))) - (current-continuation-marks) - (cond - [(syntax? src-info) - (list (make-srcloc - (syntax-source src-info) - (syntax-line src-info) - (syntax-column src-info) - (syntax-position src-info) - (syntax-span src-info)))] - [(srcloc? src-info) (list src-info)] - [else '()]) - (unpack-blame blame))))) - -(define print-contract-liner - (let ([default (pretty-print-print-line)]) - (λ (line port ol cols) - (+ (default line port ol cols) - (if line - (begin (display " " port) - 2) - 0))))) - -;; src-info-as-string : (union srcloc syntax #f) -> string -(define (src-info-as-string src-info) - (if (or (syntax? src-info) - (srcloc? src-info)) - (let ([src-loc-str (build-src-loc-string src-info)]) - (if src-loc-str - (string-append src-loc-str ": ") - "")) - "")) ; ; @@ -281,86 +140,23 @@ ; ; -;; contract = (make-contract sexp -;; (sym -;; sym -;; (union syntax #f) -;; string -;; -> -;; (alpha -> alpha))) -;; the first arg to make-contract builds the name of the contract. The -;; path records how the violation occurs -;; -;; generic contract container; -;; the first arg to proc is a symbol representing the name of the positive blame -;; the second arg to proc is the symbol representing the name of the negative blame -;; the third argument to proc is the src-info. -;; the fourth argumet is a textual representation of the original contract -;; -;; the argument to the result function is the value to test. -;; (the result function is the projection) -;; - -(define (flat-proj ctc) - (let ([pred? ((flat-get ctc) ctc)]) - (λ (pos neg src-info orig-str positive-position?) - (λ (val) - (if (pred? val) - val - (raise-contract-error - val - src-info - pos - orig-str - "expected <~a>, given: ~e" - ((name-get ctc) ctc) - val)))))) - -(define (double-any-curried-proj ctc) double-any-curred-proj2) -(define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str positive-position?) values) - - -(define-values (make-proj-contract) - (let () - (define-struct proj-contract (the-name proj first-order-proc) - #:property proj-prop - (λ (ctc) - (let ([raw-proj (proj-contract-proj ctc)]) - (if (procedure-arity-includes? raw-proj 5) - raw-proj - (λ (pos neg src-info name positive-position?) - (raw-proj pos neg src-info name))))) - - #:property name-prop - (λ (ctc) (proj-contract-the-name ctc)) - - #:property first-order-prop - (λ (ctc) (or (proj-contract-first-order-proc ctc) - (λ (x) #t))) - #:property stronger-prop - (λ (this that) - (and (proj-contract? that) - (procedure-closure-contents-eq? - (proj-contract-proj this) - (proj-contract-proj that))))) - - (values make-proj-contract))) - -(define (flat-contract-predicate x) - (let ([ctc (coerce-flat-contract 'flat-contract-predicate x)]) - ((flat-get ctc) ctc))) +(define (flat-contract-predicate x) + (contract-struct-first-order + (coerce-flat-contract 'flat-contract-predicate x))) (define (flat-contract? x) (let ([c (coerce-contract/f x)]) (and c - (flat-pred? c)))) + (flat-contract-struct? c)))) (define (contract-name ctc) - (let ([ctc (coerce-contract 'contract-name ctc)]) - ((name-get ctc) ctc))) + (contract-struct-name + (coerce-contract 'contract-name ctc))) (define (contract? x) (and (coerce-contract/f x) #t)) -(define (contract-proc ctc) ((proj-get ctc) ctc)) +(define (contract-projection ctc) + (contract-struct-projection + (coerce-contract 'contract-projection ctc))) (define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) @@ -385,15 +181,15 @@ '()] [else (let ([sub (car subs)]) (cond - [(name-pred? sub) + [(contract-struct? sub) (let ([mk-sub-name (contract-name sub)]) `(,mk-sub-name ,@(loop (cdr subs))))] [else `(,sub ,@(loop (cdr subs)))]))]))) (define (and-proj ctc) - (let ([mk-pos-projs (map (λ (x) ((proj-get x) x)) (and/c-ctcs ctc))]) - (lambda (pos neg src-info orig-str positive-position?) - (let ([projs (map (λ (c) (c pos neg src-info orig-str positive-position?)) mk-pos-projs)]) + (let ([mk-pos-projs (map contract-projection (and/c-ctcs ctc))]) + (lambda (blame) + (let ([projs (map (λ (c) (c blame)) mk-pos-projs)]) (let loop ([projs (cdr projs)] [proj (car projs)]) (cond @@ -405,23 +201,24 @@ (define-struct and/c (ctcs) #:omit-define-syntaxes - #:property proj-prop and-proj - #:property name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc))) - #:property first-order-prop - (λ (ctc) - (let ([tests (map (λ (x) ((first-order-get x) x)) - (and/c-ctcs ctc))]) - (λ (x) - (andmap (λ (f) (f x)) tests)))) - #:property stronger-prop - (λ (this that) - (and (and/c? that) - (let ([this-ctcs (and/c-ctcs this)] - [that-ctcs (and/c-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs)))))) + #:property prop:contract + (build-contract-property + #:projection and-proj + #:name (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc))) + #:first-order + (λ (ctc) + (let ([tests (map contract-first-order (and/c-ctcs ctc))]) + (λ (x) + (andmap (λ (f) (f x)) tests)))) + #:stronger + (λ (this that) + (and (and/c? that) + (let ([this-ctcs (and/c-ctcs this)] + [that-ctcs (and/c-ctcs that)]) + (and (= (length this-ctcs) (length that-ctcs)) + (andmap contract-stronger? + this-ctcs + that-ctcs))))))) (define (and/c . raw-fs) (let ([contracts (coerce-contracts 'and/c raw-fs)]) @@ -441,35 +238,42 @@ (flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))] [else (make-and/c contracts)]))) +(define (get-any-projection c) any-projection) +(define (any-projection b) any-function) +(define (any-function x) x) + +(define (get-any? c) any?) +(define (any? x) #t) + (define-struct any/c () #:omit-define-syntaxes - #:property proj-prop double-any-curried-proj - #:property stronger-prop (λ (this that) (any/c? that)) - #:property name-prop (λ (ctc) 'any/c) - #:property first-order-prop (λ (ctc) (λ (val) #t)) - #:property flat-prop (λ (ctc) (λ (x) #t))) + #:property prop:flat-contract + (build-flat-contract-property + #:projection get-any-projection + #:stronger (λ (this that) (any/c? that)) + #:name (λ (ctc) 'any/c) + #:first-order get-any?)) (define any/c (make-any/c)) (define (none-curried-proj ctc) - (λ (pos-blame neg-blame src-info orig-str positive-position?) + (λ (blame) (λ (val) - (raise-contract-error + (raise-blame-error + blame val - src-info - pos-blame - orig-str "~s accepts no values, given: ~e" (none/c-name ctc) val)))) (define-struct none/c (name) #:omit-define-syntaxes - #:property proj-prop none-curried-proj - #:property stronger-prop (λ (this that) #t) - #:property name-prop (λ (ctc) (none/c-name ctc)) - #:property first-order-prop (λ (ctc) (λ (val) #f)) - #:property flat-prop (λ (ctc) (λ (x) #f))) + #:property prop:flat-contract + (build-flat-contract-property + #:projection none-curried-proj + #:stronger (λ (this that) #t) + #:name (λ (ctc) (none/c-name ctc)) + #:first-order (λ (ctc) (λ (val) #f)))) (define none/c (make-none/c 'none/c)) @@ -495,43 +299,63 @@ ; (define-struct eq-contract (val) - #:property proj-prop flat-proj - #:property flat-prop (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x))) - #:property name-prop (λ (ctc) - (if (symbol? (eq-contract-val ctc)) - `',(eq-contract-val ctc) - (eq-contract-val ctc))) - #:property stronger-prop (λ (this that) (and (eq-contract? that) (eq? (eq-contract-val this) (eq-contract-val that))))) + #:property prop:flat-contract + (build-flat-contract-property + #:first-order (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x))) + #:name + (λ (ctc) + (if (symbol? (eq-contract-val ctc)) + `',(eq-contract-val ctc) + (eq-contract-val ctc))) + #:stronger + (λ (this that) + (and (eq-contract? that) + (eq? (eq-contract-val this) (eq-contract-val that)))))) (define-struct equal-contract (val) - #:property proj-prop flat-proj - #:property flat-prop (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x))) - #:property name-prop (λ (ctc) (equal-contract-val ctc)) - #:property stronger-prop (λ (this that) (and (equal-contract? that) (equal? (equal-contract-val this) (equal-contract-val that))))) + #:property prop:flat-contract + (build-flat-contract-property + #:first-order (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x))) + #:name (λ (ctc) (equal-contract-val ctc)) + #:stronger + (λ (this that) + (and (equal-contract? that) + (equal? (equal-contract-val this) (equal-contract-val that)))))) (define-struct =-contract (val) - #:property proj-prop flat-proj - #:property flat-prop (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x)))) - #:property name-prop (λ (ctc) (=-contract-val ctc)) - #:property stronger-prop (λ (this that) (and (=-contract? that) (= (=-contract-val this) (=-contract-val that))))) + #:property prop:flat-contract + (build-flat-contract-property + #:first-order (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x)))) + #:name (λ (ctc) (=-contract-val ctc)) + #:stronger + (λ (this that) + (and (=-contract? that) + (= (=-contract-val this) (=-contract-val that)))))) (define-struct regexp/c (reg) - #:property proj-prop flat-proj - #:property flat-prop (λ (ctc) (λ (x) (and (or (string? x) (bytes? x)) - (regexp-match (regexp/c-reg ctc) x) - #t))) - #:property name-prop (λ (ctc) (regexp/c-reg ctc)) - #:property stronger-prop (λ (this that) (and (regexp/c? that) (eq? (regexp/c-reg this) (regexp/c-reg that))))) + #:property prop:flat-contract + (build-flat-contract-property + #:first-order + (λ (ctc) + (λ (x) + (and (or (string? x) (bytes? x)) + (regexp-match (regexp/c-reg ctc) x) + #t))) + #:name (λ (ctc) (regexp/c-reg ctc)) + #:stronger + (λ (this that) + (and (regexp/c? that) (eq? (regexp/c-reg this) (regexp/c-reg that)))))) (define-struct predicate-contract (name pred) - #:property proj-prop flat-proj - #:property stronger-prop - (λ (this that) - (and (predicate-contract? that) - (procedure-closure-contents-eq? (predicate-contract-pred this) - (predicate-contract-pred that)))) - #:property name-prop (λ (ctc) (predicate-contract-name ctc)) - #:property flat-prop (λ (ctc) (predicate-contract-pred ctc))) + #:property prop:flat-contract + (build-flat-contract-property + #:stronger + (λ (this that) + (and (predicate-contract? that) + (procedure-closure-contents-eq? (predicate-contract-pred this) + (predicate-contract-pred that)))) + #:name (λ (ctc) (predicate-contract-name ctc)) + #:first-order (λ (ctc) (predicate-contract-pred ctc)))) (define (build-flat-contract name pred) (make-predicate-contract name pred)) From d10eea83e769b9067e08ca3e5b6cbea2a6b293f7 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 03:54:22 +0000 Subject: [PATCH 04/78] Ported opt-guts.ss and opt.ss to use new properties. svn: r17687 --- collects/scheme/contract/private/opt-guts.ss | 62 ++++---------------- collects/scheme/contract/private/opt.ss | 36 +++++------- 2 files changed, 27 insertions(+), 71 deletions(-) diff --git a/collects/scheme/contract/private/opt-guts.ss b/collects/scheme/contract/private/opt-guts.ss index 1dedd43c54..9e19ee0bbc 100644 --- a/collects/scheme/contract/private/opt-guts.ss +++ b/collects/scheme/contract/private/opt-guts.ss @@ -10,11 +10,7 @@ make-opt/info opt/info-contract opt/info-val - opt/info-pos - opt/info-neg - opt/info-src-info - opt/info-orig-str - opt/info-positive-position? + opt/info-blame opt/info-free-vars opt/info-recf opt/info-base-pred @@ -57,52 +53,22 @@ ;; struct for color-keeping across opters (define-struct opt/info - (contract val pos neg src-info orig-str position-var position-swap? - free-vars recf base-pred this that)) + (contract val blame-id swap-blame? free-vars recf base-pred this that)) -(define (opt/info-positive-position? oi) - (if (opt/info-position-swap? oi) - #`(not #,(opt/info-position-var oi)) - (opt/info-position-var oi))) +(define (opt/info-blame oi) + (if (opt/info-swap-blame? oi) + #`(blame-swap #,(opt/info-blame-id oi)) + (opt/info-blame-id oi))) ;; opt/info-swap-blame : opt/info -> opt/info ;; swaps pos and neg (define (opt/info-swap-blame info) - (let ((ctc (opt/info-contract info)) - (val (opt/info-val info)) - (pos (opt/info-pos info)) - (neg (opt/info-neg info)) - (position-var (opt/info-position-var info)) - (position-swap? (opt/info-position-swap? info)) - (src-info (opt/info-src-info info)) - (orig-str (opt/info-orig-str info)) - (free-vars (opt/info-free-vars info)) - (recf (opt/info-recf info)) - (base-pred (opt/info-base-pred info)) - (this (opt/info-this info)) - (that (opt/info-that info))) - (make-opt/info ctc val neg pos src-info orig-str - position-var (not position-swap?) - free-vars recf base-pred this that))) + (struct-copy opt/info info [swap-blame? (not (opt/info-swap-blame? info))])) ;; opt/info-change-val : identifier opt/info -> opt/info ;; changes the name of the variable that the value-to-be-contracted is bound to (define (opt/info-change-val val info) - (let ((ctc (opt/info-contract info)) - (pos (opt/info-pos info)) - (neg (opt/info-neg info)) - (position-var (opt/info-position-var info)) - (position-swap? (opt/info-position-swap? info)) - (src-info (opt/info-src-info info)) - (orig-str (opt/info-orig-str info)) - (free-vars (opt/info-free-vars info)) - (recf (opt/info-recf info)) - (base-pred (opt/info-base-pred info)) - (this (opt/info-this info)) - (that (opt/info-that info))) - (make-opt/info ctc val pos neg src-info orig-str - position-var position-swap? - free-vars recf base-pred this that))) + (struct-copy opt/info info [val val])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -199,17 +165,13 @@ (list (cons partial-var (with-syntax ((lift-var lift-var) - (pos (opt/info-pos opt/info)) - (neg (opt/info-neg opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) - (positive-position? (opt/info-positive-position? opt/info))) - (syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str positive-position?)))) + (blame (opt/info-blame opt/info))) + (syntax ((contract-projection lift-var) blame)))) (cons partial-flat-var (with-syntax ((lift-var lift-var)) - (syntax (if (flat-pred? lift-var) - ((flat-get lift-var) lift-var) + (syntax (if (flat-contract? lift-var) + (flat-contract-predicate lift-var) (lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s" lift-var x))))))) diff --git a/collects/scheme/contract/private/opt.ss b/collects/scheme/contract/private/opt.ss index 888b11c84c..8b69349574 100644 --- a/collects/scheme/contract/private/opt.ss +++ b/collects/scheme/contract/private/opt.ss @@ -62,13 +62,9 @@ (values (with-syntax ((stx stx) (val (opt/info-val opt/info)) - (pos (opt/info-pos opt/info)) - (neg (opt/info-neg opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) - (positive-position? (opt/info-positive-position? opt/info))) + (blame (opt/info-blame opt/info))) (syntax (let ((ctc stx)) - ((((proj-get ctc) ctc) pos neg src-info orig-str positive-position?) val)))) + (((contract-projection ctc) blame) val)))) null null null @@ -122,11 +118,7 @@ [(_ e (opt-recursive-args ...)) (let*-values ([(info) (make-opt/info #'ctc #'val - #'pos - #'neg - #'src-info - #'orig-str - #'positive-position? + #'blame #f (syntax->list #'(opt-recursive-args ...)) #f @@ -141,7 +133,7 @@ lifts #`(make-opt-contract (λ (ctc) - (λ (pos neg src-info orig-str positive-position?) + (λ (blame) #,(if (syntax-parameter-value #'define/opt-recursive-fn) (with-syntax ([f (syntax-parameter-value #'define/opt-recursive-fn)]) (bind-superlifts @@ -179,16 +171,18 @@ (make-struct-type-property 'original-contract)) (define-struct opt-contract (proj orig-ctc stronger stronger-vars stamp) - #:property proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc)) - ;; I think provide/contract and contract calls this, so we are in effect allocating - ;; the original once - #:property name-prop (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc))) #:property orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc))) - #:property stronger-prop - (λ (this that) - (and (opt-contract? that) - (eq? (opt-contract-stamp this) (opt-contract-stamp that)) - ((opt-contract-stronger this) this that)))) + #:property prop:contract + (build-contract-property + #:projection (λ (ctc) ((opt-contract-proj ctc) ctc)) + ;; I think provide/contract and contract calls this, so we are in effect allocating + ;; the original once + #:name (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc))) + #:stronger + (λ (this that) + (and (opt-contract? that) + (eq? (opt-contract-stamp this) (opt-contract-stamp that)) + ((opt-contract-stronger this) this that))))) ;; opt-stronger-vars-ref : int opt-contract -> any (define (opt-stronger-vars-ref i ctc) From ed47b316354f558b0eb0264c0f74308792c1a9eb Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 04:17:40 +0000 Subject: [PATCH 05/78] Updated arrow.ss to new properties. svn: r17688 --- collects/scheme/contract/private/arrow.ss | 447 +++++++++++----------- 1 file changed, 219 insertions(+), 228 deletions(-) diff --git a/collects/scheme/contract/private/arrow.ss b/collects/scheme/contract/private/arrow.ss index 1b542de3a5..3ade7e4521 100644 --- a/collects/scheme/contract/private/arrow.ss +++ b/collects/scheme/contract/private/arrow.ss @@ -48,11 +48,13 @@ v4 todo: [(p-app-x ...) (generate-temporaries #'(rngs ...))] [(res-x ...) (generate-temporaries #'(rngs ...))]) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) - (let ([proj-x ((proj-get rngs-x) rngs-x)] ...) - (make-proj-contract - (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str positive-position?)] ...) + (let ([proj-x (contract-projection rngs-x)] ...) + (simple-contract + #:name + (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...) + #:projection + (λ (blame) + (let ([p-app-x (proj-x blame)] ...) (λ (val) (if (procedure? val) (make-keyword-procedure @@ -62,11 +64,10 @@ v4 todo: (λ args (let-values ([(res-x ...) (apply val args)]) (values (p-app-x res-x) ...)))) - (raise-contract-error val - src-info - pos-blame - orig-str - "expected a procedure"))))) + (raise-blame-error blame + val + "expected a procedure"))))) + #:first-order procedure?))))])) @@ -100,81 +101,83 @@ v4 todo: ;; and it produces a wrapper-making function. (define-struct -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func) #:omit-define-syntaxes - #:property proj-prop - (λ (ctc) - (let* ([doms-proj (map (λ (x) ((proj-get x) x)) - (if (->-dom-rest/c ctc) + #:property prop:contract + (build-contract-property + #:projection + (λ (ctc) + (let* ([doms-proj (map contract-projection + (if (->-dom-rest/c ctc) (append (->-doms/c ctc) (list (->-dom-rest/c ctc))) (->-doms/c ctc)))] - [doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))] - [rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))] - [mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))] - [optional-kwds-proj (map (λ (x) ((proj-get x) x)) (->-optional-kwds/c ctc))] - [mandatory-keywords (->-mandatory-kwds ctc)] - [optional-keywords (->-optional-kwds ctc)] - [func (->-func ctc)] - [dom-length (length (->-doms/c ctc))] - [optionals-length (length (->-optional-doms/c ctc))] - [has-rest? (and (->-dom-rest/c ctc) #t)]) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?))) - doms-proj)] - [partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?))) - doms-optional-proj)] - [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str positive-position?)) - rngs-proj)] - [partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?))) - mandatory-kwds-proj)] - [partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?))) - optional-kwds-proj)]) - (apply func - (λ (val mtd?) - (if has-rest? - (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str) - (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str))) - (append partial-doms partial-optional-doms - partial-mandatory-kwds partial-optional-kwds - partial-ranges)))))) - - #:property name-prop - (λ (ctc) (single-arrow-name-maker - (->-doms/c ctc) - (->-optional-doms/c ctc) - (->-dom-rest/c ctc) - (->-mandatory-kwds/c ctc) - (->-mandatory-kwds ctc) - (->-optional-kwds/c ctc) - (->-optional-kwds ctc) - (->-rng-any? ctc) - (->-rngs/c ctc))) - - #:property first-order-prop - (λ (ctc) - (λ (x) - (let ([l (length (->-doms/c ctc))]) - (and (procedure? x) - (if (->-dom-rest/c ctc) - (procedure-accepts-and-more? x l) - (procedure-arity-includes? x l)) - (let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)]) - (and (equal? x-mandatory-keywords (->-mandatory-kwds ctc)) - (andmap (λ (optional-keyword) (member optional-keyword x-all-keywords)) - (->-mandatory-kwds ctc)))) - #t)))) - #:property stronger-prop - (λ (this that) - (and (->? that) - (= (length (->-doms/c that)) (length (->-doms/c this))) - (andmap contract-stronger? (->-doms/c that) (->-doms/c this)) - - (equal? (->-mandatory-kwds this) (->-mandatory-kwds that)) - (andmap contract-stronger? (->-mandatory-kwds/c that) (->-mandatory-kwds/c this)) - - (equal? (->-optional-kwds this) (->-optional-kwds that)) - (andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this)) - - (= (length (->-rngs/c that)) (length (->-rngs/c this))) - (andmap contract-stronger? (->-rngs/c this) (->-rngs/c that))))) + [doms-optional-proj (map contract-projection (->-optional-doms/c ctc))] + [rngs-proj (map contract-projection (->-rngs/c ctc))] + [mandatory-kwds-proj (map contract-projection (->-mandatory-kwds/c ctc))] + [optional-kwds-proj (map contract-projection (->-optional-kwds/c ctc))] + [mandatory-keywords (->-mandatory-kwds ctc)] + [optional-keywords (->-optional-kwds ctc)] + [func (->-func ctc)] + [dom-length (length (->-doms/c ctc))] + [optionals-length (length (->-optional-doms/c ctc))] + [has-rest? (and (->-dom-rest/c ctc) #t)]) + (λ (blame) + (let ([partial-doms (map (λ (dom) (dom (blame-swap blame))) + doms-proj)] + [partial-optional-doms (map (λ (dom) (dom (blame-swap blame))) + doms-optional-proj)] + [partial-ranges (map (λ (rng) (rng blame)) + rngs-proj)] + [partial-mandatory-kwds (map (λ (kwd) (kwd (blame-swap blame))) + mandatory-kwds-proj)] + [partial-optional-kwds (map (λ (kwd) (kwd (blame-swap blame))) + optional-kwds-proj)]) + (apply func + (λ (val mtd?) + (if has-rest? + (check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords blame) + (check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords blame))) + (append partial-doms partial-optional-doms + partial-mandatory-kwds partial-optional-kwds + partial-ranges)))))) + + #:name + (λ (ctc) (single-arrow-name-maker + (->-doms/c ctc) + (->-optional-doms/c ctc) + (->-dom-rest/c ctc) + (->-mandatory-kwds/c ctc) + (->-mandatory-kwds ctc) + (->-optional-kwds/c ctc) + (->-optional-kwds ctc) + (->-rng-any? ctc) + (->-rngs/c ctc))) + + #:first-order + (λ (ctc) + (λ (x) + (let ([l (length (->-doms/c ctc))]) + (and (procedure? x) + (if (->-dom-rest/c ctc) + (procedure-accepts-and-more? x l) + (procedure-arity-includes? x l)) + (let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)]) + (and (equal? x-mandatory-keywords (->-mandatory-kwds ctc)) + (andmap (λ (optional-keyword) (member optional-keyword x-all-keywords)) + (->-mandatory-kwds ctc)))) + #t)))) + #:stronger + (λ (this that) + (and (->? that) + (= (length (->-doms/c that)) (length (->-doms/c this))) + (andmap contract-stronger? (->-doms/c that) (->-doms/c this)) + + (equal? (->-mandatory-kwds this) (->-mandatory-kwds that)) + (andmap contract-stronger? (->-mandatory-kwds/c that) (->-mandatory-kwds/c this)) + + (equal? (->-optional-kwds this) (->-optional-kwds that)) + (andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this)) + + (= (length (->-rngs/c that)) (length (->-rngs/c this))) + (andmap contract-stronger? (->-rngs/c this) (->-rngs/c that)))))) (define (build--> name doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f @@ -435,16 +438,14 @@ v4 todo: (append partials-rngs partial) (append this-stronger-ribs stronger-ribs)))]))]) (values - (with-syntax ((pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) + (with-syntax ((blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) ((rng-arg ...) rng-vars) ((next-dom ...) next-doms) (dom-len (length dom-vars)) ((next-rng ...) next-rngs)) (syntax (begin - (check-procedure val #f dom-len 0 '() '() #| keywords |# src-info pos orig-str) + (check-procedure val #f dom-len 0 '() '() #| keywords |# blame) (λ (dom-arg ...) (let-values ([(rng-arg ...) (val next-dom ...)]) (values next-rng ...)))))) @@ -485,14 +486,12 @@ v4 todo: (append partials-doms partial) (append this-stronger-ribs stronger-ribs)))]))]) (values - (with-syntax ((pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) + (with-syntax ((blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) ((next-dom ...) next-doms) (dom-len (length dom-vars))) (syntax (begin - (check-procedure val #f dom-len 0 '() '() #|keywords|# src-info pos orig-str) + (check-procedure val #f dom-len 0 '() '() #|keywords|# blame) (λ (dom-arg ...) (val next-dom ...))))) lifts-doms @@ -855,7 +854,7 @@ v4 todo: (list (+ mandatory-count i))] [else (cons (+ mandatory-count i) (loop (+ i 1)))]))])]) - (λ (pos-blame neg-blame src-info orig-str positive-position?) + (λ (blame) (let ([this->d-id (gensym '->d-tail-key)]) (λ (val) (check-procedure val @@ -864,7 +863,7 @@ v4 todo: (length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length (->d-mandatory-keywords ->d-stct) (->d-optional-keywords ->d-stct) - src-info pos-blame orig-str) + blame) (let ([kwd-proc (λ (kwd-args kwd-arg-vals . raw-orig-args) (let* ([orig-args (if (->d-mtd? ->d-stct) @@ -889,7 +888,7 @@ v4 todo: [(or (null? building-kwd-args) (null? all-kwds)) '()] [else (if (eq? (car all-kwds) (car building-kwd-args)) - (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) neg-blame pos-blame src-info orig-str (not positive-position?)) + (cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame)) (loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals))) (loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))])) @@ -906,17 +905,17 @@ v4 todo: (cond [(null? args) (if (->d-rest-ctc ->d-stct) - (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str (not positive-position?)) + (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame)) '())] [(null? non-kwd-ctcs) (if (->d-rest-ctc ->d-stct) - (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args neg-blame pos-blame src-info orig-str (not positive-position?)) + (invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame)) ;; ran out of arguments, but don't have a rest parameter. ;; procedure-reduce-arity (or whatever the new thing is ;; going to be called) should ensure this doesn't happen. (error 'shouldnt\ happen))] - [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) neg-blame pos-blame src-info orig-str (not positive-position?)) + [else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame)) (loop (cdr args) (cdr non-kwd-ctcs)))])))))] [rng (let ([rng (->d-range ->d-stct)]) @@ -929,12 +928,10 @@ v4 todo: [rng-underscore? (box? (->d-range ->d-stct))]) (when (->d-pre-cond ->d-stct) (unless (apply (->d-pre-cond ->d-stct) dep-pre-args) - (raise-contract-error val - src-info - neg-blame - orig-str - "#:pre-cond violation~a" - (build-values-string ", argument" dep-pre-args)))) + (raise-blame-error blame + val + "#:pre-cond violation~a" + (build-values-string ", argument" dep-pre-args)))) (call-with-immediate-continuation-mark ->d-tail-key (λ (first-mark) @@ -956,25 +953,21 @@ v4 todo: (->d-keywords ->d-stct) kwd-args kwd-arg-vals)]) (when (->d-post-cond ->d-stct) (unless (apply (->d-post-cond ->d-stct) dep-post-args) - (raise-contract-error val - src-info - pos-blame - orig-str - "#:post-cond violation~a~a" - (build-values-string ", argument" dep-pre-args) - (build-values-string (if (null? dep-pre-args) - ", result" - "\n result") - orig-results)))) + (raise-blame-error blame + val + "#:post-cond violation~a~a" + (build-values-string ", argument" dep-pre-args) + (build-values-string (if (null? dep-pre-args) + ", result" + "\n result") + orig-results)))) (unless (= range-count (length orig-results)) - (raise-contract-error val - src-info - pos-blame - orig-str - "expected ~a results, got ~a" - range-count - (length orig-results))) + (raise-blame-error blame + val + "expected ~a results, got ~a" + range-count + (length orig-results))) (apply values (let loop ([results orig-results] @@ -985,7 +978,8 @@ v4 todo: (cons (invoke-dep-ctc (car result-contracts) (if rng-underscore? #f dep-post-args) - (car results) pos-blame neg-blame src-info orig-str positive-position?) + (car results) + blame) (loop (cdr results) (cdr result-contracts)))]))))))] [else (thunk)])))))]) @@ -1014,11 +1008,11 @@ v4 todo: (loop (cdr lst)))])))])) ;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst -(define (invoke-dep-ctc dep-ctc dep-args val pos-blame neg-blame src-info orig-str positive-position?) +(define (invoke-dep-ctc dep-ctc dep-args val blame) (let ([ctc (coerce-contract '->d (if dep-args (apply dep-ctc dep-args) dep-ctc))]) - ((((proj-get ctc) ctc) pos-blame neg-blame src-info orig-str positive-position?) val))) + (((contract-projection ctc) blame) val))) ;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any) (define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args) @@ -1090,58 +1084,60 @@ v4 todo: name-wrapper) ;; (-> proc proc) #:omit-define-syntaxes - - #:property proj-prop ->d-proj - #:property name-prop - (λ (ctc) - (let* ([counting-id 'x] - [ids '(x y z w)] - [next-id - (λ () - (cond - [(pair? ids) - (begin0 (car ids) - (set! ids (cdr ids)))] - [(null? ids) - (begin0 - (string->symbol (format "~a0" counting-id)) - (set! ids 1))] - [else - (begin0 - (string->symbol (format "~a~a" counting-id ids)) - (set! ids (+ ids 1)))]))]) - `(->d (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc)) - ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc)))) - (,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc)) - ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc)))) - ,@(if (->d-rest-ctc ctc) + + #:property prop:contract + (build-contract-property + #:projection ->d-proj + #:name + (λ (ctc) + (let* ([counting-id 'x] + [ids '(x y z w)] + [next-id + (λ () + (cond + [(pair? ids) + (begin0 (car ids) + (set! ids (cdr ids)))] + [(null? ids) + (begin0 + (string->symbol (format "~a0" counting-id)) + (set! ids 1))] + [else + (begin0 + (string->symbol (format "~a~a" counting-id ids)) + (set! ids (+ ids 1)))]))]) + `(->d (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc)) + ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc)))) + (,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc)) + ,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc)))) + ,@(if (->d-rest-ctc ctc) (list '#:rest (next-id) '...) '()) - ,@(if (->d-pre-cond ctc) + ,@(if (->d-pre-cond ctc) (list '#:pre-cond '...) (list)) - ,(let ([range (->d-range ctc)]) - (cond - [(not range) 'any] - [(box? range) - (let ([range (unbox range)]) - (cond + ,(let ([range (->d-range ctc)]) + (cond + [(not range) 'any] + [(box? range) + (let ([range (unbox range)]) + (cond [(and (not (null? range)) (null? (cdr range))) `[_ ...]] [else `(values ,@(map (λ (x) `(_ ...)) range))]))] - [(and (not (null? range)) - (null? (cdr range))) - `[,(next-id) ...]] - [else - `(values ,@(map (λ (x) `(,(next-id) ...)) range))])) - ,@(if (->d-post-cond ctc) + [(and (not (null? range)) + (null? (cdr range))) + `[,(next-id) ...]] + [else + `(values ,@(map (λ (x) `(,(next-id) ...)) range))])) + ,@(if (->d-post-cond ctc) (list '#:post-cond '...) (list))))) - - #:property first-order-prop (λ (ctc) (λ (x) #f)) - #:property stronger-prop (λ (this that) (eq? this that))) + + #:first-order (λ (ctc) (λ (x) #f)) + #:stronger (λ (this that) (eq? this that)))) ; @@ -1249,60 +1245,59 @@ v4 todo: ;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?)) -- generates a wrapper from projections (define-struct case-> (dom-ctcs rst-ctcs rng-ctcs specs wrapper) #:omit-define-syntaxes - #:property proj-prop - (λ (ctc) - (let* ([to-proj (λ (c) ((proj-get c) c))] - [dom-ctcs (map to-proj (get-case->-dom-ctcs ctc))] - [rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)]) - (and rngs (map to-proj (get-case->-rng-ctcs ctc))))] - [rst-ctcs (case->-rst-ctcs ctc)] - [specs (case->-specs ctc)]) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([projs (append (map (λ (f) (f neg-blame pos-blame src-info orig-str (not positive-position?))) dom-ctcs) - (map (λ (f) (f pos-blame neg-blame src-info orig-str positive-position?)) rng-ctcs))] - [chk - (λ (val mtd?) - (cond - [(null? specs) - (unless (procedure? val) - (raise-contract-error val - src-info - pos-blame - orig-str - "expected a procedure"))] - [else - (for-each - (λ (dom-length has-rest?) - (if has-rest? - (check-procedure/more val mtd? dom-length '() '() src-info pos-blame orig-str) - (check-procedure val mtd? dom-length 0 '() '() src-info pos-blame orig-str))) - specs rst-ctcs)]))]) - (apply (case->-wrapper ctc) - chk - projs))))) - #:property name-prop - (λ (ctc) (apply - build-compound-type-name - 'case-> - (map (λ (dom rst range) - (apply - build-compound-type-name - '-> - (append dom - (if rst - (list '#:rest rst) - '()) - (list - (cond - [(not range) 'any] - [(and (pair? range) (null? (cdr range))) - (car range)] - [else (apply build-compound-type-name 'values range)]))))) - (case->-dom-ctcs ctc) - (case->-rst-ctcs ctc) - (case->-rng-ctcs ctc)))) - #:property first-order-prop (λ (ctc) (λ (val) #f)) - #:property stronger-prop (λ (this that) #f)) + #:property prop:contract + (build-contract-property + #:projection + (λ (ctc) + (let* ([dom-ctcs (map contract-projection (get-case->-dom-ctcs ctc))] + [rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)]) + (and rngs (map contract-projection (get-case->-rng-ctcs ctc))))] + [rst-ctcs (case->-rst-ctcs ctc)] + [specs (case->-specs ctc)]) + (λ (blame) + (let ([projs (append (map (λ (f) (f (blame-swap blame))) dom-ctcs) + (map (λ (f) (f blame)) rng-ctcs))] + [chk + (λ (val mtd?) + (cond + [(null? specs) + (unless (procedure? val) + (raise-blame-error blame val "expected a procedure"))] + [else + (for-each + (λ (dom-length has-rest?) + (if has-rest? + (check-procedure/more val mtd? dom-length '() '() blame) + (check-procedure val mtd? dom-length 0 '() '() blame))) + specs rst-ctcs)]))]) + (apply (case->-wrapper ctc) + chk + projs))))) + #:name + (λ (ctc) + (apply + build-compound-type-name + 'case-> + (map (λ (dom rst range) + (apply + build-compound-type-name + '-> + (append dom + (if rst + (list '#:rest rst) + '()) + (list + (cond + [(not range) 'any] + [(and (pair? range) (null? (cdr range))) + (car range)] + [else (apply build-compound-type-name 'values range)]))))) + (case->-dom-ctcs ctc) + (case->-rst-ctcs ctc) + (case->-rng-ctcs ctc)))) + + #:first-order (λ (ctc) (λ (val) #f)) + #:stronger (λ (this that) #f))) (define (build-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper) (make-case-> (map (λ (l) (map (λ (x) (coerce-contract 'case-> x)) l)) dom-ctcs) @@ -1459,15 +1454,13 @@ v4 todo: (let-values ([(mandatory optional) (procedure-keywords f)]) (null? mandatory))) -(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str) +(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame) (unless (and (procedure? val) (procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals) (keywords-match mandatory-kwds optional-keywords val)) - (raise-contract-error - val - src-info + (raise-blame-error blame - orig-str + val "expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e" (if mtd? "method" "procedure") (if (zero? dom-length) "no" dom-length) @@ -1522,15 +1515,13 @@ v4 todo: ", and " (format-keywords-error 'optional optional-keywords))])) -(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds src-info blame orig-str) +(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame) (unless (and (procedure? val) (procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length)) (keywords-match mandatory-kwds optional-kwds val)) - (raise-contract-error - val - src-info + (raise-blame-error blame - orig-str + val "expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e" (if mtd? "method" "procedure") (cond From 18e33c2ce1ae9f704184c00396153eada6954725 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 05:18:13 +0000 Subject: [PATCH 06/78] Exported source->name function. svn: r17689 --- collects/scheme/contract/private/helpers.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/contract/private/helpers.ss b/collects/scheme/contract/private/helpers.ss index cfd0e3363b..e666344253 100644 --- a/collects/scheme/contract/private/helpers.ss +++ b/collects/scheme/contract/private/helpers.ss @@ -1,6 +1,6 @@ #lang scheme/base -(provide unpack-blame build-src-loc-string +(provide unpack-blame build-src-loc-string source->name mangle-id mangle-id-for-maker build-struct-names lookup-struct-info From 42b3b8820b44e10f59286dd093638d5265bd9af1 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 05:18:37 +0000 Subject: [PATCH 07/78] Added simplification of collects paths to blame error printing. svn: r17690 --- collects/scheme/contract/private/blame.ss | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index 9896bfaa3e..5a54fae44f 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -1,6 +1,6 @@ #lang scheme/base -(require unstable/srcloc scheme/pretty) +(require unstable/srcloc scheme/pretty "helpers.ss") (provide blame? make-blame @@ -44,7 +44,12 @@ b))) (define (default-blame-format b x custom-message) - (let* ([source-message (source-location->prefix (blame-source b))] + (let* ([source-message + (let* ([loc (blame-source b)]) + (source-location->prefix + (struct-copy + srcloc loc + [source (source->name (srcloc-source loc))])))] [guilty-message (show (blame-guilty b))] [contract-message (show (blame-contract b))] [value-message (if (blame-value b) From ee944b575adc29809fae40803ecf8c7abee342d5 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 05:18:49 +0000 Subject: [PATCH 08/78] Ported base.ss to new properties. svn: r17691 --- collects/scheme/contract/private/base.ss | 98 +++++++++++++++--------- 1 file changed, 61 insertions(+), 37 deletions(-) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index 18316dce23..7ad1766804 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -9,60 +9,84 @@ improve method arity mismatch contract violation error messages? -(provide (rename-out [-contract contract]) +(provide contract recursive-contract current-contract-region) (require (for-syntax scheme/base) scheme/stxparam + unstable/srcloc "guts.ss" "helpers.ss") (define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference))) -(define-syntax (-contract stx) +(define-syntax (contract stx) (syntax-case stx () + [(_ a-contract to-check pos-blame-e neg-blame-e srcloc-e name-e) + (syntax/loc stx + (let* ([c a-contract] + [v to-check] + [b (make-blame srcloc-e + name-e + (contract-name c) + (unpack-blame pos-blame-e) + (unpack-blame neg-blame-e) + #f)]) + (((contract-projection c) b) v)))] [(_ a-contract to-check pos-blame-e neg-blame-e) - (let ([s (syntax/loc stx here)]) - (quasisyntax/loc stx - (contract/proc a-contract to-check pos-blame-e neg-blame-e - (list (make-srcloc (quote-syntax #,s) - #,(syntax-line s) - #,(syntax-column s) - #,(syntax-position s) - #,(syntax-span s)) - #f))))] + (quasisyntax/loc stx + (contract a-contract + to-check + pos-blame-e + neg-blame-e + (build-source-location (quote-syntax #,stx)) + '#f))] [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) (syntax/loc stx - (begin - (contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e)))])) + (let* ([info src-info-e]) + (contract a-contract-e + to-check + pos-blame-e + neg-blame-e + (unpack-source info) + (unpack-name info))))])) -(define (contract/proc a-contract-raw name pos-blame neg-blame src-info) - (let ([a-contract (coerce-contract 'contract a-contract-raw)]) +(define (unpack-source info) + (cond + [(syntax? info) (build-source-location info)] + [(list? info) + (let ([loc (list-ref info 0)]) + (struct-copy + srcloc loc + [source + (resolved-module-path-name + (module-path-index-resolve + (syntax-source-module + (srcloc-source loc))))]))] + [else + (error 'contract + "expected a syntax object or list of two elements, got: ~e" + info)])) - (unless (or (and (list? src-info) - (= 2 (length src-info)) - (srcloc? (list-ref src-info 0)) - (or (string? (list-ref src-info 1)) - (not (list-ref src-info 1)))) - (syntax? src-info)) - (error 'contract "expected syntax or a list of two elements (srcloc and string or #f) as last argument, given: ~e, other args ~e ~e ~e ~e" - src-info - (unpack-blame neg-blame) - (unpack-blame pos-blame) - a-contract-raw - name)) - (((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract) #t) - name))) +(define (unpack-name info) + (cond + [(syntax? info) (and (identifier? info) (syntax-e info))] + [(list? info) (list-ref info 1)] + [else + (error 'contract + "expected a syntax object or list of two elements, got: ~e" + info)])) (define-syntax (recursive-contract stx) (syntax-case stx () [(_ arg) - (syntax (make-proj-contract - '(recursive-contract arg) - (λ (pos-blame neg-blame src str positive-position?) - (let ([ctc (coerce-contract 'recursive-contract arg)]) - (let ([proc (contract-proc ctc)]) - (λ (val) - ((proc pos-blame neg-blame src str positive-position?) val))))) - #f))])) + (syntax + (simple-contract + #:name '(recursive-contract arg) + #:projection + (λ (blame) + (let ([ctc (coerce-contract 'recursive-contract arg)]) + (let ([f (contract-projection ctc)]) + (λ (val) + ((f blame) val)))))))])) From 41565a3869fb5e35673f65ff20d65f67786d8054 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 05:24:00 +0000 Subject: [PATCH 09/78] Ported exists.ss to new properties. svn: r17692 --- collects/scheme/contract/exists.ss | 25 ++++++++++++------------- 1 file changed, 12 insertions(+), 13 deletions(-) diff --git a/collects/scheme/contract/exists.ss b/collects/scheme/contract/exists.ss index 5d35957e22..6529b89ed0 100644 --- a/collects/scheme/contract/exists.ss +++ b/collects/scheme/contract/exists.ss @@ -9,25 +9,24 @@ (let ([in (∃/c-in ctc)] [out (∃/c-out ctc)] [pred? (∃/c-pred? ctc)]) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (if positive-position? - in + (λ (blame) + (if (blame-swapped? blame) (λ (val) (if (pred? val) (out val) - (raise-contract-error val src-info pos-blame orig-str - "non-polymorphic value: ~e" - val))))))) + (raise-blame-error blame + val + "non-polymorphic value: ~e" + val))) + in)))) (define-struct ∃/c (in out pred? name) #:omit-define-syntaxes - #:property proj-prop ∃-proj - #:property name-prop (λ (ctc) (∃/c-name ctc)) - #:property first-order-prop - (λ (ctc) (λ (x) #t)) ;; ??? - - #:property stronger-prop - (λ (this that) #f)) + #:property prop:contract + (build-contract-property + #:name (λ (ctc) (∃/c-name ctc)) + #:first-order (λ (ctc) (λ (x) #t)) ;; ??? + #:projection ∃-proj)) (define-struct ∃ ()) From 2ed1f852aa5347696f5fe96d5d1b2c8592510f0f Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 05:44:54 +0000 Subject: [PATCH 10/78] Ported misc.ss to new properties. svn: r17693 --- collects/scheme/contract/private/misc.ss | 633 +++++++++++------------ 1 file changed, 307 insertions(+), 326 deletions(-) diff --git a/collects/scheme/contract/private/misc.ss b/collects/scheme/contract/private/misc.ss index 4023886f88..000fcb9174 100644 --- a/collects/scheme/contract/private/misc.ss +++ b/collects/scheme/contract/private/misc.ss @@ -126,51 +126,53 @@ (define-struct or/c (pred flat-ctcs ho-ctc) #:omit-define-syntaxes - #:property proj-prop - (λ (ctc) - (let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))] - [pred (or/c-pred ctc)]) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str positive-position?)]) - (λ (val) - (cond - [(pred val) val] - [else - (partial-contract val)])))))) - - #:property name-prop - (λ (ctc) - (apply build-compound-type-name - 'or/c - (or/c-ho-ctc ctc) - (or/c-flat-ctcs ctc))) - - #:property first-order-prop - (λ (ctc) - (let ([pred (or/c-pred ctc)] - [ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]) - (λ (x) - (or (ho x) - (pred x))))) - - #:property stronger-prop - (λ (this that) - (and (or/c? that) - (contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that)) - (let ([this-ctcs (or/c-flat-ctcs this)] - [that-ctcs (or/c-flat-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs)))))) + #:property prop:contract + (build-contract-property + #:projection + (λ (ctc) + (let ([c-proc (contract-projection (or/c-ho-ctc ctc))] + [pred (or/c-pred ctc)]) + (λ (blame) + (let ([partial-contract (c-proc blame)]) + (λ (val) + (cond + [(pred val) val] + [else + (partial-contract val)])))))) + + #:name + (λ (ctc) + (apply build-compound-type-name + 'or/c + (or/c-ho-ctc ctc) + (or/c-flat-ctcs ctc))) + + #:first-order + (λ (ctc) + (let ([pred (or/c-pred ctc)] + [ho (contract-first-order (or/c-ho-ctc ctc))]) + (λ (x) + (or (ho x) + (pred x))))) + + #:stronger + (λ (this that) + (and (or/c? that) + (contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that)) + (let ([this-ctcs (or/c-flat-ctcs this)] + [that-ctcs (or/c-flat-ctcs that)]) + (and (= (length this-ctcs) (length that-ctcs)) + (andmap contract-stronger? + this-ctcs + that-ctcs))))))) (define (multi-or/c-proj ctc) (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)] - [c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)] - [first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)] + [c-procs (map (λ (x) (contract-projection x)) ho-contracts)] + [first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)] [predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([partial-contracts (map (λ (c-proc) (c-proc pos-blame neg-blame src-info orig-str positive-position?)) c-procs)]) + (λ (blame) + (let ([partial-contracts (map (λ (c-proc) (c-proc blame)) c-procs)]) (λ (val) (cond [(ormap (λ (pred) (pred val)) predicates) @@ -185,16 +187,16 @@ [(null? checks) (if candidate-proc (candidate-proc val) - (raise-contract-error val src-info pos-blame orig-str - "none of the branches of the or/c matched, given ~e" - val))] + (raise-blame-error blame val + "none of the branches of the or/c matched, given ~e" + val))] [((car checks) val) (if candidate-proc - (raise-contract-error val src-info pos-blame orig-str - "two of the clauses in the or/c might both match: ~s and ~s, given ~e" - (contract-name candidate-contract) - (contract-name (car contracts)) - val) + (raise-blame-error blame val + "two of the clauses in the or/c might both match: ~s and ~s, given ~e" + (contract-name candidate-contract) + (contract-name (car contracts)) + val) (loop (cdr checks) (cdr procs) (cdr contracts) @@ -208,58 +210,61 @@ candidate-contract)]))])))))) (define-struct multi-or/c (flat-ctcs ho-ctcs) - #:property proj-prop multi-or/c-proj - #:property name-prop - (λ (ctc) - (apply build-compound-type-name - 'or/c - (append - (multi-or/c-flat-ctcs ctc) - (reverse (multi-or/c-ho-ctcs ctc))))) - - #:property first-order-prop - (λ (ctc) - (let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))] - [hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))]) - (λ (x) - (or (ormap (λ (f) (f x)) hos) - (ormap (λ (f) (f x)) flats))))) - - #:property stronger-prop - (λ (this that) - (and (multi-or/c? that) - (let ([this-ctcs (multi-or/c-ho-ctcs this)] - [that-ctcs (multi-or/c-ho-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs))) - (let ([this-ctcs (multi-or/c-flat-ctcs this)] - [that-ctcs (multi-or/c-flat-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs)))))) + #:property prop:contract + (build-contract-property + #:projection multi-or/c-proj + #:name + (λ (ctc) + (apply build-compound-type-name + 'or/c + (append + (multi-or/c-flat-ctcs ctc) + (reverse (multi-or/c-ho-ctcs ctc))))) + + #:first-order + (λ (ctc) + (let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))] + [hos (map (λ (x) (contract-first-order x)) (multi-or/c-ho-ctcs ctc))]) + (λ (x) + (or (ormap (λ (f) (f x)) hos) + (ormap (λ (f) (f x)) flats))))) + + #:stronger + (λ (this that) + (and (multi-or/c? that) + (let ([this-ctcs (multi-or/c-ho-ctcs this)] + [that-ctcs (multi-or/c-ho-ctcs that)]) + (and (= (length this-ctcs) (length that-ctcs)) + (andmap contract-stronger? + this-ctcs + that-ctcs))) + (let ([this-ctcs (multi-or/c-flat-ctcs this)] + [that-ctcs (multi-or/c-flat-ctcs that)]) + (and (= (length this-ctcs) (length that-ctcs)) + (andmap contract-stronger? + this-ctcs + that-ctcs))))))) (define-struct flat-or/c (pred flat-ctcs) - #:property proj-prop flat-proj - #:property name-prop - (λ (ctc) - (apply build-compound-type-name - 'or/c - (flat-or/c-flat-ctcs ctc))) - #:property stronger-prop - (λ (this that) - (and (flat-or/c? that) - (let ([this-ctcs (flat-or/c-flat-ctcs this)] - [that-ctcs (flat-or/c-flat-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs))))) + #:property prop:flat-contract + (build-flat-contract-property + #:name + (λ (ctc) + (apply build-compound-type-name + 'or/c + (flat-or/c-flat-ctcs ctc))) + #:stronger + (λ (this that) + (and (flat-or/c? that) + (let ([this-ctcs (flat-or/c-flat-ctcs this)] + [that-ctcs (flat-or/c-flat-ctcs that)]) + (and (= (length this-ctcs) (length that-ctcs)) + (andmap contract-stronger? + this-ctcs + that-ctcs))))) - #:property flat-prop - (λ (ctc) (flat-or/c-pred ctc))) + #:first-order + (λ (ctc) (flat-or/c-pred ctc)))) ;; ;; or/c opter @@ -283,12 +288,8 @@ (list (cons partial-var (with-syntax ((lift-var lift-var) - (pos (opt/info-pos opt/info)) - (neg (opt/info-neg opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) - (positive-position? (opt/info-orig-str opt/info))) - (syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str positive-position?))))) + (blame (opt/info-blame opt/info))) + (syntax ((contract-projection lift-var) blame))))) #f lift-var (list #f) @@ -351,14 +352,13 @@ (cond [(null? hos) (with-syntax ([val (opt/info-val opt/info)] - [pos (opt/info-pos opt/info)] - [src-info (opt/info-src-info opt/info)] - [orig-str (opt/info-orig-str opt/info)]) + [blame (opt/info-blame opt/info)]) (syntax (if next-ps val - (raise-contract-error val src-info pos orig-str - "none of the branches of the or/c matched"))))] + (raise-blame-error blame + val + "none of the branches of the or/c matched"))))] [(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc)) (syntax (if next-ps val ho-ctc)))] @@ -435,30 +435,31 @@ (define-struct one-of/c (elems) #:omit-define-syntaxes - #:property proj-prop flat-proj - #:property name-prop - (λ (ctc) - (let ([elems (one-of/c-elems ctc)]) - `(,(cond - [(andmap symbol? elems) - 'symbols] - [else - 'one-of/c]) - ,@(map one-of-pc elems)))) - - #:property stronger-prop - (λ (this that) - (and (one-of/c? that) - (let ([this-elems (one-of/c-elems this)] - [that-elems (one-of/c-elems that)]) - (and - (andmap (λ (this-elem) (memv this-elem that-elems)) - this-elems) - #t)))) - #:property flat-prop - (λ (ctc) - (let ([elems (one-of/c-elems ctc)]) - (λ (x) (memv x elems))))) + #:property prop:flat-contract + (build-flat-contract-property + #:name + (λ (ctc) + (let ([elems (one-of/c-elems ctc)]) + `(,(cond + [(andmap symbol? elems) + 'symbols] + [else + 'one-of/c]) + ,@(map one-of-pc elems)))) + + #:stronger + (λ (this that) + (and (one-of/c? that) + (let ([this-elems (one-of/c-elems this)] + [that-elems (one-of/c-elems that)]) + (and + (andmap (λ (this-elem) (memv this-elem that-elems)) + this-elems) + #t)))) + #:first-order + (λ (ctc) + (let ([elems (one-of/c-elems ctc)]) + (λ (x) (memv x elems)))))) (define printable/c (flat-named-contract @@ -484,30 +485,31 @@ (define-struct between/c (low high) #:omit-define-syntaxes - #:property proj-prop flat-proj - #:property name-prop - (λ (ctc) - (let ([n (between/c-low ctc)] - [m (between/c-high ctc)]) - (cond - [(= n -inf.0) `(<=/c ,m)] - [(= m +inf.0) `(>=/c ,n)] - [(= n m) `(=/c ,n)] - [else `(between/c ,n ,m)]))) + #:property prop:flat-contract + (build-flat-contract-property + #:name + (λ (ctc) + (let ([n (between/c-low ctc)] + [m (between/c-high ctc)]) + (cond + [(= n -inf.0) `(<=/c ,m)] + [(= m +inf.0) `(>=/c ,n)] + [(= n m) `(=/c ,n)] + [else `(between/c ,n ,m)]))) - #:property stronger-prop - (λ (this that) - (and (between/c? that) - (<= (between/c-low that) (between/c-low this)) - (<= (between/c-high this) (between/c-high that)))) - - #:property flat-prop - (λ (ctc) - (let ([n (between/c-low ctc)] - [m (between/c-high ctc)]) - (λ (x) - (and (real? x) - (<= n x m)))))) + #:stronger + (λ (this that) + (and (between/c? that) + (<= (between/c-low that) (between/c-low this)) + (<= (between/c-high this) (between/c-high that)))) + + #:first-order + (λ (ctc) + (let ([n (between/c-low ctc)] + [m (between/c-high ctc)]) + (λ (x) + (and (real? x) + (<= n x m))))))) (define-syntax (check-unary-between/c stx) (syntax-case stx () @@ -556,21 +558,17 @@ (let ([lifts3 (lift/effect #'(check-between/c n m) lifts2)]) (with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info)) - (pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) + (blame (opt/info-blame opt/info)) (this (opt/info-this opt/info)) (that (opt/info-that opt/info))) (values (syntax (if (and (number? val) (<= n val m)) val - (raise-contract-error + (raise-blame-error + blame val - src-info - pos - orig-str "expected <~a>, given: ~e" - ((name-get ctc) ctc) + (contract-name ctc) val))) lifts3 null @@ -597,22 +595,18 @@ (let ([lifts3 (lift/effect (check-arg #'m) lifts2)]) (with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info)) - (pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) + (blame (opt/info-blame opt/info)) (this (opt/info-this opt/info)) (that (opt/info-that opt/info))) (values (syntax (if (and (real? val) (comparison val m)) val - (raise-contract-error + (raise-blame-error + blame val - src-info - pos - orig-str "expected <~a>, given: ~e" - ((name-get ctc) ctc) + (contract-name ctc) val))) lifts3 null @@ -731,18 +725,17 @@ (build-flat-contract `(name ,(contract-name ctc)) (lambda (x) (and (predicate? x) (testmap content-pred? x))))) - (let ([proj (contract-proc ctc)]) - (make-proj-contract - (build-compound-type-name 'name ctc) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([p-app (proj pos-blame neg-blame src-info orig-str positive-position?)]) + (let ([proj (contract-projection ctc)]) + (simple-contract + #:name (build-compound-type-name 'name ctc) + #:projection + (λ (blame) + (let ([p-app (proj blame)]) (λ (val) (unless (predicate? val) - (raise-contract-error + (raise-blame-error + blame val - src-info - pos-blame - orig-str "expected <~a>, given: ~e" 'type-name val)) @@ -816,18 +809,14 @@ (values (with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info)) - (pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info))) + (blame (opt/info-blame opt/info))) (syntax (if next val - (raise-contract-error + (raise-blame-error + blame val - src-info - pos - orig-str "expected <~a>, given: ~e" - ((name-get ctc) ctc) + (contract-name ctc) val)))) (append lifts-hdp lifts-tlp @@ -894,22 +883,21 @@ (and (predicate?-name x) (p-apps (selector-names x)) ...)))) - (let ([procs (contract-proc ctc-x)] ...) - (make-proj-contract - (build-compound-type-name 'name ctc-x ...) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([p-apps (procs pos-blame neg-blame src-info orig-str positive-position?)] ...) + (let ([procs (contract-projection ctc-x)] ...) + (simple-contract + #:name (build-compound-type-name 'name ctc-x ...) + #:projection + (λ (blame) + (let ([p-apps (procs blame)] ...) (λ (v) (if #,(if test-immutable? #'(and (predicate?-name v) (immutable? v)) #'(predicate?-name v)) (constructor-name (p-apps (selector-names v)) ...) - (raise-contract-error + (raise-blame-error + blame v - src-info - pos-blame - orig-str #,(if test-immutable? "expected immutable <~a>, given: ~e" "expected <~a>, given: ~e") @@ -924,11 +912,12 @@ [selector-name selector]) (λ params (let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)]) - (let ([procs (map contract-proc ctcs)]) - (make-proj-contract - (apply build-compound-type-name 'name ctcs) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str positive-position?)) procs)] + (let ([procs (map contract-projection ctcs)]) + (simple-contract + #:name (apply build-compound-type-name 'name ctcs) + #:projection + (λ (blame) + (let ([p-apps (map (λ (proc) (proc blame)) procs)] [count (length params)]) (λ (v) (if (and (immutable? v) @@ -942,11 +931,9 @@ [else (let ([p-app (car p-apps)]) (cons (p-app (selector-name v i)) (loop (cdr p-apps) (+ i 1))))]))) - (raise-contract-error + (raise-blame-error + blame v - src-info - pos-blame - orig-str "expected <~a>, given: ~e" 'type-name v))))) @@ -975,21 +962,17 @@ (values (with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info)) - (pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) + (blame (opt/info-blame opt/info)) (next-hdp next-hdp) (next-tlp next-tlp)) (syntax (if check (cons (let ((val (car val))) next-hdp) (let ((val (cdr val))) next-tlp)) - (raise-contract-error + (raise-blame-error + blame val - src-info - pos - orig-str "expected <~a>, given: ~e" - ((name-get ctc) ctc) + (contract-name ctc) val)))) (append lifts-hdp lifts-tlp) (append superlifts-hdp superlifts-tlp) @@ -1026,19 +1009,16 @@ (define promise/c (λ (ctc-in) (let* ([ctc (coerce-contract 'promise/c ctc-in)] - [ctc-proc (contract-proc ctc)]) - (make-proj-contract - (build-compound-type-name 'promise/c ctc) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([p-app (ctc-proc pos-blame neg-blame src-info orig-str positive-position?)]) + [ctc-proc (contract-projection ctc)]) + (simple-contract + #:name (build-compound-type-name 'promise/c ctc) + (λ (blame) + (let ([p-app (ctc-proc blame)]) (λ (val) (unless (promise? val) - (raise-contract-error + (raise-blame-error + blame val - src-info - pos-blame - 'ignored - orig-str "expected , given: ~e" val)) (delay (p-app (force val)))))) @@ -1117,40 +1097,42 @@ (define-struct parameter/c (ctc) #:omit-define-syntaxes - #:property proj-prop - (λ (ctc) - (let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))]) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str (not positive-position?))] - [partial-pos-contract (c-proc pos-blame neg-blame src-info orig-str positive-position?)]) - (λ (val) - (cond - [(parameter? val) - (make-derived-parameter - val - partial-neg-contract - partial-pos-contract)] - [else - (raise-contract-error val src-info pos-blame orig-str - "expected a parameter")])))))) - - #:property name-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc))) - #:property first-order-prop - (λ (ctc) - (let ([tst ((first-order-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))]) - (λ (x) - (and (parameter? x) - (tst (x)))))) - - #:property stronger-prop - (λ (this that) - ;; must be invariant (because the library doesn't currently split out pos/neg contracts - ;; which could be tested individually ....) - (and (parameter/c? that) - (contract-stronger? (parameter/c-ctc this) - (parameter/c-ctc that)) - (contract-stronger? (parameter/c-ctc that) - (parameter/c-ctc this))))) + #:property prop:contract + (build-contract-property + #:projection + (λ (ctc) + (let ([c-proc (contract-projection (parameter/c-ctc ctc))]) + (λ (blame) + (let ([partial-neg-contract (c-proc (blame-swap blame))] + [partial-pos-contract (c-proc blame)]) + (λ (val) + (cond + [(parameter? val) + (make-derived-parameter + val + partial-neg-contract + partial-pos-contract)] + [else + (raise-blame-error blame val "expected a parameter")])))))) + + #:name + (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc))) + #:first-order + (λ (ctc) + (let ([tst (contract-first-order (parameter/c-ctc ctc))]) + (λ (x) + (and (parameter? x) + (tst (x)))))) + + #:stronger + (λ (this that) + ;; must be invariant (because the library doesn't currently split out pos/neg contracts + ;; which could be tested individually ....) + (and (parameter/c? that) + (contract-stronger? (parameter/c-ctc this) + (parameter/c-ctc that)) + (contract-stronger? (parameter/c-ctc that) + (parameter/c-ctc this)))))) (define (hash/c dom rng #:immutable [immutable 'dont-care]) (unless (memq immutable '(#t #f dont-care)) @@ -1166,8 +1148,8 @@ ;; hash-test : hash/c -> any -> bool (define (hash-test ctc) - (let ([dom-proc ((flat-get (hash/c-dom ctc)) (hash/c-dom ctc))] - [rng-proc ((flat-get (hash/c-rng ctc)) (hash/c-rng ctc))] + (let ([dom-proc (flat-contract-predicate (hash/c-dom ctc))] + [rng-proc (flat-contract-predicate (hash/c-rng ctc))] [immutable (hash/c-immutable ctc)]) (λ (val) (and (hash? val) @@ -1186,72 +1168,71 @@ (define-struct hash/c (dom rng immutable) #:omit-define-syntaxes - #:property flat-prop hash-test - #:property proj-prop - (λ (ctc) - (let ([dom-proc ((proj-get (hash/c-dom ctc)) (hash/c-dom ctc))] - [rng-proc ((proj-get (hash/c-rng ctc)) (hash/c-rng ctc))] - [immutable (hash/c-immutable ctc)]) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str positive-position?)] - [partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str positive-position?)]) - (λ (val) - (unless (hash? val) - (raise-contract-error val src-info pos-blame orig-str - "expected a hash, got ~a" val)) - (case immutable - [(#t) (unless (immutable? val) - (raise-contract-error val src-info pos-blame orig-str - "expected an immutable hash, got ~a" val))] - [(#f) (when (immutable? val) - (raise-contract-error val src-info pos-blame orig-str - "expected a mutable hash, got ~a" val))] - [(dont-care) (void)]) - - (hash-for-each - val - (λ (key val) - (partial-dom-contract key) - (partial-rng-contract val))) - - val))))) - - #:property name-prop (λ (ctc) (apply - build-compound-type-name - 'hash/c (hash/c-dom ctc) (hash/c-rng ctc) - (if (eq? 'dont-care (hash/c-immutable ctc)) - '() - (list '#:immutable (hash/c-immutable ctc))))) - #:property stronger-prop - (λ (this that) - #f)) + #:property prop:flat-contract + (build-flat-contract-property + #:first-order hash-test + #:projection + (λ (ctc) + (let ([dom-proc (contract-projection (hash/c-dom ctc))] + [rng-proc (contract-projection (hash/c-rng ctc))] + [immutable (hash/c-immutable ctc)]) + (λ (blame) + (let ([partial-dom-contract (dom-proc blame)] + [partial-rng-contract (rng-proc blame)]) + (λ (val) + (unless (hash? val) + (raise-blame-error blame val "expected a hash, got ~a" val)) + (case immutable + [(#t) (unless (immutable? val) + (raise-blame-error blame val + "expected an immutable hash, got ~a" val))] + [(#f) (when (immutable? val) + (raise-blame-error blame val + "expected a mutable hash, got ~a" val))] + [(dont-care) (void)]) + + (hash-for-each + val + (λ (key val) + (partial-dom-contract key) + (partial-rng-contract val))) + + val))))) + + #:name + (λ (ctc) (apply + build-compound-type-name + 'hash/c (hash/c-dom ctc) (hash/c-rng ctc) + (if (eq? 'dont-care (hash/c-immutable ctc)) + '() + (list '#:immutable (hash/c-immutable ctc))))))) (define-struct immutable-hash/c (dom rng) #:omit-define-syntaxes - #:property first-order-prop (λ (ctc) (λ (val) (and (hash? val) (immutable? val)))) - #:property proj-prop - (λ (ctc) - (let ([dom-proc ((proj-get (immutable-hash/c-dom ctc)) (immutable-hash/c-dom ctc))] - [rng-proc ((proj-get (immutable-hash/c-rng ctc)) (immutable-hash/c-rng ctc))]) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str positive-position?)] - [partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str positive-position?)]) - (λ (val) - (unless (and (hash? val) - (immutable? val)) - (raise-contract-error val src-info pos-blame orig-str - "expected an immutable hash")) - (make-immutable-hash - (hash-map - val - (λ (k v) - (cons (partial-dom-contract k) - (partial-rng-contract v)))))))))) - - #:property name-prop (λ (ctc) (build-compound-type-name - 'hash/c (immutable-hash/c-dom ctc) (immutable-hash/c-rng ctc) - '#:immutable #t)) - #:property stronger-prop - (λ (this that) - #f)) + #:property prop:contract + (build-contract-property + #:first-order (λ (ctc) (λ (val) (and (hash? val) (immutable? val)))) + #:projection + (λ (ctc) + (let ([dom-proc (contract-projection (immutable-hash/c-dom ctc))] + [rng-proc (contract-projection (immutable-hash/c-rng ctc))]) + (λ (blame) + (let ([partial-dom-contract (dom-proc blame)] + [partial-rng-contract (rng-proc blame)]) + (λ (val) + (unless (and (hash? val) + (immutable? val)) + (raise-blame-error blame val + "expected an immutable hash")) + (make-immutable-hash + (hash-map + val + (λ (k v) + (cons (partial-dom-contract k) + (partial-rng-contract v)))))))))) + + #:name + (λ (ctc) (build-compound-type-name + 'hash/c (immutable-hash/c-dom ctc) (immutable-hash/c-rng ctc) + '#:immutable #t)))) From da89b2146f0ad7038d91eafb533d95380dfe0082 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 05:58:43 +0000 Subject: [PATCH 11/78] Reindented. svn: r17694 --- collects/scheme/contract/private/ds.ss | 359 +++++++++++++------------ 1 file changed, 180 insertions(+), 179 deletions(-) diff --git a/collects/scheme/contract/private/ds.ss b/collects/scheme/contract/private/ds.ss index 6568e52499..9c110bf096 100644 --- a/collects/scheme/contract/private/ds.ss +++ b/collects/scheme/contract/private/ds.ss @@ -286,185 +286,186 @@ it around flattened out. (contract-maker ctc-x ... #f))) (define (selectors x) - (burrow-in x 'selectors selector-indicies)) ... - - (define (burrow-in struct selector-name i) - (cond - [(raw-predicate struct) - (get struct i)] - [(opt-wrap-predicate struct) - (if (opt-wrap-get struct 0) - (do-selection struct (+ i 1)) - (opt-wrap-get struct (+ i 1)))] - [(wrap-predicate struct) - (if (wrap-get struct 0) - (do-selection struct (+ i 1)) - (wrap-get struct (+ i 1)))] - [else - (error selector-name "expected <~a>, got ~e" 'name struct)])) - - (define (lazy-contract-name ctc) - (do-contract-name 'struct/c - 'struct/dc - (list (contract-get ctc selector-indicies) ...) - '(fields ...) - (contract-get ctc field-count))) - - (define-values (contract-type contract-maker contract-predicate contract-get contract-set) - (make-struct-type 'contract-name - #f - (+ field-count 1) ;; extra field is for synthesized attribute ctcs - ;; it is a list whose first element is - ;; a procedure (called once teh attrs are known) that - ;; indicates if the test passes. the rest of the elements are - ;; procedures that build the attrs - ;; this field is #f when there is no synthesized attrs - 0 ;; auto-field-k - '() ;; auto-field-v - (list (cons proj-prop lazy-contract-proj) - (cons name-prop lazy-contract-name) - (cons first-order-prop (λ (ctc) predicate)) - (cons stronger-prop stronger-lazy-contract?)))) - - (define-for-syntax (build-enforcer opt/i opt/info name stx clauses - helper-id-var helper-info helper-freev - enforcer-id-var) - (define (make-free-vars free-vars freev) - (let loop ([i 0] - [stx null] - [free-vars free-vars]) - (cond - [(null? free-vars) (reverse stx)] - [else (loop (+ i 1) - (cons (with-syntax ((var (car free-vars)) - (freev freev) - (j (+ i 2))) - (syntax (var (opt-wrap-get stct j)))) stx) - (cdr free-vars))]))) - - (let*-values ([(inner-val) #'val] - [(clauses lifts superlifts stronger-ribs) - (build-enforcer-clauses opt/i - (opt/info-change-val inner-val opt/info) - name - stx - clauses - (list (syntax f-x) ...) - (list (list (syntax f-xs) ...) ...) - helper-id-var - helper-info - helper-freev)]) - (with-syntax ([(clause (... ...)) clauses] - [enforcer-id enforcer-id-var] - [helper-id helper-id-var] - [((free-var free-var-val) (... ...)) - (make-free-vars (append (opt/info-free-vars opt/info)) #'freev)] - [(saved-lifts (... ...)) (lifts-to-save lifts)]) - (values - #`(λ (stct f-x ...) - (let ((free-var free-var-val) (... ...)) - #,(bind-lifts - lifts - #'(let* (clause (... ...)) - (values f-x ...))))) - lifts - superlifts - stronger-ribs)))) - - ;; - ;; struct/dc opter - ;; - (define/opter (struct/dc opt/i opt/info stx) - (syntax-case stx () - [(_ clause (... ...)) - (let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer))))) - (helper-id-var (car (generate-temporaries (syntax (helper))))) - (contract/info-var (car (generate-temporaries (syntax (contract/info))))) - (id-var (car (generate-temporaries (syntax (id)))))) - (let-values ([(enforcer lifts superlifts stronger-ribs) - (build-enforcer opt/i - opt/info - 'struct/dc - stx - (syntax (clause (... ...))) - helper-id-var - #'info - #'freev - enforcer-id-var)]) - (let ([to-save (append (opt/info-free-vars opt/info) - (lifts-to-save lifts))]) - (with-syntax ((val (opt/info-val opt/info)) - (pos (opt/info-pos opt/info)) - (neg (opt/info-neg opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) - (ctc (opt/info-contract opt/info)) - (enforcer-id enforcer-id-var) - (helper-id helper-id-var) - (contract/info contract/info-var) - (id id-var) - ((j (... ...)) (let loop ([i 2] - [lst to-save]) - (cond - [(null? lst) null] - [else (cons i (loop (+ i 1) (cdr lst)))]))) - ((free-var (... ...)) to-save)) - (with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)] - [(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)] - [(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)] - [(stronger-indexes (... ...)) (build-list (length stronger-ribs) - (λ (x) (+ x 2)))] - [(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)]) - - (let ([partials - (list (cons id-var #'(begin-lifted (box 'identity))) - (cons enforcer-id-var enforcer) - (cons contract/info-var - (syntax - (make-opt-contract/info ctc enforcer-id id))))]) - (values - (syntax - (cond - [(opt-wrap-predicate val) - (if (and (opt-wrap-get val 0) - (let ([stronger-this-var stronger-var] - (... ...) - - ;; this computation is bogus - ;; it only works if the stronger vars and the things - ;; saved in the wrapper are the same - [stronger-that-var (opt-wrap-get val stronger-indexes)] - (... ...)) - (and - ;; make sure this is the same contract -- if not, - ;; the rest of this test is bogus and may fail at runtime - (eq? id (opt-contract/info-id (opt-wrap-get val 1))) - stronger-exps (... ...)))) - val - (let ([w (opt-wrap-maker val contract/info)]) - (opt-wrap-set w j free-var) (... ...) - w))] - [(or (raw-predicate val) - (wrap-predicate val)) - (let ([w (opt-wrap-maker val contract/info)]) - (opt-wrap-set w j free-var) (... ...) - w)] - [else - (raise-contract-error - val - src-info - pos - orig-str - "expected <~a>, got ~e" - ((name-get ctc) ctc) - val)])) - lifts - superlifts - partials - #f - #f - stronger-ribs)))))))])) - )))])) + (burrow-in x 'selectors selector-indicies)) + ... + + (define (burrow-in struct selector-name i) + (cond + [(raw-predicate struct) + (get struct i)] + [(opt-wrap-predicate struct) + (if (opt-wrap-get struct 0) + (do-selection struct (+ i 1)) + (opt-wrap-get struct (+ i 1)))] + [(wrap-predicate struct) + (if (wrap-get struct 0) + (do-selection struct (+ i 1)) + (wrap-get struct (+ i 1)))] + [else + (error selector-name "expected <~a>, got ~e" 'name struct)])) + + (define (lazy-contract-name ctc) + (do-contract-name 'struct/c + 'struct/dc + (list (contract-get ctc selector-indicies) ...) + '(fields ...) + (contract-get ctc field-count))) + + (define-values (contract-type contract-maker contract-predicate contract-get contract-set) + (make-struct-type 'contract-name + #f + (+ field-count 1) ;; extra field is for synthesized attribute ctcs + ;; it is a list whose first element is + ;; a procedure (called once teh attrs are known) that + ;; indicates if the test passes. the rest of the elements are + ;; procedures that build the attrs + ;; this field is #f when there is no synthesized attrs + 0 ;; auto-field-k + '() ;; auto-field-v + (list (cons proj-prop lazy-contract-proj) + (cons name-prop lazy-contract-name) + (cons first-order-prop (λ (ctc) predicate)) + (cons stronger-prop stronger-lazy-contract?)))) + + (define-for-syntax (build-enforcer opt/i opt/info name stx clauses + helper-id-var helper-info helper-freev + enforcer-id-var) + (define (make-free-vars free-vars freev) + (let loop ([i 0] + [stx null] + [free-vars free-vars]) + (cond + [(null? free-vars) (reverse stx)] + [else (loop (+ i 1) + (cons (with-syntax ((var (car free-vars)) + (freev freev) + (j (+ i 2))) + (syntax (var (opt-wrap-get stct j)))) stx) + (cdr free-vars))]))) + + (let*-values ([(inner-val) #'val] + [(clauses lifts superlifts stronger-ribs) + (build-enforcer-clauses opt/i + (opt/info-change-val inner-val opt/info) + name + stx + clauses + (list (syntax f-x) ...) + (list (list (syntax f-xs) ...) ...) + helper-id-var + helper-info + helper-freev)]) + (with-syntax ([(clause (... ...)) clauses] + [enforcer-id enforcer-id-var] + [helper-id helper-id-var] + [((free-var free-var-val) (... ...)) + (make-free-vars (append (opt/info-free-vars opt/info)) #'freev)] + [(saved-lifts (... ...)) (lifts-to-save lifts)]) + (values + #`(λ (stct f-x ...) + (let ((free-var free-var-val) (... ...)) + #,(bind-lifts + lifts + #'(let* (clause (... ...)) + (values f-x ...))))) + lifts + superlifts + stronger-ribs)))) + + ;; + ;; struct/dc opter + ;; + (define/opter (struct/dc opt/i opt/info stx) + (syntax-case stx () + [(_ clause (... ...)) + (let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer))))) + (helper-id-var (car (generate-temporaries (syntax (helper))))) + (contract/info-var (car (generate-temporaries (syntax (contract/info))))) + (id-var (car (generate-temporaries (syntax (id)))))) + (let-values ([(enforcer lifts superlifts stronger-ribs) + (build-enforcer opt/i + opt/info + 'struct/dc + stx + (syntax (clause (... ...))) + helper-id-var + #'info + #'freev + enforcer-id-var)]) + (let ([to-save (append (opt/info-free-vars opt/info) + (lifts-to-save lifts))]) + (with-syntax ((val (opt/info-val opt/info)) + (pos (opt/info-pos opt/info)) + (neg (opt/info-neg opt/info)) + (src-info (opt/info-src-info opt/info)) + (orig-str (opt/info-orig-str opt/info)) + (ctc (opt/info-contract opt/info)) + (enforcer-id enforcer-id-var) + (helper-id helper-id-var) + (contract/info contract/info-var) + (id id-var) + ((j (... ...)) (let loop ([i 2] + [lst to-save]) + (cond + [(null? lst) null] + [else (cons i (loop (+ i 1) (cdr lst)))]))) + ((free-var (... ...)) to-save)) + (with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)] + [(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)] + [(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)] + [(stronger-indexes (... ...)) (build-list (length stronger-ribs) + (λ (x) (+ x 2)))] + [(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)]) + + (let ([partials + (list (cons id-var #'(begin-lifted (box 'identity))) + (cons enforcer-id-var enforcer) + (cons contract/info-var + (syntax + (make-opt-contract/info ctc enforcer-id id))))]) + (values + (syntax + (cond + [(opt-wrap-predicate val) + (if (and (opt-wrap-get val 0) + (let ([stronger-this-var stronger-var] + (... ...) + + ;; this computation is bogus + ;; it only works if the stronger vars and the things + ;; saved in the wrapper are the same + [stronger-that-var (opt-wrap-get val stronger-indexes)] + (... ...)) + (and + ;; make sure this is the same contract -- if not, + ;; the rest of this test is bogus and may fail at runtime + (eq? id (opt-contract/info-id (opt-wrap-get val 1))) + stronger-exps (... ...)))) + val + (let ([w (opt-wrap-maker val contract/info)]) + (opt-wrap-set w j free-var) (... ...) + w))] + [(or (raw-predicate val) + (wrap-predicate val)) + (let ([w (opt-wrap-maker val contract/info)]) + (opt-wrap-set w j free-var) (... ...) + w)] + [else + (raise-contract-error + val + src-info + pos + orig-str + "expected <~a>, got ~e" + ((name-get ctc) ctc) + val)])) + lifts + superlifts + partials + #f + #f + stronger-ribs)))))))])) + )))])) (define (do-contract-name name/c name/dc list-of-subcontracts fields attrs) (cond From 41bd96f6aa1e5015a3cfefd4d9ffd18755368c24 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 06:10:09 +0000 Subject: [PATCH 12/78] Made blame objects transparent to allow equal? svn: r17695 --- collects/scheme/contract/private/blame.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index 5a54fae44f..a9f0899cc5 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -18,7 +18,9 @@ current-blame-format (struct-out exn:fail:contract:blame)) -(define-struct blame [source value contract positive negative swapped?]) +(define-struct blame + [source value contract positive negative swapped?] + #:transparent) (define (blame-guilty b) (if (blame-swapped? b) From 336dd1b8084736b8ddd083358d711d073f90769a Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 06:10:29 +0000 Subject: [PATCH 13/78] Ported ds.ss to new properties. svn: r17696 --- collects/scheme/contract/private/ds.ss | 70 ++++++++++---------------- 1 file changed, 26 insertions(+), 44 deletions(-) diff --git a/collects/scheme/contract/private/ds.ss b/collects/scheme/contract/private/ds.ss index 9c110bf096..e6a917a730 100644 --- a/collects/scheme/contract/private/ds.ss +++ b/collects/scheme/contract/private/ds.ss @@ -219,11 +219,8 @@ it around flattened out. ctc-field)] [ctc-field-val - ((((proj-get ctc) ctc) (contract/info-pos contract/info) - (contract/info-neg contract/info) - (contract/info-src-info contract/info) - (contract/info-orig-str contract/info) - (contract/info-positive-position? contract/info)) + (((contract-predicate ctc) + (contract/info-blame contract/info)) ctc-x)]) (update-parent-links parent ctc-field-val) ctc-field-val)] ...) @@ -231,22 +228,20 @@ it around flattened out. (define (stronger-lazy-contract? a b) (and (contract-predicate b) - (check-sub-contract? + (contract-stronger? (contract-get a selector-indicies) (contract-get b selector-indicies)) ...)) (define (lazy-contract-proj ctc) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([contract/info (make-contract/info ctc pos-blame neg-blame src-info orig-str positive-position?)]) + (λ (blame) + (let ([contract/info (make-contract/info ctc blame)]) (λ (val) (unless (or (wrap-predicate val) (opt-wrap-predicate val) (raw-predicate val)) - (raise-contract-error + (raise-blame-error + blame val - src-info - pos-blame - orig-str "expected <~a>, got ~e" 'name val)) (cond [(already-there? contract/info val lazy-depth-to-look) @@ -268,10 +263,8 @@ it around flattened out. [(wrap-predicate val) (and (wrap-get val 0) (let ([old-contract/info (wrap-get val 1)]) - (if (and (eq? (contract/info-pos new-contract/info) - (contract/info-pos old-contract/info)) - (eq? (contract/info-neg new-contract/info) - (contract/info-neg old-contract/info)) + (if (and (equal? (contract/info-blame new-contract/info) + (contract/info-blame old-contract/info)) (contract-stronger? (contract/info-contract old-contract/info) (contract/info-contract new-contract/info))) #t @@ -310,6 +303,13 @@ it around flattened out. (list (contract-get ctc selector-indicies) ...) '(fields ...) (contract-get ctc field-count))) + + (define lazy-contract-property + (build-contract-property + #:projection lazy-contract-proj + #:name lazy-contract-name + #:first-order (lambda (ctc) predicate) + #:stronger stronger-lazy-contract?)) (define-values (contract-type contract-maker contract-predicate contract-get contract-set) (make-struct-type 'contract-name @@ -322,10 +322,7 @@ it around flattened out. ;; this field is #f when there is no synthesized attrs 0 ;; auto-field-k '() ;; auto-field-v - (list (cons proj-prop lazy-contract-proj) - (cons name-prop lazy-contract-name) - (cons first-order-prop (λ (ctc) predicate)) - (cons stronger-prop stronger-lazy-contract?)))) + (list (cons prop:contract lazy-contract-property)))) (define-for-syntax (build-enforcer opt/i opt/info name stx clauses helper-id-var helper-info helper-freev @@ -395,10 +392,7 @@ it around flattened out. (let ([to-save (append (opt/info-free-vars opt/info) (lifts-to-save lifts))]) (with-syntax ((val (opt/info-val opt/info)) - (pos (opt/info-pos opt/info)) - (neg (opt/info-neg opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) + (blame (opt/info-blame opt/info)) (ctc (opt/info-contract opt/info)) (enforcer-id enforcer-id-var) (helper-id helper-id-var) @@ -451,13 +445,11 @@ it around flattened out. (opt-wrap-set w j free-var) (... ...) w)] [else - (raise-contract-error + (raise-blame-error + blame val - src-info - pos - orig-str "expected <~a>, got ~e" - ((name-get ctc) ctc) + (contract-name ctc) val)])) lifts superlifts @@ -469,12 +461,12 @@ it around flattened out. (define (do-contract-name name/c name/dc list-of-subcontracts fields attrs) (cond - [(and (andmap name-pred? list-of-subcontracts) (not attrs)) + [(and (andmap contract-struct? list-of-subcontracts) (not attrs)) (apply build-compound-type-name name/c list-of-subcontracts)] [else (let ([fields (map (λ (field ctc) - (if (name-pred? ctc) + (if (contract? ctc) (build-compound-type-name field ctc) (build-compound-type-name field '...))) fields @@ -490,7 +482,7 @@ it around flattened out. (list 'and '...)))] [else (apply build-compound-type-name name/dc fields)]))])) -(define-struct contract/info (contract pos neg src-info orig-str positive-position?)) +(define-struct contract/info (contract blame)) (define-struct opt-contract/info (contract enforcer id)) ;; parents : (listof wrap-parent) @@ -513,11 +505,9 @@ it around flattened out. (define (check-synth-info-test stct synth-info contract/info) (unless ((synth-info-test synth-info) (synth-info-vals synth-info)) - (raise-contract-error + (raise-blame-error + (contract/info-blame contract/info) stct - (contract/info-src-info contract/info) - (contract/info-pos contract/info) - (contract/info-orig-str contract/info) "failed `and' clause, got ~e" stct))) (define-values (evaluate-attr-prop evaluate-attr-prop-predicate evaluate-attr-prop-accessor) @@ -544,14 +534,6 @@ it around flattened out. (define max-cache-size 5) (define lazy-depth-to-look 5) -(define (check-sub-contract? x y) - (cond - [(and (stronger-pred? x) (stronger-pred? y)) - (contract-stronger? x y)] - [(and (procedure? x) (procedure? y)) - (procedure-closure-contents-eq? x y)] - [else #f])) - #| test case: (define-contract-struct s (a b)) From 7716e58f61ec1508b21aa3bb14c8210c5e6c1831 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 06:12:59 +0000 Subject: [PATCH 14/78] Ported basic-opters.ss to new properties. svn: r17697 --- .../scheme/contract/private/basic-opters.ss | 24 +++++++------------ 1 file changed, 8 insertions(+), 16 deletions(-) diff --git a/collects/scheme/contract/private/basic-opters.ss b/collects/scheme/contract/private/basic-opters.ss index 23a7d7e7af..97a9ef76b5 100644 --- a/collects/scheme/contract/private/basic-opters.ss +++ b/collects/scheme/contract/private/basic-opters.ss @@ -14,18 +14,14 @@ (values (with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info)) - (pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info))) + (blame (opt/info-blame opt/info))) (syntax (if (pred val) val - (raise-contract-error + (raise-blame-error + blame val - src-info - pos - orig-str "expected <~a>, given: ~e" - ((name-get ctc) ctc) + (contract-name ctc) val)))) null null @@ -96,20 +92,16 @@ (lift-pred (car lift-vars))) (with-syntax ((val (opt/info-val opt/info)) (ctc (opt/info-contract opt/info)) - (pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) + (blame (opt/info-blame opt/info)) (lift-pred lift-pred)) (values (syntax (if (lift-pred val) val - (raise-contract-error + (raise-blame-error + blame val - src-info - pos - orig-str "expected <~a>, given: ~e" - ((name-get ctc) ctc) + (contract-name ctc) val))) (interleave-lifts lift-vars From e408fd464b7ecbede80473d93faf7399630d8405 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 06:18:13 +0000 Subject: [PATCH 15/78] Propagated guts exports through scheme/contract/base and scheme/contract. svn: r17698 --- collects/scheme/contract.ss | 76 +++----------------------------- collects/scheme/contract/base.ss | 50 ++------------------- 2 files changed, 9 insertions(+), 117 deletions(-) diff --git a/collects/scheme/contract.ss b/collects/scheme/contract.ss index ff5d9d9c3c..a0ca0e5209 100644 --- a/collects/scheme/contract.ss +++ b/collects/scheme/contract.ss @@ -9,80 +9,14 @@ differences from v3: |# -(require "contract/private/arrow.ss" - "contract/private/base.ss" - scheme/contract/exists - "contract/private/misc.ss" - "contract/private/provide.ss" +(require scheme/contract/exists scheme/contract/regions - "contract/private/guts.ss" - "contract/private/ds.ss" - "contract/private/opt.ss" - "contract/private/basic-opters.ss") + "contract/private/basic-opters.ss" + "contract/base.ss") -(provide - opt/c define-opt/c ;(all-from-out "contract/private/opt.ss") - (except-out (all-from-out "contract/private/ds.ss") - lazy-depth-to-look) - - (except-out (all-from-out "contract/private/arrow.ss") - making-a-method - procedure-accepts-and-more? - check-procedure - check-procedure/more) +(provide (all-from-out "contract/base.ss") (except-out (all-from-out scheme/contract/exists) ∃?) - (except-out (all-from-out "contract/private/misc.ss") - check-between/c - check-unary-between/c) - (all-from-out scheme/contract/regions) - (all-from-out "contract/private/provide.ss") - (all-from-out "contract/private/base.ss")) - -;; from contract-guts.ss - -(provide any - and/c - any/c - none/c - make-none/c - - guilty-party - exn:fail:contract2? - exn:fail:contract2-srclocs - - contract-violation->string - - contract? - contract-name - contract-proc - - flat-contract? - flat-contract - flat-contract-predicate - flat-named-contract - - contract-first-order-passes? - - ;; below need docs - - make-proj-contract - - contract-stronger? - - coerce-contract/f - coerce-contract - coerce-contracts - coerce-flat-contract - coerce-flat-contracts - - build-compound-type-name - raise-contract-error - - proj-prop proj-pred? proj-get - name-prop name-pred? name-get - stronger-prop stronger-pred? stronger-get - flat-prop flat-pred? flat-get - first-order-prop first-order-get) + (all-from-out scheme/contract/regions)) ;; ====================================================================== ;; The alternate implementation disables contracts. Its useful mainly to diff --git a/collects/scheme/contract/base.ss b/collects/scheme/contract/base.ss index 6b927bc985..2608c0bc73 100644 --- a/collects/scheme/contract/base.ss +++ b/collects/scheme/contract/base.ss @@ -25,50 +25,8 @@ check-between/c check-unary-between/c) (all-from-out "private/provide.ss") - (all-from-out "private/base.ss")) + (all-from-out "private/base.ss") + (except-out (all-from-out "private/guts.ss") + check-flat-contract + check-flat-named-contract)) -;; from private/guts.ss - -(provide any - and/c - any/c - none/c - make-none/c - - guilty-party - exn:fail:contract2? - exn:fail:contract2-srclocs - - contract-violation->string - - contract? - contract-name - contract-proc - - flat-contract? - flat-contract - flat-contract-predicate - flat-named-contract - - contract-first-order-passes? - - ;; below need docs - - make-proj-contract - - contract-stronger? - - coerce-contract/f - coerce-contract - coerce-contracts - coerce-flat-contract - coerce-flat-contracts - - build-compound-type-name - raise-contract-error - - proj-prop proj-pred? proj-get - name-prop name-pred? name-get - stronger-prop stronger-pred? stronger-get - flat-prop flat-pred? flat-get - first-order-prop first-order-get) From 1f969b883113a646d9bbf3470df1755dfc3a708e Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 07:07:06 +0000 Subject: [PATCH 16/78] Ported a lot of mzlib contracts to new properties. svn: r17699 --- collects/mzlib/contract.ss | 47 +-- collects/mzlib/private/contract-arr-checks.ss | 82 ++--- .../mzlib/private/contract-arr-obj-helpers.ss | 291 ++++++++---------- collects/mzlib/private/contract-arrow.ss | 138 ++++----- collects/mzlib/private/contract-object.ss | 39 +-- 5 files changed, 244 insertions(+), 353 deletions(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index 64d02c4dab..3c6ef88c97 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -48,48 +48,11 @@ check-between/c string-len/c check-unary-between/c) - (rename-out [string-len/c string/len])) - -;; from contract-guts.ss - -(provide any - and/c - any/c - none/c - make-none/c - - guilty-party - contract-violation->string - - contract? - contract-name - contract-proc - - flat-contract? - flat-contract - flat-contract-predicate - flat-named-contract - - contract-first-order-passes? - - ;; below need docs - - make-proj-contract - - contract-stronger? - - coerce-contract - flat-contract/predicate? - - build-compound-type-name - raise-contract-error - - proj-prop proj-pred? proj-get - name-prop name-pred? name-get - stronger-prop stronger-pred? stronger-get - flat-prop flat-pred? flat-get - first-order-prop first-order-get - (rename-out [or/c union])) + (rename-out [or/c union]) + (rename-out [string-len/c string/len]) + (except-out (all-from-out scheme/contract/private/guts) + check-flat-contract + check-flat-named-contract)) ;; copied here because not provided by scheme/contract anymore diff --git a/collects/mzlib/private/contract-arr-checks.ss b/collects/mzlib/private/contract-arr-checks.ss index 547d814a63..5410d7401f 100644 --- a/collects/mzlib/private/contract-arr-checks.ss +++ b/collects/mzlib/private/contract-arr-checks.ss @@ -77,31 +77,21 @@ f))) -(define (check-pre-expr->pp/h val pre-expr src-info blame orig-str) +(define (check-pre-expr->pp/h val pre-expr blame) (unless pre-expr - (raise-contract-error val - src-info - blame - orig-str - "pre-condition expression failure"))) + (raise-blame-error blame val "pre-condition expression failure"))) -(define (check-post-expr->pp/h val post-expr src-info blame orig-str) +(define (check-post-expr->pp/h val post-expr blame) (unless post-expr - (raise-contract-error val - src-info - blame - orig-str - "post-condition expression failure"))) + (raise-blame-error blame val "post-condition expression failure"))) -(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str) +(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords blame) (unless (and (procedure? val) (procedure-arity-includes?/optionals val dom-length optionals) (keywords-match mandatory-kwds optional-keywords val)) - (raise-contract-error - val - src-info + (raise-blame-error blame - orig-str + val "expected a procedure that accepts ~a arguments~a, given: ~e" dom-length (keyword-error-text mandatory-kwds) @@ -140,53 +130,37 @@ (and (procedure? val) (procedure-accepts-and-more? val arity))) -(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str) +(define (check-procedure/kind val arity kind-of-thing blame) (unless (procedure? val) - (raise-contract-error val - src-info - blame - orig-str - "expected a procedure, got ~e" - val)) + (raise-blame-error blame val "expected a procedure, got ~e" val)) (unless (procedure-arity-includes? val arity) - (raise-contract-error val - src-info - blame - orig-str - "expected a ~a of arity ~a (not arity ~a), got ~e" - kind-of-thing - arity - (procedure-arity val) - val))) + (raise-blame-error blame + val + "expected a ~a of arity ~a (not arity ~a), got ~e" + kind-of-thing + arity + (procedure-arity val) + val))) -(define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str) +(define (check-procedure/more/kind val arity kind-of-thing blame) (unless (procedure? val) - (raise-contract-error val - src-info - blame - orig-str - "expected a procedure, got ~e" - val)) + (raise-blame-error blame val "expected a procedure, got ~e" val)) (unless (procedure-accepts-and-more? val arity) - (raise-contract-error val - src-info - blame - orig-str - "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e" - kind-of-thing - arity - (procedure-arity val) - val))) + (raise-blame-error blame + val + "expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e" + kind-of-thing + arity + (procedure-arity val) + val))) -(define (check-procedure/more val dom-length mandatory-kwds optional-kwds src-info blame orig-str) +(define (check-procedure/more val dom-length mandatory-kwds optional-kwds blame) (unless (and (procedure? val) (procedure-accepts-and-more? val dom-length) (keywords-match mandatory-kwds optional-kwds val)) - (raise-contract-error - val - src-info + (raise-blame-error blame - orig-str + val "expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e" dom-length (keyword-error-text mandatory-kwds) diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss index 9d4d9800e8..4dd2791f5c 100644 --- a/collects/mzlib/private/contract-arr-obj-helpers.ss +++ b/collects/mzlib/private/contract-arr-obj-helpers.ss @@ -19,9 +19,9 @@ (define (make-/proc method-proc? /h stx) (let-values ([(arguments-check build-proj check-val first-order-check wrapper) (/h method-proc? stx)]) - (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id positive-position?))]) + (let ([outer-args (syntax (val blame name-id))]) (with-syntax ([inner-check (check-val outer-args)] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(val-args body) (wrapper outer-args)]) (with-syntax ([inner-lambda (set-inferred-name-from @@ -37,11 +37,10 @@ (arguments-check outer-args (syntax/loc stx - (make-proj-contract - name-id - (lambda (pos-blame neg-blame src-info orig-str positive-position?) - proj-code) - first-order-check)))))))))) + (simple-contract + #:name name-id + #:projection (lambda (blame) proj-code) + #:first-order first-order-check)))))))))) (define (make-case->/proc method-proc? stx inferred-name-stx select/h) (syntax-case stx () @@ -55,9 +54,9 @@ [(_ cases ...) (let-values ([(arguments-check build-projs check-val first-order-check wrapper) (case->/h method-proc? stx (syntax->list (syntax (cases ...))) select/h)]) - (let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id positive-position?))]) + (let ([outer-args (syntax (val blame name-id))]) (with-syntax ([(inner-check ...) (check-val outer-args)] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(body ...) (wrapper outer-args)]) (with-syntax ([inner-lambda (set-inferred-name-from @@ -73,11 +72,10 @@ (arguments-check outer-args (syntax/loc stx - (make-proj-contract - (apply build-compound-type-name 'case-> name-id) - (lambda (pos-blame neg-blame src-info orig-str positive-position?) - proj-code) - first-order-check)))))))))])) + (simple-contract + #:name (apply build-compound-type-name 'case-> name-id) + #:projection (lambda (blame) proj-code) + #:first-order first-order-check)))))))))])) (define (make-opt->/proc method-proc? stx select/h case-arr-stx arr-stx) (syntax-case stx (any) @@ -230,7 +228,7 @@ [(null? cases) (values (lambda (outer-args body) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [body body] [(name-ids ...) (reverse name-ids)]) (syntax @@ -249,10 +247,10 @@ (/h method-proc? (car cases))]) (values (lambda (outer-args x) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [new-id new-id]) (arguments-check - (syntax (val pos-blame neg-blame src-info orig-str new-id positive-position?)) + (syntax (val blame new-id)) (arguments-checks outer-args x)))) @@ -364,7 +362,7 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + [(val blame name-id) outer-args]) (syntax (let ([dom-contract-x (coerce-contract '-> dom)] ...) (let ([dom-x (contract-proc dom-contract-x)] ...) @@ -373,19 +371,19 @@ ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...) + (let ([dom-projection-x (dom-x (blame-swap blame))] ...) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure val dom-length 0 '() '() #|keywords|# blame)))) (syntax (check-procedure? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ...) (val (dom-projection-x arg-x) ...))))))] @@ -399,14 +397,14 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + [(val blame name-id) outer-args]) (syntax (let ([dom-contract-x (coerce-contract '-> dom)] ... [rng-contract-x (coerce-contract '-> rng)] ...) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... - [rng-x (contract-proc rng-contract-x)] + [rng-x (contract-projection rng-contract-x)] ...) (let ([name-id (build-compound-type-name @@ -417,22 +415,22 @@ ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] + (let ([dom-projection-x (dom-x (blame-swap blame))] ... - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)] ...) + [rng-projection-x (rng-x blame)] ...) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure val dom-length 0 '() '() #|keywords|# blame)))) (syntax (check-procedure? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ...) (let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)]) @@ -448,34 +446,34 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + [(val blame name-id) outer-args]) (syntax (let ([dom-contract-x (coerce-contract '-> dom)] ... [rng-contract-x (coerce-contract '-> rng)]) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... - [rng-x (contract-proc rng-contract-x)]) + [rng-x (contract-projection rng-contract-x)]) (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)]) body)))))) ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] + (let ([dom-projection-x (dom-x (blame-swap blame))] ... - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)]) + [rng-projection-x (rng-x blame)]) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure val dom-length 0 '() '() #|keywords|# blame)))) (syntax (check-procedure? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ...) (let ([res-x (val (dom-projection-x arg-x) ...)]) @@ -509,7 +507,7 @@ [arity (length (syntax->list (syntax (dom ...))))]) (values (lambda (outer-args body) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [body body] [(name-dom-contract-x ...) (if method-proc? @@ -522,10 +520,10 @@ ... [dom-rest-contract-x (coerce-contract '->* rest)] [rng-contract-x (coerce-contract '->* rng)] ...) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... - [dom-rest-x (contract-proc dom-rest-contract-x)] - [rng-x (contract-proc rng-contract-x)] + [dom-rest-x (contract-projection dom-rest-contract-x)] + [rng-x (contract-projection rng-contract-x)] ...) (let ([name-id (build-compound-type-name @@ -536,22 +534,22 @@ body)))))) ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] + (let ([dom-projection-x (dom-x (blame-swap blame))] ... - [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))] - [rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)] ...) + [dom-rest-projection-x (dom-rest-x (blame-swap blame))] + [rng-projection-x (rng-x blame)] ...) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure/more val dom-length '() '() #|keywords|# blame)))) (syntax (check-procedure/more? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ... . arg-rest-x) (let-values ([(res-x ...) @@ -577,7 +575,7 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(name-dom-contract-x ...) (if method-proc? (cdr @@ -588,9 +586,9 @@ (let ([dom-contract-x (coerce-contract '->* dom)] ... [dom-rest-contract-x (coerce-contract '->* rest)]) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... - [dom-rest-x (contract-proc dom-rest-contract-x)]) + [dom-rest-x (contract-projection dom-rest-contract-x)]) (let ([name-id (build-compound-type-name '->* (build-compound-type-name name-dom-contract-x ...) @@ -599,21 +597,21 @@ body)))))) ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] + (let ([dom-projection-x (dom-x (blame-swap blame))] ... - [dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))]) + [dom-projection-rest-x (dom-rest-x (blame-swap blame))]) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure/more val dom-length '() '() #|keywords|# blame)))) (syntax (check-procedure/more? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ... . arg-rest-x) (apply @@ -636,7 +634,7 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(name-dom-contract-x ...) (if method-proc? (cdr @@ -645,7 +643,7 @@ (syntax (dom-contract-x ...)))]) (syntax (let ([dom-contract-x (coerce-contract '->d dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... [rng-x rng]) (check-rng-procedure '->d rng-x arity) @@ -654,31 +652,27 @@ ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...) + (let ([dom-projection-x (dom-x (blame-swap blame))] ...) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure val arity 0 '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure val arity 0 '() '() #|keywords|# blame)))) (syntax (check-procedure? arity)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ...) (let ([arg-x (dom-projection-x arg-x)] ...) (let ([rng-contract (rng-x arg-x ...)]) - (((contract-proc (coerce-contract '->d rng-contract)) - pos-blame - neg-blame - src-info - orig-str - positive-position?) + (((contract-projection (coerce-contract '->d rng-contract)) + blame) (val arg-x ...))))))))))])) ;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax)) @@ -694,7 +688,7 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(name-dom-contract-x ...) (if method-proc? (cdr @@ -703,7 +697,7 @@ (syntax (dom-contract-x ...)))]) (syntax (let ([dom-contract-x (coerce-contract '->d* dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... [rng-mk-x rng-mk]) (check-rng-procedure '->d* rng-mk-x dom-length) @@ -715,20 +709,20 @@ ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...) + (let ([dom-projection-x (dom-x (blame-swap blame))] ...) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure val dom-length 0 '() '() #|keywords|# blame)))) (syntax (check-procedure? dom-length)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ...) (call-with-values @@ -742,12 +736,8 @@ (apply values (map (lambda (rng-contract result) - (((contract-proc (coerce-contract '->d* rng-contract)) - pos-blame - neg-blame - src-info - orig-str - positive-position?) + (((contract-projection (coerce-contract '->d* rng-contract)) + blame) result)) rng-contracts results))))))))))))] @@ -763,7 +753,7 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + [(val blame name-id) outer-args] [(name-dom-contract-x ...) (if method-proc? (cdr @@ -774,9 +764,9 @@ (let ([dom-contract-x (coerce-contract '->d* dom)] ... [dom-rest-contract-x (coerce-contract '->d* rest)]) - (let ([dom-x (contract-proc dom-contract-x)] + (let ([dom-x (contract-projection dom-contract-x)] ... - [dom-rest-x (contract-proc dom-rest-contract-x)] + [dom-rest-x (contract-projection dom-rest-contract-x)] [rng-mk-x rng-mk]) (check-rng-procedure/more rng-mk-x arity) (let ([name-id (build-compound-type-name @@ -788,22 +778,22 @@ ;; proj (lambda (outer-args inner-lambda) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [inner-lambda inner-lambda]) (syntax - (let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] + (let ([dom-projection-x (dom-x (blame-swap blame))] ... - [dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))]) + [dom-rest-projection-x (dom-rest-x (blame-swap blame))]) inner-lambda)))) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax - (check-procedure/more val arity '() '() #|keywords|# src-info pos-blame orig-str)))) + (check-procedure/more val arity '() '() #|keywords|# blame)))) (syntax (check-procedure/more? arity)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax ((arg-x ... . rest-arg-x) (call-with-values @@ -822,12 +812,8 @@ (apply values (map (lambda (rng-contract result) - (((contract-proc (coerce-contract '->d* rng-contract)) - pos-blame - neg-blame - src-info - orig-str - positive-position?) + (((contract-projection (coerce-contract '->d* rng-contract)) + blame) result)) rng-contracts results))))))))))))])) @@ -880,32 +866,31 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + [(val blame name-id) outer-args]) (syntax (let ([name-id name-stx]) body)))) (lambda (outer-args inner-lambda) inner-lambda) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [kind-of-thing (if method-proc? 'method 'procedure)]) (syntax (begin - (check-procedure/kind val arity 'kind-of-thing src-info pos-blame orig-str))))) + (check-procedure/kind val arity 'kind-of-thing blame))))) (syntax (check-procedure? arity)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=? [(any) (syntax ((x ...) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr blame) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ...) (val (dom-id x) ...)))))] [((values (rng-ids rng-ctc) ...) post-expr) @@ -915,16 +900,14 @@ (syntax ((x ...) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ...) (let-values ([(rng-ids ...) (val (dom-id x) ...)]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) - (let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc)) - pos-blame neg-blame src-info orig-str - positive-position?)] ...) + (check-post-expr->pp/h val post-expr blame) + (let ([rng-ids-x ((contract-projection (coerce-contract 'stx-name rng-ctc)) + blame)] ...) (values (rng-ids-x rng-ids) ...))))))))] [((values (rng-ids rng-ctc) ...) post-expr) (andmap identifier? (syntax->list (syntax (rng-ids ...)))) @@ -941,16 +924,14 @@ (syntax ((x ...) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ... - [rng-id ((contract-proc (coerce-contract 'stx-name rng)) - pos-blame neg-blame src-info orig-str - positive-position?)]) + [rng-id ((contract-projection (coerce-contract 'stx-name rng)) + blame)]) (let ([res-id (rng-id (val (dom-id x) ...))]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) + (check-post-expr->pp/h val post-expr blame) res-id)))))] [_ (raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))] @@ -1000,35 +981,33 @@ (values (lambda (outer-args body) (with-syntax ([body body] - [(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + [(val blame name-id) outer-args]) (syntax (let ([name-id name-stx]) body)))) (lambda (outer-args inner-lambda) inner-lambda) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args] + (with-syntax ([(val blame name-id) outer-args] [kind-of-thing (if method-proc? 'method 'procedure)]) (syntax (begin - (check-procedure/more/kind val arity 'kind-of-thing src-info pos-blame orig-str))))) + (check-procedure/more/kind val arity 'kind-of-thing blame))))) (syntax (check-procedure/more? arity)) (lambda (outer-args) - (with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]) + (with-syntax ([(val blame name-id) outer-args]) (syntax-case* (syntax result-stuff) (values any) module-or-top-identifier=? [(any) (syntax ((x ... . rest-x) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ... - [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))]) + [rest-id ((contract-projection (coerce-contract 'stx-name rest-dom)) + (blame-swap blame))]) (apply val (dom-id x) ... (rest-id rest-x))))))] [(any . x) (raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))] @@ -1039,19 +1018,16 @@ (syntax ((x ... . rest-x) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ... - [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))]) + [rest-id ((contract-projection (coerce-contract 'stx-name rest-dom)) + (blame-swap blame))]) (let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) - (let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc)) - pos-blame neg-blame src-info orig-str - positive-position?)] ...) + (check-post-expr->pp/h val post-expr blame) + (let ([rng-ids-x ((contract-projection (coerce-contract 'stx-name rng-ctc)) + blame)] ...) (values (rng-ids-x rng-ids) ...))))))))] [((values (rng-ids rng-ctc) ...) . whatever) (and (andmap identifier? (syntax->list (syntax (rng-ids ...)))) @@ -1073,19 +1049,16 @@ (syntax ((x ... . rest-x) (begin - (check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str) - (let ([dom-id ((contract-proc (coerce-contract 'stx-name dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) + (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) + (blame-swap blame))] ... - [rest-id ((contract-proc (coerce-contract 'stx-name rest-dom)) - neg-blame pos-blame src-info orig-str - (not positive-position?))] - [rng-id ((contract-proc (coerce-contract 'stx-name rng)) - pos-blame neg-blame src-info orig-str - positive-position?)]) + [rest-id ((contract-projection (coerce-contract 'stx-name rest-dom)) + (blame-swap blame))] + [rng-id ((contract-projection (coerce-contract 'stx-name rng)) + blame)]) (let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))]) - (check-post-expr->pp/h val post-expr src-info pos-blame orig-str) + (check-post-expr->pp/h val post-expr blame) res-id)))))] [(rng res-id post-expr) (not (identifier? (syntax res-id))) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index 757622b8b6..0a9a658273 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -30,21 +30,19 @@ [(p-app-x ...) (generate-temporaries #'(rngs ...))] [(res-x ...) (generate-temporaries #'(rngs ...))]) #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) - (let ([proj-x ((proj-get rngs-x) rngs-x)] ...) - (make-proj-contract + (let ([proj-x (contract-projection rngs-x)] ...) + (simple-contract + #:name (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str positive-position?)] ...) + #:projection + (λ (blame) + (let ([p-app-x (proj-x blame)] ...) (λ (val) (if (procedure? val) (λ args (let-values ([(res-x ...) (apply val args)]) (values (p-app-x res-x) ...))) - (raise-contract-error val - src-info - pos-blame - orig-str - "expected a procedure"))))) + (raise-blame-error blame val "expected a procedure"))))) procedure?))))])) (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func) @@ -64,64 +62,66 @@ ;; and it produces a wrapper-making function. (define-struct -> (rng-any? doms dom-rest rngs kwds quoted-kwds func) #:omit-define-syntaxes - #:property proj-prop - (λ (ctc) - (let* ([doms/c (map (λ (x) ((proj-get x) x)) - (if (->-dom-rest ctc) + #:property prop:contract + (build-contract-property + #:projection + (λ (ctc) + (let* ([doms/c (map contract-projection + (if (->-dom-rest ctc) (append (->-doms ctc) (list (->-dom-rest ctc))) (->-doms ctc)))] - [rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))] - [kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))] - [mandatory-keywords (->-quoted-kwds ctc)] - [func (->-func ctc)] - [dom-length (length (->-doms ctc))] - [has-rest? (and (->-dom-rest ctc) #t)]) - (lambda (pos-blame neg-blame src-info orig-str positive-position?) - (let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?))) - doms/c)] - [partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str positive-position?)) - rngs/c)] - [partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?))) - kwds/c)]) - (apply func - (λ (val) - (if has-rest? - (check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str) - (check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str))) - (append partial-doms partial-ranges partial-kwds)))))) - - #:property name-prop - (λ (ctc) (single-arrow-name-maker - (->-doms ctc) - (->-dom-rest ctc) - (->-kwds ctc) - (->-quoted-kwds ctc) - (->-rng-any? ctc) - (->-rngs ctc))) - #:property first-order-prop - (λ (ctc) - (let ([l (length (->-doms ctc))]) - (if (->-dom-rest ctc) + [rngs/c (map contract-projection (->-rngs ctc))] + [kwds/c (map contract-projection (->-kwds ctc))] + [mandatory-keywords (->-quoted-kwds ctc)] + [func (->-func ctc)] + [dom-length (length (->-doms ctc))] + [has-rest? (and (->-dom-rest ctc) #t)]) + (lambda (blame) + (let ([partial-doms (map (λ (dom) (dom (blame-swap blame))) + doms/c)] + [partial-ranges (map (λ (rng) (rng blame)) + rngs/c)] + [partial-kwds (map (λ (kwd) (kwd (blame-swap blame))) + kwds/c)]) + (apply func + (λ (val) + (if has-rest? + (check-procedure/more val dom-length '() mandatory-keywords blame) + (check-procedure val dom-length 0 '() mandatory-keywords blame))) + (append partial-doms partial-ranges partial-kwds)))))) + + #:name + (λ (ctc) (single-arrow-name-maker + (->-doms ctc) + (->-dom-rest ctc) + (->-kwds ctc) + (->-quoted-kwds ctc) + (->-rng-any? ctc) + (->-rngs ctc))) + #:first-order + (λ (ctc) + (let ([l (length (->-doms ctc))]) + (if (->-dom-rest ctc) (λ (x) - (and (procedure? x) - (procedure-accepts-and-more? x l))) + (and (procedure? x) + (procedure-accepts-and-more? x l))) (λ (x) - (and (procedure? x) - (procedure-arity-includes? x l) - (no-mandatory-keywords? x)))))) - #:property stronger-prop - (λ (this that) - (and (->? that) - (= (length (->-doms that)) - (length (->-doms this))) - (andmap contract-stronger? - (->-doms that) - (->-doms this)) - (= (length (->-rngs that)) - (length (->-rngs this))) - (andmap contract-stronger? - (->-rngs this) - (->-rngs that))))) + (and (procedure? x) + (procedure-arity-includes? x l) + (no-mandatory-keywords? x)))))) + #:stronger + (λ (this that) + (and (->? that) + (= (length (->-doms that)) + (length (->-doms this))) + (andmap contract-stronger? + (->-doms that) + (->-doms this)) + (= (length (->-rngs that)) + (length (->-rngs this))) + (andmap contract-stronger? + (->-rngs this) + (->-rngs that)))))) (define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs) (cond @@ -455,16 +455,14 @@ (append partials-rngs partial) (append this-stronger-ribs stronger-ribs)))]))]) (values - (with-syntax ((pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) + (with-syntax ((blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) ((rng-arg ...) rng-vars) ((next-dom ...) next-doms) (dom-len (length dom-vars)) ((next-rng ...) next-rngs)) (syntax (begin - (check-procedure val dom-len 0 '() '() #| keywords |# src-info pos orig-str) + (check-procedure val dom-len 0 '() '() #| keywords |# blame) (λ (dom-arg ...) (let-values ([(rng-arg ...) (val next-dom ...)]) (values next-rng ...)))))) @@ -505,14 +503,12 @@ (append partials-doms partial) (append this-stronger-ribs stronger-ribs)))]))]) (values - (with-syntax ((pos (opt/info-pos opt/info)) - (src-info (opt/info-src-info opt/info)) - (orig-str (opt/info-orig-str opt/info)) + (with-syntax ((blame (opt/info-blame opt/info)) ((dom-arg ...) dom-vars) ((next-dom ...) next-doms) (dom-len (length dom-vars))) (syntax (begin - (check-procedure val dom-len 0 '() '() #|keywords|# src-info pos orig-str) + (check-procedure val dom-len 0 '() '() #|keywords|# blame) (λ (dom-arg ...) (val next-dom ...))))) lifts-doms diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss index c0166dceac..63c91ed701 100644 --- a/collects/mzlib/private/contract-object.ss +++ b/collects/mzlib/private/contract-object.ss @@ -344,24 +344,24 @@ `(object-contract ,(build-compound-type-name 'method-name method-ctc-var) ... ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) - (lambda (pos-blame neg-blame src-info orig-str positive-position?) - (let ([method/app-var (method-var pos-blame neg-blame src-info orig-str positive-position?)] + (lambda (blame) + (let ([method/app-var (method-var blame)] ... - [field/app-var (field-var pos-blame neg-blame src-info orig-str positive-position?)] + [field/app-var (field-var blame)] ...) (let ([field-names-list '(field-name ...)]) (lambda (val) - (check-object val src-info pos-blame orig-str) + (check-object val blame) (let ([val-mtd-names (interface->method-names (object-interface val))]) (void) - (check-method val 'method-name val-mtd-names src-info pos-blame orig-str) + (check-method val 'method-name val-mtd-names blame) ...) (unless (field-bound? field-name val) - (field-error val 'field-name src-info pos-blame orig-str)) ... + (field-error val 'field-name blame)) ... (let ([vtable (extract-vtable val)] [method-ht (extract-method-ht val)]) @@ -373,31 +373,16 @@ #f)))))))])))) -(define (check-object val src-info blame orig-str) +(define (check-object val blame) (unless (object? val) - (raise-contract-error val - src-info - blame - orig-str - "expected an object, got ~e" - val))) + (raise-blame-error blame val "expected an object, got ~e" val))) -(define (check-method val method-name val-mtd-names src-info blame orig-str) +(define (check-method val method-name val-mtd-names blame) (unless (memq method-name val-mtd-names) - (raise-contract-error val - src-info - blame - orig-str - "expected an object with method ~s" - method-name))) + (raise-blame-error blame val "expected an object with method ~s" method-name))) -(define (field-error val field-name src-info blame orig-str) - (raise-contract-error val - src-info - blame - orig-str - "expected an object with field ~s" - field-name)) +(define (field-error val field-name blame) + (raise-blame-error blame val "expected an object with field ~s" field-name)) (define (make-mixin-contract . %/<%>s) ((and/c (flat-contract class?) From bb7bd9de51f01b2620a8162da5de0bfffd645247 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 07:23:47 +0000 Subject: [PATCH 17/78] Typos and type errors in new property stuff. svn: r17700 --- .../mzlib/private/contract-arr-obj-helpers.ss | 2 +- collects/mzlib/private/contract-object.ss | 4 ++-- collects/scheme/contract/private/base.ss | 16 ++++++++------- collects/scheme/contract/private/helpers.ss | 20 +++++++++++-------- collects/scheme/contract/private/misc.ss | 11 +++++----- 5 files changed, 29 insertions(+), 24 deletions(-) diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss index 4dd2791f5c..de1788c37d 100644 --- a/collects/mzlib/private/contract-arr-obj-helpers.ss +++ b/collects/mzlib/private/contract-arr-obj-helpers.ss @@ -365,7 +365,7 @@ [(val blame name-id) outer-args]) (syntax (let ([dom-contract-x (coerce-contract '-> dom)] ...) - (let ([dom-x (contract-proc dom-contract-x)] ...) + (let ([dom-x (contract-projection dom-contract-x)] ...) (let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)]) body)))))) diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss index 63c91ed701..c5018cb950 100644 --- a/collects/mzlib/private/contract-object.ss +++ b/collects/mzlib/private/contract-object.ss @@ -331,9 +331,9 @@ ... [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] ...) - (let ([method-var (contract-proc method-ctc-var)] + (let ([method-var (contract-projection method-ctc-var)] ... - [field-var (contract-proc field-ctc-var)] + [field-var (contract-projection field-ctc-var)] ...) (let ([cls (make-wrapper-class 'wrapper-class '(method-name ...) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index 7ad1766804..0b83cec658 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -57,13 +57,15 @@ improve method arity mismatch contract violation error messages? [(syntax? info) (build-source-location info)] [(list? info) (let ([loc (list-ref info 0)]) - (struct-copy - srcloc loc - [source - (resolved-module-path-name - (module-path-index-resolve - (syntax-source-module - (srcloc-source loc))))]))] + (if (syntax? (srcloc-source loc)) + (struct-copy + srcloc loc + [source + (resolved-module-path-name + (module-path-index-resolve + (syntax-source-module + (srcloc-source loc))))]) + loc))] [else (error 'contract "expected a syntax object or list of two elements, got: ~e" diff --git a/collects/scheme/contract/private/helpers.ss b/collects/scheme/contract/private/helpers.ss index e666344253..8f589c6430 100644 --- a/collects/scheme/contract/private/helpers.ss +++ b/collects/scheme/contract/private/helpers.ss @@ -109,14 +109,18 @@ (syntax-line stx) (syntax-column stx) (syntax-position stx)) - (values (source->name - (resolved-module-path-name - (module-path-index-resolve - (syntax-source-module - (srcloc-source stx))))) - (srcloc-line stx) - (srcloc-column stx) - (srcloc-position stx)))]) + (if (syntax? (srcloc-source stx)) + (values (source->name + (resolved-module-path-name + (module-path-index-resolve + (syntax-source-module + (srcloc-source stx))))) + (srcloc-line stx) + (srcloc-column stx) + (srcloc-position stx)) + (error 'contract + "malformed srcloc has non-syntax source: ~e" + stx)))]) (let ([location (cond [(and line col) (format "~a:~a" line col)] [pos (format "~a" pos)] [else #f])]) diff --git a/collects/scheme/contract/private/misc.ss b/collects/scheme/contract/private/misc.ss index 000fcb9174..3f1c54b6ea 100644 --- a/collects/scheme/contract/private/misc.ss +++ b/collects/scheme/contract/private/misc.ss @@ -740,7 +740,7 @@ 'type-name val)) (fill-name p-app val)))) - predicate?)))))))])) + #:first-order predicate?)))))))])) (define listof (*-immutableof list? map andmap list listof)) @@ -902,8 +902,7 @@ "expected immutable <~a>, given: ~e" "expected <~a>, given: ~e") 'type-name - v))))) - #f))))))))] + v)))))))))))))] [(_ predicate? constructor (arb? selector) correct-size type-name name) (eq? #t (syntax->datum (syntax arb?))) (syntax @@ -936,8 +935,7 @@ v "expected <~a>, given: ~e" 'type-name - v))))) - #f))))))])) + v)))))))))))])) (define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f)) (define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c)) @@ -1012,6 +1010,7 @@ [ctc-proc (contract-projection ctc)]) (simple-contract #:name (build-compound-type-name 'promise/c ctc) + #:projection (λ (blame) (let ([p-app (ctc-proc blame)]) (λ (val) @@ -1022,7 +1021,7 @@ "expected , given: ~e" val)) (delay (p-app (force val)))))) - promise?)))) + #:first-order promise?)))) #| as with copy-struct in struct.ss, this first begin0 From b24b9461557d7fe42f06ff7e63123951e9948b0e Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 18:02:39 +0000 Subject: [PATCH 18/78] Added explicit checks for saner `contract` protocol. svn: r17704 --- collects/scheme/contract/private/base.ss | 59 +++++++++++++++++++----- 1 file changed, 47 insertions(+), 12 deletions(-) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index 0b83cec658..ede3bd8f98 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -23,26 +23,22 @@ improve method arity mismatch contract violation error messages? (define-syntax (contract stx) (syntax-case stx () - [(_ a-contract to-check pos-blame-e neg-blame-e srcloc-e name-e) + [(_ c v pos neg loc name) (syntax/loc stx - (let* ([c a-contract] - [v to-check] - [b (make-blame srcloc-e - name-e - (contract-name c) - (unpack-blame pos-blame-e) - (unpack-blame neg-blame-e) - #f)]) - (((contract-projection c) b) v)))] + (apply-contract c v pos neg loc name))] [(_ a-contract to-check pos-blame-e neg-blame-e) + #| (quasisyntax/loc stx (contract a-contract to-check pos-blame-e neg-blame-e (build-source-location (quote-syntax #,stx)) - '#f))] + '#f)) + |# + (raise-syntax-error 'contract "upgrade to new calling convention" stx)] [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) + #| (syntax/loc stx (let* ([info src-info-e]) (contract a-contract-e @@ -50,7 +46,46 @@ improve method arity mismatch contract violation error messages? pos-blame-e neg-blame-e (unpack-source info) - (unpack-name info))))])) + (unpack-name info)))) + |# + (raise-syntax-error 'contract "upgrade to new calling convention" stx)])) + +(define (apply-contract c v pos neg loc name) + (let* ([c (coerce-contract 'contract c)]) + (check-sexp! 'contract "positive blame" pos) + (check-sexp! 'contract "negative blame" neg) + (check-srcloc! 'contract "source location" loc) + (check-sexp! 'contract "value name" name) + (((contract-projection c) + (make-blame loc name (contract-name c) pos neg #f)) + v))) + +(define (check-srcloc! f-name v-name v) + (unless (srcloc? v) + (error f-name "expected ~a to be a srcloc; got: ~e" v-name v)) + (check-sexp! f-name (format "srcloc-source of ~a") (srcloc-source v))) + +(define (check-sexp! f-name v-name v) + (let loop ([seen #hasheq()] [x v]) + (unless (or (null? x) (boolean? x) (number? x) + (string? x) (bytes? x) (regexp? x) (char? x) + (symbol? x) (keyword? x)) + (when (hash-has-key? seen x) + (error f-name + "expected ~a to be acyclic; found a cycle in ~e at ~e" + v-name v x)) + (let ([seen (hash-set seen x #t)]) + (cond + [(pair? x) (loop seen (car x)) (loop seen (cdr x))] + [(mpair? x) (loop seen (mcar x)) (loop seen (mcdr x))] + [(vector? x) (for ([y (in-vector x)]) (loop seen y))] + [(box? x) (loop seen (unbox x))] + [(hash? x) (for ([(y z) (in-hash x)]) (loop seen y) (loop seen z))] + [(prefab-struct-key x) => + (lambda (k) (loop seen k) (loop seen (struct->vector x)))] + [else (error f-name + "expected ~a to be an s-expression; ~e contained ~e" + v-name v x)]))))) (define (unpack-source info) (cond From 00d79083e3ad7ff53715c1162c8030f6624d82f3 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 18:35:19 +0000 Subject: [PATCH 19/78] Slight changes to new contract protocol. svn: r17705 --- collects/scheme/contract/private/base.ss | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index ede3bd8f98..814333cd91 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -23,9 +23,9 @@ improve method arity mismatch contract violation error messages? (define-syntax (contract stx) (syntax-case stx () - [(_ c v pos neg loc name) + [(_ c v pos neg name loc) (syntax/loc stx - (apply-contract c v pos neg loc name))] + (apply-contract c v pos neg name loc))] [(_ a-contract to-check pos-blame-e neg-blame-e) #| (quasisyntax/loc stx @@ -50,20 +50,22 @@ improve method arity mismatch contract violation error messages? |# (raise-syntax-error 'contract "upgrade to new calling convention" stx)])) -(define (apply-contract c v pos neg loc name) +(define (apply-contract c v pos neg name loc) (let* ([c (coerce-contract 'contract c)]) (check-sexp! 'contract "positive blame" pos) (check-sexp! 'contract "negative blame" neg) - (check-srcloc! 'contract "source location" loc) (check-sexp! 'contract "value name" name) + (check-syntax/srcloc! 'contract "source location" loc) (((contract-projection c) (make-blame loc name (contract-name c) pos neg #f)) v))) -(define (check-srcloc! f-name v-name v) - (unless (srcloc? v) - (error f-name "expected ~a to be a srcloc; got: ~e" v-name v)) - (check-sexp! f-name (format "srcloc-source of ~a") (srcloc-source v))) +(define (check-syntax/srcloc! f-name v-name v) + (unless (or (syntax? v) (srcloc? v)) + (error f-name "expected ~a to be syntax or srcloc; got: ~e" v-name v)) + (check-sexp! f-name + (format "source file of ~a") + (source-location-source v))) (define (check-sexp! f-name v-name v) (let loop ([seen #hasheq()] [x v]) From 19873777e16ac5996d6bc8ecd254fc6f5c1bf767 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 18:50:11 +0000 Subject: [PATCH 20/78] Set srcloc processing to use syntax-source-module if possible. svn: r17706 --- collects/unstable/srcloc.ss | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/collects/unstable/srcloc.ss b/collects/unstable/srcloc.ss index 89251f6318..1eb1384416 100644 --- a/collects/unstable/srcloc.ss +++ b/collects/unstable/srcloc.ss @@ -231,12 +231,22 @@ (define (process-syntax x good bad name) (process-elements x good bad name - (syntax-source x) + (syntax-get-source x) (syntax-line x) (syntax-column x) (syntax-position x) (syntax-span x))) +(define (syntax-get-source x) + (cond + [(syntax-source-module x) => + (lambda (src) + (if (module-path-index? src) + (resolved-module-path-name + (module-path-index-resolve src)) + src))] + [else (syntax-source x)])) + (define (process-list x good bad name) (cond [(null? x) From 4e3874a1c5aae1167e7133c86ed1bb82b8285d48 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 18:50:40 +0000 Subject: [PATCH 21/78] Moved path pretty-printing into blame module. svn: r17707 --- collects/scheme/contract/private/blame.ss | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index a9f0899cc5..4b9c5f8640 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -1,6 +1,6 @@ #lang scheme/base -(require unstable/srcloc scheme/pretty "helpers.ss") +(require unstable/srcloc scheme/pretty setup/main-collects) (provide blame? make-blame @@ -45,13 +45,21 @@ (current-continuation-marks) b))) +(define (simplify-source loc) + (let* ([src (srcloc-source loc)]) + (if (path? src) + (let* ([rel (path->main-collects-relative src)]) + (if (pair? rel) + (apply build-path + (bytes->path #"") + (map bytes->path-element (cdr rel))) + rel)) + src))) + (define (default-blame-format b x custom-message) - (let* ([source-message - (let* ([loc (blame-source b)]) - (source-location->prefix - (struct-copy - srcloc loc - [source (source->name (srcloc-source loc))])))] + (let* ([source-message (source-location->prefix + (simplify-source + (blame-source b)))] [guilty-message (show (blame-guilty b))] [contract-message (show (blame-contract b))] [value-message (if (blame-value b) From 4d22b7a5f49e737f7b9ccfea156965eb40efedc6 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 18:50:55 +0000 Subject: [PATCH 22/78] Allowed path values in blame s-expressions. svn: r17708 --- collects/scheme/contract/private/base.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index 814333cd91..236b4002a6 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -71,7 +71,8 @@ improve method arity mismatch contract violation error messages? (let loop ([seen #hasheq()] [x v]) (unless (or (null? x) (boolean? x) (number? x) (string? x) (bytes? x) (regexp? x) (char? x) - (symbol? x) (keyword? x)) + (symbol? x) (keyword? x) + (path? x)) (when (hash-has-key? seen x) (error f-name "expected ~a to be acyclic; found a cycle in ~e at ~e" From b0c93342d9ff8b6c7ddbf13477c8ceb11c2f0535 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 17:04:01 +0000 Subject: [PATCH 23/78] Fixed type error in source location conversion. svn: r17714 --- collects/scheme/contract/private/blame.ss | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index 4b9c5f8640..b7c39d0bd0 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -46,15 +46,18 @@ b))) (define (simplify-source loc) - (let* ([src (srcloc-source loc)]) + (let* ([loc (build-source-location loc)] + [src (srcloc-source loc)]) (if (path? src) (let* ([rel (path->main-collects-relative src)]) (if (pair? rel) - (apply build-path - (bytes->path #"") - (map bytes->path-element (cdr rel))) - rel)) - src))) + (struct-copy srcloc loc + [source + (apply build-path + (bytes->path #"") + (map bytes->path-element (cdr rel)))]) + loc)) + loc))) (define (default-blame-format b x custom-message) (let* ([source-message (source-location->prefix From 124050d54e859ffb8588885c143e1d7387779324 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 17:04:44 +0000 Subject: [PATCH 24/78] Converted current-contract-region to dereference variable-reference. svn: r17715 --- collects/scheme/contract/private/base.ss | 21 +++++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index 236b4002a6..54add35005 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -11,6 +11,7 @@ improve method arity mismatch contract violation error messages? (provide contract recursive-contract + current-module-path current-contract-region) (require (for-syntax scheme/base) @@ -19,7 +20,19 @@ improve method arity mismatch contract violation error messages? "guts.ss" "helpers.ss") -(define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference))) +(define-syntax-rule (current-module-path) + (variable-reference->module-path (#%variable-reference))) + +(define (variable-reference->module-path var) + (let* ([path (variable-reference->resolved-module-path var)] + [name (and path (resolved-module-path-name path))]) + (cond + [(path? name) `(file ,(path->string name))] + [(symbol? name) `(quote ,name)] + [else 'top-level]))) + +(define-syntax-parameter current-contract-region + (λ (stx) #'(current-module-path))) (define-syntax (contract stx) (syntax-case stx () @@ -61,10 +74,10 @@ improve method arity mismatch contract violation error messages? v))) (define (check-syntax/srcloc! f-name v-name v) - (unless (or (syntax? v) (srcloc? v)) - (error f-name "expected ~a to be syntax or srcloc; got: ~e" v-name v)) + (unless (or (syntax? v) (srcloc? v) (not v)) + (error f-name "expected ~a to be syntax or srcloc or #f; got: ~e" v-name v)) (check-sexp! f-name - (format "source file of ~a") + (format "source file of ~a" v-name) (source-location-source v))) (define (check-sexp! f-name v-name v) From 1014dd2da4644f1c2cfc40bd9a76808d79dfd10d Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 17:05:06 +0000 Subject: [PATCH 25/78] Converted provide.ss to use new contract form and deference variable-reference. svn: r17716 --- collects/scheme/contract/private/provide.ss | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/collects/scheme/contract/private/provide.ss b/collects/scheme/contract/private/provide.ss index 0b154c1d89..dbd2eed91a 100644 --- a/collects/scheme/contract/private/provide.ss +++ b/collects/scheme/contract/private/provide.ss @@ -52,8 +52,9 @@ #`(contract contract-id id pos-module-source - (#%variable-reference) - #,(id->contract-src-info #'id))))))]) + (current-module-path) + 'id + (quote-syntax id))))))]) (when key (hash-set! saved-id-table key lifted-id)) ;; Expand to a use of the lifted expression: @@ -652,7 +653,7 @@ (with-syntax ([code (quasisyntax/loc stx (begin - (define pos-module-source (#%variable-reference)) + (define pos-module-source (current-module-path)) #,@(if no-need-to-check-ctrct? (list) @@ -669,7 +670,7 @@ (syntax-local-lift-module-end-declaration #`(begin (unless extra-test - (contract contract-id id pos-module-source 'ignored #,(id->contract-src-info #'id))) + (contract contract-id id pos-module-source 'ignored 'id (quote-syntax id))) (void))) (syntax (code id-rename))))))])) @@ -702,7 +703,9 @@ (contract ctc val 'not-enough-info-for-blame - 'not-enough-info-for-blame)) + 'not-enough-info-for-blame + '#f + '#f)) ctcs vals)))))]) struct:struct-name)) From 7763a4079ad4db29c3c42d7278e779e6ff604f90 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 18:26:02 +0000 Subject: [PATCH 26/78] Ported mzlib units to new contract system. svn: r17718 --- collects/mzlib/private/unit-contract.ss | 49 +++++++++---------------- collects/mzlib/private/unit-utils.ss | 17 ++------- collects/mzlib/unit.ss | 16 ++++---- 3 files changed, 29 insertions(+), 53 deletions(-) diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index 1290a7809c..11b45f84cc 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -15,7 +15,7 @@ (provide (for-syntax unit/c/core) unit/c) (define-for-syntax (contract-imports/exports import?) - (λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name positive-position?) + (λ (table-stx import-tagged-infos import-sigs ctc-table blame-id) (define def-table (make-bound-identifier-mapping)) (define (convert-reference var vref ctc sig-ctc rename-bindings) @@ -25,12 +25,8 @@ ;; store the result in a local box, then just check the box to ;; see if we need to coerce. #`(let ([ctc (coerce-contract 'unit/c (letrec-syntax #,rename-bindings #,ctc))]) - ((((proj-get ctc) ctc) - #,(if import? neg pos) - #,(if import? pos neg) - #,src-info - #,name - #,(if import? (not positive-position?) positive-position?)) + (((contract-projection ctc) + #,(if import? #`(blame-swap #,blame-id) blame-id)) #,stx)))]) (if ctc #`(λ () @@ -43,9 +39,9 @@ var)]) #`(let ([old-v/c (#,vref)]) (contract sig-ctc-stx (car old-v/c) - (cdr old-v/c) #,pos - #,(id->contract-src-info var))))) - #,neg) + (cdr old-v/c) (blame-guilty #,blame-id) + (quote #,var) (quote-syntax #,var))))) + (blame-innocent #,blame-id)) (wrap-with-proj ctc #`(#,vref)))) vref))) (for ([tagged-info (in-list import-tagged-infos)] @@ -57,7 +53,7 @@ #`(vector-ref #,v #,index))))) (with-syntax ((((eloc ...) ...) (for/list ([target-sig import-sigs]) - (let ([rename-bindings (get-member-bindings def-table target-sig pos)]) + (let ([rename-bindings (get-member-bindings def-table target-sig #`(blame-guilty #,blame-id))]) (for/list ([target-int/ext-name (in-list (car target-sig))] [sig-ctc (in-list (cadddr target-sig))]) (let* ([var (car target-int/ext-name)] @@ -148,11 +144,10 @@ (map list (list 'e.x ...) (build-compound-type-name 'e.c ...))) ...))) - (λ (pos neg src-info name positive-position?) + (λ (blame) (λ (unit-tmp) (unless (unit? unit-tmp) - (raise-contract-error unit-tmp src-info pos name - "value is not a unit")) + (raise-blame-error blame unit-tmp "value is not a unit")) (contract-check-sigs unit-tmp (vector-immutable @@ -161,7 +156,7 @@ (vector-immutable (cons 'export-name (vector-immutable export-key ...)) ...) - src-info pos name) + blame) (make-unit '#,name (vector-immutable (cons 'import-name @@ -177,21 +172,13 @@ import-tagged-infos import-sigs contract-table - #'pos - #'neg - #'src-info - #'name - #'positive-position?))) + #'blame))) #,(contract-exports #'export-table export-tagged-infos export-sigs contract-table - #'pos - #'neg - #'src-info - #'name - #'positive-position?))))))) + #'blame))))))) (λ (v) (and (unit? v) (with-handlers ([exn:fail:contract? (λ () #f)]) @@ -212,7 +199,7 @@ (let ([name (syntax-local-infer-name stx)]) (unit/c/core name #'sstx))])) -(define (contract-check-helper sub-sig super-sig import? val src-info blame ctc) +(define (contract-check-helper sub-sig super-sig import? val blame) (define t (make-hash)) (let loop ([i (sub1 (vector-length sub-sig))]) (when (>= i 0) @@ -232,8 +219,8 @@ [r (hash-ref t v0 #f)]) (when (not r) (let ([sub-name (car (vector-ref super-sig i))]) - (raise-contract-error - val src-info blame ctc + (raise-blame-error + blame val (cond [import? (format "contract does not list import ~a" sub-name)] @@ -241,6 +228,6 @@ (format "unit must export signature ~a" sub-name)]))))) (loop (sub1 i))))) -(define (contract-check-sigs unit expected-imports expected-exports src-info blame ctc) - (contract-check-helper expected-imports (unit-import-sigs unit) #t unit src-info blame ctc) - (contract-check-helper (unit-export-sigs unit) expected-exports #f unit src-info blame ctc)) +(define (contract-check-sigs unit expected-imports expected-exports blame) + (contract-check-helper expected-imports (unit-import-sigs unit) #t unit blame) + (contract-check-helper (unit-export-sigs unit) expected-exports #f unit blame)) diff --git a/collects/mzlib/private/unit-utils.ss b/collects/mzlib/private/unit-utils.ss index 91b82cb4b2..7b193aa2be 100644 --- a/collects/mzlib/private/unit-utils.ss +++ b/collects/mzlib/private/unit-utils.ss @@ -13,7 +13,6 @@ process-unit-import process-unit-export tagged-info->keys - id->contract-src-info get-member-bindings)) (provide equal-hash-table @@ -26,20 +25,10 @@ ((= n 0) acc) (else (loop (sub1 n) (cons (sub1 n) acc)))))) - ;; id->contract-src-info : identifier -> syntax - ;; constructs the last argument to the contract, given an identifier - (define-for-syntax (id->contract-src-info id) - #`(list (make-srcloc (quote-syntax #,id) - #,(syntax-line id) - #,(syntax-column id) - #,(syntax-position id) - #,(syntax-span id)) - #,(format "~s" (syntax->datum id)))) - (define-syntax-rule (equal-hash-table [k v] ...) (make-immutable-hash (list (cons k v) ...))) -(define-for-syntax (get-member-bindings member-table sig blame) +(define-for-syntax (get-member-bindings member-table sig pos) (for/list ([i (in-list (map car (car sig)))] [c (in-list (cadddr sig))]) (let ([add-ctc @@ -47,8 +36,8 @@ (if c (with-syntax ([c-stx (syntax-property c 'inferred-name v)]) #`(let ([v/c (#,stx)]) - (contract c-stx (car v/c) (cdr v/c) #,blame - #,(id->contract-src-info v)))) + (contract c-stx (car v/c) (cdr v/c) #,pos + (quote #,v) (quote-syntax #,v)))) #`(#,stx)))]) #`[#,i (make-set!-transformer diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 64a77d6905..dec63d26fa 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -482,7 +482,7 @@ (if (pair? v/c) (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) (current-contract-region) - #,(id->contract-src-info var)) + (quote #,var) (quote-syntax #,var)) (error 'unit "contracted import ~a used before definition" (quote #,(syntax->datum var)))))))) (quasisyntax/loc (error-syntax) @@ -747,7 +747,8 @@ (contract #,ctc #,tmp (current-contract-region) 'cant-happen - #,(id->contract-src-info id)) + (quote #,id) + (quote-syntax #,id)) (set-box! #,export-loc (cons #,tmp (current-contract-region))))) (quasisyntax/loc defn-or-expr @@ -824,7 +825,7 @@ #`(let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - #,(id->contract-src-info var))) + (quote #,var) (quote-syntax #,var))) #`(#,vref)) (current-contract-region))) (if ctc @@ -832,7 +833,7 @@ (let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - #,(id->contract-src-info var)))) + (quote #,var) (quote-syntax #,var)))) vref))))) (car target-sig) (cadddr target-sig))) @@ -1303,7 +1304,7 @@ #`(let ([v/c (#,tb)]) (contract ctc-stx (car v/c) (cdr v/c) (current-contract-region) - #,(id->contract-src-info v)))) + (quote #,v) (quote-syntax #,v)))) #`(#,tb))) tbs (iota (length (car os))) @@ -1503,11 +1504,10 @@ #'name (syntax/loc stx ((import (import-tagged-sig-id [i.x i.c] ...) ...) - (export (export-tagged-sig-id [e.x e.c] ...) ...))))] - [src-info (id->contract-src-info #'name)]) + (export (export-tagged-sig-id [e.x e.c] ...) ...))))]) (values (syntax/loc stx - (contract unit-contract new-unit '(unit name) (current-contract-region) src-info)) + (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name))) isigs esigs deps))))] [(ic:import-clause/contract ec:export-clause/contract . body) (build-unit/contract From 6ac7fe78e6927319681092fc6ed3eef54ee2996d Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 18:32:26 +0000 Subject: [PATCH 27/78] Ported object contracts to new properties. svn: r17719 --- collects/scheme/contract/private/object.ss | 114 ++++++++++----------- 1 file changed, 55 insertions(+), 59 deletions(-) diff --git a/collects/scheme/contract/private/object.ss b/collects/scheme/contract/private/object.ss index a306e854f0..5bf3e0b149 100644 --- a/collects/scheme/contract/private/object.ss +++ b/collects/scheme/contract/private/object.ss @@ -17,8 +17,10 @@ #; (let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))] [cf (-> integer? integer?)] - [m-proj (((proj-get cm) cm) 'pos 'neg #'here "whatever" some-boolean)] - [f-proj (((proj-get cf) cf) 'pos 'neg #'here "whatever" some-boolean)] + [m-proj ((contract-projection cm) + (make-blame #'here #f "whatever" 'pos 'neg #f))] + [f-proj ((contract-projection cf) + (make-blame #'here #f "whatever" 'pos 'neg #f))] [cls (make-wrapper-class 'wrapper-class '(m) (list @@ -52,63 +54,57 @@ (define-struct object-contract (methods method-ctcs method-wrappers fields field-ctcs) #:omit-define-syntaxes - #:property proj-prop - (λ (ctc) - (let ([meth-names (object-contract-methods ctc)] - [meth-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-method-ctcs ctc))] - [ctc-field-names (object-contract-fields ctc)] - [field-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-field-ctcs ctc))]) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (let* ([meth-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str positive-position?)) - meth-param-projs)] - [meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))] - [cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)] - [field-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str positive-position?)) field-param-projs)]) - (λ (val) - - (unless (object? val) - (raise-contract-error val src-info pos-blame orig-str - "expected an object, got ~e" - val)) - - (let ([objs-mtds (interface->method-names (object-interface val))] - [vtable (extract-vtable val)] - [method-ht (extract-method-ht val)]) - (for-each (λ (m proj) - (let ([index (hash-ref method-ht m #f)]) - (unless index - (raise-contract-error val src-info pos-blame orig-str - "expected an object with method ~s" - m)) - ;; verify the first-order properties by apply the projection and - ;; throwing the result away. Without this, the contract wrappers - ;; just check the first-order properties of the wrappers, which is - ;; the wrong thing. - (proj (vector-ref vtable index)))) - meth-names - meth-projs)) - - (let ([fields (field-names val)]) - (for-each (λ (f) - (unless (memq f fields) - (raise-contract-error val src-info pos-blame orig-str - "expected an object with field ~s" - f))) - ctc-field-names)) - - (apply make-object cls val - (map (λ (field proj) (proj (get-field/proc field val))) - ctc-field-names field-projs))))))) - #:property name-prop - (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc)) - (object-contract-fields ctc) - (object-contract-field-ctcs ctc)) - ,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc)) - (object-contract-methods ctc) - (object-contract-method-ctcs ctc)))) - - #:property first-order-prop (λ (ctc) (λ (val) #f)) - #:property stronger-prop (λ (this that) #f)) + #:property prop:contract + (build-contract-property + #:projection + (λ (ctc) + (let ([meth-names (object-contract-methods ctc)] + [meth-param-projs (map contract-projection (object-contract-method-ctcs ctc))] + [ctc-field-names (object-contract-fields ctc)] + [field-param-projs (map contract-projection (object-contract-field-ctcs ctc))]) + (λ (blame) + (let* ([meth-projs (map (λ (x) (x blame)) meth-param-projs)] + [meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))] + [cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)] + [field-projs (map (λ (x) (x blame)) field-param-projs)]) + (λ (val) + + (unless (object? val) + (raise-blame-error blame val "expected an object, got ~e" val)) + + (let ([objs-mtds (interface->method-names (object-interface val))] + [vtable (extract-vtable val)] + [method-ht (extract-method-ht val)]) + (for-each (λ (m proj) + (let ([index (hash-ref method-ht m #f)]) + (unless index + (raise-blame-error blame val "expected an object with method ~s" m)) + ;; verify the first-order properties by apply the projection and + ;; throwing the result away. Without this, the contract wrappers + ;; just check the first-order properties of the wrappers, which is + ;; the wrong thing. + (proj (vector-ref vtable index)))) + meth-names + meth-projs)) + + (let ([fields (field-names val)]) + (for-each (λ (f) + (unless (memq f fields) + (raise-blame-error blame val "expected an object with field ~s" f))) + ctc-field-names)) + + (apply make-object cls val + (map (λ (field proj) (proj (get-field/proc field val))) + ctc-field-names field-projs))))))) + #:name + (λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc)) + (object-contract-fields ctc) + (object-contract-field-ctcs ctc)) + ,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc)) + (object-contract-methods ctc) + (object-contract-method-ctcs ctc)))) + + #:first-order (λ (ctc) (λ (val) #f)))) (define-syntax (object-contract stx) (syntax-case stx () From 2a5f883a4c9c25dbe9fc64361290b10a51c9d464 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 18:49:39 +0000 Subject: [PATCH 28/78] Updated contracts in XML collection. svn: r17720 --- collects/xml/private/structures.ss | 21 +++++++++-------- collects/xml/private/xexpr.ss | 37 +++++++++++++++--------------- 2 files changed, 30 insertions(+), 28 deletions(-) diff --git a/collects/xml/private/structures.ss b/collects/xml/private/structures.ss index b804da49cb..24aa3b6513 100644 --- a/collects/xml/private/structures.ss +++ b/collects/xml/private/structures.ss @@ -58,15 +58,18 @@ (define permissive-xexprs (make-parameter #f)) (define permissive/c - (make-proj-contract 'permissive/c - (lambda (pos neg src-info name) - (lambda (v) - (if (permissive-xexprs) - v - (raise-contract-error - v src-info pos name "not in permissive mode")))) - (lambda (v) - (permissive-xexprs)))) + (simple-flat-contract + #:name 'permissive/c + #:projection + (lambda (blame) + (lambda (v) + (if (permissive-xexprs) + v + (raise-blame-error + blame v "not in permissive mode")))) + #:first-order + (lambda (v) + (permissive-xexprs)))) ; content? : TST -> Bool (define content/c diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss index 61c1e83009..b88e961cec 100644 --- a/collects/xml/private/xexpr.ss +++ b/collects/xml/private/xexpr.ss @@ -33,31 +33,30 @@ (or/c (cons/c (listof (list/c symbol? string?)) (listof xexpr)) (listof xexpr))))) -(define xexpr/c - (make-proj-contract - 'xexpr? - (lambda (pos neg src-info name) - (lambda (val) - (with-handlers ([exn:invalid-xexpr? - (lambda (exn) - (raise-contract-error - val - src-info - pos - name - "Not an Xexpr. ~a~n~nContext:~n~a" - (exn-message exn) - (pretty-format val)))]) - (validate-xexpr val) - val))) - (lambda (v) #t))) - (define (xexpr? x) (correct-xexpr? x (lambda () #t) (lambda (exn) #f))) (define (validate-xexpr x) (correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn)))) +(define xexpr/c + (simple-flat-contract + #:name 'xexpr? + #:projection + (lambda (blame) + (lambda (val) + (with-handlers ([exn:invalid-xexpr? + (lambda (exn) + (raise-blame-error + blame + val + "Not an Xexpr. ~a~n~nContext:~n~a" + (exn-message exn) + (pretty-format val)))]) + (validate-xexpr val) + val))) + #:first-order xexpr?)) + ;; ;; ;; ;; ;; ;; ; ;; ; xexpr? helpers From 54d5b0ac7f57d6b9c4bd4492f13e89b99a0088c0 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 18:53:06 +0000 Subject: [PATCH 29/78] Updated predicate list in scheme/exists/lang based on contract library changes. svn: r17721 --- collects/scheme/exists/lang.ss | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/scheme/exists/lang.ss b/collects/scheme/exists/lang.ss index ec2c033c52..9c19ea2c13 100644 --- a/collects/scheme/exists/lang.ss +++ b/collects/scheme/exists/lang.ss @@ -25,6 +25,7 @@ '(absolute-path? arity-at-least? bitwise-bit-set? + blame? boolean? box? byte-pregexp? @@ -60,6 +61,8 @@ contract-first-order-passes? contract-stronger? contract? + contract-property? + contract-struct? custodian-box? custodian-memory-accounting-available? custodian? @@ -84,8 +87,8 @@ exact-positive-integer? exact? exn:break? - exn:fail:contract2? exn:fail:contract:arity? + exn:fail:contract:blame? exn:fail:contract:continuation? exn:fail:contract:divide-by-zero? exn:fail:contract:variable? @@ -111,7 +114,8 @@ file-stream-port? fixnum? flat-contract? - flat-pred? + flat-contract-property? + flat-contract-struct? generic? handle-evt? hash-eq? @@ -144,7 +148,6 @@ module-path? module-provide-protected? mpair? - name-pred? namespace-anchor? namespace? negative? @@ -176,7 +179,6 @@ procedure-closure-contents-eq? procedure-struct-type? procedure? - proj-pred? promise-forced? promise-running? promise? @@ -198,7 +200,6 @@ special-comment? srcloc? string? - stronger-pred? struct-accessor-procedure? struct-constructor-procedure? struct-mutator-procedure? From f346bc7f1aa229b2720dbf6cbd42afe9cc95de1c Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 23:10:10 +0000 Subject: [PATCH 30/78] Added a module for statically computing source locations and module paths. svn: r17722 --- collects/unstable/location.ss | 66 +++++++++++++++++++++++++++++++++++ 1 file changed, 66 insertions(+) create mode 100644 collects/unstable/location.ss diff --git a/collects/unstable/location.ss b/collects/unstable/location.ss new file mode 100644 index 0000000000..75a46e39fc --- /dev/null +++ b/collects/unstable/location.ss @@ -0,0 +1,66 @@ +#lang scheme/base + +(require (for-syntax scheme/base unstable/srcloc)) + +(provide quote-srcloc + quote-source-file + quote-line-number + quote-column-number + quote-character-position + quote-character-span + quote-module-path + quote-module-name) + +(define-syntax (quote-srcloc stx) + (syntax-case stx () + [(_) #`(quote-srcloc #,stx)] + [(_ loc) + (with-syntax ([(arg ...) (build-source-location-list #'loc)]) + #'(make-srcloc (quote arg) ...))])) + +(define-syntax (quote-source-file stx) + (syntax-case stx () + [(_) #`(quote-source-file #,stx)] + [(_ loc) #`(quote #,(source-location-source #'loc))])) + +(define-syntax (quote-line-number stx) + (syntax-case stx () + [(_) #`(quote-line-number #,stx)] + [(_ loc) #`(quote #,(source-location-line #'loc))])) + +(define-syntax (quote-column-number stx) + (syntax-case stx () + [(_) #`(quote-column-number #,stx)] + [(_ loc) #`(quote #,(source-location-column #'loc))])) + +(define-syntax (quote-character-position stx) + (syntax-case stx () + [(_) #`(quote-character-position #,stx)] + [(_ loc) #`(quote #,(source-location-position #'loc))])) + +(define-syntax (quote-character-span stx) + (syntax-case stx () + [(_) #`(quote-character-span #,stx)] + [(_ loc) #`(quote #,(source-location-span #'loc))])) + +(define-syntax-rule (quote-module-name) + (variable-reference->module-name (#%variable-reference))) + +(define-syntax-rule (quote-module-path) + (variable-reference->module-path (#%variable-reference))) + +(define (variable-reference->module-path var) + (module-name->module-path + (variable-reference->module-name var))) + +(define (variable-reference->module-name var) + (let* ([rmp (variable-reference->resolved-module-path var)]) + (if (resolved-module-path? rmp) + (resolved-module-path-name rmp) + rmp))) + +(define (module-name->module-path name) + (cond + [(path? name) `(file ,(path->string name))] + [(symbol? name) `(quote ,name)] + [else 'top-level])) From 167c9cb1a8d4ab0c10ecbc68ede449f13039b1c4 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 23:11:12 +0000 Subject: [PATCH 31/78] Changed contract source locations to perform module resolution in advance. svn: r17723 --- collects/scheme/contract/private/base.ss | 23 ++++++--------------- collects/scheme/contract/private/provide.ss | 11 +++++----- 2 files changed, 12 insertions(+), 22 deletions(-) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index 54add35005..72d474bbaf 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -11,28 +11,17 @@ improve method arity mismatch contract violation error messages? (provide contract recursive-contract - current-module-path current-contract-region) (require (for-syntax scheme/base) scheme/stxparam unstable/srcloc + unstable/location "guts.ss" "helpers.ss") -(define-syntax-rule (current-module-path) - (variable-reference->module-path (#%variable-reference))) - -(define (variable-reference->module-path var) - (let* ([path (variable-reference->resolved-module-path var)] - [name (and path (resolved-module-path-name path))]) - (cond - [(path? name) `(file ,(path->string name))] - [(symbol? name) `(quote ,name)] - [else 'top-level]))) - (define-syntax-parameter current-contract-region - (λ (stx) #'(current-module-path))) + (λ (stx) #'(quote-module-path))) (define-syntax (contract stx) (syntax-case stx () @@ -68,14 +57,14 @@ improve method arity mismatch contract violation error messages? (check-sexp! 'contract "positive blame" pos) (check-sexp! 'contract "negative blame" neg) (check-sexp! 'contract "value name" name) - (check-syntax/srcloc! 'contract "source location" loc) + (check-srcloc! 'contract "source location" loc) (((contract-projection c) (make-blame loc name (contract-name c) pos neg #f)) v))) -(define (check-syntax/srcloc! f-name v-name v) - (unless (or (syntax? v) (srcloc? v) (not v)) - (error f-name "expected ~a to be syntax or srcloc or #f; got: ~e" v-name v)) +(define (check-srcloc! f-name v-name v) + (unless (srcloc? v) + (error f-name "expected ~a to be a srcloc structure; got: ~e" v-name v)) (check-sexp! f-name (format "source file of ~a" v-name) (source-location-source v))) diff --git a/collects/scheme/contract/private/provide.ss b/collects/scheme/contract/private/provide.ss index dbd2eed91a..180c65a6d8 100644 --- a/collects/scheme/contract/private/provide.ss +++ b/collects/scheme/contract/private/provide.ss @@ -8,7 +8,8 @@ "arrow.ss" "base.ss" scheme/contract/exists - "guts.ss") + "guts.ss" + unstable/location) (define-syntax (verify-contract stx) (syntax-case stx () @@ -52,9 +53,9 @@ #`(contract contract-id id pos-module-source - (current-module-path) + (quote-module-path) 'id - (quote-syntax id))))))]) + (quote-srcloc id))))))]) (when key (hash-set! saved-id-table key lifted-id)) ;; Expand to a use of the lifted expression: @@ -653,7 +654,7 @@ (with-syntax ([code (quasisyntax/loc stx (begin - (define pos-module-source (current-module-path)) + (define pos-module-source (quote-module-path)) #,@(if no-need-to-check-ctrct? (list) @@ -670,7 +671,7 @@ (syntax-local-lift-module-end-declaration #`(begin (unless extra-test - (contract contract-id id pos-module-source 'ignored 'id (quote-syntax id))) + (contract contract-id id pos-module-source 'ignored 'id (quote-srcloc id))) (void))) (syntax (code id-rename))))))])) From 0edd7863618fdbdd17391a7f5b5ff21f75a95ff9 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Mon, 18 Jan 2010 23:24:34 +0000 Subject: [PATCH 32/78] Removed more occurrences of old source info representation. svn: r17724 --- collects/scheme/contract/private/provide.ss | 10 ------- collects/scheme/contract/regions.ss | 33 +++++++++------------ 2 files changed, 14 insertions(+), 29 deletions(-) diff --git a/collects/scheme/contract/private/provide.ss b/collects/scheme/contract/private/provide.ss index 180c65a6d8..f3de8b496c 100644 --- a/collects/scheme/contract/private/provide.ss +++ b/collects/scheme/contract/private/provide.ss @@ -16,16 +16,6 @@ [(_ name x) (a:known-good-contract? #'x) #'x] [(_ name x) #'(coerce-contract name x)])) -;; id->contract-src-info : identifier -> syntax -;; constructs the last argument to the -contract, given an identifier -(define-for-syntax (id->contract-src-info id) - #`(list (make-srcloc #,id - #,(syntax-line id) - #,(syntax-column id) - #,(syntax-position id) - #,(syntax-span id)) - #,(format "~s" (syntax->datum id)))) - (define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source) (make-set!-transformer (let ([saved-id-table (make-hasheq)]) diff --git a/collects/scheme/contract/regions.ss b/collects/scheme/contract/regions.ss index 04d5bedff4..6058deee3a 100644 --- a/collects/scheme/contract/regions.ss +++ b/collects/scheme/contract/regions.ss @@ -11,6 +11,7 @@ syntax/kerncase (prefix-in a: "private/helpers.ss")) scheme/splicing + unstable/location "private/arrow.ss" "private/base.ss" "private/guts.ss") @@ -22,16 +23,6 @@ [(_ name x) (a:known-good-contract? #'x) #'x] [(_ name x) #'(coerce-contract name x)])) -;; id->contract-src-info : identifier -> syntax -;; constructs the last argument to the -contract, given an identifier -(define-for-syntax (id->contract-src-info id) - #`(list (make-srcloc #,id - #,(syntax-line id) - #,(syntax-column id) - #,(syntax-position id) - #,(syntax-span id)) - #,(format "~s" (syntax->datum id)))) - ; @@ -322,7 +313,8 @@ #,av-id '(struct name) 'cant-happen - #,(id->contract-src-info av-id)))))] + (quote #,av-id) + (quote-srcloc #,av-id)))))] ;; a list of variables, one for each super field [(super-fields ...) (generate-temporaries super-fields)] ;; the contract for a super field is any/c becuase the @@ -391,14 +383,16 @@ arg #,neg-blame-id #,pos-blame-id - #,(id->contract-src-info id))))] + (quote #,id) + (quote-srcloc #,id))))] [(f arg ...) (quasisyntax/loc stx ((contract #,contract-stx #,id #,pos-blame-id #,neg-blame-id - #,(id->contract-src-info id)) + (quote #,id) + (quote-srcloc #,id)) arg ...))] [ident (identifier? (syntax ident)) @@ -407,7 +401,8 @@ #,id #,pos-blame-id #,neg-blame-id - #,(id->contract-src-info id)))])))) + (quote #,id) + (quote-srcloc #,id)))])))) (define-for-syntax (check-and-split-with-contracts args) (let loop ([args args] @@ -533,15 +528,13 @@ (syntax-property c 'inferred-name v)) free-ctcs free-vars)] - [(free-src-info ...) (map id->contract-src-info free-vars)] [(ctc-id ...) (map cid-marker protected)] [(ctc ...) (map (λ (c v) (syntax-property (add-context c) 'inferred-name v)) protections protected)] [(p ...) protected] - [(marked-p ...) (add-context #`#,protected)] - [(src-info ...) (map (compose id->contract-src-info add-context) protected)]) + [(marked-p ...) (add-context #`#,protected)]) (with-syntax ([new-stx (add-context #'(splicing-syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) . body))]) @@ -556,7 +549,8 @@ free-var blame-id 'cant-happen - free-src-info) + (quote free-var) + (quote-srcloc free-var)) ... (values))) (define-syntaxes (free-var-id ...) @@ -573,7 +567,8 @@ marked-p blame-stx 'cant-happen - src-info) + (quote marked-p) + (quote-srcloc marked-p)) ... (values))) (define-syntaxes (p ...) From 9e540043bca10416a07cdb7dc36729cd62b648d9 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 00:20:54 +0000 Subject: [PATCH 33/78] Updated local-expand of contract forms in require/contract. svn: r17725 --- .../typed-scheme/utils/require-contract.ss | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/collects/typed-scheme/utils/require-contract.ss b/collects/typed-scheme/utils/require-contract.ss index 266f7e62d1..8d71a4d1ec 100644 --- a/collects/typed-scheme/utils/require-contract.ss +++ b/collects/typed-scheme/utils/require-contract.ss @@ -1,9 +1,12 @@ #lang scheme/base -(require scheme/contract (for-syntax scheme/base syntax/kerncase - syntax/parse - "../utils/tc-utils.ss" - (prefix-in tr: "../private/typed-renaming.ss"))) +(require scheme/contract + unstable/location + (for-syntax scheme/base + syntax/kerncase + syntax/parse + "../utils/tc-utils.ss" + (prefix-in tr: "../private/typed-renaming.ss"))) (provide require/contract define-ignored) @@ -19,7 +22,7 @@ (define name #,(syntax-property #'e* 'inferred-name (syntax-e #'name))))] - [(begin (begin e)) + [(begin e) #`(define name #,(syntax-property #'e 'inferred-name (syntax-e #'name)))])])) @@ -42,7 +45,8 @@ (get-alternate nm.r) '(interface for #,(syntax->datum #'nm)) 'never-happen - (quote-syntax nm))))] + (quote nm) + (quote-srcloc nm))))] [(require/contract (orig-nm:renameable nm:id) cnt lib) #`(begin (require (only-in lib [orig-nm orig-nm.r])) (define-ignored nm @@ -50,4 +54,5 @@ (get-alternate orig-nm.r) '#,(syntax->datum #'nm) 'never-happen - (quote-syntax nm))))])) + (quote nm) + (quote-srcloc nm))))])) From a03454ec6998f4c90c46e0be3c6604ab4163b22e Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 00:21:43 +0000 Subject: [PATCH 34/78] Replaced make-proj-contract in poly/c svn: r17726 --- collects/unstable/poly-c.ss | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/collects/unstable/poly-c.ss b/collects/unstable/poly-c.ss index 4c6be196b6..2d307171ef 100644 --- a/collects/unstable/poly-c.ss +++ b/collects/unstable/poly-c.ss @@ -38,15 +38,15 @@ (define (apply/c c #:name [name (build-compound-type-name 'apply/c c)]) - (make-proj-contract - name - (lambda (pos neg src name2 positive-position?) + (simple-contract + #:name name + #:projection + (lambda (blame) (lambda (p) (let* ([ctc (coerce-contract 'apply/c c)] [thunk (lambda () - ((((proj-get ctc) ctc) - pos neg src name2 positive-position?) p))]) + (((contract-projection ctc) blame) p))]) (make-keyword-procedure (lambda (keys vals . args) (keyword-apply (thunk) keys vals args)) (case-lambda @@ -60,7 +60,7 @@ [(a b c d e f g) ((thunk) a b c d e f g)] [(a b c d e f g h) ((thunk) a b c d e f g h)] [args (apply (thunk) args)]))))) - procedure?))) + #:first-order procedure?))) (define-syntax (poly/c stx) (syntax-case stx () From 2bad47fd0fff59cde30406af4db42e6e65ffa899 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 01:01:28 +0000 Subject: [PATCH 35/78] Ported more code to use new contract bindings. svn: r17727 --- collects/mzlib/private/contract-object.ss | 7 +++--- collects/mzlib/private/unit-contract.ss | 5 +++- collects/unstable/contract.ss | 29 +++++++++++++---------- collects/web-server/private/xexpr.ss | 10 ++++---- collects/web-server/servlet/setup.ss | 23 ++++++++---------- collects/web-server/stuffers/stuffer.ss | 22 ++++++++--------- 6 files changed, 49 insertions(+), 47 deletions(-) diff --git a/collects/mzlib/private/contract-object.ss b/collects/mzlib/private/contract-object.ss index c5018cb950..76d22c7236 100644 --- a/collects/mzlib/private/contract-object.ss +++ b/collects/mzlib/private/contract-object.ss @@ -340,10 +340,12 @@ (list methods ...) '(field-name ...) #t)]) - (make-proj-contract + (simple-contract + #:name `(object-contract ,(build-compound-type-name 'method-name method-ctc-var) ... ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) + #:projection (lambda (blame) (let ([method/app-var (method-var blame)] ... @@ -369,8 +371,7 @@ val (method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ... (field/app-var (get-field field-name val)) ... - )))))) - #f)))))))])))) + )))))))))))))])))) (define (check-object val blame) diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index 11b45f84cc..966e059a18 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -132,7 +132,8 @@ export-tagged-infos)]) (quasisyntax/loc stx (begin - (make-proj-contract + (simple-contract + #:name (list 'unit/c (cons 'import (list (cons 'isig @@ -144,6 +145,7 @@ (map list (list 'e.x ...) (build-compound-type-name 'e.c ...))) ...))) + #:projection (λ (blame) (λ (unit-tmp) (unless (unit? unit-tmp) @@ -179,6 +181,7 @@ export-sigs contract-table #'blame))))))) + #:first-order (λ (v) (and (unit? v) (with-handlers ([exn:fail:contract? (λ () #f)]) diff --git a/collects/unstable/contract.ss b/collects/unstable/contract.ss index 64b9cc4433..cf58f91f42 100644 --- a/collects/unstable/contract.ss +++ b/collects/unstable/contract.ss @@ -38,26 +38,29 @@ (if (predicate x) (then-pred x) (else-pred x))) (flat-named-contract name pred)) ;; ho contract - (let ([then-proj ((proj-get then-ctc) then-ctc)] - [then-fo ((first-order-get then-ctc) then-ctc)] - [else-proj ((proj-get else-ctc) else-ctc)] - [else-fo ((first-order-get else-ctc) else-ctc)]) - (define ((proj pos neg srcinfo name pos?) x) + (let ([then-proj (contract-projection then-ctc)] + [then-fo (contract-first-order then-ctc)] + [else-proj (contract-projection else-ctc)] + [else-fo (contract-first-order else-ctc)]) + (define ((proj blame) x) (if (predicate x) - ((then-proj pos neg srcinfo name pos?) x) - ((else-proj pos neg srcinfo name pos?) x))) - (make-proj-contract - name - proj + ((then-proj blame) x) + ((else-proj blame) x))) + (simple-contract + #:name name + #:projection proj + #:first-order (lambda (x) (if (predicate x) (then-fo x) (else-fo x)))))))) (define (rename-contract ctc name) (let ([ctc (coerce-contract 'rename-contract ctc)]) (if (flat-contract? ctc) (flat-named-contract name (flat-contract-predicate ctc)) - (let* ([ctc-fo ((first-order-get ctc) ctc)] - [proj ((proj-get ctc) ctc)]) - (make-proj-contract name proj ctc-fo))))) + (let* ([ctc-fo (contract-first-order ctc)] + [proj (contract-projection ctc)]) + (simple-contract #:name name + #:projection proj + #:first-order ctc-fo))))) (provide/contract [non-empty-string/c contract?] diff --git a/collects/web-server/private/xexpr.ss b/collects/web-server/private/xexpr.ss index 791634186d..8ad3f10d27 100644 --- a/collects/web-server/private/xexpr.ss +++ b/collects/web-server/private/xexpr.ss @@ -12,9 +12,10 @@ [pretty-xexpr/c contract?]) (define pretty-xexpr/c - (make-proj-contract - 'pretty-xexpr/c - (lambda (pos neg src-info name) + (simple-contract + #:name 'pretty-xexpr/c + #:projection + (lambda (blame) (lambda (val) (define marks (current-continuation-marks)) (with-handlers ([exn:fail:contract? @@ -25,8 +26,7 @@ marks `(span ,(drop-after "Context:\n" (exn-message exn)) "\n" ,(make-cdata #f #f (format-xexpr/errors val))))))]) - (contract xexpr/c val pos neg src-info)))) - (lambda (v) #t))) + (((contract-projection xexpr/c) blame) val)))))) (define (drop-after delim str) (match (regexp-match-positions (regexp-quote delim) str) diff --git a/collects/web-server/servlet/setup.ss b/collects/web-server/servlet/setup.ss index 414831f5f2..f50d740005 100644 --- a/collects/web-server/servlet/setup.ss +++ b/collects/web-server/servlet/setup.ss @@ -128,10 +128,7 @@ [neg-blame 'web-server] [pos-blame path-sym] [module-name `(file ,path-string)] - [mk-loc - (lambda (name) - (list (make-srcloc a-path #f #f #f #f) - name))] + [loc (make-srcloc a-path #f #f #f #f)] [s (load/use-compiled a-path)]) (cond [(void? s) @@ -139,47 +136,47 @@ (contract (symbols 'v1 'v2 'stateless) (dynamic-require module-name 'interface-version) pos-blame neg-blame - (mk-loc "interface-version"))]) + loc "interface-version")]) (case version [(v1) (let ([timeout (contract number? (dynamic-require module-name 'timeout) pos-blame neg-blame - (mk-loc "timeout"))] + loc "timeout")] [start (contract (request? . -> . response/c) (dynamic-require module-name 'start) pos-blame neg-blame - (mk-loc "start"))]) + loc "start")]) (make-v1.servlet (directory-part a-path) timeout start))] [(v2) (let ([start (contract (request? . -> . response/c) (dynamic-require module-name 'start) pos-blame neg-blame - (mk-loc "start"))] + loc "start")] [manager (contract manager? (dynamic-require module-name 'manager) pos-blame neg-blame - (mk-loc "manager"))]) + loc "manager")]) (make-v2.servlet (directory-part a-path) manager start))] [(stateless) (let ([start (contract (request? . -> . response/c) (dynamic-require module-name 'start) pos-blame neg-blame - (mk-loc "start"))] + loc "start")] [manager (contract manager? (dynamic-require module-name 'manager (lambda () (create-none-manager (lambda (req) (error "No continuations!"))))) pos-blame neg-blame - (mk-loc "manager"))] + loc "manager")] [stuffer (contract (stuffer/c serializable? bytes?) (dynamic-require module-name 'stuffer (lambda () default-stuffer)) pos-blame neg-blame - (mk-loc "stuffer"))]) + loc "stuffer")]) (make-stateless.servlet (directory-part a-path) stuffer manager start))]))] [else (make-v1.servlet (directory-part a-path) timeouts-default-servlet (v0.response->v1.lambda (contract response/c s pos-blame neg-blame - (mk-loc path-string)) + loc path-string) a-path))]))))) diff --git a/collects/web-server/stuffers/stuffer.ss b/collects/web-server/stuffers/stuffer.ss index be68b39197..57dfba47c7 100644 --- a/collects/web-server/stuffers/stuffer.ss +++ b/collects/web-server/stuffers/stuffer.ss @@ -3,22 +3,20 @@ (define-struct stuffer (in out)) (define (stuffer/c dom rng) (define in (dom . -> . rng)) - (define in-proc (contract-proc in)) + (define in-proc (contract-projection in)) (define out (rng . -> . dom)) - (define out-proc (contract-proc out)) - (make-proj-contract - (build-compound-type-name 'stuffer/c in out) - (λ (pos-blame neg-blame src-info orig-str positive-position?) - (define in-app (in-proc pos-blame neg-blame src-info orig-str positive-position?)) - (define out-app (out-proc pos-blame neg-blame src-info orig-str positive-position?)) + (define out-proc (contract-projection out)) + (simple-contract + #:name (build-compound-type-name 'stuffer/c in out) + #:projection + (λ (blame) + (define in-app (in-proc blame)) + (define out-app (out-proc blame)) (λ (val) (unless (stuffer? val) - (raise-contract-error + (raise-blame-error + blame val - src-info - pos-blame - 'ignored - orig-str "expected , given: ~e" val)) (make-stuffer From d57b5fff61b314015db39aad5ef1c7b9017502d6 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 03:38:14 +0000 Subject: [PATCH 36/78] Made source-location->string shorten collection paths. svn: r17728 --- collects/unstable/srcloc.ss | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/collects/unstable/srcloc.ss b/collects/unstable/srcloc.ss index 1eb1384416..8d99e2d5da 100644 --- a/collects/unstable/srcloc.ss +++ b/collects/unstable/srcloc.ss @@ -3,6 +3,8 @@ ;; Unstable library by: Carl Eastlund ;; intended for use in scheme/contract, so don't try to add contracts! +(require setup/main-collects) + (provide ;; type predicates @@ -126,7 +128,9 @@ (define (good-string x src line col pos span) (format "~a~a" - (or src "") + (cond [(path? src) (collects-path src)] + [(not src) ""] + [else src]) (if line (if col (format ":~a.~a" line col) @@ -137,6 +141,16 @@ (format "::~a" pos)) "")))) +(define (collects-path path) + (let* ([rel + (with-handlers ([exn:fail? (lambda (exn) path)]) + (path->main-collects-relative path))]) + (if (pair? rel) + (apply build-path + (bytes->path #"") + (map bytes->path-element (cdr rel))) + rel))) + (define (good-prefix x src line col pos span) (let ([str (good-string x src line col pos span)]) (if (string=? str "") "" (string-append str ": ")))) From 9fbf023d90b369269207e1e7ab40cbb9d8c545d8 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 03:38:55 +0000 Subject: [PATCH 37/78] Took collection path simplification out of this file. svn: r17729 --- collects/scheme/contract/private/blame.ss | 18 +----------------- 1 file changed, 1 insertion(+), 17 deletions(-) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index b7c39d0bd0..447d5de8c4 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -45,24 +45,8 @@ (current-continuation-marks) b))) -(define (simplify-source loc) - (let* ([loc (build-source-location loc)] - [src (srcloc-source loc)]) - (if (path? src) - (let* ([rel (path->main-collects-relative src)]) - (if (pair? rel) - (struct-copy srcloc loc - [source - (apply build-path - (bytes->path #"") - (map bytes->path-element (cdr rel)))]) - loc)) - loc))) - (define (default-blame-format b x custom-message) - (let* ([source-message (source-location->prefix - (simplify-source - (blame-source b)))] + (let* ([source-message (source-location->prefix (blame-source b))] [guilty-message (show (blame-guilty b))] [contract-message (show (blame-contract b))] [value-message (if (blame-value b) From 2f2068356c4d01a35ab55b6152b5e4d3b2639b4a Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 03:39:28 +0000 Subject: [PATCH 38/78] Replaced mistaken #f with srcloc. svn: r17730 --- collects/scheme/contract/private/provide.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/scheme/contract/private/provide.ss b/collects/scheme/contract/private/provide.ss index f3de8b496c..540310ee08 100644 --- a/collects/scheme/contract/private/provide.ss +++ b/collects/scheme/contract/private/provide.ss @@ -9,7 +9,8 @@ "base.ss" scheme/contract/exists "guts.ss" - unstable/location) + unstable/location + unstable/srcloc) (define-syntax (verify-contract stx) (syntax-case stx () @@ -696,7 +697,7 @@ 'not-enough-info-for-blame 'not-enough-info-for-blame '#f - '#f)) + (build-source-location #f))) ctcs vals)))))]) struct:struct-name)) From 4de3ee3a9e902cc063ac7e19ff9cc4006318ac60 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 03:41:03 +0000 Subject: [PATCH 39/78] Re-enabled 4-argument contract macro, and added more output to misuse messages. svn: r17731 --- collects/scheme/contract/private/base.ss | 48 ++++++++++++------------ 1 file changed, 24 insertions(+), 24 deletions(-) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index 72d474bbaf..643cef2bcc 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -28,17 +28,9 @@ improve method arity mismatch contract violation error messages? [(_ c v pos neg name loc) (syntax/loc stx (apply-contract c v pos neg name loc))] - [(_ a-contract to-check pos-blame-e neg-blame-e) - #| - (quasisyntax/loc stx - (contract a-contract - to-check - pos-blame-e - neg-blame-e - (build-source-location (quote-syntax #,stx)) - '#f)) - |# - (raise-syntax-error 'contract "upgrade to new calling convention" stx)] + [(_ c v pos neg) + (syntax/loc stx + (apply-contract c v pos neg #f (build-source-location #f)))] [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) #| (syntax/loc stx @@ -53,23 +45,27 @@ improve method arity mismatch contract violation error messages? (raise-syntax-error 'contract "upgrade to new calling convention" stx)])) (define (apply-contract c v pos neg name loc) - (let* ([c (coerce-contract 'contract c)]) - (check-sexp! 'contract "positive blame" pos) - (check-sexp! 'contract "negative blame" neg) - (check-sexp! 'contract "value name" name) - (check-srcloc! 'contract "source location" loc) + (let* ([c (coerce-contract 'contract c)] + [args (list c v pos neg name loc)]) + (check-sexp! 'contract "positive blame" pos args) + (check-sexp! 'contract "negative blame" neg args) + (check-sexp! 'contract "value name" name args) + (check-srcloc! 'contract "source location" loc args) (((contract-projection c) (make-blame loc name (contract-name c) pos neg #f)) v))) -(define (check-srcloc! f-name v-name v) +(define (check-srcloc! f-name v-name v args) (unless (srcloc? v) - (error f-name "expected ~a to be a srcloc structure; got: ~e" v-name v)) + (error f-name + "expected ~a to be a srcloc structure, got: ~e; all arguments: ~e" + v-name v args)) (check-sexp! f-name (format "source file of ~a" v-name) - (source-location-source v))) + (source-location-source v) + args)) -(define (check-sexp! f-name v-name v) +(define (check-sexp! f-name v-name v args) (let loop ([seen #hasheq()] [x v]) (unless (or (null? x) (boolean? x) (number? x) (string? x) (bytes? x) (regexp? x) (char? x) @@ -77,8 +73,10 @@ improve method arity mismatch contract violation error messages? (path? x)) (when (hash-has-key? seen x) (error f-name - "expected ~a to be acyclic; found a cycle in ~e at ~e" - v-name v x)) + (string-append "expected ~a to be acyclic, " + "found a cycle in ~e at ~e; " + "all arguments: ~e") + v-name v x args)) (let ([seen (hash-set seen x #t)]) (cond [(pair? x) (loop seen (car x)) (loop seen (cdr x))] @@ -89,8 +87,10 @@ improve method arity mismatch contract violation error messages? [(prefab-struct-key x) => (lambda (k) (loop seen k) (loop seen (struct->vector x)))] [else (error f-name - "expected ~a to be an s-expression; ~e contained ~e" - v-name v x)]))))) + (string-append "expected ~a to be an s-expression, " + "~e contained ~e; " + "all arguments: ~e") + v-name v x args)]))))) (define (unpack-source info) (cond From 3921e16aa10a3e61396bb487a974a3ae4062374b Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 03:41:30 +0000 Subject: [PATCH 40/78] Updated lingering use of old src-info format. svn: r17732 --- collects/scheme/contract/regions.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/scheme/contract/regions.ss b/collects/scheme/contract/regions.ss index 6058deee3a..68edea0844 100644 --- a/collects/scheme/contract/regions.ss +++ b/collects/scheme/contract/regions.ss @@ -345,7 +345,8 @@ #:guard (contract (-> super-contracts ... non-auto-contracts ... symbol? any) guard (current-contract-region) blame-id - #'maker)))))))))] + (quote maker) + (quote-srcloc maker))))))))))] [(_ name . bad-fields) (identifier? #'name) (syntax-error "expected a list of field name/contract pairs" From 722fae41a8e5e74a053336ab6e5bc32f3487870d Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 03:42:45 +0000 Subject: [PATCH 41/78] Ported more code to new contract tools. svn: r17733 --- collects/drscheme/private/debug.ss | 6 ++++-- collects/drscheme/private/tools.ss | 4 +++- collects/mzlib/private/contract-arrow.ss | 2 +- collects/mzlib/private/contract-define.ss | 14 +++++++++----- collects/syntax/private/stxparse/lib.ss | 10 ++++++---- 5 files changed, 23 insertions(+), 13 deletions(-) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 7cd39c5ca3..18a44362d0 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -335,8 +335,10 @@ profile todo: ;; =User= (define (print-planet-icon-to-stderr exn) - (when (exn:fail:contract2? exn) - (let ([table (parse-gp exn (guilty-party exn))]) + (when (exn:fail:contract:blame? exn) + (let ([table (parse-gp exn + (blame-guilty + (exn:fail:contract:blame-object exn)))]) (when table (let ([gp-url (bug-info->ticket-url table)]) (when planet-note% diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss index e446f0b925..433150ac3f 100644 --- a/collects/drscheme/private/tools.ss +++ b/collects/drscheme/private/tools.ss @@ -4,6 +4,7 @@ scheme/list scheme/runtime-path scheme/contract + unstable/location setup/getinfo mred framework @@ -326,7 +327,8 @@ name 'drscheme tool-name - (quote-syntax name))])) + (quote name) + (quote-srcloc name))])) name ctc) body)] diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index 0a9a658273..4eb6f11dfd 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -33,7 +33,7 @@ (let ([proj-x (contract-projection rngs-x)] ...) (simple-contract #:name - (build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...) + (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...) #:projection (λ (blame) (let ([p-app-x (proj-x blame)] ...) diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss index 9bc54bd3a7..df8215baa0 100644 --- a/collects/mzlib/private/contract-define.ss +++ b/collects/mzlib/private/contract-define.ss @@ -2,9 +2,11 @@ (provide define/contract) -(require (for-syntax scheme/base) +(require (for-syntax scheme/base + unstable/srcloc + (prefix-in a: scheme/contract/private/helpers)) (only-in scheme/contract contract) - (for-syntax (prefix-in a: scheme/contract/private/helpers))) + unstable/location) ;; First, we have the old define/contract implementation, which ;; is still used in mzlib/contract. @@ -12,7 +14,7 @@ (define-for-syntax (make-define/contract-transformer contract-id id) (make-set!-transformer (λ (stx) - (with-syntax ([neg-blame-str (a:build-src-loc-string stx)] + (with-syntax ([neg-blame-str (source-location->string stx)] [contract-id contract-id] [id id]) (syntax-case stx (set!) @@ -27,7 +29,8 @@ id (syntax->datum (quote-syntax f)) neg-blame-str - (quote-syntax f)) + (quote f) + (quote-srcloc f)) arg ...))] [ident @@ -37,7 +40,8 @@ id (syntax->datum (quote-syntax ident)) neg-blame-str - (quote-syntax ident)))]))))) + (quote ident) + (quote-srcloc ident)))]))))) ;; (define/contract id contract expr) ;; defines `id' with `contract'; initially binding diff --git a/collects/syntax/private/stxparse/lib.ss b/collects/syntax/private/stxparse/lib.ss index ac911fd58d..83b580e158 100644 --- a/collects/syntax/private/stxparse/lib.ss +++ b/collects/syntax/private/stxparse/lib.ss @@ -5,7 +5,8 @@ syntax/stx syntax/kerncase scheme/struct-info - scheme/contract/private/helpers + unstable/srcloc + unstable/location (for-syntax scheme/base syntax/kerncase "rep.ss" @@ -110,9 +111,10 @@ (pattern x:expr #:with c #`(contract #,ctc x - (quote #,(string->symbol (or (build-src-loc-string #'x) ""))) - (quote #,(or ')) - (quote-syntax #,(syntax/loc #'x ()))))) + (quote #,(source-location->string #'x)) + ' + #f + (quote-srcloc x)))) ;; Literal sets From 4b739b5f62688853620a67627ccb70080479a385 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 03:43:00 +0000 Subject: [PATCH 42/78] Removed obsolete build-src-loc-string svn: r17734 --- collects/scheme/contract/private/helpers.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/contract/private/helpers.ss b/collects/scheme/contract/private/helpers.ss index 8f589c6430..a4c23e30dc 100644 --- a/collects/scheme/contract/private/helpers.ss +++ b/collects/scheme/contract/private/helpers.ss @@ -1,6 +1,6 @@ #lang scheme/base -(provide unpack-blame build-src-loc-string source->name +(provide unpack-blame mangle-id mangle-id-for-maker build-struct-names lookup-struct-info From 5606c590bd78a12c057b62ef43e496a76b0581c5 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 04:57:33 +0000 Subject: [PATCH 43/78] Updated quote-syntax to quote-srcloc in mzlib unit contracts. svn: r17735 --- collects/mzlib/unit.ss | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index dec63d26fa..2ada199136 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -16,6 +16,7 @@ (require mzlib/etc scheme/contract/base scheme/stxparam + unstable/location "private/unit-contract.ss" "private/unit-keywords.ss" "private/unit-runtime.ss" @@ -482,7 +483,7 @@ (if (pair? v/c) (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) (current-contract-region) - (quote #,var) (quote-syntax #,var)) + (quote #,var) (quote-srcloc #,var)) (error 'unit "contracted import ~a used before definition" (quote #,(syntax->datum var)))))))) (quasisyntax/loc (error-syntax) @@ -748,7 +749,7 @@ (current-contract-region) 'cant-happen (quote #,id) - (quote-syntax #,id)) + (quote-srcloc #,id)) (set-box! #,export-loc (cons #,tmp (current-contract-region))))) (quasisyntax/loc defn-or-expr @@ -825,7 +826,7 @@ #`(let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - (quote #,var) (quote-syntax #,var))) + (quote #,var) (quote-srcloc #,var))) #`(#,vref)) (current-contract-region))) (if ctc @@ -833,7 +834,7 @@ (let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - (quote #,var) (quote-syntax #,var)))) + (quote #,var) (quote-srcloc #,var)))) vref))))) (car target-sig) (cadddr target-sig))) @@ -1304,7 +1305,7 @@ #`(let ([v/c (#,tb)]) (contract ctc-stx (car v/c) (cdr v/c) (current-contract-region) - (quote #,v) (quote-syntax #,v)))) + (quote #,v) (quote-srcloc #,v)))) #`(#,tb))) tbs (iota (length (car os))) @@ -1507,7 +1508,7 @@ (export (export-tagged-sig-id [e.x e.c] ...) ...))))]) (values (syntax/loc stx - (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name))) + (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name))) isigs esigs deps))))] [(ic:import-clause/contract ec:export-clause/contract . body) (build-unit/contract From e94bef69381fbeb345e706e9820499c9aa909d14 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 04:57:47 +0000 Subject: [PATCH 44/78] Updated more contracts in the mzlib collection. svn: r17736 --- collects/web-server/insta/insta.ss | 4 ++-- collects/web-server/stuffers/stuffer.ss | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/web-server/insta/insta.ss b/collects/web-server/insta/insta.ss index 2dee1bc007..57a0cdb90e 100644 --- a/collects/web-server/insta/insta.ss +++ b/collects/web-server/insta/insta.ss @@ -61,7 +61,7 @@ (provide/contract (#,start (request? . -> . response/c))) (serve/servlet (contract (request? . -> . response/c) #,start 'you 'web-server - (list (make-srcloc #f #f #f #f #f) - "start")) + (make-srcloc #f #f #f #f #f) + "start") #:extra-files-paths (if extra-files-path (list extra-files-path) empty) #:launch-browser? launch-browser?))))])) diff --git a/collects/web-server/stuffers/stuffer.ss b/collects/web-server/stuffers/stuffer.ss index 57dfba47c7..7be5cfbea6 100644 --- a/collects/web-server/stuffers/stuffer.ss +++ b/collects/web-server/stuffers/stuffer.ss @@ -22,7 +22,7 @@ (make-stuffer (in-app (stuffer-in val)) (out-app (stuffer-out val))))) - stuffer?)) + #:first-order stuffer?)) (define id-stuffer (make-stuffer From 888045dcf963018e6851a7c61622a51d1f7b0516 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 05:31:18 +0000 Subject: [PATCH 45/78] Replaced make-proj-contract with simple-contract in tests. svn: r17737 --- collects/tests/mzscheme/contract-test.ss | 41 +++++++++++------------- 1 file changed, 19 insertions(+), 22 deletions(-) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 2769651825..32fc3da79d 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -2291,49 +2291,46 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; - ;; make-proj-contract + ;; simple-contract ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (contract-eval '(define proj:add1->sub1 - (make-proj-contract - 'proj:add1->sub1 - (lambda (pos neg src name blame) + (simple-contract + #:name 'proj:add1->sub1 + #:projection + (lambda (blame) (lambda (f) (unless (and (procedure? f) (procedure-arity-includes? f 1)) - (raise-contract-error f src pos name - "expected a unary function, got: ~e" - f)) + (raise-blame-error blame f "expected a unary function, got: ~e" f)) (lambda (x) (unless (and (integer? x) (exact? x)) - (raise-contract-error x src neg name - "expected an integer, got: ~e" - x)) + (raise-blame-error (blame-swap blame) x + "expected an integer, got: ~e" x)) (let* ([y (f (add1 x))]) (unless (and (integer? y) (exact? y)) - (raise-contract-error y src pos name - "expected an integer, got: ~e" - y)) + (raise-blame-error blame y "expected an integer, got: ~e" y)) (sub1 y))))) + #:first-order (lambda (f) (and (procedure? f) (procedure-arity-includes? f 1)))))) (test/spec-passed/result - 'make-proj-contract-1 + 'simple-contract-1 '((contract proj:add1->sub1 sqrt 'pos 'neg) 15) 3) (test/pos-blame - 'make-proj-contract-2 + 'simple-contract-2 '(contract proj:add1->sub1 'dummy 'pos 'neg)) (test/pos-blame - 'make-proj-contract-3 + 'simple-contract-3 '((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2)) (test/neg-blame - 'make-proj-contract-4 + 'simple-contract-4 '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy)) ; @@ -5263,12 +5260,12 @@ '(begin (define proj:blame/c - (make-proj-contract - 'proj:blame/c - (lambda (pos neg src name blame) + (simple-contract + #:name 'proj:blame/c + #:projection + (lambda (blame) (lambda (x) - (if blame 'positive 'negative))) - (lambda (x) #t))) + (if blame 'positive 'negative))))) (define call*0 'dummy) (define (call*1 x0) x0) From 5d7774e7b280eeae451d5778b577778319fa4499 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 05:59:47 +0000 Subject: [PATCH 46/78] Fixed test for procedure?, which now recognizes flat contracts, and typo for contract-projection. svn: r17738 --- collects/scheme/contract/private/ds.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/scheme/contract/private/ds.ss b/collects/scheme/contract/private/ds.ss index e6a917a730..04ccd327bb 100644 --- a/collects/scheme/contract/private/ds.ss +++ b/collects/scheme/contract/private/ds.ss @@ -214,12 +214,12 @@ it around flattened out. (define (rewrite-fields parent contract/info ctc-x ...) (let* ([f-x (let* ([ctc-field (contract-get (contract/info-contract contract/info) selector-indicies)] - [ctc (if (procedure? ctc-field) - (ctc-field f-xs ...) - ctc-field)] + [ctc (if (contract-struct? ctc-field) + ctc-field + (ctc-field f-xs ...))] [ctc-field-val - (((contract-predicate ctc) + (((contract-projection ctc) (contract/info-blame contract/info)) ctc-x)]) (update-parent-links parent ctc-field-val) From 9d7ca20eeb7102cfa87d74c9c4887b6683d51feb Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 06:29:15 +0000 Subject: [PATCH 47/78] Replaced guilty-party with equivalent. svn: r17739 --- collects/tests/mzscheme/contract-test.ss | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 32fc3da79d..1fbed1a41a 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -7159,7 +7159,11 @@ so that propagation occurs. (and (exn? x) (regexp-match #rx"pce8-bug" (exn-message x))))) - (contract-eval `(,test 'pos guilty-party (with-handlers ((void values)) (contract not #t 'pos 'neg)))) + (contract-eval + `(,test + 'pos + (compose blame-guilty exn:fail:contract:blame-object) + (with-handlers ((void values)) (contract not #t 'pos 'neg)))) (report-errs) From 2633965c91cf9e94c11b2343d66a633bb2d5270f Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 06:29:43 +0000 Subject: [PATCH 48/78] Fixed missing keyword to simple-contract. svn: r17740 --- collects/mzlib/private/contract-arrow.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/private/contract-arrow.ss b/collects/mzlib/private/contract-arrow.ss index 4eb6f11dfd..a0e84f2186 100644 --- a/collects/mzlib/private/contract-arrow.ss +++ b/collects/mzlib/private/contract-arrow.ss @@ -43,7 +43,7 @@ (let-values ([(res-x ...) (apply val args)]) (values (p-app-x res-x) ...))) (raise-blame-error blame val "expected a procedure"))))) - procedure?))))])) + #:first-order procedure?))))])) (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func) (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] From d01e61508f51cebf1f6db08c448738900125ef40 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 07:14:00 +0000 Subject: [PATCH 49/78] Fixed a blame assignment typo. svn: r17741 --- collects/scheme/contract/private/arrow.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/contract/private/arrow.ss b/collects/scheme/contract/private/arrow.ss index 3ade7e4521..f4d63fac25 100644 --- a/collects/scheme/contract/private/arrow.ss +++ b/collects/scheme/contract/private/arrow.ss @@ -928,7 +928,7 @@ v4 todo: [rng-underscore? (box? (->d-range ->d-stct))]) (when (->d-pre-cond ->d-stct) (unless (apply (->d-pre-cond ->d-stct) dep-pre-args) - (raise-blame-error blame + (raise-blame-error (blame-swap blame) val "#:pre-cond violation~a" (build-values-string ", argument" dep-pre-args)))) From 35a716d5d36b4995c025d3e46089e3dea7a09dc8 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 07:14:17 +0000 Subject: [PATCH 50/78] Fixed blame detection regexp. svn: r17742 --- collects/tests/mzscheme/contract-mzlib-test.ss | 16 ++++++++-------- collects/tests/mzscheme/contract-test.ss | 10 +++------- 2 files changed, 11 insertions(+), 15 deletions(-) diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index 2e22f4145b..fa7a9139af 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -78,13 +78,9 @@ of the contract library does not change over time. (define (test/spec-failed name expression blame) (let () (define (has-proper-blame? msg) - (equal? - blame - (cond - [(regexp-match #rx"(^| )(.*) broke" msg) - => - (λ (x) (caddr x))] - [else (format "no blame in error message: \"~a\"" msg)]))) + (regexp-match? + (string-append "(^| )" (regexp-quote blame) " broke") + msg)) (printf "testing: ~s\n" name) (contract-eval `(,thunk-error-test @@ -5127,7 +5123,11 @@ so that propagation occurs. (and (exn? x) (regexp-match #rx"expected field name to be b, but found string?" (exn-message x))))) - (contract-eval `(,test 'pos guilty-party (with-handlers ((void values)) (contract not #t 'pos 'neg)))) + (contract-eval + `(,test + 'pos + (compose blame-guilty exn:fail:contract:blame-object) + (with-handlers ((void values)) (contract not #t 'pos 'neg)))) (report-errs) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 1fbed1a41a..ee58ba9e02 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -73,13 +73,9 @@ (define (test/spec-failed name expression blame) (let () (define (has-proper-blame? msg) - (equal? - blame - (cond - [(regexp-match #rx"(^| )(.*) broke" msg) - => - (λ (x) (caddr x))] - [else (format "no blame in error message: \"~a\"" msg)]))) + (regexp-match? + (string-append "(^| )" (regexp-quote blame) " broke") + msg)) (printf "testing: ~s\n" name) (contract-eval `(,thunk-error-test From 950649441665bc420ef761cec28ea5ae36309aa8 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 07:28:06 +0000 Subject: [PATCH 51/78] Fixed a shadowed name svn: r17743 --- collects/scheme/contract/private/ds.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scheme/contract/private/ds.ss b/collects/scheme/contract/private/ds.ss index 04ccd327bb..e9a5fbb769 100644 --- a/collects/scheme/contract/private/ds.ss +++ b/collects/scheme/contract/private/ds.ss @@ -75,7 +75,7 @@ it around flattened out. [struct:-name struct:-name/val] [struct-maker struct-maker/val] [predicate predicate/val] - [contract-name (add-suffix "-contract")] + [the-contract (add-suffix "-contract")] [(selector-indicies ...) (nums-up-to field-count/val)] [(selector-indicies+1 ...) (map add1 (nums-up-to field-count/val))] [(ctc-x ...) (generate-temporaries (syntax (fields ...)))] @@ -312,7 +312,7 @@ it around flattened out. #:stronger stronger-lazy-contract?)) (define-values (contract-type contract-maker contract-predicate contract-get contract-set) - (make-struct-type 'contract-name + (make-struct-type 'the-contract #f (+ field-count 1) ;; extra field is for synthesized attribute ctcs ;; it is a list whose first element is From e5c74e7a25967683ba02fa3f7e532f71ff937442 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 07:33:03 +0000 Subject: [PATCH 52/78] Fixed bug I introduced when changing make-proj-contract to simple-contract. svn: r17744 --- collects/tests/mzscheme/contract-test.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index ee58ba9e02..41023d5ed0 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -5261,7 +5261,7 @@ #:projection (lambda (blame) (lambda (x) - (if blame 'positive 'negative))))) + (if (blame-swapped? blame) 'negative 'positive))))) (define call*0 'dummy) (define (call*1 x0) x0) From 6d8b3a2e84d93e2a26ac037755b481971b2f2b3e Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 09:24:15 +0000 Subject: [PATCH 53/78] Added customization for unknown srclocs to source-location->prefix/string svn: r17747 --- collects/unstable/srcloc.ss | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/unstable/srcloc.ss b/collects/unstable/srcloc.ss index 8d99e2d5da..200529fa7d 100644 --- a/collects/unstable/srcloc.ss +++ b/collects/unstable/srcloc.ss @@ -69,11 +69,11 @@ (define (source-location-end x) (process-source-location x good-end bad! 'source-location-end)) -(define (source-location->string x) - (process-source-location x good-string bad! 'source-location->string)) +(define (source-location->string x [s ""]) + (process-source-location x (good-string s) bad! 'source-location->string)) -(define (source-location->prefix x) - (process-source-location x good-prefix bad! 'source-location->prefix)) +(define (source-location->prefix x [s ""]) + (process-source-location x (good-prefix s) bad! 'source-location->prefix)) (define (build-source-location . locs) (combine-source-locations locs good-srcloc bad! @@ -126,10 +126,10 @@ [(or (list? x) (vector? x)) (datum->syntax #f null x)] [else (datum->syntax #f null (vector src line col pos span))])) -(define (good-string x src line col pos span) +(define ((good-string default) x src line col pos span) (format "~a~a" (cond [(path? src) (collects-path src)] - [(not src) ""] + [(not src) default] [else src]) (if line (if col @@ -151,8 +151,8 @@ (map bytes->path-element (cdr rel))) rel))) -(define (good-prefix x src line col pos span) - (let ([str (good-string x src line col pos span)]) +(define ((good-prefix default) x src line col pos span) + (let ([str ((good-string default) x src line col pos span)]) (if (string=? str "") "" (string-append str ": ")))) (define (combine-source-locations locs good bad name) From ad9968493ec76a2b3fc803f58b43f519c47d5c6f Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 09:24:48 +0000 Subject: [PATCH 54/78] Fixed a missing blame swap. svn: r17748 --- collects/mzlib/private/contract-arr-obj-helpers.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/private/contract-arr-obj-helpers.ss b/collects/mzlib/private/contract-arr-obj-helpers.ss index de1788c37d..ea6d71c047 100644 --- a/collects/mzlib/private/contract-arr-obj-helpers.ss +++ b/collects/mzlib/private/contract-arr-obj-helpers.ss @@ -888,7 +888,7 @@ (syntax ((x ...) (begin - (check-pre-expr->pp/h val pre-expr blame) + (check-pre-expr->pp/h val pre-expr (blame-swap blame)) (let ([dom-id ((contract-projection (coerce-contract 'stx-name dom)) (blame-swap blame))] ...) From 934c775c2546157a2eae5e50d89466344fd7e19e Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 09:25:02 +0000 Subject: [PATCH 55/78] Fixed an expected contract message. svn: r17749 --- collects/mzlib/private/contract-define.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss index df8215baa0..9cd106fa94 100644 --- a/collects/mzlib/private/contract-define.ss +++ b/collects/mzlib/private/contract-define.ss @@ -14,7 +14,7 @@ (define-for-syntax (make-define/contract-transformer contract-id id) (make-set!-transformer (λ (stx) - (with-syntax ([neg-blame-str (source-location->string stx)] + (with-syntax ([neg-blame-str (source-location->string stx "<>")] [contract-id contract-id] [id id]) (syntax-case stx (set!) From ad7976079fbebf9280015d3cfb2db1434ce9d7bd Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 09:26:42 +0000 Subject: [PATCH 56/78] Kept syntax-parse expr/c error message consistent with define/contract. svn: r17750 --- collects/syntax/private/stxparse/lib.ss | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/collects/syntax/private/stxparse/lib.ss b/collects/syntax/private/stxparse/lib.ss index 83b580e158..8714e1f9bb 100644 --- a/collects/syntax/private/stxparse/lib.ss +++ b/collects/syntax/private/stxparse/lib.ss @@ -109,12 +109,13 @@ (define-syntax-class (expr/c ctc) #:attributes (c) (pattern x:expr - #:with c #`(contract #,ctc - x - (quote #,(source-location->string #'x)) - ' - #f - (quote-srcloc x)))) + #:with + c #`(contract #,ctc + x + (quote #,(source-location->string #'x "<>")) + ' + #f + (quote-srcloc x)))) ;; Literal sets From 6a0469b6809855182d2d56852190417326031be2 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 09:27:51 +0000 Subject: [PATCH 57/78] Fixed detection of printable contracts in dependent struct contracts. svn: r17751 --- collects/scheme/contract/private/ds.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/contract/private/ds.ss b/collects/scheme/contract/private/ds.ss index e9a5fbb769..c33b8f0907 100644 --- a/collects/scheme/contract/private/ds.ss +++ b/collects/scheme/contract/private/ds.ss @@ -466,7 +466,7 @@ it around flattened out. [else (let ([fields (map (λ (field ctc) - (if (contract? ctc) + (if (contract-struct? ctc) (build-compound-type-name field ctc) (build-compound-type-name field '...))) fields From 51983e3829865dc0c3f6067c79b4f258dd8c90a2 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 09:28:08 +0000 Subject: [PATCH 58/78] Fixed simple-contract stronger check. svn: r17752 --- collects/scheme/contract/private/prop.ss | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/scheme/contract/private/prop.ss b/collects/scheme/contract/private/prop.ss index 37f5636ad9..f943c739db 100644 --- a/collects/scheme/contract/private/prop.ss +++ b/collects/scheme/contract/private/prop.ss @@ -177,10 +177,15 @@ (let* ([name (or name default-name)] [first-order (or first-order any?)] [projection (or projection (first-order-projection name first-order))] - [stronger (or stronger weakest)]) + [stronger (or stronger as-strong?)]) (mk name first-order projection stronger))) +(define (as-strong? a b) + (procedure-closure-contents-eq? + (contract-struct-projection a) + (contract-struct-projection b))) + (define simple-contract (build-contract make-simple-contract 'simple-contract)) From 791178a5492e73fa6eb7a2c9f2b1346ebe671095 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 09:28:28 +0000 Subject: [PATCH 59/78] Fixed printing of blame error messages to use display and write appropriately. svn: r17753 --- collects/scheme/contract/private/blame.ss | 20 ++++++++++++++------ 1 file changed, 14 insertions(+), 6 deletions(-) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index 447d5de8c4..73df3ad37a 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -47,10 +47,10 @@ (define (default-blame-format b x custom-message) (let* ([source-message (source-location->prefix (blame-source b))] - [guilty-message (show (blame-guilty b))] - [contract-message (show (blame-contract b))] + [guilty-message (show/display (blame-guilty b))] + [contract-message (show/write (blame-contract b))] [value-message (if (blame-value b) - (format " on ~a" (show (blame-value b))) + (format " on ~a" (show/display (blame-value b))) "")]) (format "~a~a broke the contract ~a~a; ~a" source-message @@ -59,15 +59,23 @@ value-message custom-message))) -(define (show v) +(define ((show f) v) (let* ([line (parameterize ([pretty-print-columns 'infinity]) - (pretty-format v))]) + (f v))]) (if (< (string-length line) 30) line (parameterize ([pretty-print-print-line show-line-break] [pretty-print-columns 50]) - (pretty-format v))))) + (f v))))) + +(define (pretty-format/display v [columns (pretty-print-columns)]) + (let ([port (open-output-string)]) + (pretty-display v port) + (get-output-string port))) + +(define show/display (show pretty-format/display)) +(define show/write (show pretty-format)) (define (show-line-break line port len cols) (newline port) From 87645ebd114088d1b1fb368df01c1ba2253eb90c Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 10:44:27 +0000 Subject: [PATCH 60/78] Updated typed scheme to use a module path for blame. svn: r17754 --- collects/typed-scheme/typecheck/tc-toplevel.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index 328123f615..9919da85d4 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -18,6 +18,7 @@ "def-binding.ss" (for-template "internal-forms.ss" + unstable/location mzlib/contract scheme/base)) @@ -257,7 +258,7 @@ ([the-variable-reference (generate-temporary #'blame)] [((new-provs ...) ...) (map (generate-prov stx-defs val-defs #'the-variable-reference) provs)]) #`(begin - (define the-variable-reference (#%variable-reference)) + (define the-variable-reference (quote-module-path)) #,(env-init-code) #,(tname-env-init-code) #,(talias-env-init-code) From 7f58c26709c9a97623f50ec812727daa080b155b Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 19 Jan 2010 23:25:07 +0000 Subject: [PATCH 61/78] Replaced uses of quote-srcloc with quote-syntax. svn: r17757 --- collects/drscheme/private/tools.ss | 3 +-- collects/mzlib/private/contract-define.ss | 7 +++---- collects/mzlib/unit.ss | 13 ++++++------- collects/scheme/contract/private/base.ss | 4 ++-- collects/scheme/contract/private/provide.ss | 4 ++-- collects/scheme/contract/regions.ss | 15 +++++++-------- collects/syntax/private/stxparse/lib.ss | 3 +-- collects/typed-scheme/utils/require-contract.ss | 5 ++--- 8 files changed, 24 insertions(+), 30 deletions(-) diff --git a/collects/drscheme/private/tools.ss b/collects/drscheme/private/tools.ss index 433150ac3f..c8c49f9300 100644 --- a/collects/drscheme/private/tools.ss +++ b/collects/drscheme/private/tools.ss @@ -4,7 +4,6 @@ scheme/list scheme/runtime-path scheme/contract - unstable/location setup/getinfo mred framework @@ -328,7 +327,7 @@ 'drscheme tool-name (quote name) - (quote-srcloc name))])) + (quote-syntax name))])) name ctc) body)] diff --git a/collects/mzlib/private/contract-define.ss b/collects/mzlib/private/contract-define.ss index 9cd106fa94..cf76531378 100644 --- a/collects/mzlib/private/contract-define.ss +++ b/collects/mzlib/private/contract-define.ss @@ -5,8 +5,7 @@ (require (for-syntax scheme/base unstable/srcloc (prefix-in a: scheme/contract/private/helpers)) - (only-in scheme/contract contract) - unstable/location) + (only-in scheme/contract contract)) ;; First, we have the old define/contract implementation, which ;; is still used in mzlib/contract. @@ -30,7 +29,7 @@ (syntax->datum (quote-syntax f)) neg-blame-str (quote f) - (quote-srcloc f)) + (quote-syntax f)) arg ...))] [ident @@ -41,7 +40,7 @@ (syntax->datum (quote-syntax ident)) neg-blame-str (quote ident) - (quote-srcloc ident)))]))))) + (quote-syntax ident)))]))))) ;; (define/contract id contract expr) ;; defines `id' with `contract'; initially binding diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 2ada199136..dec63d26fa 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -16,7 +16,6 @@ (require mzlib/etc scheme/contract/base scheme/stxparam - unstable/location "private/unit-contract.ss" "private/unit-keywords.ss" "private/unit-runtime.ss" @@ -483,7 +482,7 @@ (if (pair? v/c) (contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c) (current-contract-region) - (quote #,var) (quote-srcloc #,var)) + (quote #,var) (quote-syntax #,var)) (error 'unit "contracted import ~a used before definition" (quote #,(syntax->datum var)))))))) (quasisyntax/loc (error-syntax) @@ -749,7 +748,7 @@ (current-contract-region) 'cant-happen (quote #,id) - (quote-srcloc #,id)) + (quote-syntax #,id)) (set-box! #,export-loc (cons #,tmp (current-contract-region))))) (quasisyntax/loc defn-or-expr @@ -826,7 +825,7 @@ #`(let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - (quote #,var) (quote-srcloc #,var))) + (quote #,var) (quote-syntax #,var))) #`(#,vref)) (current-contract-region))) (if ctc @@ -834,7 +833,7 @@ (let ([old-v/c (#,vref)]) (contract ctc-stx (car old-v/c) (cdr old-v/c) (current-contract-region) - (quote #,var) (quote-srcloc #,var)))) + (quote #,var) (quote-syntax #,var)))) vref))))) (car target-sig) (cadddr target-sig))) @@ -1305,7 +1304,7 @@ #`(let ([v/c (#,tb)]) (contract ctc-stx (car v/c) (cdr v/c) (current-contract-region) - (quote #,v) (quote-srcloc #,v)))) + (quote #,v) (quote-syntax #,v)))) #`(#,tb))) tbs (iota (length (car os))) @@ -1508,7 +1507,7 @@ (export (export-tagged-sig-id [e.x e.c] ...) ...))))]) (values (syntax/loc stx - (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-srcloc name))) + (contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name))) isigs esigs deps))))] [(ic:import-clause/contract ec:export-clause/contract . body) (build-unit/contract diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index 643cef2bcc..b1bf9dcdb8 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -56,9 +56,9 @@ improve method arity mismatch contract violation error messages? v))) (define (check-srcloc! f-name v-name v args) - (unless (srcloc? v) + (unless (source-location? v) (error f-name - "expected ~a to be a srcloc structure, got: ~e; all arguments: ~e" + "expected ~a to be a source location, got: ~e; all arguments: ~e" v-name v args)) (check-sexp! f-name (format "source file of ~a" v-name) diff --git a/collects/scheme/contract/private/provide.ss b/collects/scheme/contract/private/provide.ss index 540310ee08..aa30d49080 100644 --- a/collects/scheme/contract/private/provide.ss +++ b/collects/scheme/contract/private/provide.ss @@ -46,7 +46,7 @@ pos-module-source (quote-module-path) 'id - (quote-srcloc id))))))]) + (quote-syntax id))))))]) (when key (hash-set! saved-id-table key lifted-id)) ;; Expand to a use of the lifted expression: @@ -662,7 +662,7 @@ (syntax-local-lift-module-end-declaration #`(begin (unless extra-test - (contract contract-id id pos-module-source 'ignored 'id (quote-srcloc id))) + (contract contract-id id pos-module-source 'ignored 'id (quote-syntax id))) (void))) (syntax (code id-rename))))))])) diff --git a/collects/scheme/contract/regions.ss b/collects/scheme/contract/regions.ss index 68edea0844..758e2ca916 100644 --- a/collects/scheme/contract/regions.ss +++ b/collects/scheme/contract/regions.ss @@ -11,7 +11,6 @@ syntax/kerncase (prefix-in a: "private/helpers.ss")) scheme/splicing - unstable/location "private/arrow.ss" "private/base.ss" "private/guts.ss") @@ -314,7 +313,7 @@ '(struct name) 'cant-happen (quote #,av-id) - (quote-srcloc #,av-id)))))] + (quote-syntax #,av-id)))))] ;; a list of variables, one for each super field [(super-fields ...) (generate-temporaries super-fields)] ;; the contract for a super field is any/c becuase the @@ -346,7 +345,7 @@ guard (current-contract-region) blame-id (quote maker) - (quote-srcloc maker))))))))))] + (quote-syntax maker))))))))))] [(_ name . bad-fields) (identifier? #'name) (syntax-error "expected a list of field name/contract pairs" @@ -385,7 +384,7 @@ #,neg-blame-id #,pos-blame-id (quote #,id) - (quote-srcloc #,id))))] + (quote-syntax #,id))))] [(f arg ...) (quasisyntax/loc stx ((contract #,contract-stx @@ -393,7 +392,7 @@ #,pos-blame-id #,neg-blame-id (quote #,id) - (quote-srcloc #,id)) + (quote-syntax #,id)) arg ...))] [ident (identifier? (syntax ident)) @@ -403,7 +402,7 @@ #,pos-blame-id #,neg-blame-id (quote #,id) - (quote-srcloc #,id)))])))) + (quote-syntax #,id)))])))) (define-for-syntax (check-and-split-with-contracts args) (let loop ([args args] @@ -551,7 +550,7 @@ blame-id 'cant-happen (quote free-var) - (quote-srcloc free-var)) + (quote-syntax free-var)) ... (values))) (define-syntaxes (free-var-id ...) @@ -569,7 +568,7 @@ blame-stx 'cant-happen (quote marked-p) - (quote-srcloc marked-p)) + (quote-syntax marked-p)) ... (values))) (define-syntaxes (p ...) diff --git a/collects/syntax/private/stxparse/lib.ss b/collects/syntax/private/stxparse/lib.ss index 8714e1f9bb..0513e79599 100644 --- a/collects/syntax/private/stxparse/lib.ss +++ b/collects/syntax/private/stxparse/lib.ss @@ -6,7 +6,6 @@ syntax/kerncase scheme/struct-info unstable/srcloc - unstable/location (for-syntax scheme/base syntax/kerncase "rep.ss" @@ -115,7 +114,7 @@ (quote #,(source-location->string #'x "<>")) ' #f - (quote-srcloc x)))) + (quote-syntax x)))) ;; Literal sets diff --git a/collects/typed-scheme/utils/require-contract.ss b/collects/typed-scheme/utils/require-contract.ss index 8d71a4d1ec..f1d9737f2c 100644 --- a/collects/typed-scheme/utils/require-contract.ss +++ b/collects/typed-scheme/utils/require-contract.ss @@ -1,7 +1,6 @@ #lang scheme/base (require scheme/contract - unstable/location (for-syntax scheme/base syntax/kerncase syntax/parse @@ -46,7 +45,7 @@ '(interface for #,(syntax->datum #'nm)) 'never-happen (quote nm) - (quote-srcloc nm))))] + (quote-syntax nm))))] [(require/contract (orig-nm:renameable nm:id) cnt lib) #`(begin (require (only-in lib [orig-nm orig-nm.r])) (define-ignored nm @@ -55,4 +54,4 @@ '#,(syntax->datum #'nm) 'never-happen (quote nm) - (quote-srcloc nm))))])) + (quote-syntax nm))))])) From 88aba214c95b8ba588405972611fd1bca049d157 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 23 Jan 2010 17:44:27 +0000 Subject: [PATCH 62/78] Merged changes from trunk. No conflicts. svn: r17780 --- collects/2htdp/image.ss | 5 +- collects/2htdp/private/image-more.ss | 6 +- collects/2htdp/private/img-err.ss | 3 + .../2htdp/tests/robby-optimization-gone.ss | 4 +- collects/2htdp/universe.ss | 5 + collects/honu/main.ss | 9 +- collects/honu/private/honu-typed-scheme.ss | 127 ++++++++- collects/honu/private/util.ss | 18 +- collects/meta/dist-specs.ss | 1 + collects/mrlib/image-core.ss | 2 +- collects/repos-time-stamp/stamp.ss | 2 +- collects/syntax/private/stxparse/rep.ss | 2 +- .../syntax/scribblings/parse-patterns.scrbl | 12 + .../teachpack/2htdp/scribblings/image.scrbl | 254 +++++++++++++----- .../2htdp/scribblings/img/10735f73f78.png | Bin 116 -> 108 bytes .../2htdp/scribblings/img/10847861f4b.png | Bin 1292 -> 1277 bytes .../2htdp/scribblings/img/10a0d35fa03.png | Bin 2107 -> 2077 bytes .../2htdp/scribblings/img/1132401ea93.png | Bin 1467 -> 1465 bytes .../2htdp/scribblings/img/11402043018.png | Bin 618 -> 608 bytes .../2htdp/scribblings/img/11b64ab4d3.png | Bin 593 -> 590 bytes .../2htdp/scribblings/img/126418b230e.png | Bin 484 -> 479 bytes .../2htdp/scribblings/img/12948ac080d.png | Bin 216 -> 208 bytes .../2htdp/scribblings/img/12b0447b10c.png | Bin 436 -> 430 bytes .../2htdp/scribblings/img/1325a6e7bdb.png | Bin 1028 -> 1014 bytes .../2htdp/scribblings/img/133309751d2.png | Bin 134 -> 128 bytes .../2htdp/scribblings/img/138792ad221.png | Bin 713 -> 700 bytes .../2htdp/scribblings/img/13aef4074e9.png | Bin 471 -> 466 bytes .../2htdp/scribblings/img/13b344ed2ff.png | Bin 508 -> 497 bytes .../2htdp/scribblings/img/13e518b230e.png | Bin 580 -> 564 bytes .../2htdp/scribblings/img/1404e4b2af.png | Bin 822 -> 813 bytes .../2htdp/scribblings/img/150e1d5e9f.png | Bin 159 -> 159 bytes .../2htdp/scribblings/img/1532990d5cb.png | Bin 2316 -> 2265 bytes .../2htdp/scribblings/img/15717b87d30.png | Bin 135 -> 128 bytes .../2htdp/scribblings/img/157ab5efca7.png | Bin 135 -> 128 bytes .../2htdp/scribblings/img/164b8da7bf6.png | Bin 1787 -> 1797 bytes .../2htdp/scribblings/img/169990a635e.png | Bin 3767 -> 3766 bytes .../2htdp/scribblings/img/169f2ceb45c.png | Bin 1061 -> 1058 bytes .../2htdp/scribblings/img/16a631adf1e.png | Bin 111 -> 106 bytes .../2htdp/scribblings/img/196bfa7b9c4.png | Bin 616 -> 600 bytes .../2htdp/scribblings/img/1a0088e3819.png | Bin 305 -> 321 bytes .../2htdp/scribblings/img/1aaa434b462.png | Bin 816 -> 810 bytes .../2htdp/scribblings/img/1acede17bc6.png | Bin 1759 -> 1751 bytes .../2htdp/scribblings/img/1bbeedc0d6.png | Bin 1078 -> 1073 bytes .../2htdp/scribblings/img/1f0b671ed7b.png | Bin 119 -> 112 bytes .../2htdp/scribblings/img/1f5944ec1ed.png | Bin 269 -> 262 bytes .../2htdp/scribblings/img/201c231dce2.png | Bin 772 -> 745 bytes .../2htdp/scribblings/img/2187216ca96.png | Bin 1007 -> 1007 bytes .../2htdp/scribblings/img/21b080bdda8.png | Bin 1439 -> 1421 bytes .../2htdp/scribblings/img/2330a222ac0.png | Bin 4089 -> 4083 bytes .../2htdp/scribblings/img/24365c877d4.png | Bin 1172 -> 1167 bytes .../2htdp/scribblings/img/24410dd26db.png | Bin 1514 -> 1516 bytes .../2htdp/scribblings/img/24e80ea10b4.png | Bin 1484 -> 1485 bytes .../2htdp/scribblings/img/25354f2b84e.png | Bin 535 -> 522 bytes .../2htdp/scribblings/img/25451dd2997.png | Bin 398 -> 358 bytes .../2htdp/scribblings/img/25dd3e2d97c.png | Bin 985 -> 923 bytes .../2htdp/scribblings/img/262a4fa650a.png | Bin 1572 -> 1542 bytes .../2htdp/scribblings/img/268c974b9ab.png | Bin 288 -> 270 bytes .../2htdp/scribblings/img/26bd803042c.png | Bin 119 -> 112 bytes .../2htdp/scribblings/img/26c4c403875.png | Bin 1471 -> 1462 bytes .../2htdp/scribblings/img/2758748ad7f.png | Bin 1516 -> 1503 bytes .../2htdp/scribblings/img/27bbbb6fd64.png | Bin 1402 -> 1388 bytes .../2htdp/scribblings/img/28253f4c3c.png | Bin 967 -> 966 bytes .../2htdp/scribblings/img/28c73238138.png | Bin 1821 -> 1803 bytes .../2htdp/scribblings/img/28daec71a64.png | Bin 1043 -> 1038 bytes .../2htdp/scribblings/img/29b31e5fe3a.png | Bin 694 -> 686 bytes .../2htdp/scribblings/img/2a1f3988f.png | Bin 1203 -> 1188 bytes .../2htdp/scribblings/img/2b944b7ab91.png | Bin 1262 -> 1235 bytes .../2htdp/scribblings/img/2cc717fb347.png | Bin 1384 -> 1375 bytes .../2htdp/scribblings/img/2d9ba9032e.png | Bin 616 -> 600 bytes .../2htdp/scribblings/img/2dde939d6dc.png | Bin 773 -> 765 bytes .../2htdp/scribblings/img/2e6a31a9033.png | Bin 676 -> 657 bytes .../2htdp/scribblings/img/353ed4578.png | Bin 1203 -> 1188 bytes .../2htdp/scribblings/img/42f9f9e4cf.png | Bin 134 -> 128 bytes .../2htdp/scribblings/img/4e85791a5.png | Bin 744 -> 730 bytes .../2htdp/scribblings/img/54a488e1a5.png | Bin 2116 -> 2082 bytes .../2htdp/scribblings/img/54d58bf7f6.png | Bin 474 -> 460 bytes .../2htdp/scribblings/img/5ec4a0cb1f.png | Bin 868 -> 861 bytes .../2htdp/scribblings/img/69aaaa680d.png | Bin 216 -> 208 bytes .../2htdp/scribblings/img/6a5a617f28.png | Bin 499 -> 446 bytes .../2htdp/scribblings/img/6c262f1d24.png | Bin 530 -> 529 bytes .../2htdp/scribblings/img/6efa12ea15.png | Bin 1348 -> 1315 bytes .../2htdp/scribblings/img/72aef3dc67.png | Bin 736 -> 738 bytes .../2htdp/scribblings/img/7bbcc7cbaa.png | Bin 1118 -> 1111 bytes .../2htdp/scribblings/img/89a0d469a7.png | Bin 168 -> 159 bytes .../2htdp/scribblings/img/89b3a9e462.png | Bin 1257 -> 1231 bytes .../2htdp/scribblings/img/8cb34e62d4.png | Bin 826 -> 796 bytes .../2htdp/scribblings/img/8e1ebaaf82.png | Bin 225 -> 213 bytes .../2htdp/scribblings/img/8e7c1870c7.png | Bin 490 -> 489 bytes .../2htdp/scribblings/img/957fe78565.png | Bin 130 -> 124 bytes .../2htdp/scribblings/img/969a9aa483.png | Bin 206 -> 201 bytes .../2htdp/scribblings/img/9858b8d5d.png | Bin 793 -> 777 bytes .../2htdp/scribblings/img/aac8b78b6e.png | Bin 1395 -> 1394 bytes .../2htdp/scribblings/img/ab1841ea36.png | Bin 390 -> 383 bytes .../2htdp/scribblings/img/aeddf66d5d.png | Bin 461 -> 460 bytes .../2htdp/scribblings/img/b32ce6fcc5.png | Bin 1238 -> 1239 bytes .../2htdp/scribblings/img/cf131e14ad.png | Bin 708 -> 692 bytes .../2htdp/scribblings/img/d417a51b4.png | Bin 130 -> 120 bytes .../2htdp/scribblings/img/d47072011e.png | Bin 667 -> 676 bytes .../2htdp/scribblings/img/d629961aee.png | Bin 993 -> 989 bytes .../2htdp/scribblings/img/d92d6a49f1.png | Bin 676 -> 657 bytes .../2htdp/scribblings/img/eb99639e31.png | Bin 1949 -> 1911 bytes .../2htdp/scribblings/img/fa1a9f17b6.png | Bin 1348 -> 1315 bytes .../2htdp/scribblings/img/fdaad0760b.png | Bin 1176 -> 1220 bytes .../2htdp/scribblings/img/ff11314e4e.png | Bin 1664 -> 1636 bytes .../2htdp/scribblings/img/ff2fcb7b87.png | Bin 207 -> 202 bytes .../teachpack/2htdp/scribblings/port.scrbl | 179 +++++++++--- collects/teachpack/2htdp/scribblings/port.ss | 3 +- .../2htdp/scribblings/universe.scrbl | 6 +- collects/tests/drscheme/README.ss | 5 +- collects/tests/stxparse/stxclass.ss | 26 +- .../scribblings/stateless-usage.scrbl | 4 +- 111 files changed, 534 insertions(+), 139 deletions(-) diff --git a/collects/2htdp/image.ss b/collects/2htdp/image.ss index 6fcdd1c1dd..fb81e88b3a 100644 --- a/collects/2htdp/image.ss +++ b/collects/2htdp/image.ss @@ -101,11 +101,14 @@ and they all have good sample contracts. (It is amazing what we can do with kids angle? side-count? image-color? + pen-style? + pen-cap? + pen-join? (rename-out [build-color make-color]) color-red color-blue color-green color? color (rename-out [build-pen make-pen]) - pen-color pen-width pen-style pen-cap pen-join + pen-color pen-width pen-style pen-cap pen-join pen image-width image-height diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss index 4ce7b08f4b..4af533fb28 100644 --- a/collects/2htdp/private/image-more.ss +++ b/collects/2htdp/private/image-more.ss @@ -59,12 +59,12 @@ (define (save-image pre-image filename) (let* ([image (to-img pre-image)] [bm (make-object bitmap% - (inexact->exact (ceiling (+ 2 (get-right image)))) - (inexact->exact (ceiling (+ 2 (get-bottom image)))))] + (inexact->exact (ceiling (+ 1 (get-right image)))) + (inexact->exact (ceiling (+ 1 (get-bottom image)))))] [bdc (make-object bitmap-dc% bm)]) (send bdc set-smoothing 'aligned) (send bdc clear) - (render-image image bdc 1 1) + (render-image image bdc 0 0) (send bdc set-bitmap #f) (send bm save-file filename 'png))) diff --git a/collects/2htdp/private/img-err.ss b/collects/2htdp/private/img-err.ss index 2903a3bf4e..2b072c8ac7 100644 --- a/collects/2htdp/private/img-err.ss +++ b/collects/2htdp/private/img-err.ss @@ -8,6 +8,9 @@ angle? side-count? image-color? + pen-style? + pen-cap? + pen-join? image-snip->image bitmap->image check-mode/color-combination) diff --git a/collects/2htdp/tests/robby-optimization-gone.ss b/collects/2htdp/tests/robby-optimization-gone.ss index 8da68f8615..528df04b92 100644 --- a/collects/2htdp/tests/robby-optimization-gone.ss +++ b/collects/2htdp/tests/robby-optimization-gone.ss @@ -1,4 +1,4 @@ -#lang scheme +#lang scheme/gui (require 2htdp/universe) (require 2htdp/image) @@ -17,4 +17,4 @@ (set! s (string-append "-" s)) (rectangle 1 1 'solid 'green))))) -(unless (string=? s "---") (error 'world-update-test "failed! ~s" s)) \ No newline at end of file +(unless (string=? s "---") (error 'world-update-test "failed! ~s" s)) diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss index 4fd00f1823..2d41d5960c 100644 --- a/collects/2htdp/universe.ss +++ b/collects/2htdp/universe.ss @@ -1,6 +1,11 @@ #lang scheme/gui #| TODO: + -- yield instead of sync + -- run callbacks in user eventspace + -- make timer fire just once; restart after on-tick callback finishes + -- take out counting; replace by 0.25 delay + -- 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. diff --git a/collects/honu/main.ss b/collects/honu/main.ss index 4f4d51080f..276d7b890a 100644 --- a/collects/honu/main.ss +++ b/collects/honu/main.ss @@ -4,13 +4,18 @@ "private/macro.ss") (provide (rename-out (#%dynamic-honu-module-begin #%module-begin) - (honu-top #%top)) + (honu-top #%top) + (semicolon \;) + (honu-+ +) + (honu-* *) + (honu-/ /) + (honu-- -) + ) #%datum true false display newline - \; else (rename-out (honu-if if) diff --git a/collects/honu/private/honu-typed-scheme.ss b/collects/honu/private/honu-typed-scheme.ss index bf7f30046b..1c767b9618 100644 --- a/collects/honu/private/honu-typed-scheme.ss +++ b/collects/honu/private/honu-typed-scheme.ss @@ -6,6 +6,7 @@ syntax/name syntax/define syntax/parse + scheme/splicing "contexts.ss" "util.ss" "ops.ss" @@ -13,16 +14,25 @@ ;; "typed-utils.ss" ) +(require (for-meta 2 scheme/base "util.ss")) +(require (for-meta 3 scheme/base)) + (provide (all-defined-out)) ;; macro for defining literal tokens that can be used in macros -(define-syntax-rule (define-literal name) - (define-syntax name (lambda (stx) +(define-syntax-rule (define-literal name ...) + (begin + (define-syntax name (lambda (stx) (raise-syntax-error 'name - "this is a literal and cannot be used outside a macro")))) + "this is a literal and cannot be used outside a macro"))) + ...)) (define-literal honu-return) -(define-literal \;) +(define-literal semicolon) +(define-literal honu-+ honu-* honu-/ honu-- honu-|| honu-% + honu-= honu-+= honu--= honu-*= honu-/= honu-%= + honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>= + honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->=) ;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx)) @@ -338,6 +348,13 @@ [else (call-values parse-one (extract-until body (list #'\; )))])) +#| +(define-honu-macro (e ... * e ... \;)) + +(foo . bar ()) +x(2) +|# + (define (parse-block-one/2 stx context) (define (parse-one stx context) (define-syntax-class block @@ -349,18 +366,106 @@ body.result)]) (define-syntax-class expr [pattern f]) + (define-splicing-syntax-class call - [pattern (~seq e:expr (#%parens args ...)) - #:with call #'(e args ...)]) - (define-syntax-class expression - #:literals (\;) - [pattern (call:call \; . rest) #:with result #'call.call] - [pattern (x:number \; . rest) #:with result #'x] + [pattern (~seq e:expr (#%parens arg:expression-1)) + #:with call #'(e arg.result)]) + (define-splicing-syntax-class expression-last + [pattern (~seq call:call) #:with result #'call.call] + [pattern (~seq x:number) #:with result #'x] ) + + (define-syntax-rule (define-infix-operator name next [operator reducer] ...) + (define-splicing-syntax-class name + #:literals (operator ...) + [pattern (~seq (~var left next) operator (~var right name)) + #:with result (reducer #'left.result #'right.result)] + ... + [pattern (~seq (~var exp next)) + #:with result #'exp.result] + )) + + ;; TODO: maybe just have a precedence macro that creates all these constructs + ;; (infix-operators ([honu-* ...] + ;; [honu-- ...]) + ;; ([honu-+ ...] + ;; [honu-- ...])) + ;; Where operators defined higher in the table have higher precedence. + (define-syntax (infix-operators stx) + (define (create-stuff names operator-stuff) + (define make (syntax-lambda (expression next-expression operator-stuff) + #; + (printf "Make infix ~a ~a\n" (syntax->datum #'expression) (syntax->datum #'next-expression)) + (with-syntax ([(ops ...) #'operator-stuff]) + #'(define-infix-operator expression next-expression ops ...)))) + (for/list ([name1 (drop-last names)] + [name2 (cdr names)] + [operator operator-stuff]) + (make name1 name2 operator))) + (syntax-case stx () + [(_ first last operator-stuff ...) + (with-syntax ([(name ...) (generate-temporaries #'(operator-stuff ...))]) + (with-syntax ([(result ...) (create-stuff (cons #'first + (append + (drop-last (syntax->list #'(name ...))) + (list #'last))) + + (syntax->list #'(operator-stuff ...)))]) + #'(begin + result ...)))])) + + #; + (infix-operators expression-1 expression-last + ([honu-+ (syntax-lambda (left right) + #'(+ left right))] + [honu-- (syntax-lambda (left right) + #'(- left right))]) + ([honu-* (syntax-lambda (left right) + #'(* left right))] + [honu-/ (syntax-lambda (left right) + #'(/ left right))])) + + + (define-syntax-class expression-top + [pattern (e:expression-1 semicolon . rest) + #:with result #'e.result]) + + + ;; infix operators in the appropriate precedence level + ;; things defined lower in the table have a higher precedence. + ;; the first set of operators is `expression-1' + (splicing-let-syntax ([sl (make-rename-transformer #'syntax-lambda)]) + (infix-operators expression-1 expression-last + ([honu-= (sl (left right) #'(= left right))] + [honu-+= (sl (left right) #'(+ left right))] + [honu--= (sl (left right) #'(- left right))] + [honu-*= (sl (left right) #'(* left right))] + [honu-/= (sl (left right) #'(/ left right))] + [honu-%= (sl (left right) #'(modulo left right))] + [honu-&= (sl (left right) #'(+ left right))] + [honu-^= (sl (left right) #'(+ left right))] + [honu-\|= (sl (left right) #'(+ left right))] + [honu-<<= (sl (left right) #'(+ left right))] + [honu->>= (sl (left right) #'(+ left right))] + [honu->>>= (sl (left right) #'(+ left right))]) + ([honu-|| (sl (left right) #'(+ left right))]) + ([honu->> (sl (left right) #'(+ left right))] + [honu-<< (sl (left right) #'(+ left right))] + [honu->>> (sl (left right) #'(+ left right))] + [honu-< (sl (left right) #'(< left right))] + [honu-> (sl (left right) #'(> left right))] + [honu-<= (sl (left right) #'(<= left right))] + [honu->= (sl (left right) #'(>= left right))]) + ([honu-+ (sl (left right) #'(+ left right))] + [honu-- (sl (left right) #'(- left right))]) + ([honu-* (sl (left right) #'(* left right))] + [honu-% (sl (left right) #'(modulo left right))] + [honu-/ (sl (left right) #'(/ left right))]))) + ;; (printf "~a\n" (syntax-class-parse function stx)) (syntax-parse stx [function:function (values #'function.result #'function.rest)] - [expr:expression (values #'expr.result #'expr.rest)] + [expr:expression-top (values #'expr.result #'expr.rest)] [(x:number . rest) (values #'x #'rest)] )) (cond diff --git a/collects/honu/private/util.ss b/collects/honu/private/util.ss index fe11586a0f..5120dd3cfa 100644 --- a/collects/honu/private/util.ss +++ b/collects/honu/private/util.ss @@ -1,11 +1,14 @@ #lang scheme +(provide (except-out (all-defined-out) test)) +#; (provide delim-identifier=? extract-until call-values) -(require syntax/stx) +(require syntax/stx + scheme/list) (define (delim-identifier=? a b) (eq? (syntax-e a) (syntax-e b))) @@ -33,6 +36,19 @@ (define-syntax-rule (call-values function values-producing) (call-with-values (lambda () values-producing) function)) +;; shortcut for treating arguments as syntax objects +(define-syntax (syntax-lambda stx) + (syntax-case stx () + [(_ (arg ...) body ...) + (with-syntax ([(temp ...) (generate-temporaries #'(arg ...))]) + #'(lambda (temp ...) + (with-syntax ([arg temp] ...) + body ...)))])) + +;; removes the last element of a list +(define (drop-last lst) + (take lst (sub1 (length lst)))) + (define (test) (let* ([original #'(a b c d e)] [delimiter #'c] diff --git a/collects/meta/dist-specs.ss b/collects/meta/dist-specs.ss index da8a2722ab..b96401b67b 100644 --- a/collects/meta/dist-specs.ss +++ b/collects/meta/dist-specs.ss @@ -91,6 +91,7 @@ i386-linux-fc6 :=tag unix i386-linux-f7 :=tag unix x86_64-linux-f7 :=tag unix i386-linux-f9 :=tag unix +i386-linux-f12 :=tag unix i386-linux-debian :=tag unix i386-linux-debian-testing :=tag unix i386-linux-debian-unstable :=tag unix diff --git a/collects/mrlib/image-core.ss b/collects/mrlib/image-core.ss index 29e02a9ae0..ceee10e07c 100644 --- a/collects/mrlib/image-core.ss +++ b/collects/mrlib/image-core.ss @@ -908,7 +908,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! curve-segment-start curve-segment-s-angle curve-segment-s-pull curve-segment-end curve-segment-e-angle curve-segment-e-pull curve-segment-color - make-pen pen? pen-color pen-width pen-style pen-cap pen-join + make-pen pen? pen-color pen-width pen-style pen-cap pen-join pen make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale bitmap-rendered-bitmap bitmap-rendered-mask diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 9a66d363f5..df4650e6ca 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "16jan2010") +#lang scheme/base (provide stamp) (define stamp "23jan2010") diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index e5d993b059..b0a31a43c3 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -973,7 +973,7 @@ (define (check-sc-expr x) (syntax-case x () [sc (identifier? #'sc) (list #'sc null)] - [(sc arg ...) (identifier? #'sc) (list #'sc #'(arg ...))] + [(sc arg ...) (identifier? #'sc) (list #'sc (syntax->list #'(arg ...)))] [_ (raise-syntax-error #f "expected syntax class use" ctx x)])) (syntax-case stx () [(rx sc) diff --git a/collects/syntax/scribblings/parse-patterns.scrbl b/collects/syntax/scribblings/parse-patterns.scrbl index 17a999542f..81cdceb011 100644 --- a/collects/syntax/scribblings/parse-patterns.scrbl +++ b/collects/syntax/scribblings/parse-patterns.scrbl @@ -104,6 +104,7 @@ means specifically @tech{@Spattern}. (~not S-pattern) #((unsyntax @svar[pattern-part]) ...) #s(prefab-struct-key (unsyntax @svar[pattern-part]) ...) + #&@#,svar[S-pattern] (~rest S-pattern) (@#,ref[~describe s] expr S-pattern) A-pattern] @@ -515,6 +516,17 @@ key and whose sequence of fields, when considered as a list, match the ] } +@specsubform[#&@#,svar[S-pattern]]{ + +Matches a term that is a box whose contents matches the inner +@tech{@Spattern}. + +@myexamples[ +(syntax-parse #'#&5 + [#&n:nat 'ok]) +] +} + @specsubform[(#, @defhere[~rest] S-pattern)]{ Matches just like @scheme[S-pattern]. The @scheme[~rest] pattern form diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index 53026fa901..4a40b50c49 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -8,10 +8,18 @@ lang/posn "shared.ss" "image-util.ss" + scribble/decode scribble/manual) @teachpack["image"]{Images} +@(define mode/color-text + (make-splice + @list{If the @scheme[mode] is @scheme['outline] or @scheme["outline"], then the last + argument can be a @scheme[pen] struct or an @scheme[image-color?], but if the @scheme[mode] + is @scheme['solid] or @scheme["solid"], then the last argument must be an + @scheme[image-color?].})) + @defmodule[#:require-form beginner-require 2htdp/image] The image teachpack provides a number of basic image construction functions, along with @@ -27,70 +35,85 @@ Existing images can be rotated, scaled, and overlaid on top of each other. [color image-color?]) image?] [(circle [radius (and/c real? (not/c negative?))] - [mode 'outline] - [color pen?]) + [outline-mode (or/c 'outline "outline")] + [pen-or-color (or/c pen? image-color?)]) image?])]{ Constructs a circle with the given radius, height, mode, and color. - If the @scheme[mode] is @scheme['outline], then the @scheme[color] - can be a @scheme[pen?] struct or an @scheme[image-color?], but if the @scheme[mode] - is @scheme['solid], then the @scheme[color] must be an - @scheme[image-color?]. - - @image-examples[(circle 30 "outline" "red") - (circle 20 "solid" "blue")] + @mode/color-text + + @image-examples[(circle 30 "outline" "red") + (circle 20 "solid" "blue")] } -@defproc[(ellipse [width (and/c real? (not/c negative?))] - [height (and/c real? (not/c negative?))] - [mode mode?] - [color (or/c image-color? pen?)]) - image?]{ +@defproc*[([(ellipse [width (and/c real? (not/c negative?))] + [height (and/c real? (not/c negative?))] + [mode mode?] + [color image-color?]) + image?] + [(ellipse [width (and/c real? (not/c negative?))] + [height (and/c real? (not/c negative?))] + [mode (or/c 'outline "outline")] + [pen-or-color (or/c image-color? pen?)]) + image?])]{ Constructs an ellipsis with the given width, height, mode, and color. - If the @scheme[mode] is @scheme['outline], then the @scheme[color] - can be a @scheme[pen?] struct or an @scheme[image-color?], but if the @scheme[mode] - is @scheme['solid], then the @scheme[color] must be an - @scheme[image-color?]. + @mode/color-text @image-examples[(ellipse 40 20 "outline" "black") (ellipse 20 40 "solid" "blue")] } -@defproc[(triangle [side-length (and/c real? (not/c negative?))] - [mode mode?] - [color (if (or (equal? mode 'outline) - (equal? mode "outline")) - (or/c image-color? pen?) - image-color?)]) - image?]{ +@defproc*[([(triangle [side-length (and/c real? (not/c negative?))] + [mode mode?] + [color image-color?]) + image?] + [(triangle [side-length (and/c real? (not/c negative?))] + [outline-mode (or/c 'outline "outline")] + [pen-or-color (or/c pen? image-color?)]) + image?])]{ + Constructs a upward-pointing equilateral triangle. The @scheme[side-length] argument determines the length of the side of the triangle. -@image-examples[(triangle 40 "solid" "tan")] + @mode/color-text + + @image-examples[(triangle 40 "solid" "tan")] } -@defproc[(right-triangle [side-length1 (and/c real? (not/c negative?))] - [side-length2 (and/c real? (not/c negative?))] - [mode mode?] - [color image-color?]) - image?]{ +@defproc*[([(right-triangle [side-length1 (and/c real? (not/c negative?))] + [side-length2 (and/c real? (not/c negative?))] + [mode mode?] + [color image-color?]) + image?] + [(right-triangle [side-length1 (and/c real? (not/c negative?))] + [side-length2 (and/c real? (not/c negative?))] + [outline-mode (or/c 'outline "outline")] + [pen-or-color (or/c pen? image-color?)]) + image?])]{ Constructs a triangle with a right angle where the two sides adjacent to the right angle have lengths @scheme[side-length1] and @scheme[side-length2]. + @mode/color-text + @image-examples[(right-triangle 36 48 "solid" "black")] } - -@defproc[(isosceles-triangle [side-length (and/c real? (not/c negative?))] - [angle angle?] - [mode mode?] - [color image-color?]) - image?]{ + +@defproc*[([(isosceles-triangle [side-length (and/c real? (not/c negative?))] + [angle angle?] + [mode mode?] + [color image-color?]) + image?] + [(isosceles-triangle [side-length (and/c real? (not/c negative?))] + [angle angle?] + [outline-mode (or/c 'outline "outline")] + [pen-or-color (or/c pen? image-color?)]) + image?])]{ Creates a triangle with two equal-length sides, of length @scheme[side-length] where the angle between those sides is @scheme[angle]. The third @@ -98,72 +121,118 @@ Existing images can be rotated, scaled, and overlaid on top of each other. @scheme[180], then the triangle will point up and if the @scheme[angle] is more, then the triangle will point down. + @mode/color-text + @image-examples[(isosceles-triangle 200 170 "solid" "seagreen") (isosceles-triangle 60 30 "solid" "aquamarine") (isosceles-triangle 60 330 "solid" "lightseagreen")] } -@defproc[(square [side-length (and/c real? (not/c negative?))] - [mode mode?] - [color image-color?]) - image?]{ +@defproc*[([(square [side-len (and/c real? (not/c negative?))] + [mode mode?] + [color image-color?]) + image?] + [(square [side-len (and/c real? (not/c negative?))] + [outline-mode (or/c 'outline "outline")] + [pen-or-color (or/c pen? image-color?)]) + image?])]{ Constructs a square. + @mode/color-text + @image-examples[(square 40 "solid" "slateblue") (square 50 "outline" "darkmagenta")] } -@defproc[(rectangle [width real?] [height real?] [mode mode?] [color image-color?]) image?]{ +@defproc*[([(rectangle [width real?] + [height real?] + [mode mode?] + [color image-color?]) + image?] + [(rectangle [width real?] + [height real?] + [outline-mode (or/c 'outline "outline")] + [pen-or-color (or/c pen? image-color?)]) + image?])]{ Constructs a rectangle with the given width, height, mode, and color. + + @mode/color-text + @image-examples[(rectangle 40 20 "outline" "black") (rectangle 20 40 "solid" "blue")] } -@defproc[(rhombus [side-length (and/c real? (not/c negative?))] - [angle angle?] - [mode mode?] - [color image-color?]) - image?]{ +@defproc*[([(rhombus [side-length (and/c real? (not/c negative?))] + [angle angle?] + [mode mode?] + [color image-color?]) + image?] + [(rhombus [side-length (and/c real? (not/c negative?))] + [angle angle?] + [outline-mode (or/c 'outline "outline")] + [pen-or-color (or/c pen? image-color?)]) + image?])]{ Constructs a four sided polygon with all equal sides and thus where opposite angles are equal to each other. The top and bottom pair of angles is @scheme[angle] and the left and right are @scheme[(- 180 angle)]. +@mode/color-text + @image-examples[(rhombus 40 45 "solid" "magenta") (rhombus 80 150 "solid" "mediumpurple")] } -@defproc[(regular-polygon [side-length (and/c real? (not/c negative?))] - [side-count side-count?] - [mode mode?] - [color image-color?]) - image?]{ +@defproc*[([(regular-polygon [side-length (and/c real? (not/c negative?))] + [side-count side-count?] + [mode mode?] + [color image-color?]) + image?] + [(regular-polygon [side-length (and/c real? (not/c negative?))] + [side-count side-count?] + [outline-mode (or/c 'outline "outline")] + [pen-or-color (or/c pen? image-color?)]) + image?])]{ Constructs a regular polygon with @scheme[side-count] sides. + @mode/color-text + @image-examples[(regular-polygon 50 3 "outline" "red") (regular-polygon 40 4 "outline" "blue") (regular-polygon 20 8 "solid" "red")] } -@defproc[(star [side-length (and/c real? (not/c negative?))] - [mode mode?] - [color image-color?]) - image?]{ +@defproc*[([(star [side-length (and/c real? (not/c negative?))] + [mode mode?] + [color image-color?]) + image?] + [(star [side-length (and/c real? (not/c negative?))] + [outline-mode (or/c 'outline "outline")] + [color (or/c pen? image-color?)]) + image?])]{ Constructs a star with five points. The @scheme[side-length] argument determines the side length of the enclosing pentagon. + @mode/color-text + @image-examples[(star 40 "solid" "gray")] } -@defproc[(star-polygon [side-length (and/c real? (not/c negative?))] - [side-count side-count?] - [step-count step-count?] - [mode mode?] - [color image-color?]) - image?]{ +@defproc*[([(star-polygon [side-length (and/c real? (not/c negative?))] + [side-count side-count?] + [step-count step-count?] + [mode mode?] + [color image-color?]) + image?] + [(star-polygon [side-length (and/c real? (not/c negative?))] + [side-count side-count?] + [step-count step-count?] + [outline-mode (or/c 'outline "outline")] + [pen-or-color (or/c pen? image-color?)]) + image?])]{ Constructs an arbitrary regular star polygon (a generalization of the regular polygons). The polygon is enclosed by a regular polygon with @scheme[side-count] sides each @@ -173,18 +242,26 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ For examples, if @scheme[side-count] is @scheme[5] and @scheme[step-count] is @scheme[2], then this function produces a shape just like @scheme[star]. + @mode/color-text + @image-examples[(star-polygon 40 5 2 "solid" "seagreen") (star-polygon 40 7 3 "outline" "darkred") (star-polygon 20 10 3 "solid" "cornflowerblue")] } -@defproc[(polygon [verticies (listof posn?)] - [mode mode?] - [color image-color?]) - image?]{ +@defproc*[([(polygon [verticies (listof posn?)] + [mode mode?] + [color image-color?]) + image?] + [(polygon [verticies (listof posn?)] + [outline-mode (or/c 'outline "outline")] + [pen-or-color (or/c pen? image-color?)]) + image?])]{ Constructs a polygon connecting the given verticies. + @mode/color-text + @image-examples[(polygon (list (make-posn 0 0) (make-posn -10 20) (make-posn 60 0) @@ -692,10 +769,20 @@ the parts that fit onto @scheme[scene]. } @defproc[(scale [factor real?] [image image?]) image?]{ + Scales @scheme[image] by @scheme[factor]. + + The pen sizes are also scaled and thus draw thicker (or thinner) + lines than the original image, unless the pen was size + @scheme[0]. That pen size is treated specially to mean ``the + smallest available line'' and thus it always draws a one pixel + wide line; this is also the case for @scheme['outline] and @scheme["outline"] + shapes that are drawn with an @scheme[image-color?] instead of + a @scheme[pen]. + - @image-examples[(scale 2 (ellipse 20 30 "solid" "blue")) - (ellipse 40 60 "solid" "blue")] + @image-examples[(scale 2 (ellipse 20 30 "solid" "blue")) + (ellipse 40 60 "solid" "blue")] @@ -916,3 +1003,34 @@ The baseline of an image is the place where the bottoms any letters line up, not Two images are equal if they draw exactly the same way, at their current size (not neccessarily at all sizes). +@section[#:tag "nitty-gritty"]{The nitty gritty of pixels, pens, and lines} + +The image library treats coordinates as if they are in the upper-left corner +of each pixel, and infinitesimally small. + +Thus, when drawing a solid @scheme[square] of whose side-length is 10, the image library +colors in all of the pixels enclosed by the @scheme[square] starting at the upper +left corner of (0,0) and going down to the upper left corner of (10,10), +so the pixel whose upper left at (9,9) is colored in, but the pixel +at (10,10) is not. All told, 100 pixels get colored in, just as expected for +a @scheme[square] with a side length of 10. + +When drawing lines, however, things get a bit more complex. Specifically, +imagine drawing the outline of that rectangle. Since the border is +between the pixels, there really isn't a natural pixel to draw to indicate +the border. Accordingly, when drawing an outline @scheme[square] (without a +@scheme[pen] specification, but just a color as the last argument), +the image library uses a pen whose width is 1 pixel, but draws a line +centered at the point (0.5,0.5) that goes down and around to the point (10.5,10.5). +This means that the outline slightly exceeds the bounding box of the shape. +Specifically, the upper and left-hand lines around the square are within +the bounding box, but the lower and right-hand lines are just outside. + +The special case of adding 0.5 to each coordinate when drawing the square +applies to all polygon-based shapes, but does not apply when a @scheme[pen] +is passed as the last argument to create the shape. +In that case, not adjustment of the pixels is performed and using a one +pixel wide pen draws the pixels above and below the line, but each with +a color that is half of the intensity of the given color. Using a +@scheme[pen] with with two, colors the pixels above and below the line +with the full intensity. diff --git a/collects/teachpack/2htdp/scribblings/img/10735f73f78.png b/collects/teachpack/2htdp/scribblings/img/10735f73f78.png index 41d52546c029c301eb9d249cb7f4ac20078023d9..74b36d7285bc0db1d1e0be1e257749ae54a8838c 100644 GIT binary patch literal 108 zcmeAS@N?(olHy`uVBq!ia0vp^nm{bd!2~2jb_J9JDPvC;$B>FSZ?A3SWpLm)>~QFx zbvsk%zuErD`UPvfgH$ga+NNCgKU_Zt0^Tfd+Hb}g&uk=dH&z*_ox#)9&t;ucLK6Tr C+adq} literal 116 zcmeAS@N?(olHy`uVBq!ia0vp^T0ktu!2~2NC1>6OQr4a>jv*Cu-d@`%$e_S;*x|^= z|EHEMNMtNf*8N}^u6R;o8q10c2duyKpGh} L>gTe~DWM4fUR5Qf diff --git a/collects/teachpack/2htdp/scribblings/img/10847861f4b.png b/collects/teachpack/2htdp/scribblings/img/10847861f4b.png index 28209c64d492b4109274bf0e61229e42f718fea4..93d0e905571eb7762cd1eece17362c6cb72d354b 100644 GIT binary patch literal 1277 zcmV56}cHFl%ZBrdBRY7Fxk(op(RH+mZ1>vY0nT66}7J|BPA*e9w!i6xn5v@?E zcMugs##`k$UN|VyYVCMI)T2dfFLppgv1-!fEFz9}nzWA9XBGbU<9`xDlJ5&dQ4|OP zr_(txF<~;9*4NkVcDvi{_W67e1W^>l(px3^4{e(de-Ra8{)`TV-Nx{Heomde2H{r!EFN`+yV*=!C` z>Bs5mX>oCJTwL7p^70ehMxzmi;g*(`KeIk$a&i)eVZB}-l6!G+5ddH`8lNwwvDs`g znXId;D~Nk^bW|h~SuB=tiD{0GjsO7d?d^jtGkPIzZf;~U z+1%XRFL!NiZCP2_ON(i`ySvqD^_`m}Nd!T5cXwaMO_HQsE?-$$p(u(oKR+K66O)jT z5X#&C`9Kh))oKj}0|0_u=+)`?sBM zIEgFYDubp>93CDzolYn+GVWNLVo#YO06v_UDZ~nvh&^R-yIiiQs3?w5D0Da+OhwxFT9$}CWpO(k4v9p&_G+>d8 zFT+XPY&ZL@m!+3|{Ocoo%Hkdy8v_7v^YZctg1|70sZRM;`A+oi=he?M@7Wvfn-9_t z^;z}zTeGK3=yW<1MS)(gFDWT`oev2OK@b9g;Q06$oSdBS`TWq^@8@GQ8Ziu`=W zlaqBi-NVI4GtuDSAOPU#=qSA6^Yio6)YPh~D!+CAS=ex1TRIo6T~$yuQ9ZU>bP#9~c-A3WXgV9e-@aalE0SK_n8f%y^9d zJT^8qFbvaZG$xbjNmi01`}+D46B7#y3y+VFSt=Rb6h--bKAld7AV_X*?$p%O{d38L z)9Gw#YKo7K&&bG_nVAWCmO=hA0RXPAuZM<)+S}Xr_V)7g^DzuVQ4~QCu~>Y1dg}3b ztXAvh=H~SDwB2qmDk>^1Elp2PXWx@1xci=ylaulBag)hpu~-}qhsWa)2m~+;CnqN> n6biLkjiP8oL_~PEUyB3%S@BSooQs0$ZDaU(TC zB-R%c72IfR1nYxKdu5_A^?|6B;3E%HkfInLlR0-WrM0Oui8XqEt8o5b=6BA7aL#uy zgb@6H#717~@p#6@#u$cKTwL7U-Szo=!C(->Focj)DosvK)@U@jxw!=e1v;HhB9TP$ zOf2l`Pft&WhK63fdbPH;R$N?6Q4~$n1VIo4fngZ04+euSmuqWlYj$>aa&mHOYpbfN zs=B(GAc!!2Bn-!Ky}i9^wc21XjE|3>ot=pkUu0urqo$@NAtB+#ix-E7ha#1N`pwPF zyu3V`rtNlngw_!D_xH=o%kSR3`|;z)tLbev8;;{`ZEe3NzR26RZ*d&ASS*q1XJ=;t zz-F^u-_7H4xilJ0cXxMq{m96OLZNUt9MN*~Y;SJ^Ku1T1nBL)V;5fd#yc}IO&*tW) zTCE-%8@pV8e0-dqo<1}*bQ5l#nVA`tO6B!>FVQzQHjGzkH;gE z$u7?8hB!Sv)o3(RQ&T_b8yXr+Ceuy3d0xMMt<&j#=sAuf2x5JG{dV*m$B`sCH#dh6 zk^sQ;^mKA^a#~tiB%8$b!7$8dG+M1z0FVH{)YO#0V7MJOkI`rx9v)^{HWmOreE3jT zS1103_n+Te=dGW-p8!Cs)Ee&_^`t(+^jDNhWl~ZS!!Q^^h$Kmy&6b*)DpdXQpO@x; z%^`!P9MiMEo`p??sIRY&kB`R?LUD0%hlht!sZ?m)Pe-0!8d?6f0Dwp;@(%j@`$tDd zB>-@KelBu2vCdmXBJorx0)WiS%$1duSO7o>#l*x2)$zaRRim&ej^jR`@7tm|juR=p z3FLD5!NGw90HjhW548vq+XU8-(HQDWUmSt(07AnpCBln)--k0Mq z2Z4h-F?SxQA2jM4pZxhGl2iz@*-TLsAcQOyOGQP+?d&%^EX&GdvYnkBKnU&a?Ik26 zM1G9FJ~o?;rfKwjzkm4fVHA(HVR`)cF@Ny=rtj(LDJ(3!9rwb*0znXgK;VZy5D2JL zDyP$V3;Lp>qW1Q7{_~HcW>;5NUS8f!ySux)v$C>SmJQXjEK5<8P&X76TrQVfE}x&D z|330lo3XUC6cR^~qobpYj105cd~q0e znv#;@_xq#e_W67O(9qEEYjk;o-P+nplH}^@>h;}ryPYJ-#>U1=Q^D(nfq?^zPle@BddJJRVO=OG|2MYJPtH#Kc6{iH5(~0)Uf~lfl8kj*gCvjg8{s zVw$EYiXsR?sZ{Ro@B96Jr_;H-ygWWWzPr0yR#sM7S(%fQ6ZWwX$;H}5_V)HhM@Jck zaX1`qx7+Xc%VaVf$1^fAv|6oBr=ut;Hueg4h5rF46OeZ$ep#&m0000%9E&i_^T_iGs;RbCmBgL&*VTlcf3O3Ag$3x6K_=hy#= z)T~wSQU6azkM$1+<)12^ufM$*`yyF(&~wnW|D`VNOE3Im?bDYRR8Kv5AsBqBwVH6| zJ?{GZS&b|Aowe>iV^MxedAN9beEfrH?fR54a%$j(-;OW@%A0QGO0v>00K~pXu3S+$ zuD~wypN)m9o&9Vq%r5h)r@r}+*ES3QGw)@;`LHPe=#9^54FkaV2h$(D@j1Xo&r%+4 z{4rWhbK_4@DPQ%9lW#2w8L`?~AtO${wODza{Wd=}R>QE&)L54Nwov@v-=ESWsYDiT z@Eo1Eo4Kvt8UT=q@zII9s;8pYQi~G_?eZ2U647g^vV+qXvLdIFL@NEYDZTKnE8Fxr$ZwwJ|l)N33`Mw;Y&h%Mg)K#pE;yoRf;SudR~ukiMh14CNY;@ zk8ouNlS^D=Qmd;gL?)BTrJ}sFi|Ry{Jon1uBc}#vwIinno_pnSDD@njtnqMG3!58X zRUPCjktAtuyzr#tc?f?@(a194PlP-V41pIfj=X;9WbaYG9#!vA|Ld1dzIbtjApihI zbg^<@JT6pHP?B}2mt-V!T#YO zVop-QYNnpR@*KTICC8ez0%&_0_&fVtt^{Po;oA`B6_AKKI zwfjQtKRNf9{woxo?bZL3XH*SJgO{%AdOAvxCGoGYp0PrOd!GNhu3u9ceCtb=wn$kb zPpT21g$f1FiT~Be*rk*PuY5&uvq~kI+sLY;g$e`!_=K2=Qw$rKIL{|U0N`1XT`nKG zYQipaJS*lXlE4PgLInZ<$y&p5CCT|T0NlBOEFUdw2m}DwMd~>n8_ohiB8;32Cc;^x z4JQS(P=NqI<Z;3<^lj?NV?lmfa6f9mY0*Lj!r#q_S?cUBX7hYP%&z5drDoT1?)_NLSfK*R z#E@;3S>ZVrIVIv)(R_X6urLGXt@W1(07OV(`(#QaM(QL~DD|Gu`5-wos>{it zQLFR8dPn9$=>j(Q3an@_Aw8E0_dRdkf2M}*zO&YS&o`ha%aB|e={c7cO*@dit4!E; z)-v>t-Q-ZYgC++v^p3ssB}V-iMGm<>^+DrC^YhCn0{=~)sbhXb1I3@(uJHPpoI;gj!~Y0_Pxk`8nmz>5C%JeWeAv^24^SrQ|j!r zm@CGrt%NWHIr_=MU61ad6(S^!g)j!JX9EKO9S5AWLWHET5S`1KN@St$u!~lRkTe!z zuprZzEOhQRx9*`xNUeKp&fWKOaEAIl13>q1)sLVmp$gt4h|!Krp^C6)q>W*8br6PO zdPdrC#WfIO!VVjX(B-rE2X%E(|Dem|yPq>K8DetO>lpz0e(u#H(HXYc5R(hJ9yB?N zLT|sLYp6v#zH6w(+wZ`Y)mVrHy9O>34xaBa*{VJ=CYxdKe2vdVw+v!!LoQ{@gw9U$ z6QhA@!B30^oSpZ1h*BUHtmjH$@Tt~guLj7*i5)R8$6gI+eAK)37;U?dw_jBlddBVU zwd1~7-!hEm7K6b`XkSelti;@+-h164`|!Knji}pZK>)z+r5-a8lIDQ`fP;RXfRHo~ z1ORsUsSO|`%>w}dXMlQl3L$A82mrW()Vouz?&eCxR1g3#?=;%n6eE_+ZLXHIw*`eY zaLW%U+Kno>2`PAPdzfNhjw-kbx##&2iWLu4a1&DSZ1b2LK3%EU;j=0q>2Fhtn_-?q zy7oGBhBY%q&)&fri+-xGW~S(Qhu_lDQzId_^w_uc3`}OjMz8?e1GWVlJbQTm^Z51saHRh2d!mA~zW`u>MQ^P}$h`_2CWe8bYTspjh*00000NkvXX Hu0mjfxQPk4 literal 2107 zcmV-B2*me^P)H{?~000OANkl& zPi))P9mjus`macGY^#dwNLC{|sf@0T9V2NHyXg+C*Z8oa=%MKX483f~nnRL9kq#~9 zdPT7m>wxw!q`)r2u&wK17_fueWW98?m&}D5ryWqQv7O3t9a&NANR%a!6vZ9LNis!B zd_OCWynSvV--mo(J-$DDQp`w_1pj}S^-hTS;{2Zyw7U#Z%$|5^Cw>p3B#u8+mVJodVy`#DRsa_#cMAIJXw z)jwi&Yt?%+_=C}7{lj7TpW3mn|8g<$Sz2|_chIx{<*wRSU-;YF$FD4Co_g{^IQ&$r zo;dRkcm3UbjVt$^weLS;EB#X{!o}0$*Dld-7Y*-yrz>@u%;>g)IU+L-}h=AHc4@0axt-u#p{GXRXgH~qnzp8{0H zmWpuW_i;V##vkHRQTL*gZ!HQrQSYpf6DQwVtUk_uQ=A&BlUZhJEYE(U-2SicP8m_E zkwtav_{81ZZS6JzfLwx)Pu$f!6~C5QoJiHa<>Evtel4RqIDH{6a)xFTk&~t`82W(f zqK+N=XtlPWS77G1y3a_BV#ygXdPy)M%0w>-$r%vL(7Ge12A+TQaZtsMPu6)#^@`1n zuNqwTNRl)+t~@VA9-<#oG__3hBcaFxL*S*0BX3+f*?Tl-#Ogg7eB;u|moAPl1VFW1 zNlY1PvBXrm`-HFZ$o%CsqqPQ@zr1$f#~lC=zgpl~>NO&tmf}|noyW`o&_5jR9}Xjy zE9Ka^gpgS>G+<mOD6!M^rt50b^H~76a|2lgwAc`o*z6+pqK}Q{0U#Act`<|#yxDLM#?dQm1F;~Wnd-M3JI7E368CPv+8vXV(quPzlm!F$5U+M~r1il1Gf zuDz^eZ&R->75%p0ebj_=(P9Y#0Q}v8n5Ui+#C(xYiTSkx?#B7Gf_FbQHdZV_03eq@ zwpeb3=UC)|iDO0oVYAg!Yj02!tB3I)*4_Cu2myfnDl#^=DhTVy*uuI;CMX=H4)SjoUEc9YFe4>#GEf%Epw-w~A98EpT|h{Q}iCMh@mujqb|92zwg z=Fq6!{orP2Y~}6%AYeyhffY>_Wb8_D-wW3LXX+&HJ8R$fLIZlW3;}>b78$#c6)iiE zJxwL{owW_U?XJPzYW7}JiD+f){-p=%$v-O>8WW#Dg0Knjv64i*DpeaV4^?G}qxS!E)8D;>mwwO$ILi?qs$xf^-+CAAD zaSs2gy8*SkXDG`or=NN*MJUaK65B<;gg_|GgA#j3kU9fGX&#i=?hy6P7D8zrl-Qmy z_0E>3ySWBuDwNpPoo0uZVj6RJt$M@wwxIl`-SQAc>roYMLdvn*zC*FCM^(59sfhgu z#k&zz;U=UU+u^gg0)_@>SHNESuLIkZ4ZCQ*Lxy%p3>Ir^-Tw zxw-eGpJ~hw!|pR0A$A?{_zr4})xLwCT}QV47%rpTb`PHps9sJyVaLO#16xw1tw8&a l6u{>GBt`S18~cBo{{R`A(zvRy!ma=S002ovPDHLkV1g^b6G{L8 diff --git a/collects/teachpack/2htdp/scribblings/img/1132401ea93.png b/collects/teachpack/2htdp/scribblings/img/1132401ea93.png index 48045cdc4c1b00a0a114b179b22cca979d7deb7d..76bd2360806b3084940a78b0d5e1761d0787f5fe 100644 GIT binary patch literal 1465 zcmV;q1xEUbP)_gQ>&r~6b+$83n`LF3u}?oqNr?D%T_IF+oB+=RUbqjL_w>f zHbtft*_Up_h2|HI6k#y=5%VnKiRXP^=gys(Y z0N{uH!~S9CRw7o`#l^*Sb#)aL6{V%6QmGUG@b>l=i^U!vA8&7OpPrsrMZ-{x%F4YolXM)^7He{%gb>bZ)j);1OhudJBy2pkw}CwCPh)q;E9Qe zcsxEkJFC@d;g(vhc6N3)9*<8D7jqD{26~sE|*gjwYl7)qZe82?-1#fR}bfd6& z9twqU9OuK9%jNLI0Ap8FRPbbnLLn~fi;D}!1P+&0tG&FuU@&lF8w`g1{e5n} z005v;sXQJJH(!s(qf)6L2F$gC*XxCc$SRde<@I{uHq3j$m6a8X#ln_tu~=4CR@i#| zS4yQa8jZ5b$s&;`8jUKIO1K$Pt$1{F)YH?0&hGB+K0ZEXG(%z=jmFc{Q*`#p$%)Bi z`Wkj#US2pHuBoX(0oT;jgu~&yygU>(^PcGa{oQ7>jgF3@u&q|>{QUg;`#Xv;l1fTS zo}Zr?YgU;|_Wb-@Qc{8v6SdzGkH@#Rwnj!q;AU2PRFakx1wa zBoav^5~;4PMhu8F*FLqoy9@c%tyb&a-X3~1c5IbO6$k{f<{6PlX1m?aHVzlIUaxn%-Ji7- zhGA~ETd&uD2O9w3bUHgbJ3n4`b#-wo2syG_TU+n$?l26)Fzo*RzNMw*``7@0tE;Py zjt-;I2(Q3%!ZsKTE|=@(=BBN!?Yr3k0H4q2^Z7Wt|DC=2wzjrJBJukA%K4dd*X8A< z(P$K4t_k@c6D+p~nNtN@ON3lQ1*;v@YPH|*7p7*~+uO5Rt#qR~tQD)Os-n^8*Vf3W zIdyz|+-9>SlSw**WHPz1urM|@h8Pf4Lhgx1Mn*O_HyQi*1VLjS-X24Uoc1(f&zw&`mQNoT zfZX@6X~%FJkHum+?cLKpbB#vhbUHcjTqufiI2`a37Z{u4X~%Cdp19Dm)oL||3h+;z zpP$30IxQQ=aaKp}|5q>=)o#&ZMCOM^o}Q*C3bG%dlSCq+C~9hI3Sz^Yt=HGrT`m`^6oKP7Ns^P3lW;Q@cd6#) z<{BFt;g*e!jdOEz=y$15?~n})446!&%F4=*J7keaB%MxE6eSjm%gV|=?vVNY{+*qj zrKKgrJ7nyZ=g+%yGMP*&m0}o1k|aS89PZBX>MQcp-`Q9EVgImy*oeXe%rCzHxYROP T1T?J_00000NkvXXu0mjfdH2Qj literal 1467 zcmV;s1w{IZP)tzZ0Pyni5{*Xh@9)pg&mSHhIC-NWgcL<# zbwx!*Jv}`Zi$$eUot~ZsgTYWJ^!oY=0LaeHE-o&nY5LEfKX-R`YinyWGc)0E80!;4 zNECF3hlgXa*u=zy!C*iu4F8y+718vOY9ID}BCRASw|n^LKS5YElbq4yOZ z^T)=QyQg!!Qbkf*kzO6bc2yFe;S_fkv&q zv$Jz?agkvdet3pq78Vw|y1Gyz#On9<_G)Wu`LWYhTU)!gw}(O_@J~-qd3kw4@OgQ8 zPft&L@KULiWmzHYw6QEJl}a<=Gyd)+5=knR5{^%$QW8n#*oxSEmSuBubA_;Ta&lf? zUJz*1$qxpDG))V^E0s!gz`)>3N=gLcgTWwA{L#@7HprvRU@#mXAM?a}JRZGXF9fgG z>pdP1N`W|fG)*%MLvkH|Y7|99qfx}^!QXgZueYYAh9ADBrpD{_A_Vvw&+T@bOeTJK zlgZ?EyD=j4>a|*}&*$TZ_xXHUtrmmErW-dmH)t=PnpUg5xw%1Wh@P19^Yb>FjVs<} zv(3-X<8|28tJUgAB!Y_Df0;xgi9{l5wHl8mNj0~&wmLdG$nov%?c3YiSQ#naY&P%i z?vmqoc6KZl%a`G^va&*zm6etL{(iK~Znry~&R8r)=$1oe zOQX?*!(o|BmPsI!$-?2VMx)_?=2Tc)UtdR@0K47pa=FO8amH)4+Pk~EPeYJIBJunE zI-Twt@c@AB?d?xvu+3&82{l6Tb#-;0-hn=!udc4{+wlN^{r&y6wziMoX=`iS-{0rz zhbP`>G+tj{zb9c7MO|NC8;!<)ga-f|9v-%|w4}doZEeNmlV6T+XlS^&xS%MCqNvNu z%li8Ie~JeHoSd9AH#eKjW^^Y1U3inp|u(-x1%Gpzx2@>8i)c6PRK zJh~H}5uZ#Z6N!ZI@quJAnM@`*;{gCyS65Y4RYLGpRaIA4R|o+Lzp=5=+}tb#-_+E! zxw(l_h&wogxpKzF#vp`gsBT!$CeW#$jNtySv+Bv6PmUrU&N2;qdG0D}+!gl@=8hr3dExe*fCq z+U)Es;lLaz{@vck1r-W~TrQ_5ie*`bVR(!S3ax4iw4Yqn{Kfy`fAPGH68B$2{s+7K V;??1=yX002ovPDHLkV1h!&&rARS diff --git a/collects/teachpack/2htdp/scribblings/img/11402043018.png b/collects/teachpack/2htdp/scribblings/img/11402043018.png index 4d58aaeb8ce2b9912b6d727e11f558275c11833d..19d80754fd6cab1b48b7a89f7a17552951b3fca0 100644 GIT binary patch literal 608 zcmV-m0-ybfP)kLLaxKlk}_zkQ)w_ zV+Y6M5Bbjwhu?2~KLY~J!48~*9XJO&a1M6h9PGe3*nxAf1Lt4|&cP0xgB|qa5Ec8V z*ket5#~Q>>O_-NV2_YY!UjvMn*uy%6`69o@`85vn1+~GV1^BPet(s z_p`bj{EK|=OGbq{tHpu8rw~G&)#AY4QwX8X;yWCRgHTT)A{rcv1J9kv4mDxxWP&wq zolJPv6WKworx2W-#dJ{VDFjbvF&%aaJ%uP4-F0;q%^|B!fm%-?g09Y@IjHv(qO-F& z4p=>fXzwh718z?tS~`p1fZJ1umd>g==;$c~)LB&r9X*ABI;-TMucr_%JFDcNucr_% zJ1g&?yQdJ(ot1Q`3G>clj7O5eJCB>|FX_&IkC|=vG~b379CXQ4As^B|yq7%ow6x9_?-EOnO!X$qk3c zu^R?uS(3lckPvb@efNDDLX1XVZ+)Kw4n{*KjD}7a4V^F=I$<<)!f5D((a;H_p%X?! zCya(p^rqpbdq3S{O&ekj>O@JH70w7D?;oE7j7!(ym%ewXThL}Pr>G_WEIQ6FC%4cy2=)WjD@12?h|HStBzkP%r3D82|9G9n8B#aC2A zUSuI&##dBBUSuI&##cx~c4Q%*GYN2wNQUCw|07*qoM6N<$ Ef|9lmZU6uP diff --git a/collects/teachpack/2htdp/scribblings/img/11b64ab4d3.png b/collects/teachpack/2htdp/scribblings/img/11b64ab4d3.png index cd3326d0966447f31bcd1c8c06ecb169057c4f1a..db3f38aa1c3e3fa5a33863f572a968d069944354 100644 GIT binary patch literal 590 zcmV-U0pjCLVrQ&QUy0D9V{*4B;7kW6}se4=-Q!_LIuIC z6qF7{C#QBOwZts`8WcieV&v_6cMb{Cq#Cqv=RI)WEqRaQGu%tKhcNjORP|gc+Zs^a z)=IN(y;-;3tXpr^tvBn|n|14rs@qk!^@m&)JwPA41dF9uEX8^TFi2yN!M+^!wBF~8M5Rs_TP2}?zuM}xQQWlsm&F-yC;RLlz64Yi;E!ur1DN? z!ply1y}1h=-79lx0Ls7k zm+3Y-4L1PPcEs{*J!-T*l5qn-Ws|QLT5w8k04Of}sg?wga|?}&5fb?Z(_#vKgd#QVhQRhou7 zHRen%1b^S1O}SroY2=B2zYuqO+P*Z}9i;K@n|NmY45Xp%ct75J85^7N&%4zd=f2<^ z!W1`|xsSPXHgs6$T=O~x8RO@gGsUF3&1wAZ{F`;_&ARnw-FmZby;-;3tXpqX-Aqb_ c|6*0w3AEsYzjj#IZ2$lO07*qoM6N<$g4v5BZvX%Q literal 593 zcmV-X02)Tsw#$77E=; zq2eGqb<#nsq*-irPzXtrraV4(k3&K+u?cI;g_7Gk=`3AGmaZd9*O8^`$kKIW={jOecN5+HMX5<1$cL8^shmjV#K;5%c?t?N zR-&=8i=l~j9a--6-Gou5jF8ylO6gbkAjK91J!I2K& z+uI0C>8)*^2j(D_^dL`QNTS^7bVyUT{L7WJJJR>2>GU8^7oVmJHx6-{OHYr}xreFg1^=kI zfQj^D4l@j*a~dHTJ-8!B430}rQc&P9E?uZ*liQrlPtxC6x{fSeN0zQ5OV^R5>&Vh| f#F#Gl{vG)@HwA^m2~u*U00000NkvXXu0mjf3-c4S diff --git a/collects/teachpack/2htdp/scribblings/img/126418b230e.png b/collects/teachpack/2htdp/scribblings/img/126418b230e.png index 042649d335f6c175cda324249f471204482938b1..6d834be9f92e75d3d9c6b49736e1d677fed2a199 100644 GIT binary patch literal 479 zcmV<50U-W~P)x5$;r?9TWy540JW6Y(GaHc8AGR9bYz0SuY zec%q~=`2Jr48bs*g`iJkbSGEJOHnNAOHsH|l9k9#ah`kQxU9W#jPsmoM0E1IE-K6C zEm2weT}M-*IVGGQl=?PKsf2Ty62U2Knp4}pZa=kc*fazsQzvJdR?bJlxid|sN~TUr z{-M3ZUNCWb&OZdD7fhVuqIl#V!W+kU%Ns)5$?v)dcU>YO%z8oF={5i0XwzQMbAs{@ zVb%*8PV4!HFz5vhr}g|p81w?x36p;a-Cn>tVe${5+Y2ZseEuP{dI9Bx&p&t=onF{> z(#<~vz85x}9`FCVkYpLA7dD(CA%ec&Nr?r0kGU_`oLni5pQ8{lq8HYjDEWuL^aAKa z&p*UwFMv)-mJ#z09#X0G+<@QaU$@&I_@MZ||5f(II^nQRIII(nPjqtTd49LUPwpye VynxMl35);$002ovPDHLkV1gq;+xP$g literal 484 zcmVJ0 z9D{nxvZ(LFS4!P(w@+)laJgJIpLX~gr$xbOQE*xmoE8OZT47a%Rb^|cL1;SYm+(}Gr<=eu#dAMeI7&U5*u zRBPY1QCU8piOO={w!&GdR+6Thd45@(=Oj&qvm&jqt`AM~e*VxjVO>j>`C8sI8J?9S zO}%MikMp(eQGgy5#)7H!90dqTESOqxQ9Pmmu^Y#DO&x-xwQt)9_X0&)^J2l#dXECQ z&W#0G3yJ~+FBUW{a}*#Lv7l+0qX5B(1wjiF1qf;^2wIpZKu}|W)xt*sf)op^7Cs8# zl_;@5X;Gs9fse(y*5mfU3Q3k>VzI6jX&rQ(4JDvpT^dpV0000FSThE^qZBP(!Ie5^< zgz>V0sISnW3oafDYL1 z!@2SM47Dw~taaKq9yI81v&(UnJP2$QvJrW4;JhS*)`w(mn|4**OXqfX0-ea<>FVdQ I&MBb@0AQm|EC2ui literal 216 zcmV;}04M*6P)s3`Wu79IG0Zn`8_3A3$62QBlhv0 zj)Rn<>v}dKeDBLOUq{I|rh1a&^L70289G}0<&GZyd`CBbwquAt+%e7{?3m;Cb}aDw zIu`kj4i5frM+iLp?~askp4fL5{#Qrl0~8| SAsEvD0000e_M0_ diff --git a/collects/teachpack/2htdp/scribblings/img/12b0447b10c.png b/collects/teachpack/2htdp/scribblings/img/12b0447b10c.png index ea65c0a194fbf3415f5f4a8046fbdf1d19306e69..646be0ddd1b0b81c6fe0a66c3a1851d531adbf4e 100644 GIT binary patch literal 430 zcmV;f0a5;mP)`tH+)}2Nx zrn?g@>4IeQ`8+)+-rx7n@9X=+%hT1}ZDMwA2I|uWefc;|qY35Sq9-@ko#QC(L1==w zhoXt#&Oqbt&O_tt&PLba|;spPJWriR-9O>wsknzC*)GzHz3XiB+_(G+ppqZ#jZK{L|rg=UP~ z5lyz+7fqhq9ZiNi0-B-jAZP};Px# literal 436 zcmV;l0ZaagP)s_sfhB8Yd++Xj&Et`EIDUEg-!FYkTZfv(!FH($%Q?RrDf6Mg8WBl?M(Ug+m;x}aZl(>{I7 zP2=={o0jQeH_g%~-6U@&w^!3N0y}cp|L@=K^XK_vb@%ib7&G?}IJj?Lmti-o(U0!y zhx^H4L-Z&&?9gM~FhWmo!va0c4Rw058@luyHx%iaZfMc--B6(yaYLS7$_-(9K{q7n zW!(^?7k5L3Uc(ImdL=h%)9blWm0s12di2_ERH6&GQG+hyMsd2B8)fN|ZWN>oyHScR z??w^2iW~WKEjKdhif-i4b=^p&tGkg#x8Ozs-H02pbUSWD(M`EApKi^KnRJ70%%R(K zW0KytolQ4@(8+hs-Bqzsx^Xwh==R;bNO$4pIo*q!Cv-<{4(Yz!Jks5{d7yiAlY~<@ e$pzhhN8STfDUva`@^D`O0000;!*Yjz7vGwP9sEvnzpL$epZ9rx@5B4OA7ccm*xZC% zj*She>Rkaql2B1W$;sq$k<}_qL1{Ml`7_eeaBu*P24iEAl$65E=fk~w=;;9fs}(sp z@Os5py(&T5+uMm@sJxtrsH}{XN@{D9psd)fIh{}_u&{6vSz3ZZf!$q^g+)IBH8te* zQgic};PdB1L`_YiDvR3J@-pP|FzxyE3kn4m7sb>TXJ#I~R9qY_=g}k5>Bwvr zxP*}HI2=ex!MAT0XRfa!B?aHV3s^*uSydJ4>$xVse2L0R0gLcAo0@`Jjs1PD`3DEM zc@vY9eAnS==Jz8n4Eer&wI1BmRv6C=n!}dR9DmW>(tP|HJ|Gi>~=5=wzdTHE5Paz2Y2qEzn@Dk2ead2WM*P;P^=cq z&=4{*xNMTcd$X~T?%t)65`hQ*9FHGUb~e3xcX8$g=384}7})L7G>m0!4Ge>yKci<| zbZb0)N(@79-bmB1Aa!-Ly-gNNw47+#Gc!=Bu(u~+zXI&-;l>S2Pe)0KYNpr2Vv$zq z1d9dv`SANAjYl@?>Vi%eWu{pCe&}@Q>WVZT!EApYsj0BpVx`4mvq7!KpFd#-BitG$ z6B!Jo*Gqix&!N|o!9XTc_|Y)7U%!H3;BdsYVJts>fMM|EOXx^Av(i$SOfh!~^7=K5 z#?Wwx*~kde)8Tesh7-%*zerEV@bJ0tSu>9ZS}pqeE>DZ4uMb)+Jf73Bvrj-v3#rv) zG{*Mehhj96T1_o2XM!h^J3CM)u)KWP4P#kZfn1KAonYY9d-K^dN=&52#>;M4kQXn= z?WWe&z}JA`{5+IOIGu6nR{*CIN+ss!*>C^N3JcNJ7B{CLt*vV!Z07*qoM6N<$f~iaLU;qFB literal 1028 zcmV+f1pE7mP)l000BaNkl#xkx;Vu?tDa z7S`jQ)>cKC6&8o-X{b~Yn)KrbcphKBD#@)_&SXMMOXR7xHr%+OB)2lT zSFfPcMLn2aFY@wWx64kiK+f$(Ru)D_W5tY(Au|&P2l94MaFtlCR8T-SZ^nu#EhU42 znwn&8A+IK^uOl@T%gga2S5}akinTQvo5;ONs;Vd}iyl1^75wlaEi6!9pX6O+6oii- zq19q{S8V*=9xh(QhYwQskuK-=L$Am4=h9a7^+B(P&nIb-bh&5GP*fy&6@cPm^z=wt zAyMw|2~~RPgbkgcnPJ?&4J^v zwI#J>0k*fHQek#hWVjT$@^Uma$#Dwi$rF^7iHsF3H#CIHmvML~(@DVN!Idi*9265P zPVVp!moDM;YeiZDZ{8p$M@*gK-mT5eboDBgmB~B@$GCNia&zhF)A*6`3*FiR$6;=c zLC*x{=fQE<+>9M1;wrg!k2sDVKW5Uk0QL2>y-hY-te7|@PE0_f!Ojk=mIc_^L0TF< zeToqhPtItB&BjnE1e*F z>*!#X=?%8I6q3!7+?RGMUI?i98#*prs{n9M;zp*fW8R4R9P57sF?w z$W>IpVo9u1FpZ5co5P1A$&HL4I~#6y!kq+u|3-E;hKG+0hsk+7(CIKRa6(!F0|U_M z;PC{Hg&l~F4$^ALY)2m_(-)&~zL zIhmT9Pq=FVYHP{urq0g4UjyQklTfSSbe??60yv#et1&rw^ess4`gL@5osLs5ot-Et zIr{iduD>7o`BH!MCIp`k`T6MY$6vYqePm?d-MdrP5_ta}>FLCg>B;WS(;IK*n9V+$R)2KftFxxX_ton6S^~M7Z{~cPJ$Kc+ bf7j(?B)Pmf%$0?JMlyK1`njxgN@xNAb#E|O literal 134 zcmeAS@N?(olHy`uVBq!ia0vp^S|H591SGu{#_<3tUr!gukcv5PuN~xNP~dS2G_YP)y~oXt@rDhIEoRUb1|r9HKn7 z-*0(ibob-?ulqkRLA>&VpLgE?0Pop+3IG7ygoQ4KZqr1Ny0rw|a0t0dvrYy8><4Gpg63AM!!{U0C25P%WSj)yGuIo!*hm>L?6^YH{E(z_ z#%@3lUS$jek~6k>ff46DmEelOVI-#YDWTIcpl^T7Z2Mgpt1|kH#ddj%7?%kRk0y*N zqq|3N7zClNlNH34=`cXQ;GetRYcJ4a=*lkMH=ps+^WXTL>uQHUj7|n=qmfQ}?@ zgK+M+eHiOp)oY6nO2qJqaZQ^OjT_QL7p+vqMIeOMN48U&p)yO(!kAhTuPkC*#HrM4 zOT~~d5WsCN*@~crC^0}*B?O@*m53o{h?~mCga(E&lu_8uS;U__peBZ#0m2Mc9077h zm!G!@`Jz^&a>kM}uGhXwGaD;;a5=-mc*Uz^^;xOZ^|;wJGNWB3o?)olFeS!m5Y64% zgji&-k^-2WOmyQSP`U1_0j6;m>WImuvpTY>VNuU@uIGIgb+II0G^$AofcU@qcRYvHxR=rIJ~F4ufeOOL@~KvzACkcH3)gTl0To!5y7I3EC0IPO`b z9#()828Dsvv_{Sg6sGB>;4tR0)onP#@@Z%KTMWp(ChFbY3}CPLR{BH#P1lT z6aY-qG))r#D5Z$V`&!wy-RX3W$KzXXZ~f_XN~KZ&5Dte`Rjt)(&*8U{kH@1}EQ+Ey z7z|WZ4TVAgkj-W(rIb>}_(=Bq{l#L@>-Eazav%`6Uax{6>~_0EBC*+Q6h#@2$3Bvd z;|zzx^?I!+3eWS6Mq{;FvBpRwQms}U$MN4}y;IVU7t>;x7+PG^NLxP z#k!NpWUJNMZnwU#@`~m2d0CbxlS!da5Cj1LbY1^~&1N%><1|fU$N78?0ES__#VpIp z<#HUyNs@HAT-ar^*%U?bd_MbNwrw*&mSs)To(v+U)9F|&)^4}i_WoeqZWjPbrP6PJ zMUo@{;CX&D8ogro`#qD%#N%6ov1^7{n%s1O%1ojJ=hQ;7_YyXO+szLIgXzC2!|A#KY&J^>A%rlDpSIucFBXeluU9UY1A)NxdKE=+x7#HWiOpuC zs_J+==BIUCcQ_ob*K1W(1wm*u8mrZcnMNX!YPIUR?%Uhe>-AtTh%sI+m#ktK#&kNp z-EPkw4r$vqn~+QpFYR=W_rs zP1BFGZ9A9CA%tXEzFaP>*lac>Njjg;eA00o#wd!S>-rO;l%~_^SS;3Vx7j^^lih9? z07|9OPlidBWdINaVKf?X$ou`C$zn diff --git a/collects/teachpack/2htdp/scribblings/img/13b344ed2ff.png b/collects/teachpack/2htdp/scribblings/img/13b344ed2ff.png index c2a1ac2e4dce5bcedb6d632163a947dcaf89d6c3..1e8277f47b25adda4706d55a713b8d0d15f40ac3 100644 GIT binary patch literal 497 zcmV`<^iDPl@TJQfVdKWQ}p>`>lZxAG&g#LX&-hl5A@PPR6yvHrvd(YO* zFbsX)8)IIa&bjCF$vL0jsxlIc<7lmY4PlHCLMWxQ*5TQb^oVPeEe+xtWlMvCMcaTAYLsjPPN-3a+CDYP zQ2(c5j3z)ajV7w!jQ%Ud{7l7EU)Qw|Vi*PnZj=RJ&_-DRh7L-NhT8xY3d&H|lvdAB z+b`KDCTPMaX7!uV+)+wRR8=@y-{^<8Ar_!{jb^+Jp_F338D04{#1snpwutp_LrmfG nEgkQD@-{?#u6!GUf`aD{x8QS_erzbe00000NkvXXu0mjf%UKTl@cC;a{YIEUX)$nMDW5ByZH2v7H<6E&_c}dU|@hdm@BD zg{1nIrw+r=_r10D&gs3sUavxkxmd?>bk5!9u+~Z`wbsU%_-xxYo*WJbYi-jszhS*x zF857XYrXfo-7ev1+qUbv+r$`C*Y(548DkjM5Q1~=A;)xo!qIhIJW)zXDSz-GzK_!F`jHTo0mX5naOL)s+2mNPO)u-hXs<#DrId4Sx`g&hUnN3&rLPh{S(9eqgz=g* z11F4ELahPgl~8}LlDzV)m|pn~yuJQ4CH-3^b)c?mDdjK>gzuFiFm$gJffc~Yc#WF@ z6^4~iE6a3%P-{@WS4>vkD`p4YUgwF{dZMb5>GEEm+|fu`U+eXSI~rQ+l=XS93-4%5 yVOSr2k>z(ZriggwDTKi8XyoU@I~oitcs>9ensb~(t9SAM0000+q#@SfMEvwdTOSl)vohHSgO30xkTtfo0#7J`lcH_1EcR3tA}vXi~<@BXxE zuM(%-`RDzopT2+f{o{{PtCMp+6j-b<>c9VNr>N`Q=rtO*p6xtiDd-gB*Y|v7?(dRa z+e&Tx{X7qy>_|2~-L`#pWZIF9Et6JEzGTw(-ub)LzV#-(D<-YD%$K}ZXJPf%O?MJ? zR;fH$5_;8+=jHJ?hXYn?DXJ=}TXUF|`r4-jUoR8rkl?i7{oO8bk2P<3;{OLLUCSHK zbH0*y$`QAi^Wv{F#~Y@0;l1@7jj;)(NiXG_%Ecq*M*M1jaFGdjkTTArTZRNwedQKCHYP-gqaI1&9Ir>ejWZ4p-3}g_v5$MfA(83K27qA66!dBpxR!~c}as1_l`HL>f$DAF9OrRCC{*#Yhh8qpv6K>OB@9ZLM+s@#8JQ?#6m$!CJGp;u~5*Gi2{adEM&Fhqky3l3t27s zD4=IjiG`GwTNFxB!0^h_Eee^P!&_}w_4_+fYBR^TP<@@!03&|m6qu! zVBE*zto58IVBEywtmQu?3K&jZU%sc0T6WV6etnuIxQNB*wDhznU|hyx1h0q!#yJ+8 z^Zjhb0p8@cpUpVu7Uvu+>(wvQHJt1Iq-%(emI@y&6+T)je6&=s0RZ0bpU!_Gm^VZf SdD&M00000q4YfFxP~X|OPal_RViQRYC_iL49lKD7Hu%2s+eRn*m~xO*vje);pc z)!D}6SC1qSa#v?1F$?emGD#`5wEIN@iSol(b&7N}Qisk`Os(utdno$66Dxt}*p<2Q zaBTTVQKKuz`AJvE;%T*1_!ND0<+??|8Xar@G;(`w{^Y&|7E*bf@?WPttrn!^F3aC7 z3f74aT_1<V{2n~K#9Jbn9b zMgu@>B0JE*rxvykHV^=W3^Vw=pN~8B3oDFY5C?Cjg!SA*1c1o9M~St1J)@LK%w!|o zxo}LbHB3i3^$k*Px^FWX6#)PzBb}mTnAMe-l_q;L0Dy~AO?t-^XK`2n0OVu(|GpH3 zpBKTn>u+SaS-l&I!#WWFu%>=U?~>xwT%Z5|8-hJZhgmy)?(-dv$d7Z-3J+N zwz=yP=NQ+mOBNR(oBP;2>sSC_>|ernL*5gw^azvVZKK2e?5+*}f3Z*7V#s~*7UP{m z?2=dsL`U1_CR&Vf?z2~M=WOzCtid^3UZtFCRwL`$pL5O9y9+b_SFo4atu3=#TV}Vm r%x-O&-P$s{wPn<9LXuQmZK~%dHWVK3_h1(=00000NkvXXu0mjfJD-mq literal 822 zcmV-61Ihe}P)){9Ki8kpLShF8(0-sgpHYPuxU(uNhWHd7hD4KK!_2HMl>cwPyPd%c)`Sz|9~Ep zg8>r`CK^cy7f#A9keGnH%*bna(Y@FX8C~mP17wc11sCKU> zmIBd{Ycr$a*y1rwD^MTjCtV?nr`b~GQ*{_C&?V6t9cleCba!R;^!_0gDnCj2Z_=J- z3!;mCZAZE!TE{+hd>(wT%2(=TESjwXow#QW+@g2dfWq{d(eTi_r+mCdcc4c1_BtGSmsdgQ~C#7ZqT zlwnMh~OjsPIJQa2fC$4b)BWY2msDnXV$9%+|k!`z2S8F{=r4O#m9L<4S*w&n*# z$kO>3{=Xhg@v|ETj6p*Hz;e^L8QNl<2(t95+5y}cZB<>OAWN?cb|FH-?NJ*diMs1F zWa*{lrORLg>y_);^0*r5sz0 zLa&(3k@(idk>RErJFak!Q9LfCxB%JM!xp~j1pvnWEqp)ZJ@w|mVG4O$=x{HaH)Zf2 z4e&NI>acnDUy(5_<>vi&atj&d!JI+?Gnk5nV&TH44O_Dhf@MiywyPE6Mr|vdZ*M2tRb|7M*h%u}w~^CJ*wBZH@_pUXO@geCxSV?>Vt literal 159 zcmeAS@N?(olHy`uVBq!ia0vp^T0m^a!2~2PJ(Ft$QfZzpjv*Cu-rhXO*(v1kNnTM?>T?6op{1u%^!dB70^ZoPgg&ebxsLQ E02{DF;{X5v diff --git a/collects/teachpack/2htdp/scribblings/img/1532990d5cb.png b/collects/teachpack/2htdp/scribblings/img/1532990d5cb.png index 84f6cd5fc69c134c9d8685709d5c2974e5e84463..2cbd994d51ea7ad0a0056472bc1ed67206ba2e93 100644 GIT binary patch literal 2265 zcmV;~2qyQ5P) zT~Ji#8GxVVM~y_0pYDQ)&>$ddB8ZA3PKbZwwALzM9ot$n#?NO!8OHGf zXCHiczwg_#e=hCqxAFVYH2i*mkr75l7#(G7jKM*Mh8P?i|I331^!L->&%gk8?f}Hb z5+Bc;ImE}4m`Hp)9uICeNl7Fplahkljmw3DVO*M~>HMcdL-h60*GEqey}jJILsu7_ zopg24-A!8?H*a$HE~%-crjnjcdO8^yWM-0?NkT$Ue+uhkpwmN(|qy?t*w-n^76|R7D_t_VERrIw6$^gFdu)+=qP*k zuzRc?q$IOX`yhS;EG>Rz`=twHIbCWs#WaVNprKbQ^--U zQ-H)o%F1YN#_Oe^fY)EAuTR=3geco7z_ZWt=9^r(!q^xK7jpEdv{0x}aDRFnRaLz5 z3OPCK-%nhev`vsve4ZX=`EshONlRndGHPn1ZGw!2=4pas$Jn!n0|(f$MOr0jL`e&T zfRYl@(%7^KO{2J2+9o(yah?Kv^%eQ~R8_HTnY2m}u+aWAi6u+8aDl=?E?<^b2?Eyb z1gu=ikt39r(%mhsVifDHdlS6-E*CFy>Xh2g0MHB|?LH-<;Rmmfja}9~APXvBzR;~Z>)urP27nA<3!T`g6L1-pN;~MoUY&f9FYTZYdv&@2^Q0a0 zVXsadkRX=Fa0! zQzaj2ocmAaXE{_!JLtwnoz}wV(hj<@%l;GvJ@8|>`?=2kG$ocoi?SCZuurF-!)a*; zBiN^-LdcIostX$ON?f8Fyy10=(+sD`ud zJ%wMx3F%12v3{rDz#(Y|<5;{?Hn`!8w1#mk-f1@+k$Vkc5V7((A_{ImkvSe4bj}fv zWfOd3j!4F_a;I0}fV4xfu^xnCU&1A6jR~B2 zdIUd#yJm`H9BX!Z4faVp1Q!dgd-LGmW;#IxaMr!a{0_=Z7RfkPo2O{F4r|~)(k7E| z=IQ?^fkyL1GLF?cS?>f9z*6hpLO28SVMN;G`#9^~cf1B4nKF`btTRtDp$+n&P1@v< zIP)~lui(5{BN@j!oveC-2w;&;%U}-tQ(7Z*SftZ$;m^_zA;k*kh?#H$o`-g6lPBPu zBiII&=8j|>D|E8b^B^9F^6Op}oP~KXDsA#)?7r^33V$(uB;%+(PcFC)>*0#5#}u&j zJgtRJ6(Si&?M^%3u(U&XP4TR@T%LXqw2aB0iBSm z&SeOju6rxthB}dqqiQGB-(Tg2qH3p~!bxd|aH8b?6c7J}1f?z)*>Qg=f(uGTGLDj+ zR>Qxf9m0%~os@p3SAD3rKSjWONQQgizik89Zhy*w>#9XEj(VNceNTTQsMkr|&&V)> zdYv-t@xb6D)a&Gd+tLo zQx_ylJA@zgI^A+QDZvd$k#-0_>UFAy719pjN4-v$VX3r3_))J@3jkTd7U4#{PQY>4 zD(w(vl)61gx|wQ z5G`#I9t=G%Oc+gL<3u9Enonbi}G@oF6EhL*t=KSCbXzLPXQVlShR?X z7g=HD%So#4Pv7D7^2HZy-b`Jcv`Pq3zY|bY#D^cUVFT6G(kh|C5}knJ;_+0+j!CP8 z1oii)hpDMy>sCric<()?O_R0>CRUlJ0C{;_x1AIOj8pz0?tc>n%X(#GIbdU`l`kp26Kj%MdhcI+TERoZE)*s0S5m6ep2 z^XaFgr?YJv8#l6Ok+joOuw|zJem`f(U zEnK@sTN`a{%$dX7xum9&n26hr$AjBVTpS4rBqR_U%k0_An4$Y-ole0()9C7=y`A=U zIy>p=qO+5pp7F1{cj@ir-aY(&;^LS&lb9G{Vwg3H>C>4$of$L6|BQ?zDvIdn@#%EA zaJh(x;GK6=e%#$WxLkNVcswjw@}zGY9_HRX?%$`spZ8)Iw?O+(Z0`+@%fp$$g8=UY?*00000NkvXXu0mjfG8kf9 literal 2316 zcmV+n3G?=eP) zTToQz9l(FPu!0cobQdoO2?DYvqNq6Hgm__`)>#@YM>aXK`4qMAfTwra6f%mLM-)y=j`r(zjMxS9Q6Tb zfAI7FecztFIW$e9q5`KAhXbdRs3@FHTrQ%cnKA{Ji^FiH|2fo`eJv z6N!nzCR{|1{W(00rZGASFf_!_5W~ZajL_fDzySUIV}E(@0KXre0uLlO`?WMPu?rwT|xO0cjPC7d1 z?4+xU)>dxb3 zo{UulBbRCdBO}z+QC*GC$Ej1?zD;Q#95qt~ zNKdDtf~F?CUW$u(^G$ktrJX{E%Bcc8_Z)A(&6O*Rj4)>ohYm>#g$gzIs>e}X&1R}cy=F%myvRJf;ni^@FAY-nn8t3p~cJ5^FUe>RdRtXx>PyZ4X z*|?FcEY_|?)7Y><+9o)dbgBY;`z=L9R9CZTk+ez>FxOr+fdvaVcaD-0E?$&Y2?C~0 z1uR|4!Gn~S)72%dViZ#^faARP9_P<<{J7dr9ng#+tv@MTa0S*$YZ&}d8=WeLBL7cc zhW(Ha{c;Wlf7E8*tA5}#)WJ4s4I@}(s(|J2XD9%vRokAb$?_HSLYcINZY-1vI1&Me z3*A^~0R-}(3T6r2y1f8C1K$IXBW$4)Yo!7%!a`{WeONA)4~nE6^kKPFH(;i;gFY;m zsvR<<9rR(jRBhmvcF>3AQUOuY0{XCADh*V+C-@LnOf@R)pbyKXaznSYgFY;mDiwO9 z9rR(jR6l_ZX$O5+E>%7#`l1obrJ4;_r5*HPxm0;STwhlXYdv0-2)7_X=)7(}UiAzV zL5+RCN(mN2wX}n7td(jdd?oFm8w>4K(a;Ug%iRUG_o~UV5So>}RDq>Z{Q^!%I~c)2 zseTT}r5%i5mAz^@)PhI!q;Bt3lj4`~4`uIB1+Y-6zezh7#1adj2kK!O42o*l3*giF z4IGv3WE@MR`Yr62b})|lQ{{sjPD*PS$NZ^wz(KiJDh3ggA1k8a29!p|!-@8>;z_K9 z?<1p=aZH}-b=WKI5G>5R08WR?FcbQuO#;{p;A7bipGHh4uEMY2g0#js_EbHZ zpTgZp>SP?#rg{T*OFIM?b1r~0;a`z-pa@_ufREt!P#IyJjAO#7a=~?20sodZnSec2 z6WIt2k=MyMCQN0%14RI{Er4_2B+P;#X_NoQUI71xH{j!l>|`8MO;sGU!hC3zHhCoW zRQ<@W;Y_4jx z7b&c}04{|a>U1)W!l_h$cb8{H;Z#3^W6}=cMAf}275)QhN?lK~=w4L{=alMX992^- zhkr^tgc(&+Dg7?A`cQJOa>9L>2KT~$+Xk@WUR40sRqJFNB~z*U2?Rz^GL^cY>tO^X zQ{`CWvBU`|naTsVr5(bLlBv}FWH%$In#!IkHBj_}eGQ^ys!>I~jiKbXtn}NZ>qf~` zoiI(>A^a$r>Xw~K6>h)`X@~HmWU5QBMA{+zD4FUaER=Q#KT4)*1|Uz^BHSpM3OE9r zq#eSHs;T}C8>Ah=jH;=sAPJUBYlIV3Q)%!g_@lH&I8ikfupeH8m!&nrhQg`(;ScaJ zxTH85I&En8@4AS#Odd_MSq2M?r$jAGtYKvEJPeu&RUeLXojR8-K_CGDgi zQ>O}$lS5@CXV22!PHrySw=24bnRl;xB;DQY+sB?gxLj=8#@4N5W=cCv7K^1C=j>T3 zEBX9$va{K|nKf&eJ6GE2DOfdCfYDJ-p5*9Jjvd44WaUcA%2>53GEa=wPW3Pi4OCT8 zRmJJkq^0r7D-;(~T+B-^5fu?HJ+V_gip!TdbB1re!RO=pbqWe7EM)$C3JUOg$;c3q zvQs?`zn|J#YHO*hu)=m{9G>y(q+S+Jq zqoae)PC7d1?jHMf_bxp>+`Gr`iN8@sh&8WkH z!-3PuyYDLgfPLiPaNzOa@vvaQlfGaezn{K7`uZ3cpueAi0fvSc9AtQy mp&>>_7#Ts+&@@Izf&T(L=S;ehfCmr&0000VzfNWS_T2wf#Xx@A=9_QSm)@4Y bd5QODBDeQ>gNZ+ZMlyK1`njxgN@xNADP=H( literal 135 zcmeAS@N?(olHy`uVBq!ia0vp^S|H591SGu{#_<3tKTj9Okcv5PZye-gP~dUC=yIq2 z>5gVcmcKi^{cnZeW5&t;ucLK6T5BQ-z( diff --git a/collects/teachpack/2htdp/scribblings/img/157ab5efca7.png b/collects/teachpack/2htdp/scribblings/img/157ab5efca7.png index 3290717ca750f83814574180aefe3197910cf447..8cae7a8f42b5b25dd692e03329f640450b8a8880 100644 GIT binary patch literal 128 zcmeAS@N?(olHy`uVBq!ia0vp^njp-<1SHj&rY{6i?w&4=Ar*7p-Z;qF;2`4csQm4I z(Hh5Mq33rGAF$V*E$2M<+H)hhVzfNWS_T2wf#Xx@A=9_QSm)@4Y bd5QODBDeQ>gNZ+ZMlyK1`njxgN@xNADP=H( literal 135 zcmeAS@N?(olHy`uVBq!ia0vp^S|H591SGu{#_<3tKTj9Okcv5PZye-gP~dUC=yIq2 z>5gVcmcKi^{cnZeW5&t;ucLK6T5BQ-z( diff --git a/collects/teachpack/2htdp/scribblings/img/164b8da7bf6.png b/collects/teachpack/2htdp/scribblings/img/164b8da7bf6.png index 73e3167594cd666b7aa9e7824cdcdbd2fef6cf78..3f5e957375f4d532cb3c083a45b5b40f6ff23daf 100644 GIT binary patch literal 1797 zcmV+g2m1JlP)2 z?Q0ZA7@wJ)-MhW_)7;f)B<8ATNR>oXln4P4#7JqV_Jaz7Xg{=+(*6hj4aE=b2lb1f z2-T7zMgjLfj0phtnnOEV7yp&o+Zhu8j5Ui5VejW_7atLtn^82%k^^9@ zIl6b-#|J%o_ORptSZc=MKxo$zcdyjZf!MA$*lCXL-3ElE+zEoGvy&MOz)Z8aDirG6 zvfNo|#|{*Uuweq2X^tK0dOt;d42OyezK53s^m_d#PB=S(IgsBL zWKaC)zMAIY+JKPvzyZ8rL%Fw?Rx0(|t5ZFT}I2Z6D)d$+W6r}p@<+TTxdx!QVLX@tB|pnYR#XX^)9 zOU@7kY5R6*`*w3`N*f;5M@FcsTIsi}W(c9wxLV%SXrK70rYspwl=A~U1)B0hj3k}yqGOKe6}$BoK!R` z?JZqBs;b)1kTx`gqEXMDJyJ&p$6b8yVUoh&Nbb&%o|&(yUu`3nf4xj!y{Eq}*tTH*LXmvF zbm@|~d9!@*APj|U+p!KKzmU0dZ{g`gop$OSocidfF*W7u>A|h7pKe_TN>3){F5Na2 zOOe*fa3E}^l}hRI<;sm4z@`1zCdvG9KXv}PBZ7g0d*al=L34K2ckGz6^%qiBQ)jO! zlPL#nI=MVDrl(8i&r@6LyCq@HmuAjfaaJ&JJnw0y(+lU$k!-epQ+hf-^ULqrKdu(uE6kUTt%}H2Z6>o^x!-EQTvf|2MMj=IcmV{rfk!1OxZ#Rc1O}zIf5j zliVb!v)9}h((mA6ipQ9quH3p+Yp=|o{f3vc=pVC`_hw%{JmlK_*CI~ zDzDtzOAD4_V)l}<;FiHN- zV`ek}OU|w*sj3D;+(|a8RXDsI zS_LP~nT)PDwk@<)@X>5$GFpklEL8=k0&=lv6u4FGIcYAJ%@Vi!na_4Us%cc?_N@+1 nTNq7~8XP{PRRy0fgz&|`QnGW>Eqh^b00000NkvXXu0mjftypwC literal 1787 zcmVY000KUNkl2 z?Q0ZA7~h$l-MhW_OLA9Z5@N1;38|8ZiV`6pf*2_c)qc=`AleTtrIh{!{tcyt_JjIG zP=snp5u<{LN`k>a612fYO$hK=sN}wMnY+VF@4v;)2AVQuVnxPIi6?botbRt5`ic(^Uln% z#|=ClX5LvjMj;>Y`&oHsCR>b#__{h)-VrOuLNp9r5-ab_WQ)-dL>epaY-9rfTn!Nb z2>^geyu{|&7VB%F*9{~IMx#s!u#qioX)GV0mKG)i*vR&LgtDPql;Tb0V-$-4mx}=h z`YwGPn}P5;8b?TIZ>P_Jf$YGpwv|7{jt=@9Xv-Grg6>Z@t~|pxH^Xq4G7Z|Y!~3?s zf6}#gFJ&53Wuu@kuzQs!S?uhDbeAPmWrz1|=lIn;^1Q37izX9#vW1#Jplj<|SH+z> zVJJk63_aPA!`*M^t@nYD)YC(a3?ccj})OR1*^ zxZO_k;poVY9@~#XJ~J&rFzD&+b(#-HL3XIS!@DhJzCCJdbM4;k9G^0rl`XZ@*L_iO zDB?bF05vr^!RHMelr3(kssH-()hFup0ima_kB>wgAobdVLw1F*zu}u+=&5p13EXb) z@#8QUw3pQzI3imJ`!{~u%Llzyi~zsiIpy}t7B|#1{_vF$u_5GwwY9!er<@q=Hp`Y; z>Kng5V(~t&1n~R4Cr{e`hO<+4sJo-#yDzJLp4S3!yS*n)*gLD)lPBjTSM=Eaist9a z0HOQfL9}U8vA>^`O4jY!AltV!R(GV^WE^G%sIARkUoQ^~Xp@sxO=1YC zFlJ}f@o{Zpf+&iae(T8w0EqRq(w0WgmPRSw#AH011mD~&H8)F#4(Zd=`pk?zGlLfw z*Quop59*6*7o7n7EpLNy?F7KA)AWB)`vZD zH7S(}moAmAU*{a!A8z2(ANLaHuGylQvv)h5GCXW7EO`3*>@DcvqLMgsRh~)MXw&9Z zls-3CICqXzwHRC##!_Ma=ganL=A6i!8p-7H*|RvEwr)yGX6JwUUH#{!byM%aku@`3 zS}L4BZ}FZRONE7B`?ZX117{_iN)^0PUTwM$7nQ$%b4oMkXbsFrCW{v?RP$~(aN^8W zC&u<0IGY&K=jKW`Z&unX_2;1N@342^cs@)S9@ZZ}Hs8MRa5{T;+&MmF&`1Lo`};}G zRQ#-G@{1R5In9ToBb$^;^0jMbTBfetvnvi;AC!{5+T^4@HMM@5;$P3LuQ5!5Uangn z7~ph$t*b;cl2`6hBSTL%&Suq-k+rTa4L!87ey$W$D;vttP&r@wE)1N#Jw}rWRoOV7 zSI1V7mm8j_E;m#)XxFin!NK=WW^RvCra@aa&SZ?)*_CHX&lW1pds+vBs--&qpCByv zpn@3AE-;X-O-#I*$%tkwk3Xf)fq`tIDEjoPutc7kGg-&57i>!N`piuEp!j5-2?55k zWk#~ulydOmB9Uc+fts)(##5(!NgSbgk4Z`QwI1e0d2J(E0j({J#8g-aYsC-pM`h-h0lu z57TP3FpNJTsHWA5E>&rELtA5KyFf}aH*@6JGTm(50+=?AmaoUYVHkr^&po?Wm-|d77j5UoGbbM!|MPLwIJ|=WApI#_k+LdZ0iDm zzIl1;a3opQB%-t6HsTt`j#^i^R=Rq~c~b zd^+jGm)BP~dof<0$-@8ug6G6S*=JKuwKjI5OM4gV_rIMRKGVnA-U9EV)j-ab@?Q@= zetPEx0MwVZd@}LG*LPQO{2gDT*~0)zuc(D@lG1Ruh0pLlQuN-W#liY+0|1NyQ40e0 zWF#%x9EDn18#_~yvtO6N!_cAEb2pC{=HIA7^2GSyT{l+Rv#m`q*B+QXJt+*y56+b+ zyVbAG%3&Cy$8%b^v`;s0Xy#_`CeOquMmac^ZJUe)skqxjM1!N9FUh@HS#$T&iqs=p1m+A(twj-K(oD7HU+lHEe0F>!{4-i-o5CtZtvny;|8&)`H}De;vp2 zw(rja+ya@SV!ev*)dIlnlSNY!LP)zcRTk3}CvM=cEK&;J4~q$FqG|K)j2kwC51007N`>J{po zustSvQ6Qo3@5c%*AIbp$z_2|TNp?1KOi&2IoOdCADXpMM)yt#JAVWd(-| z*Pq{$`QZF>(&xUhA#&~h+2&TgksYtB^}V2@NdEBH{MlyX!uZ9auKO6Ws%% z+&WrhB@gQ>^Y|*Ix{cqt`>pd^&c+kW8WJLgVH|%)-w1Ydowzc;Nhw$Txc!dLXtrsa zcP~0Gcp(A+CdW2lyqmM9U3EcIMJ^vzB(DBDPb8FmerYk@-z|{oKbBLG+Xw)e7rDkf z_wWK231QQ{32v({XxjP4S+uTDD40(K+i#4kN}(=&#N(B>YPH&qR@uH4sT#F*YGUt9 zr2>FlrmB4=MAz*8t&{x$udMa_*AJ0AcCO#Hl%+Jw-hxXzU$Q0U6u+ts0FG_GF=mdh zjf3SNiKW>*+-)O5T|Q4)g6Aq-9g6*{f6Y!StuAUZZMNWr$c#!!*dDWNTMUJYp+>P# zwj=K6sscU$WTkMqnGL~{+;PgZm7|d7iZWhE+PiUkaCCJl@_w(vJHMpU!nYf)BDXnv zFh2fiQE03uuH;v?Z<~2qSS!+Mwf}nea%7yZEmOA|Qvjf&MTXa%**-(&xl>y+)G7@C zgwOEap0-SX^Z~%Z)n@n2L?*`;0NMqTlb_ulJn`ID50KzLmXn&!LjU?slAAvhT^|4Rrhfk^2_a@?6aY{u)sNE33~!ioxm+n% z0f2=SZDM?ozUuCo;<6kb0MP9$lC#(7yA1$b{T%k*Tjk=(005<2b@$9OTtxu@Nn00w z&GI%RC4uTh&4rm zC+QWaF=_WSOB))IhC$NqX=cWQr&G9RViB2cx%DqtT+0+klDpe%8H@eq&t6%<&;* zv3=|(#s?d_C&I$bQGk)FrmqUKveAt@zp7ndg|C5yx2k30m!hg}i8AkcC7~NaO_89b zp#uOg3?r_hdYHUKXLEH?6aL0f0Dx}S`xdk`bejBM{RLk6jF{zZqMMzQ75<_jn+8GD z4W-{$R})0fkxr&9=lB^d<5|$DoSp?!P$SY;O;{9YX>ASwN`?CIZ{_-`oXh2kZWRD9 zoakfb`0A_hOpNX0KxY_Da%`DaXmer(vRQEOLw z97NlaKKMNjaQ5h<7|n387S@Szn+8m5>X`&CUZ%EcXU{%vYdV*8_OwHBN>lYqbI!t= zHsP(HJExxlz{3kA(~^28(8HefbMn%WX0(^qYF@eS&og>9b0#K(0Kl(oH*_0nM}m`woe6^gz=E#ZkfdVyV2JooI-4Xq zy4sk~Vi?9C`g#fu1*Eo&$=bbylePU8AhP+%5@V+rBvf5 zFs7lD>#B@Y0H9f#`Gm78^Z5W!SJDDnFt*SeqMqAgx`T!+Bi2VdUsoR?BqV>7h*5M# z%Vor)V10Dzg=2=$YPDSwg?U7lnA=| zItEQ}BT(>gi8aDLVmA5SOn`fkZn@TF;-Rr#$aBJ4QO=c$@o)O~=Pm%yP)hDOj=y6I zuLDd@VuV&+2NKvm4ud43q^h~j6tTI!!}M)CTf0nnu9erR|4@BU%&^$yA!!F613>0Q zF7n*N3nfUapG4zu3(&cN;Y{E3{XD}CCZO|q)PmlEUdq0#ev(yk_01DSq$)g@YN|G} zaRLB9-Sg(|o+*M-$-xuxP=yqP$ifiF{iIMSH29iq=s5tG+7lnMYwHgUesc zKbwEu=pR5RzEgW~Z>BNrq{YEB3n~C~wsmFv_>{DdT&lc#rWncbpG-hCivbg-CWcaJ zW&j}XQr`Ga0V(n3e+y7q*#vH#EG)c9R{7OJ`nS1Ad}HHSV=F42mStY#;!)*{)g-As z0QiKny+T}&e14D7!92A!qmAF$E|B|-#(x5lUk+0FwB}klDxCL?ce-h9Fk9Lxm9qZn$SU|(0mnt0o8UHPV{*j#}1On z@pr`KpZ;+->k{$2u<%yRkK6B%4vjuE8tuNs)Yg~tTCD~St-bR6VI2Ti(rNJ@M;oKZ zt_a023;=SkR^+Bv007N`8nbL9X=e%*+i*Az$=Ru;SHH_6_Rzww2Oi@^rTLr2;TlZ; zOIej%y?xf{XAkP|7P_s)h%guL(Jb#UmR1Y(+~#_2OKEmPmqY;o7=~>;`UbDOHSNG7 z0N8qA@ubDQ6$+_HzRvFmddJPEl(+sC9TMZ|6Tubb+ld1)$jF zq0tKieZpBPg}SClknvM7{-MI6kD}M^pM|q9!Z*%Z4Wu8<{c&4{tb_bu42PAC`KIsZ z#jXg=xm@w(f?vSEa{y5Bgugf85+P~T2hD=I;c(oXb;OgA0Tas~H|}}+LJN;PfOHFB zet2yDXR)Wii03F2Y=6$X+h&|5eA9#jV!SYo2jxOx8DQkUD-vxr+a=5XP96!?Zt@kAv= zL->z#JzTIpHi5iC@8ZeWdw;dz=nsY%5XJdd{<=}IUW9fE1)IEhK_XC2hFwO>Ow(v zVN+veyQ{B*_h^>)XcpVszR#3@fJ7}cl(ulQ8p?8bOpa~P1oyxwHxq?Hk{f6s?|S8n zVxd?l^$K+figt4ka_WD90$(s!emOPaAALI;p) z^v|1cnDX2(1_rTE_KwFvr9w@mnVqQp(7|NAZNTWq7hc2ogSdITP^nM@z{L2VSL8Mr z_S}#|t<<1zu>c+Qy)yiL(6o1%Foj4}78PU5#T&MgRZ+07*qoM6N<$f{TBF5C8xG literal 3767 zcmV;o4oLBdP)~ zXtmY}Xce^%I0A}{qJ$Y4LP(erNCKJPj}tE8auXQVHv$7NMBelJ zHOb#(=HIT8btnibBV$TfwD-*TF%gUXj7^P()5D?1!}CQyynh1#!Wa3ycYFcf{%*kc z?JXSukeIQK}lbwKQOo%dV>{|6a3D-l-G{ zBmf{0b?UZ@8l`Q`QUFk^{vL4v33&|_tvjQCsV{HATQCe`d)s-3IjL0Y#u`yWrBKu; zK`KsW-6vB{etBb+gFF2dxjcd{5Xln>q@PYZ-CW;}e%d%%y!+k!klCIVHl}zVjT*A9 zmi~6=$+NpJ0id?H>Ep>KzrMGI?PK?<+#Ue{G1}C?H}NSrb0M=ljuyN#Wodvea{z!* zAbgSU-n957TfE&>>F)m-lOD57orz?ZnwwKa#)|JEkH*BI+~{;NWQGiL>lJ0n-CeX#E;PTkK=h)4rc)XVA$TYcx!ue(o1%<$+tzG(x^26ux$I3s8vD4d#d60 z!&y1k%PVquq9!eE%uzNo5&C0zdF=atUQa!i4FIO*)YElahcNno@av1C z8&jq2GE%Lblhx*9^LxLM!5H57G57n;*U?KSV9lNx3}>r@>wX7-smn%xcHvE2waWe* zlqwv_-*{nf`ojw^NbmdFrm*z~=9-vyk9%%O^E>{>ko^Afg>%=3k{aGSQOo^9p4()`-e;8x%6-PYHKD z$FdCjyl2S;{!1YMFxXbU6P+F0tSj>x%CdQ=SaIz?IYNQ-^UF)|{?2|3pYiOn?0Nu5 zzr@i;-lK~gBm~d&ATU>%*Rbogb7*y;P%zI>miIU(rCe3~n9D6~)@U?s&C>m=lGQ5B z^tkT%swGb*RaQS2Aeq&_1+zckmNZ}Z`Vo@H&-dPuw47?zU5;txiMK_b=2f%+!11j& z$IbJyv^5)~VR0rGXKqxGM@ACg0z?7)=u0X93AcQoIfh?&OLM*_-@lR z#GHdG{iC0k1Vy>wN?v*Ej@f4f)k2L%^X=PL!lJ#b7}{l78Jo!*|N zQmO$UWR^!l$_iZq0KnGCa?hJ1C5L*0H9Q;9;cM_zF^js zQiV(j0H)^D$ua)As(WV(OR~5CK(jVY%v`6-8~`|Z+wQx+#?g%q01BD%-r484N=u%& zr2}tbdgv+ZY2dxFKN|kazumoLmp-Y_NY=)mD|b#aHX#XKnI1MPcTGd`&Hv>oWvam# zRu%A{rk0_`_&qbsEU82@4C439Ff#5VjP@DNp8eL?-t9EH>5>m4kj%-f#I3dIVXWVnxo4azZzR zssesfT^j&k7)D%9bue|A*5}HC27J(H$)j0!kASyxKs zok{?p+tbF)^U_t}=^4w@mPXf``B*W`(KZ19bzS6X0~TvWcMc(_76K_S_(kwh?`E}1 zv)1(x+M;y9>*Bz{wU3%L-O)l&Bf{Mpuwg^jRB&`Rv~4@M^>JClIj)17H40lADtpX4 zQw!>(H~jCOc?JNFE*8y*@191Fx)#!@%SRhgdo0@AQtiVw)`;R94;Z+wxK+Eg3HjPn zfiCjwX%q^kR%-x2P%YADZ|y+L69Ir%-rAcv)Q$vuS8D@40e~q@yE#cjvcVYQZ_~k` zp`DYZ0WF4Mbh5|9VQsI~O55ZF)r{3+5P7*bD?8fdXm9HjD{`*mYi2OPgj=eeMoNVW zKdUheg-lz9)RIRvGx7{!mFMyRpr)t^G@x(M?~Phcli?0(vSe8otvqe@gpj5DSwoDX zby_ARo*wI>T_-y04UIs1{~jEt~kdPk$~10CmOW^0XbKAxgFyYYZ7S*0veGYlLe$IJjZIN z)U$~K06@))#?G#Zf>O-E8{&}*DF}f^Z=exC3Z-0)FV4Nm1AysW5o6AcicYaYCQ)Qx z>smA8NP){tVoE& z5DMveI> zLZ5lmsvr!*03iEXS$1j}08mYhBUg+j?MyMoHXVsZa%OVzweNF?Jv8v!!6$ghY2lU$ zxCSG9F|CxT66TzF{;&pbp;?)Z3U>4u%k&6lYBW&GX{_Zm6=&9Uh~)r)Vc6zluW?J8 zQw}}`fbAETPFdPrzmN!J8@!LAk#1y6dE>)~z(_aGP?nG{;bhdMUn)WefdH`K;Jn3K zCl20F+|s$;`zT6@C=_h|rm(O0UI#MlKKh^n8qg{`*%Z-~Uxx z9*SBS6tURPGlZ#>tEvk4X+Ia@pEoS|AY%Q2Ik**(JOI$BA@x}HPdn12ZR7`OILs|g zw*0UlYE@9ym9j4v{R+Lv1AwxpynV5k3HhupsHVo7jzrJfKs-hnuwm(w`n_*nY~qrK zl+M14_m409H0m_yA&)}A4rIN(W7ZkMhk-a&e=$9FXC$c#$Myf@e)n!F{&V*qafZ_X ziBNWA!_`NZiVXCbu)rrFdAV+mPg0`AD6nwL_#cWlN5yKVe{ayNO`|uAJCeTrcXXrgd$6`Q0fRC04QGFwyJ1X}JE5II!KN-9{Y~aSENuEX zt@I9a`r`U3Je0s;K{xy4>>GVD2LO@FM^jC-Cn1jRHX*b7NZ>4NOh3E$<_9Mi(X2=+ zWVTGp4F~4#x)MvM&XCMJUC5-$niq{P3;EU08(SO1wk%6KCrc-9yRc|4-J|6Gps`w1 zna{7xZ>TSCb@H%xCc4xCq+xNeAfv=paznmWXufF+4=oBj|@*2u>crTyv%`B)47i*7T zX6PJG-NPvyeULYTfk7mYzU6vIAy*kwjZRj-Z)>n1H(-qXm(Z}_)`@(DTm=A=WBiAS zIT#^tIG|Ff(WhL1js}Mfe{SCzfdSAQD0jaIVkLSAF+$#u zAu%qQP`g>XcjmC(afG~K0oBClox{=olU@4mItYxAH)NQ%A+(m$WI;D`3v>vJ_8JxJ hINWy}NfrLa_&@h(>tE0?u3`WH002ovPDHLkV1oBhU{U}8 diff --git a/collects/teachpack/2htdp/scribblings/img/169f2ceb45c.png b/collects/teachpack/2htdp/scribblings/img/169f2ceb45c.png index 89fdbfc52ef821d35d655f8f4fff547361f2818d..d4b7ede7b840c996605040c1ead9c63149c814fe 100644 GIT binary patch literal 1058 zcmV+-1l{|IP)W@pMu*C{cZH8QFTAyM{VoFtA)0_qDIlZg*|^GV%< zG0_+j(?OA?SY-3L503nR;CLD0oeqh+Q0wBt)Uwm{#0rM zyJoXPt==oESTf1R;|#Jjno63smm+21frfzrcRrs&wpOb@cP_p)bYkMuJ9n;Px4V1J zWNMUE%y>iVM;DGNJcmUcCiKsvnvfT(E70?&sl)n^-{$+ZfRhkB^nK2CYwzLgX6*AcqDTB)TyrkfN}+dLK9c6ypu?u{&attNu>h4y)80PV*T?nr_-MKT$Bd4Cl+AL=XjodB#J0`$mLOyVAtQ?U zg9lp?DT+cM@QbXRq0q0`uB~mh+1{q8N}4`$;zS?jGZ`)%z5yg>i6qrlYr9mhQ_1A& zLu4+OM2Qf*-e$?3&|H;?OeS6&Utj+!wk?(x2#G@B!J)UdHeXZovV;b;y5jWdAGh*D zL$4R#(+Cj4a`tOFEj`(iAP5yfkfJF3Q-UliM?eViD-TIh;PKB^wR*4F+{m)C$UT1i zlj5Hn0~IS16s0qn?5nGPB9~!Cj~)8}*`d$`)&>ALaKHr=*$*`}FJb%o^$U^6ZHlVI z9{_;gKOBoOkDN0Y91jG320% z*VVbRSuPf1mY09Oe?QaFF=8}6SANc;N4w|ef7sj%0|4^*^rcH}BuNRvzxOnR(B(Rh zYy~tJ40WBIlNT>G$KxTygu}jY*jF3_p}ae;s_Kx(Gv)O*bKEjw{wsiJYx}OT@m=I9 z^Sq?j*LHSJIi1~m_82fp5UPFqo@r?4ID7Uti^VNBr@>I~@k}`!U0SUklMoUX%gHlm ze!>C(08r`wHAJ3|@cf!qYtZSQE}uE^ c*a;f`29#8p@zpSjy8r+H07*qoM6N<$f;}e&MF0Q* literal 1061 zcmV+=1ls$FP)w3@QgbxO=;jg0C-NR&MoCyAqyfck>QWa7i#d{Xyd zOf-hXbdV_-4_h=52xJCiix9Dqts5z~6kn$7Sioy9}3pxewp( zJHPyX=gU2RdJ7AM0{H)fc-RwA24x$&31u6*2`bE1R;CLD0day*?ce|W*6fW9e>%N^ zL$leTR_~S7FO>=>5)9%RO(jj+w-aUIu8n~KH_xXL*J|}=&Lp;GPfUD#>(*r)c6ZO2 zOpUVo`TZA1M&3ufy879!u3xtkW#JK7RAn3YMJBTWfT(E60>?!}F)ul$l2msFj$8Bj zz72TI-`#Odp5L6D{Dfh~VzGsMo+AiSudk))2AAtBO&`K( z(l$hqXP8l`iLP(gk7btz23lgV09JCjR4_Om430;mH&2}S0stu2Lnt(H>C#)tWVmQz zLOi}0k1sAPTyARWZE5-Jem3%XZgB9G()%S6i(c({b8q|@ue!>^~)G09O;6s}(V+-Q8-ZubDC_Qve&SJ;EY(bd!QhueLwxA#w@ z(Tc>mx&Bn@wyc_CV;^D)a+J;(Paq{H% zTlJx#SBr0P1PEa%+c%SuUgeS?2o*t)qA2{+f-GuBKnU^29!XL_kpow)-fK2DhQqTc zJbLt_;`fe$`jrTZ(wR*5)z#ln$S|Wvj=YC>C^UiX0RRphZ~>+EMorBNm|wegE*iZ_ zQI+@s0QmjG@i?>Nn!(_BAn+pqVlufrJ^d-xD=HqVs(K12b^SS=?_9q=gjTa4ojaFf<8fwr`IkF)vK<{GM&mQ3*F1c#wTnNsnjB>uqM)Wu*Mu1JTy@O=IKR zC{*k>m0n-l**WEOcJJ9^z#>7Y_U(J3p`qjS>7OkYx7?ZrL%qi{<#2RqwR$WGT9Q diff --git a/collects/teachpack/2htdp/scribblings/img/16a631adf1e.png b/collects/teachpack/2htdp/scribblings/img/16a631adf1e.png index 5bbe9d16d49de04f50c8c6886790c477d90d3edf..ef51f68169e9a6d8d284c41386bd5a00953cd3f5 100644 GIT binary patch literal 106 zcmeAS@N?(olHy`uVBq!ia0vp^qCl+4!2~2j&wdpLQih%`jv*Cu-dFSZ?A3SWia4jI;j5X zpY~+gM|xFNep8m{?&g`W=X>??b)(dLK0fhI6`y85}Sb4q9e E098#QNdN!< diff --git a/collects/teachpack/2htdp/scribblings/img/196bfa7b9c4.png b/collects/teachpack/2htdp/scribblings/img/196bfa7b9c4.png index e77dceabaf834278798788a89277908ed3a67058..2a646850aaaa475db8884e7fb954de43a482adb9 100644 GIT binary patch literal 600 zcmV-e0;m0nP)lo`8n8pn;YLz!$Ir5)&#H3KJU=D+@Oi zS^&r5qTmm*t2=W&xd~MJWo8pDb7zMn66fXy-7b1P+}+{v5dil0adLw5bA%y+Ao-I3 z08Eg@f}IXaB?3QHsl-l)i$#)0lH_)KG-42JQP(R7I2vVPx7+mn6tI-vkA^XHO=!-t?!pKAEg+Bi*dk z!hD{x1E$Y>j#leS4=on0FIuWt{J7^)mSl0Ot1ADJ&6G)xN)1umv>_4+^%Rs`k^9f-R_depavr zH7_p;wxC8qev8@NRZx8&0E~P%jx5;h?J3xTnu7xcTToT|=t#jnJ_Z1DcBWvTp6c04 zRP#TR=b>D7y6AElo(ITp>cxdqd&Mc94K&Y0%RY8_>1e}0K#FJJe{l9E+3#DoH_kk$ zIP0PAjEiKgX2q`6KEvPGam+#?V>szdlZvxkiP{WXqBgsisNGpe)b45|QIz_QDvGwl miELWCo79L~%UN$7=V`i7?`v|4Dl@$!QAcK|p&#nlyVZxMzF z0>kAPFJ?0~o6P44Y|DI}%_e8Fn5!}t-|sUBcEIZy1nl<{;u{V6zJV?2`)oA!=Brg> zcs;AtJ@`sxFI%!w`4eBOC16X|YKDBbOV3M;_dIsHvH8)6=jVyplG!Xrqj-F&l&~#X zD#hS?J-V(H-gVjQ?c$3?E4E~@xRr0WE!vWu&SpLgt@B~HfgcWSed_;w1BSyD?<|kL zdL7fL>G5kE(<$op{~frwob|0s=5oJ^A4MtIlFQ?GUi^m#>t$b$R%`w+=N}(aRP_IGHSpKNw&Hs)9Q{V+X0RG}a zfxo<5@HaOK{PndeKS%ZdY`HE9g;cj*D8O}r<&W;&U8?+w)4gUWU$Ryw-u-<_mHz?h zUa$|Qy+E?lvCeO6u28qNMD@lR$#U5WUoQWqHZ)bU*@SI_rYdz?$`YClbqURJf`sNU zMM86wBoRf%gS04$vv53~*2aiOG@RikJ47|+lZ|h9;j0udx2aJ800008ESb>I`+9{F(5-^r6NsY^QzArINQ*a#Wx?YyW&jZ@F z-S^$ctAK6W)^+Xs9{Z_2&pgjf({x?uKz_$3IZthkW*QLne8OA(K4xLZ*5sg%o&bgp_&ZA!Q!LA;lhLA#*$m zLS}l|Au~O4L*{#Ag)H)rhb;A^Axk}kAr(9%A$2^GL#la+A=Nz6LTY*>gjDu;3aRhK zL+X1(Lz;NphqUsz32EqEhBWlJ3Tf-{7t-A09MZ!(hV<|_gmm(NVHiRPFIN-ZAnoU9 Tc&cFPRXvKt@L`lc7<|WN6e!GA`;H85FfbMntWU5mD=; zdsG$a8&yj>M%9w|MKzE(MYWN5L^YHBQOzXXQCmp*qBfFrL~SRVqqdW@M(rYLirPzJ zkLo~LqdJfnqxz6oqPmf&qk59csGcOcsLmvcsQx6is3GKg)DV)_s8J-(Q3FXHqQ;WN zsIerasNp1kQ8P&HQIp7P)FhHi)I1WH=UGICO!C|pBwftJsc52N00000NkvXXu0mjf Do_>Tn diff --git a/collects/teachpack/2htdp/scribblings/img/1aaa434b462.png b/collects/teachpack/2htdp/scribblings/img/1aaa434b462.png index 77e7adbefe182e7df6145cd489fe302813ea5aa0..9e3acbc688770b62c73797c41adef63f85e1275d 100644 GIT binary patch literal 810 zcmV+_1J(SAP)^bvXpIg~(Mol77Gw{=P)s4Yiw z)PqX#DKon}Gm2RK=fRo}InM5^)Or8u1NfBB7azNI_fSJxvma^Aexx<~k=E=-0!mTw z{m)~PKCQB{D5V>+NGIrY$8m2m2u=?u^|<-*%kS;=y>nxNDT{Kq+-#PcXg2JfjnI1J zyItI_UpRO_+w1${c8!)H=6vzM)Q?i~Zz)=X-RB<}Q!`2_mK(GN``v!xX+0x-%N6YYaSbTmIP6iw;$tIi(;`1X) zC21WN&&L3eC-}dCf7hOmDV1ol%az1Msq5`{J|^DnJV~?574c)Ai4Yi!_86LMIWU;+ zt900+V6fOrO0%WGV7GskV=I8cdS)QO)&YadoP?LH1_sC35Eok$4DRzVceXMZSZ07O zY<)0r%{}edwSa-R-ll}UCjVbk3m6#9V8uqm4hHs_KK)Bhi3AuV&M~;yLSPU&yK!gB zfkE!P%7rZo2GKJ*JGL|!q|YTy*$QCr^DI`@OkZhL;hLpAA3?JzxQYT>%4`R&BFz>t zyMU{RviZ&K;3{%#W-}MKiV&OAY_uO%J{8#y+g{Rc06^b(GOks4?z0_O{|u}OgV|-o zQw!VG>^{@dXFHj>hIqv6u~~W$ufR4l>zq7DvklCe zM=hdks#*VRNsdigZyW8F@+4*4TG1~Go@BLJ+_`N z9`YOa=k&ie=Ea06`2uekG4FnDnVM0`?kCc?jQgJrw7E3YeX9NyUdW*>_=L& oA8E~gq&54IPFcRh<)mo-0t5Z`*$v9xoB#j-07*qoM6N<$g3sKEGXMYp literal 816 zcmV-01JC@4P)Y0008_Nklrw2d%RlR@2e-m_Q{=^FzFN&! z(WKuw8fe$+Kjit%@|~Nvv%Y%BZ%HW8pJpG zGeIe$K@_ZKfA|y;lp+{R!FqN$?o$*a7fitj_CYrs?^4twk#M{l9(1+KP`kAFcrP6F zoJ(R)IO@g6dzh8jU0OUH0)R^N{~KQ3emX?H^4rPI7aVVDuqThFL*zAANt&H6@UQ$@ zn9N{$6p@tknZe=&CL?DxgWbWCTh46;>+?3BT)+%2Z3Ygxj2RreE3|SkGq^XEsN|An zAnB#K%Z1HA)k1WU%bS6)b808A#0>a7IVSjh`~NkSn1PlJR&s5~&A>4pz<=5?;V=W! zRD?>-WCp%rkh`4E46HLS7dfjLxJQ3>a&9vSOgv5H0%q`b(96!o@59Pa_2J$QFWb~y zMnKNUwlkOEmUFRP%w<^RENpjk89q5Zo61~27IR>}fj4e64VU-)O<>ys=a_pYm=v<|el<*LSe^Ws3+fi3LySSHUSVSdhc5#nc ziMWmadRe18>DBB}U6VXL@S`?QOq5YGeZhM6=59?$ueoa zo}SJGtuPGnBk+9yaGam%4FGaK&_@`;_p$sA!w|Wj=o0{}tm_s82m;8RSQZ=ymX&F@ zK-S!RA3>nsW!stSGb?Vg4rBYavejoM+=AfSIU@KzdOcVcS}oYN)V&4UCM_uwC-1HfQ_(TH|w;p_}YN4zn0gGr5>Y8#)Q=yoxk z>W{D2adAP$Tk85uft%Jgo}SR_3ARCin;Smf3I(*=s8-2|De7}uZmJG_AD)NjXVEg9 z!gVp50YJHo%S#lCV(-ZbPEP1OrKHcTxT!jPdxPuZ>r1rU-=p6r2oTWRQXLvE@L!w`c3?(Rg(Vgc91>#P0>M@Kk26UE8paB+cpogA~JJ~!c}mh0mK zo=0p$Eue}@1)UDjCnJpQ^tm24t!+F$qSq6RVTj?7`~Gt72GDAeQaBFUZBj0k@W%RF zgPUp_iv>InFE65HK1a8U_jhvQWCG8_=O+LZi@3Pp-gtbB(^F9#+eWK}!$We+2KqGR zrt0wZ6|RfLLbUwz4{mOF+8Pcq9P+EF-l*Ei;h`p=t)y~X1r zIdMLR>tZs|U$$CByNyCYwB&MVw^6H!7B!%)rOy@I)YLnj!t?O)AzEfL{QdhqeMMk3 z)MjOMGJsN2Z9p^BXA(Cx^{SKA<0EcwiCmX7#$(YknZR{LR=&JMsU-Fu9B_lF)zEH} zIHnC~EA^@8rrO5W7hD%_Z-fKOAE35@7|&F#LNypQj^*>{bhrsQPLe(~+*I3meun1} zamtS^5twbvW^moutgKpvs>ah(93PXjv;i&d0he%7Z9{7kqY;Kfa+qox4-e?~V;2;b zQ1z)AOrwGGb8`3EfTq=_;HK(uIz_iD1O}Zl0gT7!^+Z+GNiPAaJ{OyV>Too|U_e@4Uf_9TLQ`!+J;ns8KAFL2-BKISh~ET3$aJV?i!emLkNbOa zY1#b%1OfVeGU=@aRiCPzG@Cd-C&keQv`C-U*B5aUCNRWU0<#VI32kF&qZTudViA{@ zD3_DYimGS%eke1!x+3%Pc#NAHB3IQmRBPD=sy>;)sANhd{Q4y}qlv+0^FyOSHb)~u zY&^!*l^`~sb>iIE znWYl(E_oLl^r?d>DB5%!LPnkC#OLK7Ls?cTVoW!i*}jXBZ=+BUb9cQ?`jxrKf<(k^ z16k(tT=yv=pC>^?<|%h-S$tE5h8v7!DJP?J5hqB?B895es0b+wv1KUBy*-g@>h-MN zp~bny-X7^OL6DHS8OqYKM8~$x6`KljITE!R4RO=#OK02|^xUvhS=MT?B9cc}rNWgz_^*qQWitHrL%2P9NF=iEhh^S3EZ$F zSu*R3iz9^se;QE1+YDtX-$Aj+muR+u+^Jkc^Ee_J`L>xXnR3!9UBdLm;t0#fS|o9U zu`HX-bl&Awt7Q6$b4bS_N{Q=Q(`+b9`HOTME|Sf_su5k2)sxlGv~Dn#rR>f~NtQA< zHq)5Lkq9fe!C02H8ktEq0Go^Di!(9_`B;Wts)n+Z(~xCto4=SKpN5tOP9UHl2Dq!{-r=XQ-A!+}vWEnTu z*dofxm8hiOoyv}~lx5^7&8B!CP%5QnAq@4S;I@r;I<7KZs)#_G~0$nqy)9!Daq=9VDK zAA=k(VK&&XE;sC`bmsY3hS4{$b6IX6NErUcQ2oW)4w1{HTDOe;r(^?|3lfIhu#OTk t#ag#v%I!Z=y8kn`wQeKx|6AN4{sl7N!6~Y5!1e$D002ovPDHLkV1n&jS=Imm literal 1759 zcmV<51|a!~P)Uw%=IG#@7dHDDcEwdSZ|Nc9zt-va& zjnwK40j03o1ZODJHT2YQtWIK&kGQ=hx?M6Ek44L50@oFh`tlN`lGuB2!2PCHL%U7# znl{0$6>20s)kVI(;JSEwBQ#h#0d)~XxTxwJs^6%2EuTlH!#&Ay;)JTFr@F}VGdz!| zRDQ-;fw{e`77^2_D{XMz5 z?1un?0R29h3^#%*RMlOYO`M;T5@{3MN~l&ChRpq$(h%Vg%thoUy2Q|CG3F)3A}%jc zF2|j-<9^>YQ=vH+R)oHeYDpck-DxXpbKYobK)ofuekCxGBkj>GE za2tMJzJJSPcC4&Oq9*&$rrl2%kYhlS|Yh?`ExFZy*;rhmr6sA zom?srH`= z;hXfy%rGjf6bk&gL4~HxP@nQm6pMU?XB)_!%9S(^E22@;WTsChp|lDZGp(_(!eX=* zYv{pPpUq}EFO92JGOa~klzs|I7k09%E9y^*=+8pWibYa#|S1XcX0ssI2>lAw0000B{NklX`8Yo3dX_lDqb5{G>W3q=_Rk%4gd(!z-9{|pD=8EX(=iYR0@Tvyn(eu5Ezb6bGhYG>Gsvb z!bJywXw;9QIuzCUd?Rb+`un?3RA;lD-%vXMOilfXqB^trWZvP%Kwk=NftFg#O*c>z z6TNP?#pfFl3Y9fAZT0o<35CiHRm9^VtMx~ZXBfjAB9T%q*Xneim6z9*43s2;{rz1| z=RnpOAOH2{&C^GY{9ar8PJtyJ&)GFW~_P)Pvbyf~XpWAH_iBw0A{>5Uw0ssod zE`?$jMWt-E3pU&NLO}1{{WccE)#~=chp%Q9j6|}nz5TmHB5Jc;xPJY3clT%}xneP~ zSUe6#koTd{a+jUe`U3#y^`B=bv)Z}yBLH~(c#tIVbwTgnzX$+2-N_shjm8K7b8}+^ z;m07xdur%%l*vlNrbO(w}eV6wWpz3&CUjV?JJKu!EuB;gjyM~5-0)V!*ud;;2pGhjC( z?%kgl3?@3Am33$oMQw%^0OIkG*ZW|8-pS`zR9CkM1XV?pEG#_p`9>m<=Lpgumuom2 rQBI%)p#P6vn)~P$XsNXYT5A0Zi;axwj)&K&00000NkvXXu0mjfOr{CL literal 1078 zcmV-61j+k}P)6>KDoK)o^xrLOa?ZInAs+sUhsPD0DvHMY_=e8DTa+MEJOu@a-mSQsySjY496$A z+)}A@`_gXVqGy|E)Q_S%6xI2BL(7%+_I9AC&SpEmstEvKV&V@J)tSvF^LAIwx+%29 zx-nuFBP266*6ns%e7+%}P+3*gQd@gaC{(U0f+Ry$>yIAKAci?aBBfle)#*MfEv+dg zD?tQ%dpn%YzML~U`s=M*r;i-@y}J6H0z*8Wzj}JwL!l`EU@+J?J~=gY$8P`mz=7`@ z8;>u`8jA(y=RJ87Q>lfe=Cy0@x!o4ITw^ep%F7#Yd~$gBiq&fB>M|IO=IZLVR|F*p zysOI)kK^_A?fdtCEtPH$2A|sPmo1jF{r#UR6xxakU4GW??)O(r&&lEFal0)dk?QEt zKUu6-06?MGrBLk3WKuTU1)J@BA*}cAeH)MCYIW=3!&kHGM2xv>m{6%?c~}cqEaoSO5CE9Xr_j28S}lU~okuC650ci9F9bYiFg=7}=Y>dryl*`M*#I@ z1g~bDwX^bgQXWqdj|WRikcNhj*A^m?Yy*H;Y&MaYr@ZtY&pl! z0N`}?Q~a5kp>yZNCR0^9o#!*RSS2NLK3@s|V`INjhNh?Q1AtguBNSE?fpy=$GXUUn z-SPWJawbWJZ{9pX5TV-Icj9}&z=)@`(+G!jG}Mt*wJ2A_Bw_+ z#>cNmA}^H6X05g(SGnFj_Ryg#GTEEAZ=V?)y!dY-liS>UO0WNt%@!7tz+iBW9kccI zbv}A@b@AbN_wG*&1{0mm$~m;6{KJrB$m@MLJL}~0%PK3I1cHh+gv`x7_xXk*krxP3 wCzoqD91*3UIIRDVHq-fai*;kP#kw*22f_J_?Q8)!(f|Me07*qoM6N<$f@<;y!~g&Q diff --git a/collects/teachpack/2htdp/scribblings/img/1f0b671ed7b.png b/collects/teachpack/2htdp/scribblings/img/1f0b671ed7b.png index 14f280af243126b8cc0b59fb3afd2fd0c2aeccdc..2d310ea3324e2f064318a99a0752e0fbeac20e68 100644 GIT binary patch literal 112 zcmeAS@N?(olHy`uVBq!ia0vp^nm{bd!2~2jb_J9JDRWO3$B>FS$q6YbDH0q9I5z(H z|Nno=>*X%`!j)DlncUvWZLPlYE^xOyjN!?|d?SvTA%cg^s52**5oiR1r>mdKI;Vst E0P9a9)&Kwi literal 119 zcmeAS@N?(olHy`uVBq!ia0vp^T0ktu!2~2NC1>6OQg)s$jv*Cu-d@|t%b>u+>?pVK z|EXmO%?w_j->uyo)T*-B(6d2IDk9zSC))wv@@uo!E9pbPf9t*b@3AfB7Sfu}umNNe NgQu&X%Q~loCIFDFC2{}& diff --git a/collects/teachpack/2htdp/scribblings/img/1f5944ec1ed.png b/collects/teachpack/2htdp/scribblings/img/1f5944ec1ed.png index 2b513da2346f3701335c8d773041afc4bb7b632c..8c49da86a29a5d1a81fdfb08173f50b90d2640b6 100644 GIT binary patch literal 262 zcmV+h0r~!kP)-`1`|}LEDaHt{$MtqUo%fex z7!t1!I{?)C6R)-#>OG5j_kT>fvoYgdirw!*?0c7E$GaMP-ICbl7RL6sJT|_YV#~WV zHoFzE&8>?KZgt#y_rzUyXRN>bW94lUYi_H!`8JH(ZrixwHjkyZM=ZLX;`;3uS8mt1 zbbH5(HzCg7oH%pS;`z;te{OR8z4`I`9uflxqhbJIR19EBDe>2rCvtl8OM3>IdO22j@5<(!W z@5l3XyPwDFh78a4{&Er#Hb2|juZAZSw_TnpT z7rx%c^G!CGZ?%!U!iMoW8^fz@0B^CaywNuCc3aOwY$cDfH9XL6=CO7g54Rh554)Ck zva5JMyUe@V1>W1v@dSI7=h$hUW+!;2z2wRE56`#1d>4D-d)X7;%NCKL?^gT(P6YN( Tt*&|i00000NkvXXu0mjf6y$qC diff --git a/collects/teachpack/2htdp/scribblings/img/201c231dce2.png b/collects/teachpack/2htdp/scribblings/img/201c231dce2.png index f641cfdd40d9da87e3451e3251e2b0b0fe34e30a..582f004f71774cafa32f8e1b63841eb4ec0c10da 100644 GIT binary patch literal 745 zcmVY)GIUeWVtzxLmh(er*{0txi@=qVLy%Vz0>`+KWjc#9SlM)} zM(aMSJn!LqP*cx$s3b|?GJ+uReSf)Ju2!os40pR708}cKTCK)$-1GBuye{=#Yi zK;^nOo6T%Co6qO#^*Xm4%d(9|Ls67!wfZY}6h*deyRI9@ac-eQ5JHk9sj5oT^et}B z^Gws+Znsxi4`CQa*L6`8uW%W3~-EkZnhOt;I3K3%jLFjh7 z2%*gQ(Q%R_g^K}Tu~-;}ae9G|+?Hh(E>889Wu0|$a8{t?GLbltjZQDogFbrMSEnAFnU3atD?A?yzT>Iv_nK+JTv)SG~pU>|j z#-utF1i>XAi2_-#*Fg{f0PXvJ?(DHY9(kjWe;)wQdTRB>ey`rUF#QqV_j#VD48zDg zb{XFOz75@BW^f=4UjMx2rsohvvD4|$tJR7yY3z?rO9Q~r9k#hP{&6lPoIRG(VHgtJ zBX4v=gj0eWOKH6HIS0Or*G9Q1mS(?e_XJfc6++y4Y7ruGN+^q^s8*{HCiTTWAtI-Q zvRH~Zjw4L!)q4YJa5_Ga2EBTZoD#}nDK(u=CzAS$ zmzNiw=Mm5IEX&?g%(5(QUl0H^8jX9pQyl^TMNv){uqA;IQWRzHu2!p(B;Cg?NmAOX zeV?wXstm)FEoK--Rn_$H+fCE7uIpvHbzMK~4)?cN6h&E<%M;78oaqaX{$iS@34&0D zSP%qF(=vlcZi=G1-EQG}+zXzzqW@D5obs67KjmS29w}iMI*xPIUXLux6m~M1n00000NkvXXu0mjfEJ$9) literal 772 zcmV+f1N;1mP)~@$s=(ERrPo{QLxfTCLV-G$cv7y}fNV zo3bpQo{&4G_p8-vI-SmDv*mJmG*}eHR;y(gM!jDDEj~?C&+~#H$g=Ecu1z6?G)*&2 zljm74n1v6+&~cpgdR+*-DM1iy+g4Sz7#?Hnx~}j0XM;DT>$+uG9LJr6&$4VXnat<& zQrJX_qIA1mgb>wE-(!qRX9K`|KA%h`yIrO6uIrZ0&Y!?_T^2qJ!?MPEuYBJR!*D-7 zO;g8ls$&y5j+3V89=zvyznNnvYQ0{2o=4-8Bng6`YBo_21gq6*3-9}W(eK*X%Cc-a zoo?Z0v)N_X6b=DE9LJ}uB_(RPT*h$>WWkN1=;#l|(RdV&-u}G-K>McMSNpwY??iX6 zq9~GOnZp>ryu47;kX3^=F5?{#C=UQhk}&Y2aCC-6Tn3&%c>o}Lrb8klTGTq~5-7doTv!MIYPA|8qJ7h5 zSZtS(mOv2zG#U*?Twm=oEVj!?OP~kU-p@Pp&r_;H+yW=p%aU4HCKeMAt*TchuEXxQ0WLXwP@sey&6iG4kJ@Hzt)+O;d z?i+6y#_le-A|Zqf!`Q;t>vc`jE`!%JEieCmdTg4eAP7~n1wk-PGr#@8^E_|ccGY;> zwl|B;t?^b>RoC_E*t)J$X0ssI2$WJQ|000BFNklOmg1h^5*$`zA=08-go8w&OP@t=iKAH!=Y&!%2zxdzrDSc z$z&Rhh8fn>)TmUd@)n{$rJbD}05F+M`NOfXv2xepej@cR6z6lre|&t5$Kw)-q`A2n z03IG5Q1R7j^}oP>mA(N$Yip}qF2B0ELcbLXMI;ho4~s^lp-@Px)sBviGDDqCXEvKX z9?#9qjaI9jo0}_$a=YEJSWK_iqbL9Xnx+>P7MxBe>IIw4w!FOjH?6m~w+8@Xu{fPh z=Z9o6nd<6l05~`}V9c-Y{A4mI6bb==Ac*{slamtwkV>Wbuf+ubyWPIJx{8Wnx7#;1 zHUMCAa}&pLilUg(C6h@U$G5k)+4n^vkr<6e06086%=f)sF8~Y=4_8)JGA0)Qg2CX$ z#RVD%gTc$oO8`(Rm43e;y)x42>8aoEZ)|L2#{%%kdw`334&lA{emwl zv)L>V2#$`97{}-H357zF$y5@LVOVW#Z8Dh*g+j;)hr@|PLa9{t_V#`VFO$jo`}+fd zKq{32fOI;2c6K&6I4F@wO5*u^KI&~$aQLwiR;!iE{e{SO>RBw7R4Nq+1OOly48Fd; zS}c~5Y$R0Vi5!p1WynIK@dD1ub}5YgvT&UCX=~bE`>tT*Vk7TUaeMlbaXsFKR-P^VHl=R zD9XkQ1cH%~k@xrasi`R*k5?8R^8V#Eo2}@CZvYUB#aNcmXfzxSXJ%$5-*h+}4u_*8 zzP-I20P5@O4F*He35D5H6jfDK#SCehcDvm;j<>Y5uwZhzTv6ZS@c_W=>@1(pFCNL9 z{@2&nIF19r+S(d&78e&W3zIk_dCl-qp@Bb9|6Muew z-re2pa5!FGUXY{L>$|$Tc6WDK!2A3Ab#-+p6Ots6>2x}KdV1t?IRGpzEwO}u^1@~0 za=ADhPE%9U*49=omqX_C^fUnQ`FyL@$|O@%fBUhO%jMqQ-U^PROePbL#~T_N{$S02mAg_H=Y~wAg*hN{+#Ifm3oFJU%`~A`uM3 znwpvb;Njr`WkIP_{v`$9g^x;XX=#y4rB_#1Xe^V-g27;Z%TOrf_xsgq^~lHwGu3D` zMx)W`bl%+DsMYG(+1V^Bhr$hdHKIo;@;jK0Ek4Q zL?Xd9NhXt3RaF3RaB#qo|I1y7#bN@1002mmWSg9voB)7WEM_bFxC={5ORKA^%y?sC z0{}KRHwl8EX_|>)EEXdOVtac#e}XU!)9dvBaCmsg=3Ooq01OQcRa8_kpEEf5F{217vwIF8rU)Wl*jzu%9TKp+r}M&)vOPfyQR6-XqKzP>)M*Bg(= z0U(h`oSmHw3=CixR!{+t$3xYQA`hP#F`Lb0WxqHr@Fto}rg%K=^?Cuo=kvY3zM4#? zg6he_g0Zo&tYrlh=yW=vP>2%YcDu!5aesgR7Zr4LbSM;xXfzrK1cJdJ zP172UrnR-TI0ZtXP_Nfh6cvxhDT*2#9AuYqL7)@6TrQN0iHV8d*A(tdCX*=|jjpe+ z(=`2i48Nj)BuSDaxm<46E%>Se9LFURiQR6O$z;8~y+tWdDwXZ+?a$B8Pft%cj>}}S zQWWs{{Ndr@_xJb7$w@AkTa*G|-F}P3l5@dFX9|bId3I5$R2&XxdU~2oTCG;A)ml(N zTU#3d)YaALbh?}ia>Rh9>B`DVW}3-l91aIT5Y5fac|4`l>72aN=>&k8nHe6Bm)nxv zIj*m-34#ECwY4?GEG#VGI1T`zP$+++nwy&gfR&XMHhFh z^RBKgtJV7Q@`4zxR@>Rxxx2fY$M^pJer;_nIuAurh_u;k-QC?%sT2Sf7Z>xGm)@Nj z*zI->htt^DxV5#FPNxw$H8lkQJRZ+%HZ$kRiEsEzOQ+LsZ*N&IRWg~3L?ZR|^?ywN dC;t6^;!ib9ir60%--7@E002ovPDHLkV1hT8&>a8( diff --git a/collects/teachpack/2htdp/scribblings/img/21b080bdda8.png b/collects/teachpack/2htdp/scribblings/img/21b080bdda8.png index 6bf1de68c54f830e9ffb5fedad5a0724d4cb159f..d3e0c455b7729272997312309b2dc26e9187291b 100644 GIT binary patch literal 1421 zcmV;81#?roIQ^VX#@<-PhW~+jAOcpYQjx&d$#6%npD|(P%V!1nIgIyyQ!JUpycs{x==spN7wmSt~mZ)368@$vEV^K;kEZfa`k z;NYNEt2G2ftyViYIGCE6>S)_&G};|jtJR@Us9vuNp^{Or*F&LDvtgvLH5yGM5)n%! zBNB;dG#V-F-QC?5udA!8Kp^0DyUk{^PN!2S6bgkxr_)(17Ps3S2n4RKu398JJ3FG; zPN$Q!NTpIUGc&xWNrc^QPo+|%*6DPLV;>zIp*WdL>h*dd;AZIc`eZVR@}r|85$yi{ z{?E@(6x(bz;oxT2Y&MjCet!1%_X}lvJRVfW<8iUzX2j!hH1T*mR5oQ?8y_FX^5x~F zG&U(D4auOejYcDu^ZC3qHYp?xJFt~XC6?dc-=(ohA!*ow{r2{T<$-|#X>3wR8g^il z4};OsQE6;a$oF)iupb^Cu>AM$UukSoNE&tslgWg)N2OBXyIO5RsZ>@f6*MuKOkZ<& z$F*!Wi^|E#NwMt7$w`!Fvsr2m{r(1kSS*HRx7#h2O-e|smY}oG&d#vBu&^MOO-e{B zK`}NqhK*LOR`~`8Y8Z{iYPE{;v9U2~8t?T6fJ7pJ`jwRx;p~-_6%-~C3BEMm>kR;V zdwW=3TwD~+CX-1M5y3DFo_@Vvw^%GfR2GYce7|EDhA*>Sn*%^B7DJbfjSV5}jg1YI zwCUlU*-J}HX!Q8_*m00iDwR)9PbgVhT9VGzYPH2;5xsmqUwgLC=fmV;v8dH*rLzHG zYikSbuCK4#CtqJ*WAfJ4R{P}6?D6q&vhO$?4!%r>!$I~Xe)^Aa=Fm7R;y8O8-`)X=9!(H?G76NZfm~eA*Bg9iE z+w1kB^~cA@$jAtJbYx`Y2w<1gTWwqG#Cuxp>#Uk(<5j-K`0vl zmY0_iP%f8;hK8E;LqkL5av2XTFE0x;6v0-hR4mIPV{>z}S--itiIptNs#L1(vjJdr zbrmtMudfD!!C)}FzP@7R>guX+H*su@Mw83skhH$OzP`SWKXbWUo0CdF!Ob{1IiXq!il6yrL8<+*Z#9%QpO~1yaw3taR;yy! z)oPXO;a01annq!h!^r*py;$&9AzxRgu*oK3SymdG6jIxq&L(F!FE20B*rbqexki8 z8Fm~F$L{WKy_$-Q9IK9HP+e@fwXL7K=3+4KZLm8jVIQ7Hd|IOuSaBO(v64 z!FVK-Nv&2Z6Th{!)na#ccE&J_$Kx3p8PV(YU0q#WU0r&;-eR$MJRXK&&d$zSB%7O? za_}yf3wOz8v(wYlBqKbWPG>fo#kDS%OENx@NPzz8>dIg+h+#LwU@%-=U4cB2NJzu? z_V(6lHPBB^PKswYV{&p5`azrSA|9v9+< zU*qv-#_;g4JUlKWJ%ohux3{-Y9vvN(hsTAu;U6K`@k}NY^qFe4O8V#8gi58VR;yrQ zGMR+Yq*1R>D1dlkVnQl@Vqya1g+f6vhuH5CLa9^=${vqLDjt{MRxLrqA08e;d0}Be zDjt{MR;@v*e5=(8wa0NBY1|MDqtVE59LTL!D-lh?BZM-U3|It%LGk!tFbKj-CPPYV z_unIgwzs#Tytue19*-yECc2!aEM+ikC5pX;|KX0FWetr(gkw~O{vMBu6*cjfFW@ctcnKLspcvB_KaHQc8 zLh*PUe0O$sNNGDeJCGKS$G@}{i+8)-;9IZP1^bfCX2UCKc6PR7c!W?ood)ZTjg8L< z8yg#tkWQz?cuK(gd_Hjh`1mlJ&G=oj+5GYG0SP{zufuqyQkl!;0IF5Cdm9`aY+fH69DI9wgIj?>K%}8GyjrbhSr#yBYirHxYinz8 zk!4x6TKz3}gwXQxGLW91pZogy`uh5wpP%94^768HH_3RdR$D9<0k*QTva+%QAB)9e zo6Up{;1NQhPzZRHN~Kb%z{gN1B*{t+Ua!}eN+teNlu9MNUjOZQgb>3ppYaUCNcEA4 z@9F6&m&-W2TrT(Y^vJ-=+0}e`d5K1&_?2ih`ttH3!;12zD&@+TgAa$ppPODd9R3MB z<&H;l*r7b=(tPAle&EuaZcv_VQJ!kjoM^W!GXz&pHk%E9*W`A)JBFvZ$fCT&q`APR zyuBcGb49IIcXD%u=GM{=Y^=2#9r3~I=;$b)&x^t5^ZBErBS914uRyx>1DmRpx0H#M zKR-VY<>TYyQmG^!Un-SOPEG`^T7rnj-v=BV9EfK(V}E~N(5f{^mH#s@Qz*Ym60ZF5 z@o^|;G8vBJq~bY_!`r;wZWl}w#^WQ*&CQKe_Gclf@eAYex?)*Y9v&A8Rz4ArFP9!4 zALZe3A!+?3jK}}%?(S}Rcw9(oJ;Hc=kQo>lkcY>Gq)|&4e|>!oWvA0A5049R!#_f> z-%~z1g6JNcLDY{8A@ZTAxw*NPLsKIoBON|8g{U7HLv#wZwmhRjP@`77f&S=6#G3w=zl7UGKgpiN(KM`002ovPDHLkV1gUWy0riR diff --git a/collects/teachpack/2htdp/scribblings/img/2330a222ac0.png b/collects/teachpack/2htdp/scribblings/img/2330a222ac0.png index 9274a7d58dedaab11ccccdf9c02239b9f77f9414..d039ba6c0b1de9eb421bc2953bb35348ce6e7a8c 100644 GIT binary patch literal 4083 zcmVu6o3PFqJmb)2c%;*9!_NP@o7dKv)74Swt2K5eR!&LqbS$=a1+!W_fu@UK;27=J(&b_nh<2`{myA z?m73q=m7vAT|+oKOTpv692xnIk&&)_f#&Jj0SJPi0R}_J=d&s+b?pcQy(NtFRa7`` z+{mKSb?pcQy(NsW=yZpT8~Z9MbnOTPy(NtFRa7_x1+gkCp|>EY>7J4Cj*j`p#tZH3 z7g$=3K7FcdcisX<`sj2UG8uv(Yclz52qkX;BNY|aetr-H*^tS7|7Qe(AlCoKh$Q$E z6O-NDmhZn0L6C)q2WMb_H#(|YmvqbstFm&DkB^?dJ_JF~ym_RRD|J3`bj(N}oo-Dg z!u77js?rly4l4vcqpB1o!% zX%>ru$II=aT3Jmpnb_WLytA|D;K4`}lW+)XjEh5%M4B~jyLYcRd6MMgV`^)g;^UM5 z$3Kp?v|#mf^;J~Z`1#50vhnl7uvRkK(vrVtPl~Uv$>PP%u(4Xa{cHE{;(>T*Lu(gOl4Jw5;2)upGWCzzS} z@VoDns3{$9Gebi+7BBA1%>@7mxZL`vs2htHXRKe}`}naY!#LH~x98C#xm_$eJ=x1k z6XU&QWtks+bi>A`{`z$RmkR*+B|ksL+L|*kpj1~mBLIN@nwn?}3wB$Z_)^H{Hzp*+ zJ34;9dUaP}p&A|wxZDUMBeAct5YEms$hcTv&zYu3a&IyT0~3;BF;<9KIh zw1ow$vJ#C2REz)s8sp<{zWXkJYU*{9P}rK5mgM1)?B&&wl?6m1^nUj~ew^atgCLMb zCch{xMQ;#@M4dS~w?FtG$=$s*HB}@Kz&&#u4(+}78mLs1me4W+04O?i=-&422(CO$ zNs)8~0o7q)rN@sW2s}J>s_NoJRBkEzVg9poXW?g`p)v&kP>B%%k9Yfn4;bO$a(lar zitemk8}H!I7#Am;okcd4y=6;VdOCtYM^@I|pde%;FDI{)6T;-JyLK&k`Eo_mQ!Z3s z1OPDA(?cZ^5yo?0d3olB4L59T>LMfOW@Z$LQ3!Q%m@I0@!fZ~y}boI z93=KUzbt)W!3ij_GYi~!89PjKbJa8Z!f=Z7cN3+m`F~DF%TUfB4 zJwvY|1@$XNIA`aLG+Itb2zPiGrHYZIrF~%F;x%i`92`2`%OZi`2Y>&vGiTI#j@QtX5g-(1 zZrJeP#0iw*=>Y-1{P-h$Dd6#bj*h;*a3PgQj5Ice6EiWoi;C|2?sq6HKlGJgMi zAQYl@T|P8s1OOhJ9q-`q?9Lsfk|Kd1(!_)}HU_u6Ow1e{Dlc4!cXCQ2lO_4$PfkWG zSRk64Q);;_BO}h=_TGE9 zmMv?~%oHzJX`Y__H8sd)M_O7a1j5kIKV$MN*f0VBXiZIxcXXT`A4ib+nL;T#cu;A^ z+`ZzM9Am= z;O`%4VuG@&!YnTS;lmHF85(}SdbPsTQ6$RVyt(A7uQYL63Rp5Cnw$H6^=kV0^HS{s zF1P;r^&2)e;SkhSP@s}cW=Tmn1jSfe*Im0d$KgozR$aW9x@r|%8NviuG6DeL3=G6r zTmO=uFTR8mvz*{y7M-rB_>K%Jk;tm7%>Bb3qAe|}E?t_Pm=L#j6&A*jNYgA9X5Iq; zFlPh+z@pQmEiKv4o>hc~Qt)^A}n$lknJ4TCws!QvO$Xlv__d-q0}o0pwE%Wi9n zwzTXkFUQz>P1dZ6VCLks^-*ozEeFtrALn@y0{qPaBe$y3i*69Cnva9ZAPTFZx$|DGRNV# z?c8ZhA|<)I-~Y>BCcC>ecm6dn8EN7jvnX@(N2gD71_uEE0xmas`SQAJ*Te$I#dl-~ zc)SQBBe)`0fBpKc_um&^&I}KiojF6n;|uofgSQGagrUeHSs* zX9P~nYOY*SRE%I27gHB4n(FOUT6{;w!;>egE?t^tv8am{br%)Mm6_vkYOh|6A(65^ z{ut%fj9jS0Nblpv8SB?e?wBEVP>qq7iJ6mAV?qM@bx}@ma5w~MvT)$^_lHAJ_SUT^_sK+abImkb zqKixF%9YRa@>IGPIz~jIj_mB)-rll1W@s?l+8Pc)O*e0g${6>e@`BDXlFiWaRaZ*_t)#ZFj>E7vDRwvSRJ*W`>7V z(&dhf#M;@l-@V&Fr4}AIpotsIl9Kd*fLJ@b1}YU{YefztaAKzUkq9x8JUqn3_p-0Q zP7erBVbTeO>4AZd|NeIXz)(ZOO*c2qonci~Wo_CNLn75)y(*hJ0x3o$6EpQjxGZMJ z$0Lo6;hIqTx^<6EpGK+s_#gjB4-ABLBTY=CmON@>sG;HBjvW*Nq4L57shZA9MtE$t zRAPn|x(W(@@b`x=xuc`8c6RNVnMxHqva(`rZMh>Oa7+5Sb*jENkil+iE7-S>g2$Jg zIRj5;h(A3o-Z3jWco6gBcL0F$bLYy>os(=4N6OKsPmz3m_DnVsSA6@e=B0L7OmuY> zA2||*!<8OC&YzsryJl!8;PJ4`l>V17-^d73?{E`J$QIvW-2dVWMJukH;NapTM`YV) z$Hya0Owg3()yCY+%)I%=#@eG?_T)PZ|A>g0!NKawm!;Zk!ooQH{Q;4YvML5q%9d4`Ja9&F8NF{nfZJ6Y)MZywzgKJV)H9}N1(kq2>^(*w^v%o z5m$it)6=(>EkoX#0RW73bi~@)V&|Y7XmN~i`uq7)Q|2x%$YRTn9wm5qr2G3@czAdn zJBBQbb9NSRxzl}p*tsbUEi!^|@?8qnt5)?h7>ib{Kqai@P@+XfP?nneD=RDi`OnW< zTBm7&jWN76vU87;qp1YB;!f&~bNWi^DhX3YSDVX<_nzM&z4%)^r>4b9D0 zo;wG(tUP}tDxZHloUu$?{%x5 zUQkL(S7G7P+qV&Pt+o0spO(fR^2zt1h6W0Ops4Ji^n^@%W@gr=O&EA7587gcg2yW= zzVq1ZID32K%?jjGR0!YrX%4N-nz8nF15;CD5=l;Pfgu?_g%@aL(ro!A>pQ*o784ILUm3Q>X7%c&hYqP>aOuH=i`T9#*tbuzQBPl=+F; zP4CGUFQ`PK_;`@!=y~{%N+iO6vLH8LX%37Tk$eRRc)VmUuiC3uF|=QM^=h)07rc)x z_ob#GFpeXVYqR1bNANB#-iV2;s_;H>0_WsZ^5vJ}OKpS_j2VH$YGZ8d0E4kUApu+a z5Cm;VN@7)2HO9t5T3V-JJLJU0cUDzZw1oxA?=IEASVu>+g$1js3gxH6DgnzeA}+qa zgTv)++qQv5!#O)+Xj~FFXXgzxTJE-O24-e+)6<;(ehiK40qp)Hwmmbm<<_m)i3z)a z0P^|sSeaD>`uX!ON=prKIQPAKkuzzPfaMrr(dqgI1_mZ3i9-FWY$ZCUlE&l)j002ovPDHLkV1l>@wm1L) literal 4089 zcmV*`TQV@_pAQ%vk#{z{)6)R{^w}5Mv`T$p}u64COwr;ns9(CQV+TyNy#HAiV zLXek41Zn|!xKN-7K7a%WP~;)WSXLyE$kYx6c=rtzc<|esm*mL^%@6P<@cYpaZ zGnx6#1U&!%^eb;OPuBswLNq-cX>2Uy@pK&s1kD{$`WOt6K)|BYbsY!<%^gvCD=M5e zZDP@Ax()<_=8h;V8qIOjrrwGQT?Ya|b4QfkiVDY|AQqht&4G!3PKYwv-ag;hc%g&C z0xPTGXU}vU&fE~CmqxQCkst`NA(7_7v@$nDsi?5=^MfGBmPG3PRTK%VUweuSg0Zpj zt}d(h--jT`($kaM*T)|o)@?|-7llQqFY@ux)7OU}2%0yKxN4QoN09DC>7~(ZNF?~t z*3XZn>(z?xMS&+233Fkt)v+i*Bw|-pN%s_@uWx^CEf5NI7?qAi8Ej}+Xm9@x4hNUa zH#If??Qi?*>U0>DjzwX;J)ua@`4_ViQD(SYt-iijktn~ww1WJ(kVN4P4#wKq{r8hk zCc3+^j_MUMv#bQI_LRwurbm&l|iAgvFHN?dsSSlGl?tAvEJavlb<6~-Pm*V4-|HnTL zH#cMTN9(Pqu=Vp(SY_+yhhc7IxVbrh@7@$&Uz5d)ZAhdQ$B!>PasQ%8& z2t=YkGns^C%hCe^a)N{VYicx)RpBfv0jm+zUt60S5|SPeVCCiY=gv+&Jw4&n)Q8`G ztE3s4jyE+haC7nEj@(=TfRM+li;B9rcyY#t4LwhuXwsikeSNzhKUP@9qS2DQy)|*( zQ&yJw(MLCJZR>8_5b}5cfS>d8V{B}=eSJ#Xq7nrFz^<;2wzTB5wn`pF0zpGULcEjH zcWc&k78a@zw2;S(Ffx*aE01V;I%2^B!Q`YGp1X>QzFWIC-pQ#UK3*gcND4>_Tzma`^77@gjZ=lFCJF#x zqPv?yARu(?-tzLyjT>*;+SW!!&P+|sW=6*2CwqGlUc~L|i!wK#ZAePb_p{B`0D$ht zk0}JgSXURqi{w#R6ac`>hYu+P!uZRV2sZt-wK*Xn6at~@$`!%*xJ>OxTU)HXz0w!O zJ39|GH_H?XCMK${UZoHS+1s}DF&GHVCwh7)ixx49i`1EPqk|ia_jz!^cC0~AtJYc11OiWC4b9-y`pbF}X0st6k zZztpN?5ZmCO{NA09-TfN4nYM64ve(5Ay|%fbQB&u7!EXJM>0GMU}CK5frdzbp&d$*S@ zYs<`(EN7`+UhL{>WVb`j&15`&;HRH3`7D@;0sv@9O^tVQnjRfRu=$BhE;@8b>E62I z{{0jmpIh$k&B@6>e*SrFL9Mf{7nkPbWKBQ7Yp@gr08o1T_`RT@*)}X9f#7?8 z|40)Plvx;Naq;&bet6x`@Vhl@X5C?m#o1f7lzjQ6CSl8fu_)r1neW!DpTcY)X=@t}L7fE!D*0rVl!QZ2jEzn0_3JZSu1sy^rAw)+SHsC9Ou$$a006hIFUH2^ z=lp!hBfNjh2@Yn_XtSm7k)aR>EIK{+4}XZZvZ}m%d3tP2Qr=lu7(*mZvRIf!4*<}H zC;$K!jTUWX#d-d`A~ck2VFB;oS~D`Tw`@_vVNP(cguKj z1`^%e>;nSKoSZO@9`m#0iSF*wW5*I*T@7(K_g%Y00)d&cGhC~-C^E-D3zsaJ;d0$~ z?J_13lRP{g{N*p>U0s?7{|2nOoaFp1%G~_%nKRt}egJ@w$4g$my!QHai2-u@9vLB@ zA7Nw!=ke-p+_?Sz`;y10!NIb#XUP^81^f5IhYcEnfha>wO?i9vkS#1KLPPl+j&#*n zR~LmqkfaNhrtgtSUA_9{!-oKXp0cuNE32{2PU+g|(NX%vi)1|h{?45P_4R7MMS@16 z!27rAt5;`BUNDP`DT@|O^z_f~kUxJz!*EMWI0QA`x}{PpX_~0ia0pVGua-q5YE4h4 zdU;X3yjn9dP-YdBiy{^ZTT)Y#JU#EMSka!HtjOjA-)_O@+gJif1{MvdnEb#-Js zJ|`rkF)>k%<^X^fd3mY6zKL#bO;oDVLiba9g#X0yK5c{tFkg{^X3>LvF6$}`5h*Z7e#vire0T{;ypx}FdfB2C%JRECp-j3~FjEsbQK9(D*|7YeK8NKQ$m}?IspT38A@WmIiEyi+!gNu(I zl`o$j9gQ?GL6h89o0+Mpc@PB6H#XLu@bb6sVf-T^ruzG78ln>MsCZ>nrC33 zu$2v_S8Nprrd99IEVu7rjETgp85#MXek#cljWe0~d-rZlPdB!)nXQTKFYt2)?F~)| zaSjejb3c-#kzjK2_OfNjM?3(4k@ogjJ3H(GRDgDS3YX0mOiY-&x+0q`KXwf7>6z~D zZ|Ujjef&7GG0w$B$m31+_F@;NEZP+X;r6`@Hmg^&8H`0MSE4f3^0cB|QBY>8*>pPn zU;p~7xw-PvB{cJe)~6M%4o-yI_b^;GJI2OFa?_x*pdf}wl-!F$pr@=XW#vlDqLf36 zqM%9Niv)r+KR^1v{|%SWFJ4R|k&ttGLLM(-!2*O!x*DRz;nT-pST0?vZ)k{M^XSwm zLv!<0=g-3>tInM>!s8#EJc-as-_X#?%d4-t8nam6MvI~#uTUTeYDr1yEGYOmB?Z#c zdsC{X7nG9HSy=e&&K-odHd_6ip_Y0eP2q zAzN6?mcHk6IB^aR$R{4i*R>FSf2cXy8a^X!Z3d>M#zdlmI8aDs{5<$`$dNG z)@VyhrB@wg=wmR*c)a|s^36p{tkH@nZ>8^FBbb=D_3pdUKUG0bLqftWcXydHe1x2y zhG=E@y!Fp>UQ=-3fbE(!OAjAb!{O3HhZe6}SFnG-bfKQUKGD}#8zV?7qR4NK8R6mM zOy+trS#6(zQBf1!-HiYIN4ij3b1mk556IoVXO@&utgR=yyESw>(bGe*wq`zf0GG&| zC}9QmqR0&O@s}?t1cKxelIC_w6OQV{a_$==>I*REmczvkMt zWN&ZycwFJvoQ7aOr${f`ijN+(aCKdQxaC!q6(>*PoSjSl`d7)LHl`KqMS*A8hS=CX z24h1)0_LySn3Tk-tZaylg|xJU!?xpr*Xes!Wo5LbCCXohs=-Kmd$gq`tFjX1Pn=Z( zs&6I@&jOihn;c4Fld%bvnzvG^R$fyTyP rOc4lz-ofDxG&Jxz94?E6mCyeHU`kSS-%;gt00000NkvXXu0mjfwwnKS diff --git a/collects/teachpack/2htdp/scribblings/img/24365c877d4.png b/collects/teachpack/2htdp/scribblings/img/24365c877d4.png index 80925da1422cb381d06388e6900482c2c00983aa..a055c89ab23866172e191b2df235e0b01aaf16bc 100644 GIT binary patch literal 1167 zcmV;A1aSL_P)BZSTp{z|_Em0p5`!Sz%ISOw>ZYx|8Br3 z3`nUEH7R!uk0_#QQ=tZK>bTZQOF&9Y)U>&4cuI<>b%5%)Y2f`@k^yO>qGrWi!!r*^ zIwpDo0cjJWX4hRK;jp1l9a94uZP-jeic8e|xodbN8P!jK8bEbiB{2r1C`I*s;pW1% zy7_n4@Tgl7Ve<`m=OE&M6oIIp++D--8j!ROC=kH`dQDLacZ~xiq8e3#6V`D{71upr ztsrXQuA8K!h*}${fvFA$$K{ni`?08nyC%-oo*eAHgaO|D`2YL9sD-pf*>FyAW@LyjNBF$ z{13T=BpHb!LP!wa?5Ph|W837G>0F)jvFjza#)2h)ZAt3@>0rX(%YO%~-ajY>&AV-K z+vL~Z-08RwI29-$HQFj+m~^1h_+`%dIMR4CVc6%E$!*iQwMO2oI6!Tbk|H)vKx04{ z91#UAu}QAhC{4!x;Eda*WB2&OaGZt<_FNL2YzYI6!5YKK>vzAdwW*R05C+F5YM66tG`BP_Pcv&Su=D&l4gbJT0us@YrVs{%LH!g;zbF${er)6x z`gk|7O>Xy`!8zy8MeuzKLa0(NYaJjgt`~daoqV_-jBV4gO@7t?>=|jlS`Jhs469r5 z4ybKtM#=Ytn@iX3aogm>Z+tfW6eq0RgA!pt7}gkUEm6crMFP`=v#CGqyO!zLCcm>r zIV+jB_hgODJAueY8kQvCx!=jix6hn`$*ms$ex22fG%t4;CJeqDCI9wZDu%fO+!ycl z2%Y}>J_RJLJ?{i6_0=x1<0eI-F7o_1wR+q(oq@@ppVE?%f^sM51ePp!5+S9cF7nsy zBxpGX=iGhSbVia(;&E%<2~;!k=6ME0{fRH!4MstSb=BvSQCt~mUhXg;431l&%AG{W zl&A}Mo^W#!WF+VM!VRC1kcg^82|9t_Op0WJtctqGbm9;DZqRbv+9QAIj1-hR!5*o# z)A&;2dgMXWMaHf-IODd-t)BD!`u%H$dAY-YbYd@e5+QG*F5>(%8=UbVCJDZfNV$^; hc^384l0)+;_yG?s?e}X;dH4VT002ovPDHLkV1jR3GL`@U literal 1172 zcmV;F1Z(?=P)J0j4Kyx6?5|SmgO0QaShJ z)_ZRiC=5fPrgF%6FCbece&E{N8F-fi4j;?<_%q|C>Gw@uSkNJGbPc>9gXFyF%ExglG zGF{<1DYveRHv9Btn(%2G+cLE3TH>Ffom>1>K^_MoA3j4ZhSeTl)bF9e<%Hk_B zr8K&(X0yqWWYjqZ!^G5r16>tLB5|R0P1k0VqctUJVrl}l@a9gTqeS6!U60KsXM0~U z{@siVn3{^BYhE^+98p9qL!}lrOx*4jB{k)#Ytd{rIf^RkeV`^bEWFdsGc~PS*Rt4b za^lovVq)fyn%1Oid2Kco_PZ)IF}0w30_#al8R}X+n@x@+qs|df3#f@(B*WB{vaVq$ z++O(3p!znO9IYu47H`IzyD6upbaegTHk+JpsY&mH3Mq`#tLs|ZY!)C9wW%5nT!%eP zTy@@hpRTpdt`kKS^%I~LrY7tjHs1BwrF5-rHg}raa~&OX zfnnk9G02UdkJR7kTH9>7kYv>9L3HusRcbTT7H!6OYfp|xYJ>zN3X)us z)5V$}kQF4!NE8u5g7D-1`fxRIZSL6K)fu1oK|X7&Sq|8c^gfV2CJa7(e>v;TxhX2> zU7Nc$zxnLXCbhVW2Zu;gWNre%SW{cj!f4{dhlF z`8hQal7w1@M*2V)93E*&#@N)(b6%e2POP!_{5VVHnI8cpq61we3&2_+Ma9ktMiW@oOW7`NJzr4 z*39;P+xqS|g@JH;>AOSj+Wh)6pU*zTz_qoj5C(){ok4SnzCJDTxsN!Xh1ci4V|%X6 z@11eQis+4PS!Z!wkorZ4CCUH(@N^uyr{2is&X9k-DQj?ws~?65gHH$fzn7Q4u8a6D z!MCBh_=kfkNcu@!7wmQ3ckZ1v#nN?==f{~d!?9ldOn`y|^xDmE`^Qa_IUWp>RJMM-A82IiHTR3QlqL!+?Nvx za-nRxE)WF5?L`!vyqgO@d2m7^Y7sT63;ySdNhv6?u8Yj3;q|#66(D!+I9xh7Mb%HV zU+O1CeB*I7Dx&Km6F(T8a@Xe0(EEDx^V5j9`e8u&nO8r#P(fW6@&2BVPI;7_giy$( m`pJcg>-u4-pasTWBoy1gwcwQ>7l!7HFH+(AHSN zhNLz@NwgvMT#8)EQlK2I*j>(YRZu}#_TGK{Fsz>Pq%;e+TK>9$z)z)G?{99TS>%% z5Ydp@x`b>N;sU>hQm2*;bz7IqhPstHHTG~2{2KLr?RulZx?FEG)c3Vx4+p`o!7$m8 zn+Gv#XbigRgPrz{ULWk#7<70eLNIGI4s@vXT6;&;dTrxC2i}Mf%o+}7YeLgGP7Q;} zSl{p9Ca&*qH<*kVgF+!*XqYE{g2lv>q|!7hwJAviSd_B)TX@X<&Qe7=~x2*(06y_K=tX~JHt4}hDu^^%(0YLJ)9S!R7TPO z0B8;RlG=)@PAR{!A>kr++P^+~dt@Sd6I2a|R4zOI;})ENi~Zt*r%70imCy?_ccV&bbHf>y554Ip?+(h=n3P4uG?U zb?ToF{I?A_YFMZK`M`hMfTITXEI-cMxCA1KOgi)LmiK8 z11=hb_9OXp%UVNY&^3|CiZ=~(aNagxtJb$Xidb2#*K+=WSZhd;Gy8FY zkySY*UuGT4PjIm4;n2AS?Eb-nlKKY#h=rp3gk3pLrNOVcu^G|J!%>#RaNB^xt0B9y z(LB`cF!dkk>HpR9Cm%RK*7%29%q~t2iDho9)T){}J<8c>INXEW7P+A^yC`gFp!Fel zC)W?R>?_>3$6369PY9c^xTu&@|BGDQj&6J)f`qJdJC7`N^F;5;NhCg! zocqz1eKs=&9Ogk58b2$3u_##~@vX=@@p9}|3b4BdAW0#y7qg2Wx0+b2133g$qib9- zp}c2avNdAe#q8p6-ypUj&GGYCa(>s*+_f13>c5dpDDQQRD_He|s$u>B@o-*PvU%@` zXJ2y>JFyC86CowYkIy{2C5H2)~q5k`NSS z5e^X~jaw6gBhwQif$+`vo#mPD`nr3u9wq`37xz!M9ejIzwpb_{nVx|E;YEc;ptPZK z)4BZ4F*!&TTMAsjtMr* zWHUTwv@v@wAunYKh(`mqyyKN1g0Sp+_x8sv+S$k5bMCzdtM6ZT&pqdSf1kbQ?s@!{ zAW0JZFT}%bFfctfFg=Fb1ppwxZBX6Y3;^(VOT%r1{h3H)Qi)88+Xdi$CS&)fZch$T z7d|W8v3lWsCX!yM$pt=PCi#0@Ex`c8NHVoB(>2jYU3X3NO)bpe^8#2&s%6cKlNCvl z)v{)MUH~siZ!^tD&V`F)Ryp4~+GAYOI@&XUDMfZ8#hOCK8%?5Z@HZ zJ&8)ExjEEf?e5K?4wX*BxhcRw(lFSr)T*uBRch4@gYBG~0vseZ=WwQrt)WhCeF5hrkc%rEYcMWJ3?zA@zZItDjs8{x z*JnChlC+F;&nV_#YR)L;T1L7#v9u-wzWcNq*g3e^yee(5SfWdTHb+a(F9Y zUvfw+L2c`PpZ(+TwR1gp1|M`_XbSfZC``_$PHl+A4XVzd|FHJ*<+gAC6X&aZ9&cY% z>Z?zt^NGJ+5W*zx`hi~xzB>>3;yx&OIj?#*IXA*5*tpP?1OPC#FmvpiPo%@YE@5m4 zN(zoCNZjuvaxf{kKmq_D0a+@&dcLs=$FhR49G2M~+44ea*d~j2Et62{7?&NrUOaw( z3Rh?-3iDcDn4Iss(!*K>IuZcDyjpSU`wKrV$q}_R@d#daWJ+#qhJeSXsb+(OQdMX5 zdo^V$EtVY;y*!*;&u+_&^nKW7O(+roK>zgU;cMsm?vAjI4MFh%Q74mLcD7p%QyG>7 z0HD@s#WiJB9TFC?!OC7JI1x9mo!~r+}v0ZK0zO)9$IPd#JC4m`;*Rb8Jp(D67mIXFaR48 z^SlBZvCl~`Co#_}uo3&51alJ3QwS_OWJt1LC9l9n(&4TJ7C8xqB(+xZ3T&j+>uOo# zBp8xlN`JEHmI;YUr)k7<-rhLa&NwH*grt!+uV5k<2j>W%Ajrx}t(x(7#Dqiwoi>Q^ z3$Mx+f1Y_VFV4n3i9zQkLjEriOkM#1Amj`3;`U}gkwSgUiB6034TafDQ#lC+D@f#L z(lp#ixyDXBIIiZSW4P$SO(Y@Cl;XOH(-s9zh_*hW1Qo z@(Ph_L#wjIHZdrzcU$x2bMNflkYMpHvz!DPiN%>q$QR_tWnSEKe6^!1d{-iY@OWa* z2Rja0JaAwzMWT`X)cdnZ$yyiBvdq&jM(-p5+F+oR5ExyNRrILYgkx@GQwSuT6TOr2 zd&VU@!!}i96@_~Gqq-W)%X!tMy(e-urtye>f|-=x>zwFC>IZ?u_$S5LZn=2-fzwaF zVlNaS`B@a7;N`_;T-bfg-OCbS<=Zai zb&Sg(>$6nPox$xTZxq*;!#9B?DQUVQS1TAr#ZU^3s-)>Ee0^5uUH>Zm35<&J&%>5W Q!2kdN07*qoM6N<$g1S__tpET3 diff --git a/collects/teachpack/2htdp/scribblings/img/24e80ea10b4.png b/collects/teachpack/2htdp/scribblings/img/24e80ea10b4.png index 3fa98bc5874e346ad6e38adcbe28336f46f95769..43659d6e16539e7a25b8916e569f174eeb94179b 100644 GIT binary patch delta 1464 zcmV;p1xNbK3(X5HiBL{Q4GJ0x0000DNk~Le0000^0000L2m$~A0B342%o|vJNxDHq5@<{&>^JV^p9f zSX=vLew=f@@1AqdyZ7DuG9-i$ycr<>(-U}g_`lUx1-%YwRXU_MxLUPdtI|zVt!G+A z(7_Rvq}1NJ{FqnMqt_xymvowH1HhG!f7$Po(p1$6e*m3L;;*;e?lE_X)P+QVkUD({$HmFu=Hy>E+ zv($CgyqP%5V|Ir{`<11$s`9zR{c<3|p3`eWHhN*~gKL~SS!@8<`Q=J%0T_kNCEwNo z!1m+e3*Pa>WR3UQZ(L*!i{+ATX+XI9zT^lSeE5*Rio5ST~L(P)o1X(s4Xz!sk0U2GIQwJEo*j6X#|RX+Fn>4!wNt-db`65AVvhH2~2 zcH5+fKQ$3GH!m?W4&TPz?9cDA%K5n4TGxAd|1I3D%=_b9Y@yK{F7CbAR^NvZGHhU_ zOhY#_*e#E`OVd~YKq3K!Mvl9(iA*6?e`K@wC9N~s{UIB@6;c&uPb#P_Z9SM4MP%m$ zIXTU?arbw?+^%M^cd&Cz`i%epMVUcX8Uk2C-tX1ntWD?HJe#>dciSQjK!j&@3`n`+D6cPaRwhq`hf14Y1 z(o)mCaLpXdo>-uesLSoP_)Qwx+h1uVq{52*% z%+%5Zb5%0U4098=`F8ehR>a@hJqvx7x&n4AQBBBFi2_eYH={ax*#dx6BKKKpIQly{ zB860q=LG8r*P)7Rc6{F0x>0E4 znJyNRE@{t`0V<6W@U}aFq9BAqqkZ88Fr@Zf;aZr)AQCFMmPV(-U&|1<(&P4b^*Gz# zKAiqZ`GM524LPyE*2O}t)beV2a6wrbi&4~qKS}`T%z^stMWB&Wuqw?khmhAY>G^U^WRM1OO_TCM*7KTSK2; zsJodJy_Y{IA5lfcEnc{GHl~wG6lb>;42$GTqP)9#1Ev-x`;sH9>`n2clM48(zB4iT z9sv#>{`OCs#H)7&)|K)*f4QRQW1)0YTJblJXmo1yvCwm|g~5?tW>zL6V#UUfLWt{z zLDVrE7npjUvDY)u!H62}mnZEi>Te$kjrLQ?)V=&c8%OiqU#+%xw;F2|gJMM8$rS^D zi?^+%ohdwn9^Sy{kkUKYg-j(q%T6lLD0PBHp}95P)yEE=p8)haf7I5{=jdULf5{l3 zDxWLv9C`2XvgeNn5DJDwPe)w5Y>lpTnBanW4I$~4o{7mv`j;6?eZix7y&zxXZ1 z6mO@^f1nT*pJu*m=VpnU9URf!D~&ym2Lx=PSFrQ`^N~b$DuUXQ*6PCMzP3TNQoH%U zVxOh1v*yjjSst@HEZVOuomG|39qyL{3HF>`6SC0@WA9((+|FVHz|JpMVspSKY%ck( z4gj_v4`1+(CnjsW+kX85b66~wbV~!m-S;I&f7m#g0|20>xPO&Xkz`tM7|~#P&wv*vNHg zyKT~gpPPu98yA@whi~C#_UCt4<$T<1t?RwC|0Zr$=Kc9iY@yK@F6_P0R^NvZGOT2! zOhY#tGg}^Zm!`1*fJ6ccjU0D*6PZG)f5>LOKN zrlqEP;hH&Edt!k?s@AG?SSTDreKH3RYuw3Wb_YewHHsi$3yDs@P&aOM7uNpaI(QNMKvKyB?>$u-Hht&WeWgOiQH%D*nQB! z5h`%wzVDsn1-BdL63BX2<6lW{*N6 z&vdbnbV++24^U~8fVbTV6a^s^8tn@&fFZQ+3fICU29ZU^z?bw8s zX4Z7#z=9*ae!tfA%lVp}r&baDR1>nLof)I>nXdyugOE|wg0)HL=^vj;rpb!G)7H@E z7wT?iMepSg%12aDaf=tOos9{k62;kV1;Zlwk|^(P-hiov$-d+WD|=Hs?xX@ftM5!q zzDIzAhrj)kCh_WBfpw+)e@?C_`dBF4lve!hLmHhLeJu2w*uvmQFEcBX5wT+9MJj2{5>e>&9G(C6r3jeq1A zp(>v%?i_jV@Urpy0|*5}q9-FRUbaS8J)qYOl5Xjln0%!FCw-|ecsu_(2-rew(UoV^ z2S<8!wMg82?f!0%*QVOh0i|+O4FIcR0|0<(LYb_`I56I~Z#G{2-~7wOUoc#j<{907*qoM6N<$0fHYC#Pt9G diff --git a/collects/teachpack/2htdp/scribblings/img/25354f2b84e.png b/collects/teachpack/2htdp/scribblings/img/25354f2b84e.png index ef8f7a061afbbe4841768ec94049d9c970835ecb..03cb70eb7448678939309ebb82d3be99aa90e8a9 100644 GIT binary patch literal 522 zcmV+l0`>igP)8 z@*v(MAk$jkE~kPEw^2Z*wFUsph1(EdxvGZ?=RRP$3Wjmv{9Pnf?iygVY7`gFDZpwK zOy$B^2W+gG$%QKbLzT%SHwoBS1wpYQLT)340 ziB$%;aLWP`tH3N5ZayHr$_f{5G9bMQY;)m80d}r(gbOzWuyYl-$A$X?%z`+r1NN`sJLxfEM)ZCjzA4zA){B>g&M^|MtsK#)MOSiVwFj#`7C7Z0~vs-v8?s4 zvAt?NsIFf(Yt%UU;!p-y$QrAbf-=cMR-JMt6!-if-kWD3t5!{evd%(QUdJdXr&!3! zRYRcMWFZsK3*|lwnE(oELo8(C4rSm$v9Z|K%aMCxyDVgVPh+;*FOU2V3dUaNtpET3 M07*qoM6N<$f_B>T-TH(^?9 z_>Tzy_;@}tF5;|=lAQ6t^^w+zX{|5k)9b?l0C*5aX)aY6XN8FGT%T=Gta>TFJs!S4 zPwgART`E-(t1?PA$yg7&qTx2m$gUqA7!9`}#%9<68qR-4*8aF3gN6%tiBzR;j5ot3 zq2at@WSuYQd1yH2jNM@i(Qp-GtO}WxHW|CaU_CTki*e7mF!2=Eh+(Uv;TlF&3TcFq z7zQTMaE2J^VHVJE>oU^Az%CkYIb-iICuq3YjJ?CaH5zUbo_YdH=X z@jw>1S~#Zu(IkeM!Q&KMq+v40CM=hfF|=%fgjsYcZ|$`_qvJV!JqGe_YJj ZZa+cq7Y=x`PgMW_002ovPDHLkV1kNr^)vtg diff --git a/collects/teachpack/2htdp/scribblings/img/25451dd2997.png b/collects/teachpack/2htdp/scribblings/img/25451dd2997.png index bccea64f9231a61547ffaecf46dd6f7197725191..2833c9b7d53d474ccb2337e55a05b4954b2d81dc 100644 GIT binary patch literal 358 zcmV-s0h#`ZP)Xbr0K(MqA`31ku!YYOTVP}z~PMsnKEEK(4OqQ@Q+2qX&>}5a% z4?IC<2ApIZSrklDh9Sd{Y09GDI8GlVN!;C^&s?tw+}C=|rg`PtmPzseYb6QW_D`Q> zPq9{(J@;k#0&A7!Bj5LoqPKh$vF|57&)>pYc|P%R?BL`0x36mltX0=nF95b%xaLM& z4}bRxXc`8Avk!vn=O|T$VQ@bGFrcacKz2K4tl94YKn@2#uNS*N9*th1oK8lsP%amv zS14U)^a{nOe1y~6+YzWu|ue+hui#`*9!;@Q7H zF+V;qzq-zEe)`UDjo1D_|NVuY`;*3LfBPb7{DA-f-{ZtwI0lFTga7~l07*qoM6N<$ Eg67v+w5=S@sn#nPqc|Aka_*!Hc4zc$k sGS3-BbX~eGqlkIVahyHN6|Gm-ADv!rIKhSW^8f$<07*qoM6N<$g4I5xx&QzG diff --git a/collects/teachpack/2htdp/scribblings/img/25dd3e2d97c.png b/collects/teachpack/2htdp/scribblings/img/25dd3e2d97c.png index f5ab17d819d68486e3a1707bc808f1190032c3d4..6f31fd2399c4616f676b638c2f23bb2db8f9ce47 100644 GIT binary patch literal 923 zcmV;M17!S(P)3)4JL7gt$uP>ln7wy+qB)ufE>}yk(?$=ixrHNb?JV6rQxgE!G;>x(EZ4M_j6j|Q|bJxaL&R9 zseoBu-SArNU_%A0L#={pW4A@9_t|oN7NcN^LP!$;E!6vhH2p&5)Ho6UyT;kGJ44IQ+5!Pys8D zR%>iwFpmQ;p?1h)(AP7#p?1gJjlrR6FcRpnbi9A+^Jv zgxFULEJLMQV^2a{@9)Ar_^a0Npc-;;QmwHc!5v>$;SFTf8a7NpuiD`N!dma!r7xxy zLRj-S0{7JpHdMnJG^jNWCZOYM2;RbyTEm737*IPLN+|1n8djh}t#K%!%;PXTfPZQY z4^ohYX0=8k1Tl{n!n;quA3@CHb$Fz9u;B>gpkA#}Ao}C$B7By9{}~r?UxV;eYhXkf ztOkD#v>oyPV+YJA^J61kzxv?0Fy4+CIHz`qg>oKiVcp@HaXZR+JP+>-uNh^1b%pv6 z`(R{!$-l&Qq6{{mMy(MS+4^+`GVn{1oeWK1zI&8t`qJ)!lLSp)P3oQhi$>E|J*-NC z6Qk)%yGL9SWPO#6uNVk7P)&%YuTA-l-C~jTWs0V+pKx3foES}C%cZ_zu?Qz5!HLoI z_0jE4w3t(#FF`Bs-)Do_C82PX_wPsHvMSq=9+*@+#6>xeDVT*WS$;8y-v=0Rd%i91 xs|psNQ>hRS{ri~xFc<3Aj=PDXD5dYrivMtA2$C>kWMKdR002ovPDHLkV1gcvx&r_J literal 985 zcmV;~119{5P)w;NG=nVLa448x-oq7-i6*~2ZjLH85+*Mf$mUQYa8xvT9 zW|6eZ#ssFJU8n9cvUkv?Q+FBJ3N-1|T}HMJM|A2gBU^=fox01&fI~WImyre1XC|+a z?da59Mph3Qox01&>R?l+?lQ8&@KvYoGO`xtpi`PtP-}MPG`X1ENh1a>Czu}jd=;4t35bt%o#W* zHQ?+}t`RoWec^1D4Z?(UMfMj*RhEW6wFgg)*#H@+R@?B@nAcz&eyVMNpT?YqZnXy- zHD(JeOHY-uxM|E=@CdB@w)U&664oK5wy}$k#vFjO+Cvr}kv)YQY7bc)MAitKkW|~q z;$ZyWgvanhZR0PUTs$P@AdajLo@pIKK--uza7HK}9`RDP4z@fzSLPy~W#{3om*>hHl#z8=JrXaB zGBWvB;t^5JvI^LST8VZHl(Xy+D(!g4B5QyR zm3BO2k!f$bi-R(@3(E=|Q)$OT z7TE`HTiE|lZT_4v{@QgOl$$>bfSIctLZMt6jlpH1d}M?tOg%8E(vFJwP%Z(p(4~@( zg#MMh5pSpE`p9Zv5juqqLZXih=!ZG0UtjJg2!ez>GI#s|20)IM!*q1S00000NkvXX Hu0mjf0iVH# diff --git a/collects/teachpack/2htdp/scribblings/img/262a4fa650a.png b/collects/teachpack/2htdp/scribblings/img/262a4fa650a.png index a6cb9f558456d9183f05ded9828402304b05d55f..0dd50084e16436991abdf220af1292bbe8063ea2 100644 GIT binary patch literal 1542 zcmV+h2Ko7kP)*7bZ=DpC6`7!Mu404Mli3OeUC22nZO}Ljj)=db?aG zF2?QKC@h4(KjPxBY#BmAU@$bcd>-dR}$`0CXdYsul;H%3MAzyS|UhVahJq`|fi?ZT zfBxjcg}i=!e5_xrU`NN_fsVH4;}yz@c1#-tWjG>HY-=6vJy_G0Gkcr;cDy1X6jVL#-g-Tz=sbA3sYN135yn? zrba+r9p=wh+eHaWmY}*?fXfAqMr{`*EMAPaZw0vB@bgpKMG1j{`0_amUySw4%C;UD&oj^Do2nZ11=ZCH?wOy28w?n5B5FCv9dbM4YV7DVENPxkB z+FG?;lwdYv@nQk<=AofMZ5Jg}RUtA`Ky)-pOVxH!g4v9vOF@f;VPR^25y+;#o?0!t zy9GowP%0~tXArD zJ%>C30K~`R&6^3Zs$^$l>(-v#>z{MYj0`xP$jnsP%mWSw7A(Nam(c6c>;35yj7HdO zqmMv)i}ZA~x8vf)-F8xaf6|uY;N|tmS-f12?^Y}bI{7cjs-VwhRufHVEp)j88gOnt?Q+; z6G=&!HVv0A58hzN*WI^|CKH`bZw;phIywk&&mIqP8;^MfyLWThvawG%@l0DA@v7td`57~KPU0pnLhFUET9irVnLcf7jR4^rlAtAhb zS5ZHOd3cSD+_#Sb0ZdEdyLZa^_C=DIm&fE}&Y8orXZiD|(i+axkR;^gAwM5QMFi(7x*B#n>~^%Z!QUTR sEkqF!5m>SWMkAIl$Mor=eH;MbKfR@yM{%PWhX4Qo07*qoM6N<$f~@54jsO4v literal 1572 zcmV+<2HW|GP)w*o~zDTW}Z1cJvlw!7e*2z zlkh>fM_U_eYVhnKI1fvn*;fRPpLjWug9b!vzL41vZ*?%z*Qq{Tw3l}$~G@6g)Hq9ShCKv85?7N0*4!9t<>*RRaU z;lzpDwvBalAv~`;UN29bqS44ji&#;isH<#szn@2sQWUvs7u{~fiot1Z<>kxN>9}JD zfBcZyNuGLrJr^wC^5wMILig(zx0^XRjEUjPmvWlRP|we&Ue7~^25KggTem2RJaMAm zhW)9ZJ!w z^l9+5WYW??fP41zRo{pD)vGj_`0?XVY01Rp;_TTxe7M)j-qdY2YPIUjlb$p-(qQ1j zhdpb0sQ>!KS+jWQ(lA)brLd4wrm(TGTXBy)Ol~f|e8J_*A?_=Nhyw@k;sx^ayA*bL zk?LxSVkmo(p~mZFTpaWB1IxOqFI~!W=Z4iuK93&JWa6Jcodp5vB_)iGrq8E>mP|4; zdGciERe<{H)wEhw5Ry+x38zh?*V}&eSG}QuQBi?k$N!YfOkTLq{!!@owO+rDRjV+1 z^zbhp%GkK^ztykfZIY8&RHWKi%14r@)A8Lqc8vP>?|AbDX=&;WrfkB)v2Go%T>~Hh zz>_CPNkRBvoDK{F%a-B619YfAevBncR2GuY!i6X+gU2HPfWv{ zazUpP0Ki~?)2X(O5?n6m^#TBxOsK6@*+voN<(M-^0D$S!QD3jNjuI*=kdPn%KvEKl zi`CXqLU}pn%>zl=Y@9Je-M0UZ?ZK4C{rkwsKv-$qsz(D~o=-aT3@s?Gy>*zMHm+7FBVo(QC;@Zp6jm)hif{=%W7lGt6c<90L!54;6WNXlcRe(;b&xX40lj+`Cte zDJ+9epQzOa#+kdSH#IRTigx>OYsq27if#eW9#M^h2f1?P@CnJ}`gJBGP?7@6dZKZ{1SVPkFN7$B*2;osp5u&E?y-io16r zNxXB1D_3&rR31OhU%!;zAf!A;l1?XcbE(%eJ)LLHC`cUq{hI{^+_j539W54~Ki?U` zRmuReO94m{?%cuMyC^7t!GOd>BqSg)5uym44q7d~eS_PLZ{JW=h003UY?}S8YDay-HQGv=zxLk0#(AwnUX-S~5)(E`+TC@I$B#8)#+h%Gue$5W_pw%(=?VL*))(L-_(;~3)4-8T};2SgV-z* zz?rS+S1hGsDHThpSW3lGDwa~Ql!~QPETt2zWg9MiF}n_A`;M>avf;3wD4VQCQe>t@ zQm{-|yM@W*C1rr@E(&5Ikr7Q(*Aah{d;d(MR))aS}L&d2*K*% z5QTNYArR{yS40G*aHoLPiGVu=`Ia)il<}pEFJ*iw<4YM|%J@>omomNs0BYUM`00y@ z{Z|(R*Z&jVj+?Cq8*%rG%NCq=rEyS7 m`x`M69K(`xa|~JB^VtVnzNqa_#>LP80000r@ diff --git a/collects/teachpack/2htdp/scribblings/img/26bd803042c.png b/collects/teachpack/2htdp/scribblings/img/26bd803042c.png index 14f280af243126b8cc0b59fb3afd2fd0c2aeccdc..2d310ea3324e2f064318a99a0752e0fbeac20e68 100644 GIT binary patch literal 112 zcmeAS@N?(olHy`uVBq!ia0vp^nm{bd!2~2jb_J9JDRWO3$B>FS$q6YbDH0q9I5z(H z|Nno=>*X%`!j)DlncUvWZLPlYE^xOyjN!?|d?SvTA%cg^s52**5oiR1r>mdKI;Vst E0P9a9)&Kwi literal 119 zcmeAS@N?(olHy`uVBq!ia0vp^T0ktu!2~2NC1>6OQg)s$jv*Cu-d@|t%b>u+>?pVK z|EXmO%?w_j->uyo)T*-B(6d2IDk9zSC))wv@@uo!E9pbPf9t*b@3AfB7Sfu}umNNe NgQu&X%Q~loCIFDFC2{}& diff --git a/collects/teachpack/2htdp/scribblings/img/26c4c403875.png b/collects/teachpack/2htdp/scribblings/img/26c4c403875.png index ef6d9ce1c9f6724ac21e4022965d60a5acff86c1..7cb0cc02802b6f2b532cc4c14c18cbf388183719 100644 GIT binary patch delta 1406 zcmV-^1%dj%3$_a^iBL{Q4GJ0x0000DNk~Le0000z0000z2m$~A0FeOpz5oCPeMv+? zRCt`#kt|Dp6=UWKCCbj5-Hl}_Kl|8b_Pu%Y?diVLA%{up657DKA*QN>+H>0 zmX*)v9mnxJ@7zr*rOv}$tJQ4VP9ze8^j9L0ux-14R;&FC?sB=D%jE{aH6@qJRVtMq z#ocH$3WdUOiTzS26dH}jkhxvgO{G#1t=@q9unr~IgC=yK15Mb260F00xDkn-N~K)a z9S(P=()Ox&*Pn$SCcLCrK_5&B5+U&Vq&Xa@P*2|^DHjv9BP z(GYQZG^D3rK)Qcozog+sNUw_llS-w`l%#Q+8POcmC-7h}V!u3qlc2FKq);e?a#t!9 zVLfknJc2tR1fyWXI&6dYHD7wL4eMYBeRf^B14l+fW`q%Qm~Y%-!gS3Dc_$&zS6~Hy zK723UeSj6X5`r#z{i6}rbGcjqcePp-zBY`81Bb^vc>P3cFC&C9M#vM<<08B~FLd{MX`rW#;3z_J zB9Z7Nf0R;=p~WFgHy=p29D!=Q2vTl&i=f7|t9v+H?t(Z?Q={2tyAL1!I z3Mcl_dv#i6zL!}g@QpvBlVK9lg$BNNsXN2ydi|Q-7!FA(**~BWT zR4OT@Ms|01{dfP?jo!k(uQ&=1b%WQi)(`g@yw>kL)Kk(vywwc^QWtonUa$M_{;3<4 z_2O-~>MNcEb@nWjp$%;)!>nQO2u^&(t8hEAQGxUYczSx;e|J-VM{|0e^~g8{tOk92 ztA?3~v+KHcPSnf*V)#!3%YhTJX(uhU(mJNx^_a>?&;c0 zCZm)hoz_x{i2Nemh)6Q7Ys=x>;?<8EQN=H5UE37ebXqBe2!b8Gj)>gR+IBd1Teq}y zZKp4-Whtdbh^LGslSzMBbWBn&{-+oJ(2F8|MW{qY;Z`&%k&;PF?p9=f1L70;OD{Tv zicpD)!tHmSs>?k#HWuL`s~7*(i}&>68+by1Jb^cn6@^>Ts6grhk7To&SzR}p(u*RL z-ZSP>kKry<;1hg;3fzUqy3I|4TeuaC3ZyP@LU4;m7df^BO<&3!g*Es`w|Qgqu8=i7 zu{WWl8_2{S#2wdpRcz;fvEN-c?EjwYhTnXhCZ-bFIxVj2;<)~YP)gNmHQ{B$@bb(5 z`}j9IWB#8_DOE0uNpej7YpR(3M^^FuZ?9syPtujX_NCtUzc2MZ#MMCiQc9`g^tuI9qOaK4? M07*qoM6N<$f^+q~m;e9( delta 1415 zcmV;21$g?l3%?62iBL{Q4GJ0x0000DNk~Le0000!0000!2m$~A0Q{pr6951OhDk(0 zRCt`-kt|DpH^%H0Qgl0Sb~l!##MygnGkR~{d^?(XZ)RsMd7ei+B{38)M@L6nTU)!k zyY+g#Uaub<9JJf*cDoHElgVT! z(9g_&%(Pmq^P@YCGdVe_`@I1h=Oxyk4Y(0RKRG!W9X&(QTdh_g_dI+a9(U*Y4D%uM z5q%$w?z*l%PDbHn5A zEWyp7Zqwx^EWv(=s}fw*suYXGv!dI!t#j{x1hv$JMd)J<@J$R@gl3S>ogn(ah$+z< zjfRNdqapqM3ex>U`y~ypLi%2eoKz~MXDf-W=SzKjpTMKRp#Aa)PJ+h0kV2slg6=`lyFa};#3uDYSc!IKc~Yp?=; zpS~9aKfwxI3!xW%|5=Ooxm+$7y;`jbcN<#Uf#YNzoPMIX6B5NAX_gzBO|@DLKsQa( zZ*(VUUJAJkFZzM@KQG|2=1`xtVx?f3rbKrfN9-GHEe?u!av5Hqm%H=4*67n(#1wHl zkx2Ab2VHc_viueqE$uC8JrvmAU%`fd1sMO9O~+vYZ1@_|_d*s`gHy<;29{+h==pr! zuU=N`f7J4h9(g=?1GhDlp4^5vLAAuVH?&;4tQzF=`Tx)l4-dt@SggO7)XLYid3g#? z!lC{0MEgG-E#@q#1|P(`8OGt^VHdqrD*1J{G%T?`S-$(jkQwR4SGDU0d@@wOSq4WkLT@=+8j!$iczE1zyp-LQ75F+9u+mnCGxC5uZow}<)Uw#-Z)oSQN8 z$vtdt$;^@&C&@Bg+=DSw6PBqH9Eb`iC?FIHSk{)7ws+Ut!%fl%9MZdbT<0f!`1k)i ze*J!urv3j~N(h30l;M3~?|~fzHwexPehmCW@DGs)AQ46)3?Tx6gTMhC0DuA^-b^6P zAk84H&@F;)5p;_|IYGHVyFjmi&XIa5fS89B??dz&qBjt`iTG{AyO9XXd2A_2GxUYf zuZCd_jB8=6nwRHXR_r}Qenjhe3OOIZQV&qc+eucT28?_Jwoip{ zGSPdGdjw3~)CM640uliXy@k*j6@w`NQ;WPGKw1G10v|;G7DTVB9ZCs|>)^fwk|8m+ zKSPuNM6Y9PKLA3wYX>)?b{yrP>?rh+YNtpGBrNr6XHXPNJu>&zf@I*n0H#*$M6zLO z;l2Qp0YCx(X@#p1uG7$a)D4y*dJkNu;c67$tnfcLF(s2(r`u^{)Fd(^{4k=;kEX_3 zi1(yWN9j zgRy@)*ibJU>g6Is+@z0>`T2M-!A>B-3JDefLDC>;lFruYEjojZ%5qSqJeu*)jK}a? z38}X{`NO5riko;49&VZ(xf&h2&Q1)->_%tj8yBz3vTraisiv}*N?)wJ6+6)%>is3u zcQzjAR<`pLdTSxGY&+w5jm~z@c!82u(b2#Bx4(&aFFl=SH9-(2=N8-Q_l&tOJYG^H z0T&(^X+97hyePj_3YcA6?duOx=KQH01*|6e&-$)>oZuod`^bT$Opc95vfbOoyK=39 zJwN%bexgJ$1#oOQY$O5=oWGkt+)2Q4BFsrhaZAgDm?-rE(~R7)h3ut!xiL>J-YO00gPCmFI}0rSwL0+Z}ULw z313$u8x72PF>SOuigx5z?6Nx7Pp>WrtH^lIor?#2U8#IA?I@~Uwe_GWryzM#eXD`i z6P@Qjy(!-}*jtln3!d7rpea}x2kpHxZ-KzGv@ z-u9E?S~aV9WVGY_US)fBoZlOdj6y}L{+8ohETn8tE*9!gdof5wU>OxQMq(UlUDi9S4)>PX=QPF?8Oz+_wB_M7VSO* z0hHIhFR`grD`)wpqMEwoouZmLXZa>^t>IZXGbelr{smC>?1NTSeOmwk002ovPDHLk FV1kl$&XxcG literal 1516 zcmV*X#U*7f+wx z!|#5d^m2WEPeGGNB#?=aQWJ1qFn7TWf*l0w0XGWn0k{X?1K`8p!$?GsV3A+}cJhiE z;l~KV1i}Qu0_`Gb7eTuiqywZAloQknXzfz!(k$#9SZHC?1Yz#`MG$IXU4%Z37!F_- zW5)YKy+4Ke&cp-VvL_eNSqkZ8+iCYJRJLo@1u~08NB;ER`YPhN_+;*IjYea1Y_YC> z$B_HnqanE}V8a8x<^$ou3$kQeC?@At+xml~DSv8490+_5oA=MwCU{P!!la@hv`cG#*5{N;?V$bb z$I{0NK!WG|?Z@zM+mb93zRPmdBPT*hnSJIVfh^lbS?Z7xp(Lqd*0MbsLMul-@}MEK z*0Md2E~d{ZwN)LGqa=B-RUOjjl;Y_J^!#MzmTHO&+yqZ21KXBI$h1atRvsP=++#w0 z3p^TFM$yaD>u4Z3crNDeYYGmv1cq9|{yVX8FV92(5R_4$Z8uq0TJkE*d6m{>)r3|* zSCaG+3wW9bT2FYp8kuNd-o=!`VlUc}U$M*LSU)qGE@F|fp4%4=c)ODM65L)?yK3t} zV@|>J$+Qp~Xg$$+?tPApCY?b`8j81lo?o$RYDRgno~BQ`e?Kfss>14h1)KK?V};um zPy0!^tN?U3edcLDDU6jAi$_K}&h3>qXUDm{@yH0273*&~&c;IW=44}`{+8oVR&3Fq@I>HC#k1hmAj#=n9i76 zvhAq6IZL)3)fsc4_`}0dwzF`vY+q;;R_}9^?G(n!?-h}$n_z*+SkLVX`@LPiB=NiU zqL)`~{UjaRmMH?B=7H94hdUeDSa9COq~5%wct?K4n`zx>PA3D81{O>ras9_{I?j9# zpk({&YhQf}8jTQ9x7g*c4|Sbwn0i@MQ@8Q$kA<;{_llmjOVh0Ybe(PRv|SR$Di&*N z_)=t2tzyB!USDVH%z0mDYjCg^>J=OKt4TbhRJ#R7x9;vuz)P59^hpA{jb zRxu_z=b!8fA+?Ili(17fgGoH3RBI%AIpMED2emGXzM SrTt6*0000LQ4a)$}4zktQUQ0z)vg2`PWrL+vqG2tnWvwLl`UjB0|) zic$*fp+RO-T4+fzk*FBHLZ!wBqmJpE@BZ*yN2hsd*RGd)KZaqQwb%aEKHu!U);S}P z#Q*sF;Pp>0z$ru#)z#?eu(xM4(a;boE8%vJS*>{g-pLqeB@70xSwlc9FP~)3Xd;pq zE)WoFYFtgZdX)hIR4N^h{*s_=ZND^goS~G#ey?uaQH9+1Cf-3?rtgAXoOCOJ9m(nh`2Zm47ghE zqelo0MQA8)-Ow&QA|p{&2G_ET!(zd?bJ(~M+1dE~8354V z&**6S_%Jt@-@mi8lz^C@FI5DsmPtvH{qZAxeVLXfU1~Jkw8?QDF&Y^hOn-mo=JMV> zo;X30+qd)6Cz5Pyqg>9&NGVvYW@e^jFIvPaS0ww@D+1!PXZH4?L!2{*?d?+7yLUWt z#PKqmG23CB++<>5Ap!C6W4e~*;6bT|c6M^#J~lMi*g*35aRTDFOQGO_10-2pO+c)u zuto3MML}SFJxOXb+`QTG5=kZ}bKyc;buTUD%9XrvL;9>;OF$eGB|o3FwIpe^a@8uE zI?e=bYooWf^dpfxc8niBI9`J@W@mzueDg*U)P*ekOHiYcDJksho5VKf=bbN;!D0b` zswx0bDs4j%5qS8JH8ny|5a6;)%%2aL%vRkE1_TBoG*r6O>j4O3r9C49-QCE~hag~h z7-qAZgSm7mv|1DvA}b3r85$a(QaO&CDzj^h%QA++K}19#BLfQ-ObT-#=r~440l;X) zAAd-m4I6BJOr`Di_M)>BVPOu2ii%KBfcy8MP@u5TBeu*;==HdG5h@j8W1WUggV}TV z`XW6YCr?7HMof&&@9MEhtp

FKnKM1^`&UUb^(W_XP)|sfiU8Hcv|nUcN+YEB5Y1 zMg|lLPpJT`UXA#8oIj77H?e1r=2y<>hE?MNf~^OvjS`Y>(m8DRgyl-aPvgHx3ufc9=-s+iUxFCJTV! zVTd9CT)T#V0K~>lc!I2~I1%WG8u%yJk%4keoK;l}3?v`|qDI4x4#~fJH@&>LZXJt@nU%%4 zbE(tu?OSRz1jOiQUcYX$C%zPhhtpti+-F=c+hJlNy`DRE5D=rHc}&$!vSl251`z1Mx&8JHjg1HjvVTJ`nc(XSA0M{_5=b;R!_N#Pq0wMs4RMHRF#jS1K%DU;{~3^iM>}-(;Q4bLJ&KSJG&aIu_#HcLs+hh1 uhdP8@j?qzk`2xLuHmV8WU$#SMKmG)~8taMHG0Not0000*FP)ITxQ-jV^ z!|3P~;(sx-`_JM5K&L}$DijJdH)Gc>`1&F?7Q@3*geW3EA8BdG$bd?P!a|At$`!nM zgSIvtIDq0}Ti*J5Xf)Wm74`K{C=ebF5+)PQp2d+P2ns@SGJ1NXV7(q14es7WQWE0h zF*xXK#E%~%EDT{`xN}GH+`9**5_NTUf~Uj`pt~D|g@}qmdASQ&#$hty{CRBJgq$3F z`2qkSIWWMO7B)`` zDeV1w9zAM*7><~2FivhTu&9WD_~eNTSq>eN@@ZEW_wQ$8qm@nCqfVS4AdY(j0(kHs zN!HX55GyOK4R-IQAh4lE$K8Cz8jH^W#VRV{pXmNK=w;-%6S~k%fP0s@F3$mHqvb*gWkn z0htUY6980K1Ats^t%{7qqerZ*6@r5Sr<=xt1(3JP!Phxq@q>}K(J)`%uMw3 zpr8PPfRPaxjV@N`vSm=KQB;KNY{+D2Y=lB#KXR(f&M_{F1w%uKj6`N87A~9=W?$2B zjEw<+UXMTikUSeVTK$;HM%>qjt}cX!+o>upMqwcyJU~DIii+G~%gTaQi%XZFP#`YO zVc0a7-G`44GBR-L6qHKD##;R@&QeMx0K9x@^)xmDz=jP{(f!>pBm~XPtgN(pT3hkz z724XcZyz!<5fI=m6@WEskdS~27jWwq_U^SGGd<=hL8C!@Jd%>o&|q~+nhp&CfY~g0 z`}^_pCje~QhV9#hvNG$Asna1bQ3wqM0Dph9wqjraEiHEXGnp_rXysI^;pZnLCE?*i zbakP$6z9$%A_ASA5Jf(H3bPp%6=-WiZ?CkyS~~r^ZNcf&=RFp<2k z&-(93762n75JdpEejR~M$WtRz`g#T6?Eh-c2wXk>0K0deV4mY0*H!N7zBMn|)x zg!%bQNukjwCF7D33IbQIWNE2w*4Jto5I{goPiJ$pD4<=G{~=r@x=tg}*<>#_;tkwA#5SD1hH@p3Z&z35%KfgomeemjD0&07*qo IM6N<$g80jl8UO$Q diff --git a/collects/teachpack/2htdp/scribblings/img/28253f4c3c.png b/collects/teachpack/2htdp/scribblings/img/28253f4c3c.png index 45622440491372c8c4a0025eb0a58a396a7706a1..d2a06d730cff440f624b9c06554716df9d9acaed 100644 GIT binary patch literal 966 zcmV;%13CPOP)7KauB)7^1zuH#V?sYBhjtmX9CFWHejAkoG6CwA6qGYBiRY z^jjpt{p87hOcd=M(_pcU< zMU6(Hk-J*0nx@%~+ceE;wW`ZYG;+JHyZ=CPU00Wv=;E$aD!?h2hDBI~ukaOCVG*X` z6abY|r8n~6JcLp6t z9Yn{p*dMo2ofEf2-{^g;s}>fxaRU)x1zx~wcnk006KnvGffH~V&cb=P2o2%E4C+pq~C z1h4|j@Cfd~9k>J|yU-28P+iV2opLLsfHN=!kKtW!(_d@6gU2uhX8`C5y(8{tg~BYn z(ZSj--oPw8>o}YKj=NIX%;mbui2Xzzw(@!DVENUayIK|39SrUs;kvT#dc94)ES0!@ zn<$D~A*{k0tid|0!zcI*pCN<|_yU`-1>fL1)S(W*5DdX#I08rEIGB)u;hhcW2{;KS zVH8GT42GKwrpd#H+`PH>H1z9F`JmJy%)u?V&^qu3pb@wLw_pwy;X|9j+Tf0&s8lL> zo;POOgXR3a#%$a3yi%zYMbS_0FbsX)&n8sG)2eJX>-&Bfh9ZKaFKG`(j^l_(0`;oF zD6Q{FTE}Hd=Rpm5CxWQ6ymJgpFcZo<4gKAD{@+_y?NSQYu{%oTzM+Z!>ptyn_xrTF zgWRXZO69&dRx0ZdO{K5y)6k!;vmLa$W~@I~M?RQ!dl5A!d#g8nJJw#j%yu!xDMzGlfQAj}CLdC`dn+27#(q?-b8|NP|2$o9H7~u{? zL?l?N%^}!CIM+is1lhRfooHT*jdvHl#C*);T=mCWWQyeX>|}P{nRmt#5wfW<6G$tLbvo zhCW>^-h$OMgKie9a0{l3MO}`1&=*UkrOwbBV+j^ZB`u~p(3NWT#+^nJM8{k?G`do~ zL$}4y^usN`9z5XOIYfYYcm^-wHN1rnuna&B_QC-;1V`W)98SM$S=_(R*|USY5B}6q zB#!d}uE9h7{Cd5;&~%QkD}n zg5xm0f!?w#)#sek2f9)UI0#qZ9=sWBPHc}ia1XA)K>+%q?-l)VsdOD)>A>w2ui!d7 z?m5@?fL^Pu6bgOi%VDAktHq-9uuAKSUayPqkA`@Y@O|mJzVDn(D-|wYBuUa%3=6Ob zi?9Ss@Bu!;M~Gn=KEVpC!WZ}oO=toz24k=tcEC>94L0Op&yUUPUf2iwU;-v!685Yy z*fw|WaQ^(}gquFlJEdmf23&xn?Nh-BG!94M0^EREc-P_GT}Mxnq*AE_K``mMqecC_ zCS5lOf=Z>5BuN{39LHf8=JWZjCj7nf`Ft3LaU8eMJ$+eyH1a%8M2uB>N1$vEm<+$B z8J!&Uq@)Cr-cr&ou)#K$l3Mz+7Xp9l@@s>#x#<0&tZp^d=zrbdUG9H_cX`Acyi{4; zR;S8pF=I`cEFrbD)rGr%vs{{L>x$I>^3i~ZWcWZvL`0?wg`SSV3I$z`{|_HUB)dnx zlIeqX$?o-rR9U@Lk}9iLc|=5lplxOh0uv@?s$Zv0b!%$U|I30uDVJkrruBJd#soK} pdL3vqIC&D_(Id=MGmW8}*LQ|=u9f>ypBexF002ovPDHLkV1m#6(fI%X diff --git a/collects/teachpack/2htdp/scribblings/img/28c73238138.png b/collects/teachpack/2htdp/scribblings/img/28c73238138.png index ecaaca43789e870dd6f067484238d953c7e9f38a..27c038dd274912ba490a4f4cce9cc54a61c2c04a 100644 GIT binary patch literal 1803 zcmV+m2lV)fP)& zPfXKp7{}kfYsY5UM8h^P;t&!u)DT%9!AYX05i<^Yz$5VpC*zre@$AVHcaC!4v=}@X zV+fjT*$9b&5L7194MxJ>y1H)N?@%nG?aJGyooxI*7g%||d*5&S{(0W_ZJ^5KGEz}0 zmA-%fzPY)H5c2ta*RNl<*=*{t28B|4E|p5jWb)wPK)&K~x%&G0&W&xXzO=l&Txl2~ zbZ~I6yuAFcs#J57o^!ceE|*isRlDAZobX&Om)F+Ts)c_2`c<>@HykHCZ*6VyJYOv| zpU-b?ZPmU?HRpuqbULjceQH2MaO|1mxc&Wo{pkJueU9U5T&0?G?3u9Lo`dFn?3r*_ zJ_n;WE&bqmp0Lq!9LMv#!{MkFu)Dka<;xf8)_6RgTeohtw6s`KSF1SkytA`IuG!hy zX>V`W{L{B@-x7(0D2md@pFe+QGMQj7*wxi#vZ5Ap)V7U!*1W#4u@R5QWy2DpD8}RQ zjg1X(6)oq;^WNSbxkfXXZ+5)8Ab>J zdRnD~! zpFc3ABm_)9YDqL2ot~c7y!$-QPft%rqfuBTH933F^YinkT8c)a^YimY3#tY#6bdk9 zp->P60XF8#Xgp=2P#M~cXEXC0IPp%UQa5kjls~Sl zth{~u_S2_ND=RC%e*Kb03YW`u<;s;nAaM8Y-G>h!1_FV~Z=gPY{0M6;G)?dA?fw4! z8=$>#;X*o{URqiLXnT8m$H&JJLhs(ad-?L^!otF-l29o0;>C+_I4pg{;3KGVxol?q zlMc55Y;JCfqBt=zF+4m>Vi+N`u&^*ZJUlTmA??-Ko<4mFvrSPH$8lio+S(edeTkwN zi^X2OdSz4?kH=}6zJLF|spqWN;v`2DMKih3>({SgT1lvJ=6>$M6h*<56h&bSyk!_; zyWI}c+U@pd&z`}wlJLwtyWMV>*6nsrPEJZgw;{&I$0sKzkx9=C!@#r*!}xqYnAYd> zVT`Ayrsn46LZJ|eBoqqG&CN|sO-T=lHuJ2^c=r4Ku=&~V_e;No!{Kl^49H1n@EcGz zo2{v-38rmoYVvx$FsCTO~}H>j~^2@G=^awJ$eKyPJt=U48v%iNa(||tnAa{@r;g+lBh;U zM?D^o(XuqbX674&P-|;ID5|sp-3b$Ha4dDE|SCH z7#kZq^`;oY)O>>wYHMpVD%6w=4i4VFefuAs(J>5Tv)PR9irH*7sZX*j>vp@zk0#x2 zceNp)xw&~{WMpJy#86EDVD$Hi8KP2h?b=B)NF;BDqF0m}S|4fq`n0fq{W~=*bdCo-bXx zM6Rh8+|kj|-`}s;Y{D4#_xE>nbbza9IY+J063+;suCA`jmoGQQJL?XIgJoHgmqS>V z)$jZ*EiIO;>}$tyJ0x7GS+$@$LykQYZbX9jE9-}2&(dl^KU!yn&_J9RW3OJlsvmu7 zKtpiCv)Aj@Sz|e!&U4VPk-{@YQR=r(WxBh&!G~LQh4Qe<H{?~000K$Nkl& z&rjNJ9LGPD7GV|U76D!6aGET*EoKr;9P_XfX2HXDa7WL2T6XrZ?BE};lb$`!gD0}M z!?I+?Ezy86Su|!pWU_%`qM{ugrSy9!DOgH<`Y9;-eVw3v-aOB{eSUnNAHgC?68!(5 ztKASq@#oKTEW zCdudX(P$J=#ClM)ed=&siAu7!x0g&N^(DzM>hA7VUHtOp%iFha%L|i8Boc|lhYuf~KYuqtb6&Hy4-O7+T17ZNKVKQ=Y9a{2{QNvF zI~5cF=mgUGHGS{Yf0Xs$JB z;bz}9BF>S?X0!QxJ{F4^6~=~PKD7<~2W zRVWmazfu5z-qw;N$xL@BZ=NIA+1V)+3KJ6(!^6WQo&jKKX=!+Pcw%BgUgtAwTeVt9 zPN7ghEa}K(GMTBVshOD>qr#b)nW?EMIA7al!lXBE-r%&dPfyJw3g!un-IeNhHBwaA9F#dU{%ZPc#6Sd1Gd5`+Pp!xb5@#oL({Yw+cZrF0s*7KKp=oFumS}DX4BMPe;iE^7j0zEwO3c1( z^a{2t?Ck7(@ZbTts;{rFv$GSIV>uK6mflJm1JmWC>##!OTyvs(9n?4 zjH=NPwgDg<4v&qEX`X(v+wEgxW2ZhBL(l+VW)K2^wzf8-LQTow;NboH_s?$Yk6{?A z)oOG_&1$vE?UQ9$m&--IX5ezUs&xm=&CMetBO@athDw5<7>(niCFS$2TerxCh7#9_ zqHSDntbF$Qe1y|Di^ZafsLzGk*k)Olu!Xm^wITAVIYrxuK0_tx>FFU+5hklQMcatb zTD3OP+S*#}6skgddplyZs|Q8fHk(c7#Be2cyS*}^)SnyS=38~5w61dX>Q!=?W@46Q z2L=YJNd^W68lhFolx$zSc8y$CEpbOjM}L36YL$wjsQ&)`j*bpo5$i#zPS(UW0CaVA zUB7<)!W^Tw+wCmNk{m=~SysOzXlZGw$znkLI8hr3r**ZO{hcExY!fbJqE|c{hZDBt zNrk>ZXCiTdP;U&}ym?b!aB6}Jf!emmA+W*Y}|Ifdqxb*x7E0zx4<5B4{00000 LNkvXXu0mjfaF&ch diff --git a/collects/teachpack/2htdp/scribblings/img/28daec71a64.png b/collects/teachpack/2htdp/scribblings/img/28daec71a64.png index 0642049e275dc6fa63f253d9b3839d435c53be07..886c76044a22f73422fedba0b9f39b879aad1318 100644 GIT binary patch literal 1038 zcmV+p1o8WcP)Jv&zB=yz{~e#Z|K0!ocOZfwz@@}y zH*40XRyL;ehGpZ?mi?bCnt3A)E)w2(Mhl4m006uM%HFTliN%2ho!nwO@obG}@t%v` zK-5qusE8e-_WhT3_4>egIPCw_+`fje$v{n61Y{iiYL2 zPx#6c*?e*++XtFHS)K7{3tu^%#)LT;Bv4d3*|4%1$Dp{9o?J|!Ktw6>S;>d5T||xm z0DvG>1^)P%`p(*Z7mT0{{R4PZZBe zJ->&7veIllemz=6mV+67^*rIJ z+my&o_tol?vVEW#RyO-;#SuQYkrRFF=A^=dqSWv%#`URDem={XXrGhxV-;L#PxtZ-6@9OYj39mTuJl^foQd*-Rx^z zG@UO{5X2!>Hj#CUP$^JNu>|I1q3nNwGPyX2^}E66aVgX)VcYGS_b`;WwvJ5u^4U(Z z98U^g@sl55sybUFjL)>9|DN*`Dg~+%wqbRgQFe^ldF?oHM+ii#DVAUw7kA40FYUzt zZqRAW+R|?H_o)}k?ypt#`UF8o6eCt#-jDLR^+}mr93Xf};#s`f(jGMPm_LfmZeGyI zi5!B@EvYPQ2{^9@rfAlua6dRy3RITcFE}6a2RypQM#*{{R1X;QYd^$0uTq7p&mxkM|6;NX0MT-Cew^{K4}JBHgo3JtN+4Tmtucg??le-`g7 zJAGplg-%hCF_jnBqsTSCet(<2IqUkvBNRG?fq}u@EDO#i$2H%7ewwl_;o*x*lsiRL z##~e0mVDQI{qcVCnz$#guT$<6Mn=X!y9#6x(p>ZP$NLGZqo2RIMY&TL7#OT{!sWzu zkwut@*ZlqGr^##LsO1!1E@3~L5;Q?#UGwYrw<+rqs1iXC5bo5-%^^UJYySQFGkbFu zRgx_P7_0jjsCrW|;xGXxJ8xFtTz+mbf-14N z=HkknKQsMzC3wyf%Oeqm{Vicph=KueHi+7b%E4eT;u_Ss;P?0txQa!qB4xC>| zYUcx|(M-&7p1pd?t|Vwd=6wA6YU}Zd)N)F!Tc@#_H%YosS`-@(cM;z^!~>X_SmHc; zNp%W}Yo5Njar(wa%ALZ>!k*|gfusn+;+ic-`zRkh;biAc_n%38vc>M2=WlOcxxb%6 zrwH&!WChM8GBe|I&4Kd^C=3`mah-JkS;Q1^1YGm$&-b%8w^Cw?vAR!;TL-~{pD5Q{ zyMK`Eti;U35@1`7zh)-QHCG=TBu}#tpLBv}Kc4mqIj(v1@-i7Zjn#c3oSSjA;>dRm zsVxUyF5z&eMy$yP&wY&;S|DoRquD$*v90Wi7&I?Xc>2>_@7Z?DJsliUCR N002ovPDHLkV1n!(4=4Zt diff --git a/collects/teachpack/2htdp/scribblings/img/29b31e5fe3a.png b/collects/teachpack/2htdp/scribblings/img/29b31e5fe3a.png index 32d27bb051e3b5f8c24de68c56ca698fa0e3720a..82647dc886292ac19abcbf76b6a6aecbaab3662c 100644 GIT binary patch literal 686 zcmeAS@N?(olHy`uVBq!ia0vp^(Lfx?!2~3Y&ik%lU|=fsba4!+nDh4b*<2<^9@Ye5 z)=pvdT??3&Oqq~&$zzr$r_725J&Qu8M-F_8T_&DJxKZ+SJ<*1fK0n@vdN`ibwS{Qg;G9b4l6Q<{f8 zGOx-*M1o!N{XPj1751B}882!i@D;7>KeF(F<%!ivB8`_?nq{&x_GzrOII(@zi`GjM zn(w?`Q#NIrj7VVRwgo277c7X{!*!;?@BPpGpVG8P4`c%7xW3tX>6yknrMRV!w`t@l?VI|gO~Xz}u(vf# zgHNfjcAA<-*u)pxgyoK^G`&3382Cl$#4;5jSIwsP7Y_xPe4n*S`t9GEqyML$F8aRm zp7P#5(Y||wU%6C0)VR1Xq~pucz(o!dyS|(V4C+=AdO3aZ60X#!CFOlWmZw@y7+H9= zXe29nKhl`EfTv5Re{qUX>W4GCEZ=;X%vJ2+=lx*`hkqA3u|}@n{k7>C?fc$W*xz&u Se7p)whYX&selF{r5}E*_QaQ5# literal 694 zcmV;n0!jUeP)+#=S_HHIKI?Ot6@lhGWlb&`5h&ki*WscR zf&SBHbQiq{sy>p(b*U0T?Kx#cms$}R4sT<*7(`$@(T?I`6T$R}b|U3r%JZ&yagWg- zvRfW%zx(L-%k6x*p1#cw`VB_}jTb_u3rz&=w`7hBQv@!hgJ>7B2)ybkaV~rjI2M^A zT)K$BxANxe(n|#HwHkT!czzPIy*{|&R2 z`;ld*jPf-)^M0vD8AYVT=2C|;mPm=gr2=I{k&;>$Ey}neB~>mel+i^>^e*!#>kuhX zy3C-gNu)&MGKI1}k&;=LsT1w)c;JsgEFn3HAtX_RB#Mwk5t1lE5=BU&2uTzni6Z1F cf28*@Kil65@M5*;I{*Lx07*qoM6N<$f-K@ZD*ylh diff --git a/collects/teachpack/2htdp/scribblings/img/2a1f3988f.png b/collects/teachpack/2htdp/scribblings/img/2a1f3988f.png index 3856a91e09573465c89cb09eb450fd0fd82f793e..ce9a9ae7374a1e11360d22092e74ceb6ec430752 100644 GIT binary patch literal 1188 zcmb7E{WIHl9RGOOd3I_coRLx`ADPg0YAL4Q9 znM&l;(-$)%vL*|4q!CZ487r+&r5wxlAN20^e!uSZ%j;h6d)>YB0{y)-R1H)C023Q zt9}aKnf1$}?80af8CaB6!4ck20d5^$rPZ|7v=Ch?I1`XlYaJOtR9x6C)C+@+}R(cc#ZW6;66L?RJT56{ofrBdm;cO90qztHg90f@|E zv0UoW+IiQUoeQTWr>Cc4@mF}*<&ZnoePKwMYzew;qxa(A9)0S*m?~|HR}k(Vb#`{9 zkJaC3QH<#L-AhNwsCEA2>@2)JINGj;pkLj*2T;mbi<0dG#|cW{l%9rQLkR^_IV0kh<V8P=RN&nKzM0oN;zhg3#cBXLF%vb{+#~l`7}TCit0YFQLxWQP2n}WNx$*UNSv8*|(aBf_I(q`){c!cww6*l=vlIEuYo%4g9(u+quvb`=duY8nlIW?k5`!PhB)FR;<3NFyl~cDDV@Nlr*{V$;nB9;8GI3 zzTx?zRLVqhZEbC3iCo!e@MLh1vvsh9N_QPb4~t!lG{N8f6h{tIT;lBTKw~7h}1i6HC~AZmK9uKwC)v#Gg&iNVZTcG2bqa3oh|yV zSOG_A__Q537nzx8uo$qrs|@L!9RR?oK;M-Lo4c(O%+wOvj8 zX~w@7`WELe94;=lFZsXYRPnmkKVshB{rvZnQ|o8vD;|?rj{P(F?ybp{?zSf+MMERX~b}UU+rWSO`%Q= zW4~o0s>}~QR{Z+AZ`J-;KQ9xmv){5 zM~@!;_;KT>;{9@_MtkG#XKh_{amA;_`z1_`81lA9i@5H->zDd#`C?Btg~=zUc&SER zwiiz|S{oL<`l?VT%UV`D!Bis#z3Hp3zmC)q>#`PbozLT7H-G=moeOs#o`0NWX59Mx z?YC#oo?UYN$Ke?Y%mSS*ufFcm(sSG7#I_)4<&npQx1#^pwVkk$^WT0u^}ijra|#1j z>!Ft~HQ(yi2}h@V{`~py!-B-b#&1gdyL62hZsu$Y(715#QMjRdnu(NaV9D;gTf~26 zo|(vKVPR2GQL$j}QUBzLKFcp}y`4M%ynFS;{^W@~4mx71L$tPR|6$>FlEpE@Z1%!{ zj&DlxM>HfG0yM7Vm`U2SCQavYSQ^xMGzq9G-)HjAntf%v*Is^^q5sL*XENiC{rl~0 zY?kaj%D>TX+nzl-U60P3;d$%2@3@s@!|T_tWAxmsyWg*DIFq)Sx7~U6S-0wm^+Al1 z4U;Dem*w%TXg-r+Qf4K){*DGIYJj9b6?gT?%;6AUa&jb*!i z{|aiGPGr;&;Yv?WFDVa@oOv`!(6ul#v-1(3mNN4M50$K~v%*#{-P-W$1j7`sr9NuT z*}Jq(zA3Xl8m+ZTg;}82Eqd*=xb@+6TcS=f+_`se-u(I6_TfiU*qRq!%vchn+4_9d z44#I|FW-Ev;`*=WbvK29sqsL9K}39fc+R3%CmGhPUF$h%%cf0>&g{qp##OJ|?z`_E zJzB)Hd07jOgN2NktDywXDcg*y6AU>yIVDzeORRKXzq}GMk#R%R+NVW3qt;r<@Xd7d zk(Oj|6qs}}W&i#CyLL@_+;~D$rTTo1S^DOi*RNks+6W3wb93{R%HETfOjPk)e9`As zhfk`B)b{P$%YnIQ+cvkwfm@?w`;RZa_(I#Bb#Bq7`pX$6e#?tXORuIF&GcDTWB321 wv+rB>;C(;hRch35=3N{)eNJ2a3AMNR|6;nlw}!v&0v1LLp00i_>zopr0Ea3!EdT%j diff --git a/collects/teachpack/2htdp/scribblings/img/2b944b7ab91.png b/collects/teachpack/2htdp/scribblings/img/2b944b7ab91.png index c951e4c56548407f908872956e8fb795ebcc6747..f0777aad1e30a3a91870befad6bc79f4e5066269 100644 GIT binary patch literal 1235 zcmV;^1T6cBP)_K8!vWI0ci%vl%<4-LUDp0agru-`fp`|UYw7s;wEtFf@d(R#&fl{FsY5RTZx#y&x zbJ}z6J?F9zLJ&mUIAQ7;vW;no2_0#+k@EziXcmiw5W=E&#HA(2r>7<#dM)+v{?xqv zz+wgXs`7A-Un#&=>L|9i>qX3ub5>cw8tBurEeB=rs2ys z+m4iv*Ef1yq;D0jP_-47;|dj1+}K{!n|sdGNy}>O%9$WZzqqXq#l?mPA5~k2r#FN* zw$1&c?L`$+H^ncf`o`2d++I|nZIV6@Z(z^=H_@DX+T1_7eVB>Mh<6;TYFKnSovTbz)?01%U$1yK*LyFwp3k z^zp8OLzp1{;GFac@=_6k0W5Om&I|!tz{A*lZbD`nu24k=1_1RR65(e>000OfT}z+r z+|_M9oq~*Ar4<)fQEm@n_70TW({a3#nAC?GMhNwPeNBC#@GxW4 zCmX}Emt`@FZsIx|lv*Yfuw!=H4OusLnZVAS`xb-igQ{gTX)uVR5mE8EHwG+_ZzQaS!d| z7VZNEBg|LL4~{DvMDKN7W4v(oL4Uv`8_?bQ%dLC5tK?0#P{7I0W%Afe9(&n9WYA;6 zJx1&N;J8((UYxb&d{itrag51huV=q?r6&DQ9-y$9`BNb+uUDMDY*9Q8`UBxRFK5AE z9=>#={YcH2s3qVbLYr`vroE&FS81rjb@{~^OYfUHS^$XK;QLw4VDjMx0 zT0|{8T%}3ONZXN}vGp~!>Uq9?aw^}Q7WY0|cw^V^jEP#JGjA%?triTB7y#IYCc_VQ z8|O_WAw4xQBh4|Y!vMfz#FH|4QM0M=-_FMe#xMXNEcT>b>Cv4(j_Ae}TS6vvndXsjZ{+drnXT>BX z#Kgs=?9SYlH3k4aySuIE48Q1r@S79#w$QOG|K?AAYL`_sy0xaQ&)cEa%PJZ*&Ehp% zS9sd>o^9`!l-BBRcfB+m43L^;amTT*!|WSjO`D2qa#mj5q&R)qKC0WSJ=3P>tURY| z5G|Q)VY)F8LgAjN26~gK;_dK$X>YN$_VYPeh?s!&mLRxCd?o8I6ENKp!BPHd~NU78ksmh^;O1-pF$e~r0 zLr<-uR4wWyRp~2IFDa;qC{-F&1e^zvNCPGq9Nq@(wXwag9!wD6nelpOsh8gg?E`=R zo&PtxGv5akG6F&IyFd9@BI6t5g3{T`PcDdr0VH7o8D5`o`%!#!T5NCOc9k$H@0whY zuJrKJi&8#EyAD_hV*miqg!d2n5&(eNW$BCGLVtK;ii%rq48=eHB{aP#0RZldBnSgY zLL_4$Ec@rgG9s@!s0}?JDlfS+m{^75vuP z4DBf%UQvA0BI<14gV>{haPAoAw9=iuks&`a*13>0HY-)Do*tlRmoex|$O+iaqo#BN@`vbYUzJWG$0yfsBu(A42&j7o(iR;q-n>Gp+HbK!|2P7LiR$NGxa!R zG(2w8*2klfrdl)fI7CK+8-A$~*soqjWf4>4BzhTb5mm)(NiIB@;YW=*ASg!xvN-EQh+DTn zJ`H6BT>EFG+Z#(gl|{@f)%J?5`FZ$!wOK}xm%r)ZN68j3TZhMOe)p)|ma{qCH^}h% zgzx(z(Rli0XBNrl==Wda>MAzuBCN^~W$@FjXy1camSW2cnxc+3SWXY%p+%c{^Kf^^V0AO#W>Fq;AoAo+!{&k!NfM0J6`60!m ztZ@HHnn;i`BpKWvH;Rn3^+BYJ;ecSAnRj$rT;y@VAZ0+yli5O1lsnjp6kLV^z}+#O zD;R{}eFc{>G9?;hs$FAjMw|~LLxRij>Rn9I1x#lKT!x_%V+~Aw5F%rIPJ*@*WF7y! zII|4*6-0(H9hC&-D~Jr;tE@VL@)h#a5YOdqKD8HzggiTa>1-Zuw;7AZwYctOgT@-O zW(`2IjD1xmmLd7w&0y+!YS1XdYNnoZ>9*fq;9zRXh`JuNZ}6z;0x&U@ni}GMY$Ztz z1Tw14G==k3MFI24DQ8DpZvD=yd`amSg%Hq*M;T0NGJPdW=7kZ@7`6B$7yBee@)kIU52 zmiuBgByHTK%!M{*LrNN?t?Q|QNJariSCy>#ilM2KFWEkN(~*ZRnOe=%2d&&Y&34nX z$+|3$sVvl?KZUfpyTNT9pB0O9nf4Y=W%uTh`kdNwHrd>*i=zMlfUw7XYEk-@pw&JQ h)Th;6<2RMj_zzkGZvU8X@-P4Z002ovPDHLkV1h>JjD!FH literal 1384 zcmV-u1(*7XP)<$f=vER-5csz5K=7}`cDsWEDkRvv6p6QzmigAXRYXj1y1F@5k! z)6^LBrAE9p@ufmUOie=!g{>`3iiM>>xx+5(o?UkL+6vI3}fiV_XJb{u-Y0E95Z%0C@7B@cN{_;n?V`+}14Y zD&h>@^=L`C(k;#glw5%=KWHZpgTj~$`r-h9`4#2kAA>)8qejg7+feMI?}M`e1pshs zBu*X!AXl;!QYRMV#NUdl{m>Wr|D7$2FV-WoN}=i(f+Iu%TJSCkwF1YP%M^AWY0vYZ?P#K$7stnH-P>7Ta`r<0~bu{f) zKKw3d&tifR75`KH4`NkC4w7Jq+?ARnsYr^ZD+2&9kdi#`_>CWZP~vLA^uS!tKi$4k>0z}t%xmcScW;#V0-zXoqaquYf9#p z)hpfN1j|ZWbhz^bNlk-rm)hw@Y5)vb@z1>w+ z%(pcQg-LfMKHYX1-%@XT^-xO2C)qBu@SD#Id&&{Ba1!&s8P6VbI(6TS2~4|MIepl1 zw9fEqCCR->siP-s0I;{h^4ejdN&rR9zlf6oboVDi6X_SH zH-|e9bt1tjQB-he+$>6TYmqo5_opQDOvj_MazMldgHr;nhHe#_rrpBUy^u;Y0B(;_ zu8}Ft`%xbzO>}42D}l; z8N4KitH`I&BSWDZy}@H0pO*`>xwdA(V1Mb+x~!T~KGBU%#aaLWpb;|@P`>y@jKryKCXYeWw9MCCX5()VTEesY3+D^~0000lo`8n8pn;YLz!$Ir5)&#H3KJU=D+@Oi zS^&r5qTmm*t2=W&xd~MJWo8pDb7zMn66fXy-7b1P+}+{v5dil0adLw5bA%y+Ao-I3 z08Eg@f}IXaB?3QHsl-l)i$#)0lH_)KG-42JQP(R7I2vVPx7+mn6tI-vkA^XHO=!-t?!pKAEg+Bi*dk z!hD{x1E$Y>j#leS4=on0FIuWt{J7^)mSl0Ot1ADJ&6G)xN)1umv>_4+^%Rs`k^9f-R_depavr zH7_p;wxC8qev8@NRZx8&0E~P%jx5;h?J3xTnu7xcTToT|=t#jnJ_Z1DcBWvTp6c04 zRP#TR=b>D7y6AElo(ITp>cxdqd&Mc94K&Y0%RY8_>1e}0K#FJJe{l9E+3#DoH_kk$ zIP0PAjEiKgX2q`6KEvPGam+#?V>szdlZvxkiP{WXqBgsisNGpe)b45|QIz_QDvGwl miELWCo79L~%UN$7=V`i7?`v|4Dl@$!QAcK|p&#nlyVZxMzF z0>kAPFJ?0~o6P44Y|DI}%_e8Fn5!}t-|sUBcEIZy1nl<{;u{V6zJV?2`)oA!=Brg> zcs;AtJ@`sxFI%!w`4eBOC16X|YKDBbOV3M;_dIsHvH8)6=jVyplG!Xrqj-F&l&~#X zD#hS?J-V(H-gVjQ?c$3?E4E~@xRr0WE!vWu&SpLgt@B~HfgcWSed_;w1BSyD?<|kL zdL7fL>G5kE(<$op{~frwob|0s=5oJ^A4MtIlFQ?GUi^m#>t$b$R%`w+=N}(aRP_IGHSpKNw&Hs)9Q{V+X0RG}a zfxo<5@HaOK{PndeKS%ZdY`HE9g;cj*D8O}r<&W;&U8?+w)4gUWU$Ryw-u-<_mHz?h zUa$|Qy+E?lvCeO6u28qNMD@lR$#U5WUoQWqHZ)bU*@SI_rYdz?$`YClbqURJf`sNU zMM86wBoRf%gS04$vv53~*2aiOG@RikJ47|+lZ|h9;j0udx2aJ80000_s=ueCm4UygQt!+D)DarUZfYMC!KbO^AAt^p*r=U5PI9 zNK@2T$NwnK4pTOT$fC=HyFy@1MANqMF69I0xMbU~IAGE5G+_Ik=rV7N>c%hI_o=(& zmYkP>n;W)Fi0CrmW)N79A=~HYCJ{eHO3v@`RSpqCI+HSoo1mRqY!(`7j{|`v-o7p` z3p9Scwqa42C+jq$kD_C0mrIqRWIkaZQ_xv%#s3 zxnU6r4YjKvus+1fUBIHS(twj6w#`#)@B_e*Oyq@W5BEJi^Kw(lnb9x)HEk}b!lu(cL0D-O!Ke?08G+fC-lPoNU1+}00000NkvXXu0mjfvfO~m literal 773 zcmV+g1N!`lP)cd;0w!uV)lw3n)wG!i}Zd=^ANS{J#s!^hJ9ptNuz(5((#A005W> zdFTRQlHz0PvA|=Y#{!>)r#I(e8h%8cAPDc4>*!0D+Acl6I`lR)Rek7(fJq{lXFcLMDiTGx&>WSu3+tHWx;X+n=c_Nq-WY%jbdDWU0wNmLL z^7676y38|0lHV=&t3*3Z+$16nT_!vgGHX66&ciHjX3%-6^MZyC4LOp%bG%Y@z_vnC@srq_m1bD|Vo-{aftB81eYW>#aGc4@a6Xs%5M zGHVo$Wqw7Wiqjjs2o3hc0urWKr6fj-y-aR)3A&R->wf=GrJAvwmDrl|dFa z+t`g%+9rOMABQdz{y|gJjp4K!YW1P5nX)JiUFQ5DvmU|)9%f0qtKD3?1!+8VneZgG zZZ;CFbJSz08AL#H?IFmldsv=%Ebwa$qg`k1_V}(pybh6wt+nU6F|=H2Q$-uP%u##Y z%*xB+96jxp_BoZd$$mV${_r{!N!}Q%RyVCSaa+37R;1TG4L;AzDtQ&8QL}&4IHZDXuj*9_|YHCwmldU9=&nH3$9>q@P2cO>-FaGyp~d@g{#5JFbEbvcFG zxI1-Sjamz1=raGu=rSwK4|h&!pI*xfEhKYvapAJDtmYa&xV>%&IuwUs_15gWA`%TXbN(d=>zVhqa*H-|eVh zGg#?XkJqQZn_1C;)q2=bcb9FS#@O`-fG&}UE8XnwggW}|DwVaM-~4ZcbDkB)P6oBt zZrJq)fS;pC@~6MsQU8l3tHKC-@BjdJ%<}{X0L;~2&9%k>ke3Of00000NkvXXu0mjf DPfmUF diff --git a/collects/teachpack/2htdp/scribblings/img/2e6a31a9033.png b/collects/teachpack/2htdp/scribblings/img/2e6a31a9033.png index 178a528a7beb313bd0a5857028824a75708c6da9..879569394ebc2355fdfa6da1d2af6d6af6812ce5 100644 GIT binary patch literal 657 zcmV;C0&e|@P)t2GR`E|yD_<=fv30Pnby1fB<7Z^6B-uEX`E8!w{A=AX?S35QaUu>l#5YxcIU`fV%GHt|}}RA4RJ!7O1Ls z-DQdClmV?eoj$oyHoL2e6MdpT81)8sUGrQXjTg+lYrVn!;XmTz2El9YFyy!XYvaxF z%AMz*xKFpOWi>pKuH1t@5xdm)@4KUj-}j*Z-eJz}-d~vdt>ZMguyDYm-0zOk+KR^66B3iBJc710Sgdp4?}&Wk0lLjXt;e%8}oZgvV^X9KWa^Wz@$?z$#~t|LS4x;=#M zlcg`6Mw<=UHW>y1pT;oAwrR7WENk;{`bYIBBF7gu9M?X6b+@m+mU6p zGJcL_Q4sX0o~Gow9ZOf^x|F6psQW%mCOvwKOeW;}-KiG^d0y|*)p#BiMQimur`2ju zZ;{oC^1Ow5meG99;4Lzrzj=GURL^rx@6x_u?CaHwf@hx8&YV~CzFvLc|7CML?_+h} z=huBm?Hlt^Jxzyrf6Hbvsrgzxs`vW6Y!laQR1X4v#fChrbN*8Ad|lOTEbE1O81l=# zO&HdxI}X3u+c?gXdX}}_Hw+V9|6LtuVw<blynT|szd3EB_*GSYTRoj(z2+K63D#>&r}vBUSR;z~2lZ{LMb`h~;EsrP zJAS{0G#!_cx`))HbZLOpEyxH|ErSu!`K)a5k<=~u3REq$mt(JFdxPM7R*?hN`gSawzVo@*jck+wG=vpy5Ml&Y|;FpE_!-d8e_XrXWRLx`ADPg0YAL4Q9 znM&l;(-$)%vL*|4q!CZ487r+&r5wxlAN20^e!uSZ%j;h6d)>YB0{y)-R1H)C023Q zt9}aKnf1$}?80af8CaB6!4ck20d5^$rPZ|7v=Ch?I1`XlYaJOtR9x6C)C+@+}R(cc#ZW6;66L?RJT56{ofrBdm;cO90qztHg90f@|E zv0UoW+IiQUoeQTWr>Cc4@mF}*<&ZnoePKwMYzew;qxa(A9)0S*m?~|HR}k(Vb#`{9 zkJaC3QH<#L-AhNwsCEA2>@2)JINGj;pkLj*2T;mbi<0dG#|cW{l%9rQLkR^_IV0kh<V8P=RN&nKzM0oN;zhg3#cBXLF%vb{+#~l`7}TCit0YFQLxWQP2n}WNx$*UNSv8*|(aBf_I(q`){c!cww6*l=vlIEuYo%4g9(u+quvb`=duY8nlIW?k5`!PhB)FR;<3NFyl~cDDV@Nlr*{V$;nB9;8GI3 zzTx?zRLVqhZEbC3iCo!e@MLh1vvsh9N_QPb4~t!lG{N8f6h{tIT;lBTKw~7h}1i6HC~AZmK9uKwC)v#Gg&iNVZTcG2bqa3oh|yV zSOG_A__Q537nzx8uo$qrs|@L!9RR?oK;M-Lo4c(O%+wOvj8 zX~w@7`WELe94;=lFZsXYRPnmkKVshB{rvZnQ|o8vD;|?rj{P(F?ybp{?zSf+MMERX~b}UU+rWSO`%Q= zW4~o0s>}~QR{Z+AZ`J-;KQ9xmv){5 zM~@!;_;KT>;{9@_MtkG#XKh_{amA;_`z1_`81lA9i@5H->zDd#`C?Btg~=zUc&SER zwiiz|S{oL<`l?VT%UV`D!Bis#z3Hp3zmC)q>#`PbozLT7H-G=moeOs#o`0NWX59Mx z?YC#oo?UYN$Ke?Y%mSS*ufFcm(sSG7#I_)4<&npQx1#^pwVkk$^WT0u^}ijra|#1j z>!Ft~HQ(yi2}h@V{`~py!-B-b#&1gdyL62hZsu$Y(715#QMjRdnu(NaV9D;gTf~26 zo|(vKVPR2GQL$j}QUBzLKFcp}y`4M%ynFS;{^W@~4mx71L$tPR|6$>FlEpE@Z1%!{ zj&DlxM>HfG0yM7Vm`U2SCQavYSQ^xMGzq9G-)HjAntf%v*Is^^q5sL*XENiC{rl~0 zY?kaj%D>TX+nzl-U60P3;d$%2@3@s@!|T_tWAxmsyWg*DIFq)Sx7~U6S-0wm^+Al1 z4U;Dem*w%TXg-r+Qf4K){*DGIYJj9b6?gT?%;6AUa&jb*!i z{|aiGPGr;&;Yv?WFDVa@oOv`!(6ul#v-1(3mNN4M50$K~v%*#{-P-W$1j7`sr9NuT z*}Jq(zA3Xl8m+ZTg;}82Eqd*=xb@+6TcS=f+_`se-u(I6_TfiU*qRq!%vchn+4_9d z44#I|FW-Ev;`*=WbvK29sqsL9K}39fc+R3%CmGhPUF$h%%cf0>&g{qp##OJ|?z`_E zJzB)Hd07jOgN2NktDywXDcg*y6AU>yIVDzeORRKXzq}GMk#R%R+NVW3qt;r<@Xd7d zk(Oj|6qs}}W&i#CyLL@_+;~D$rTTo1S^DOi*RNks+6W3wb93{R%HETfOjPk)e9`As zhfk`B)b{P$%YnIQ+cvkwfm@?w`;RZa_(I#Bb#Bq7`pX$6e#?tXORuIF&GcDTWB321 wv+rB>;C(;hRch35=3N{)eNJ2a3AMNR|6;nlw}!v&0v1LLp00i_>zopr0Ea3!EdT%j diff --git a/collects/teachpack/2htdp/scribblings/img/42f9f9e4cf.png b/collects/teachpack/2htdp/scribblings/img/42f9f9e4cf.png index 6ab99f4b0627528b6a056eaa21539b19601c39b9..76665a9d69f9285d78aea2e016a326170389fb65 100644 GIT binary patch literal 128 zcmeAS@N?(olHy`uVBq!ia0vp^njp-<1SHj&rY{6i?w&4=Ar*7p-Z;p4z(9c6aem={ zU2W4NRjob$P9NCYlP>Cg>B;WS(;IK*n9V+$R)2KftFxxX_ton6S^~M7Z{~cPJ$Kc+ bf7j(?B)Pmf%$0?JMlyK1`njxgN@xNAb#E|O literal 134 zcmeAS@N?(olHy`uVBq!ia0vp^S|H591SGu{#_<3tUr!gukcv5PuN~xNP~dS2G1LKsrT+I?>i}X!-wbHyL(TUuIpgFkFGvW?yHymFaVH6467q< zyb(9vh#POjjW^=P8*$@}xbgO1yQ?|vWTUnh6|8gYMTL`%S~aJcJfG@vOp~GTwVwST zmov&BY~8A4)k;?V@$UD7r&Q<_Me;xVf`9~X+eUo&drQ=d^_Ntib{8P8Mm1{U&la5wJ;oLUy?Symf zXjMF3la%ZBLru3>()XVW`J{}MW}G7S2TW9S3*fUToDzi@f86;Ixbc74jt*+Rr6{(-hiXaf|g6v?FE@Hm#AMB zGyp(nyRxSCx5s5;nyR1e$^d|VeY5;oIM@s@a>!I|J_9_o?}OafkkJh=dNkebmC%71 zU^KDBAh%_^@q-SzT@ymK7X z0szVbk!_aa9esmxJc?|yRD=C@9%Ok}G{N~o4jpx0*d0x9EZ@8jn`6xKuDQ=#V4>@> z&W-{L%-p9IG_*Z;s1caj^vrCr4w=-sF*LKqPHlRqk@iC!ChzfQ6hD36u641I=V6a^ zXmRI<4r1W(YbLzRVB3ed>7Vu?j1U9CMLM`hS94n7OTCz~@HO2Ra*s!7|2*vtnz}?? zjua42dLHSw$>9CTL1t607*qoM6N<$ Ef`0T#U;qFB delta 684 zcmV;d0#p6k1?UAWiBL{Q4GJ0x0000DNk~Le0000!0000!2m$~A0Q{pr6951LuSrBf zRCt{2+L0|uf9~vXHc_kb4n5yV-*-|}_}ugUy{C>^tp>vxW%?5z9TqSE0N|y$K|~fY z1`wg+h|qCF=r|&D91%K>2pva+j-&s8Ue0JI8#*IESzjq${Eez`@77NG#PSV ztLYDNF{Siu>ryGLmeT5vcfTJzr2?-Q?>vo|yWZcCf3C@Jx+DL5Uy&}14nw~xrj%kz z`TiC?d2=tg%yim-_B%{Ip~Ppel2K{!?wh0wEg6;Kvsd{<`!Bqeu3W?Mnsl@(3g_6+ zjS1)4(W-d7CMnmgFE!D{LT&%Kkd4cOqZun3m-k-?Vxeit;Fc~HY6lUalvW20GgRqR zJ%}{vf9rHbg2NS2DA-~r>6B2=4p&4)sz0sMlToRhwdr^_R?e!)Xx)wg;4-IWVpXgp z6J=u6%bW%}{cKm()S+2<)YRJ9t_(W;*Eh?rl>JQyBLJ|;DcpEEc*yS@xv?SJ03D0~ z;L)`CRd%fDU<3dYOAK;aw&36Ikkc`-#DGp8fAu1NgvL!Wnm7qtjUuu6wAAd&i zcGLH9O{?`>54%jOJ6?& zTWk|o8pppmGalRHOMC|>l(;6)?FJe!?ZPT)QBk!kHPwo4L1Lq3t2|Xg>T6#SFMa51 zC8R!~HdR`Qc8gYJySu88*dm;z%V+<^Za2p=^ z=|-WG(X_$P--c9qo=>cb`9h;mF<+QZthT>OZKulfOl)QS=%xYNg0km~SV(82bwU9k zoslwP!;Y|BD0|jdMCXo(+T3N%hOohKbsjquF%w@$}?+5CBL8Rg{YO8c`}rg<1n&eJ09M!@ep@ z+E<@#mB|kQK+TQPU~47uk@$?b1t%vDFzwAlL|^vA?|NQMb)S7^r9M%Dfq&8Oi3@QZlA&V%<4+<>faOpnOKg;@&FJB zTAqt^9Q%#m?&L_Tw?3Rm-pD%oPJ8+uv3&Yo@r4&_)3WRTNL~E+fB9Vb_RY2+GNno^!GS0MQ4;30A%2@)xnu52KZa*U0CT(GR14`BRLpl7^tX zOwco{Y9ki`;D;Gvd5vWJ%3@PXm%oUOU%}lDG^G{Kiq-5&CyC|hq>>j)^L*lwba8YJ zM|E*@F7b#scQORY1xn9yK?!(!>9jx2mkPb~>3l)Pnn4S)dg;@7y5ed;a*;Agkc+Cv z)kCLUjH>_;eJI}gehFW7>-(kX!wpEh33II31Yj~F4h@0P~i-lHC8jzw;{s~3V972#zn_1ETASV)cv7D&fzn7sabPZ0S zJ(N;ZRj_*LwAoeqoyP2p_{-;3e0Bkls5U_{CoL~;tZHVygHD?h>HFvG&(qkoYqKAG@UMvpgUMW$bLn($YAW&d*HiDk z2a!nEJMa8@V4z$7Euysyss?7>L8q1S^q%9fyr#j~v)_!2d~RsCo{5S1k&(~Op8ZDO z{uvzBVxnmp%hsmNm?)HM1pvUxa^d{>>tkaE=f~?aHg@~``Rf3HsLxw94OnEN)2c0a zmL>J0k0$7}y3k-x_r!x3+7~7m1{9U@)Ecprg#rL?MsK|pq0{O@#L${%7)DVj4?Wlx zJUcr~XU-fQ8tNkz4h{94Idc>M5Tb2o#DFAIrUzyV{p&b^poL-J+__gSTsRqtbm2%M zk**6DPM$mWir&5)ix|2N$|6RRmmM~mRLm;Sd+y#N=-&(sbPo)4)8r&9LI5<=D2tGo zOM;uG-Zne^+}Rx#Dt`=zJ>jrtWQ1UZBbN59FP3F8BIS{d!^HrARUjVLR)O93EM+3J z1~Rdfx7@^{%<2N2w!?)0;Ls7`PIBmon=`fgY98WElyfL=VpGdAbXsqK1%UpSeWXGP zNj-??DBGFmP-^)hoz@#b01(_6z-q-S(y6XIAz`e>44k=cX*!0khUAdCNK zG7w}9A4&p%-N_A}3=W>$$R;%e0f3FXsVgN14ilV~5Cyjh1ON_!*mI?%?+A~%A!Qh* z@5t8h>=cOWQ7Q5G(7s-*A-AuW^EBw#n+XB{r;XfmwdBR$T5wdDVeJM1fXhzo*=4Uv z4?;cMGy9tikZ1OrLOmNi1Ji*3z-(gm_jEB4%$z=HSMu6vfj2iC)x4Q`?eqqu${Rwd z>K-RSuQLpGd(rE|wnmcIhiz`};~&X7rF!@}2s}3mK5*D{;!Ru42^&Jpi8pNr4pU}6 z?V!}9{VprMW}V>Y`}wZj?3K&;=z}5vg!XdB2Q9&;S~%ux10~ObnR5y}&P$L^fnOW^ z48yc?R7@vqo$}PR(<|V3-svq*MUU&l1uasZS9baAI0DSDtxVaoLom4=O*Z9jhnXT# z-D*^=AK{?0Q5H{?~000OJNkl2 zO>7&-75;X1xuljq;*TVol4G&7>@<}f*>qC7kP@Rt&;nIZIE@XsLexN~00wgH)$k>U zUIQ4&$w(C_0h}~O5jSlS7;tN$PEyNuZNZf-3sfqJF(rzUNG{1GcejV7#J{DvJCtNe z`A*{SeVqAr-n@D9c2|t5s`%l7tMx@*R{#55d}bjDU{8zV$9p{-%WUGnHWrNTZ0BWl z^nPS1nO$pfJFLA2{X0fE(QO@jG+(M2z)~_h_Go@nhO`;bkv$hnMPjMy_DC!>r`Nt6 zQ7Kym#>4Si*5l#$&Io{&vS;U$VkTG1TFm5T=aU;eq|HF3?5W7g(+PDAwgt*$C&XMl zk*#H_A)d%4#G3A~T~H=l+okKmpxIVNne6Xlq7jZkv#pF`mL_KNE23nCvm#1jHZNE? z0ECe0gva07(|7duo$b8B>`6yMY8Gxdw zS3XMJyS0S^VNv$tiV4}e#_^c)`EboN?(^YPJoao{x*7%9*_9!YX?!@IUtDCC4c?z z^ZyxJjz%&7+WfW`L(M0C(duy3tohM_10b58Y7N@SeDZ;5`s9QB%db=>Z8!h1c=?b2 z%cP4}aAsPZnHI18HG1ZE&mDi&OE*Ye5CCb3Qg&LB0fZl!PQR)tS3ipke-JL!yoO9# z9{wQwmp?`52B`}IAS0P@(Xs(ac>v!{nWk4zMz1Z@Rdw~V$mlhrM~1p+P`2D;b;o0- z>G7DH5et!j{z>-o@Qe}G<>8t6C#KUXT@V0Lj#9RiliPgVblmS}3!Ps1cs3^)3aB|r zx$^NWU3V2A0Hi!+{vhQQue*zmyAV|XgddA{zFjiTy7TQ)`0+X<_KnWA*YzVh?qXC1 zK(SocWrY&}IrE#ghMcT89qn}7Q|#_U*Z; zsl{kCnMz3j>~_Ab%@GWGj~r<~aUu{5mSsDdY}(mYR4d<1$4!g$jyk;>)o$FFe*gV{ zjg9GqcS%aeS>?kI$LP2kQUA97jt2q2&_0>LFpw3>>NjC2I|aa7 z$=h#-=(rkDlTE3cVHjDaES0bg$aXbb&Ye3xFwkR`I55z2?%Z)`vI*^M69!p{GIOxn z=%4;+^V=8(7cRVZ>C)*?sKW>)6zaHi>GXvQuW3`v0bmJ3=cz1VveL5CPLrrL3G}i% z_X*k`eSMvMeVvr)3QGt;6IfY7#B>ZEnxWer^wG34D3pE-2ED3!wMsEoO-nlxh$FJV!a(JVzFnAJcJtZ3IAIpK$nPw{h0t zpLzoOg!*>%(CBPOW8-w(-5rHaPyM#T!W+8o7M`3sOIg*Z00Cg*DP`MuHl1Da_)OD1 zKGwFnfwk_ko*CR@gmq?cPwOtL*}in4$)>#3q7nB7P0OyJ^qy?_)o& z{8jJ4!>-M{^=GvZjwNPqdU7nWS_lA73u*JS#&3GI`B~lDod6szuK%>Z|MYrJtS$=O z+s#jSDdo^n6Ezl7#v6o!Y^Pvab}6Oj7;o_O$}mjNu`MIpC72#cDaG4D4s;t@eh0ca zZw(LMOsvYbo0nZqdF7WjBP@ev8;yc&x5Kn-x1%g`2y}7JAFQ)do_bggqtrb9ut z)xv5|3>$=C<+Lzfir3EyytU>E=dH}^XV)Q}UKbRH?sb`PKV4&wkGwHxuSI!d(C+a) z`&F%>IF6QP6S8X=A3AC|^_HEKSLX;}PQ7J6bd)kF+6WXKyVc!foc0vsmwNe*z3jEC zned}LfWUt4WWUY-TmyyD4M0)0VC7r_Z{#UVm%y(D0)}B4sW;OR8%J3f+wBvK$lmQM zMy6-=)&9*YiWIF|m$64nb?{QiwGTE($${i)>cj?+0H`o@al-<$l zc*^lxuvt1S~df82Wr-?y91t`@!q;l+SKl|`+YjemfvS@*K6O7(9ae_`&%nc u8g7R*w7+#zhO`-|`QF_R@n2Hxc>Ev6F9OIJ0w13M0000Zo@-F4%`J^yp|clL-&{p;fYX=m9RVViHS-o>u#SKn%vc;4NIcd?Cm zJ8Wajy#to;0oZKNw$7XIYt^<`udffMlj~kRR)T=16G>vXn-sR$?MPB> zw-c@QZCO+u4g$7CRh|pj7FAUxU|V#iH7EPP`qCQ5Bis*H4E!_>HYf>yYuL)C?3A+DT={SNpeQHJ1$rI9rX#h3yJsujLH)L0000v?4=3@CZ<N*?_lbk;cy7_!5I}Q!QE%;fsDO)+q zZoyB}jlw>af(ih6&VW}?0iY-t@Cqsb)HMTMK?QKFnKqV!>Q`l}NB}TR2C#w(0JhD5 zS5N`Kbs6vqDgbyM171M|0N-c8U!lBLjsPG8!f?}155rp{rmp>};wd-&N3q3UYBCqv zN}O#5u{T-7+hUF}U~8~Pv5gl-aSm5TmF4WwQd#OOOgqw^>#Z?Zn}J_L--F@Pfz9}s QLI3~&07*qoM6N<$f^>k&egFUf diff --git a/collects/teachpack/2htdp/scribblings/img/5ec4a0cb1f.png b/collects/teachpack/2htdp/scribblings/img/5ec4a0cb1f.png index ad20f76df38b9f7fdeef7e32b746547012c03c01..2d67258f5ce9ba9c365dfdf803759fab2af7ca9b 100644 GIT binary patch literal 861 zcmV-j1ETziP)jfF+SgqnLGE~`2ij7;=OzCe1DuXGk4}rMnq7?6Ig)`?Q}0P z4g`5vfGa5x%s>k)!ZhR@2(sFV6EF`;aKQl`2M4?1IRMS@5$d!AItP!7=)gC(GUy0K zD*v8!AV93~U8G)w%J#^9oEHiQWAMk&)EsgDJqDxne(&O?nO?~U6@t~w4Sd< z>ca~8h-5@wM{w{7?kMB~VyT3IU=#{E0$>d0oCpdqszwLqV9Y!kkhYt;?3cH8krjOn zF1pC~;*Ggx)r{{%vhEHL=~6nl1S{?ifCuox>R?f1QzZFb8whYvNpLL&IwB1sKf+Tq z668@I3qj|1iR)!N`Ce-kSvEO{aCZ9RgKr60CHgJWl!OCBIs=P5o)Eg%p88W1v%FPN zzDS6OJWEtQB6T8P%N-62TnpQ;9Y2wXq)NSdA{# z&qcM+A0t0QL7ml%@1s8a9t@E0a{#o#p-A$F4gCS6x83Ety?}JX7DxF*kO>|MBB+79 z3wmSNUBIwl=6%;oNc2IYc{Dh4BGRMFe#94X(5}_p&>lL$NL>)ws&H^WOn#_?ES#{( z-w9ooDWOkA{l$gb6sK(pux_axF()U1Ej3`!Jd}q9y8*?v<_?(hbtbm0iQ#A!36U8t{uwV={kcy}XTC@mUgwa9>HwFbQlp&2U|CWl#LJ|^+KA>8(=!2l3 zMYJd~BKtIopdv#>D|LKZjLyuRd(J)Q+2Ik?c!yw!^w!=#R8sRh4*p9R2c)TnC{BX0x zT4ONy_mqPMViP|_YDEZ^hgL&H#ExSa{)8$|+G5ywz8T(xDy!f`Ea)QL0Fy&h&1LIJg_v3N}1c0w_9mxB! z%eNVYvb*4iHvIq;J#T_Z-vR;8SHltC0>Ck-1`5~U=n7ne+hC7Zh{Mph z{JVI29P!HWOu5#s#J#;1x;-UoAow?+IOYSwu-0yZy@?@?LsbNah+Itup?dZSY0QbN zPoU9PK3^zTKsEFvNL0V7Qla}X?lbj1#bhcDpau5Ff*8=$tEF$bLpZpQ5=lApakpikeFg*x*Dc6+Z|U@TPWbMF<+ zN!)2A0RPcmcms3=Yj#4L9fZScL7DTqr9u@h-&l6QC{Vd?ER;Ck>mYy|#}s7ZeDhl6 u(02_SV(BH=C0sOsK3H%Yf%7-WSn&^%TK@pT3o@Ai0000FSThE^qZBP(!Ie5^< zgz>V0sISnW3oafDYL1 z!@2SM47Dw~taaKq9yI81v&(UnJP2$QvJrW4;JhS*)`w(mn|4**OXqfX0-ea<>FVdQ I&MBb@0AQm|EC2ui literal 216 zcmV;}04M*6P)s3`Wu79IG0Zn`8_3A3$62QBlhv0 zj)Rn<>v}dKeDBLOUq{I|rh1a&^L70289G}0<&GZyd`CBbwquAt+%e7{?3m;Cb}aDw zIu`kj4i5frM+iLp?~askp4fL5{#Qrl0~8| SAsEvD0000e_M0_ diff --git a/collects/teachpack/2htdp/scribblings/img/6a5a617f28.png b/collects/teachpack/2htdp/scribblings/img/6a5a617f28.png index 3023e68f766f756a1854158d7f575d213cb780f5..4bb9e69275ef4fd2299825490b8f677ac26e68e7 100644 GIT binary patch literal 446 zcmV;v0YUzWP)bgnEfPs%a&rmK zJM`Wn5^3*0J$K3Pxy$A5fDi(_VHOb)(YEbMrIJi06-6;k({UX952bW88kI_=Y&N@I zuf2KJ1`#dG0)S?-`OdyGnM?#hn9t`Qe!t%ff-oMBe@HKeVE}-x>o1?n<%YwdAM9o} zn~9=$xm=jf=kxxtn`*V%Xf&ADG%cvVUa!$;lzB>NP>+bREWgg5BmI6K07BfCCzHtl z0CCsn@VDD791e%vioC2uh(;j zFOP_trp4p&cDwy}JiaBRv{tJn5{c<_>P>!lL^MsaTrQ_lsaC6H7>46GyWMUu7|605 oiA3u4x^3IWqrvLx| literal 499 zcmVD0lnr;=Pi8Ns)z5zmfg04P*#bmJh24yl?EGCi~uo#6j6^W=sq85pyF*zfr z!h46J_qyTYKEp}QpWl-=Iqx|PBEka@@o+eB97ic-S@zK}KtzUN9&Y~y!!Y1ffryA` zSym>K2?m3Tq8NrjDa9*3i?v#+Fd52ssS1cA?g{rFW zDt5b_*Xwl^gphX?h$zc40C*^+0KoJ72ThU9W&yzStnL0H5{Uo+v)}JIj>E@o{sh~$ zS(d$2VcYfxirH)i03PRoESJj<6vN>V;CdtFa{1lsIG@kqaM)Eyl5{*C-%`|SwPZ5s zDiVo=qA0KDH=B(piqq-TRjgJk02q(QujJS3wIoUPdL8c``)D-s`Fy5nKF@2K1^|sl z!2xR*s#Gevu2V|q^Lew` plx3Oc`9h&!S=M*&Me)zS^9z{i01ow+eyjih002ovPDHLkV1fy$=GFiJ diff --git a/collects/teachpack/2htdp/scribblings/img/6c262f1d24.png b/collects/teachpack/2htdp/scribblings/img/6c262f1d24.png index 3e0b8e3ec21bef7ef44708b1364656fbbf8230a8..9c807aa52ec6afc1222232b73c1cd604ed741f0c 100644 GIT binary patch literal 529 zcmV+s0`C2ZP)S?8S6aE-OQe$ViH$qB?ac34)3ag;9r2b*aulhx+gOQ|yo+ z#>%;#J->s`>DljPANIh*czA@=YZKguDB$xNB7YcwPXs_@ON6#6(b++T&JGaT!z!H} z3liFaKDGOF%~Lv&t*MApt$8-wnh@CL2%Vjc(Ai|)Er}?^i0l~y0h!1yC)@MBu>}Do zDm!mLSBdPcsg6gkb}db0r$fkuJ0kq-+SJboKYKevWap#E8$|YzWfSCK2NfKcMD{@r zgR)JWhh4W@a31#NByth^l;?J1>DQFE_Qs^m*5YJ0%70}&w0EjaT+f zxpm;UgSlAuO2+n{iKq3Bqbv_QIfTaww$j}zS=zdavm(wHT6Zj*?Bo#Y7LI43 zDJ<2$?2sSTaqOE|O+j?c8txv5O$a zYID7NpM&q|-ScA~_QK0}d4*1=1G?b>ka{D4MFC$o5D8=efJX#C$4j)lB9ZcbnUwd@ z@v-Y4U+ zVo~EFe_QUJBMEptg0p4oGFNy}z-twfK*V1bQJS<>$(}c2xLdbd%$V0k@Y#UZ_FGx< zl8E;@rqlsiSn^L5Y^4TkVa8vT&?*ev#fEPhc-U~#$bfGZ@LF})>-ndBy^4F=+l(bI zOL(c`c)_{toR6#cXkaO3UCEw5(DA(8cTVQSCjxk?pq8<&WXx*{&WpHM>0SZx;}Zd# z8aP>mDzk(w_|Pb-(>Te^Al~6i0K*C;?|hQ^C_kIzceUSvh}UuniG^T`Q+SnmS3#O+$x(t)b)(+|ZoS zQcB#pnp$e5HVHX1A~h89%%-AeW}?7MLBTU>U-$R6clX}A_wK#Vy?39xPg!jA=T2Z( zFbD*4B7Z@Q2XgwRJK6(r0@-~T1aep;6A4FHb;ikQ^queBmCHifEe`hCn;Vi2OkGPy zUCZ705zNPz;!9sVta^9;qk&%#BLn-r2deIrk;^DP6N=3A6{%-b>L<0@tx~y#zx3KR zd0^VI(KI|;r=R<3EKu4hfV~PEObhVUIf47wniQF?jm}KK1+~Bt&jb)Xsbsa`zuW!q zYCVt$1oisJ0yC&45>?&L3PuW*sqG1PR~cYEJw5mCu~;l?)6G3^zQol;Donx3oPvUa z2iw!r(@`jtLZM*GLTe($Vle`N;P=hgY&NZyM!pDvLgkB4>$SN;i{0JCGr)9SULKW7 z1tN_mR-ANpNGU8V1geyjl&mcM`ue&wgIgB0Z_C+aarBr*Gm|exk;{o*z%|)jeNhs- zXL?jouRk9D(z3DThwu|8Jd`z#Ph#_Ec6RpAlPBTOg6*ep5v7rh;P;DMTwK(L>Ae#ISc8TUA&KR1J~hKW zT%;GnO8T6^{MW&$CznW$&ZPFn#`o9?9N5YoG8kG0=Xi9_zNxG;XH=OT5v`ReOLxW2b!9jCnhF}HW3C-2U0FN z$RaMtMB41>=g-g6B{0_?_w5#J~R@0h=zCd z^YJ;4T)`d}T4*$y$z&=c+Ota|Fj#D7M+c$R>eyh4gB2%WE-XGZ$UTERjQJaDYx$Vn zMaY$H7}=s;f9&Yd`eR%O1t(DO7P}3cHgiC&>YUtzt(b2!KV4wL;czuNw4@O}Y+7Kt z{?qN2%avyl8(R|C;<~!}!lV}{jI6V>^K_t_89c{0b;_CK%vN~AY+(;`j{EG)%*^B= zSDcA5M^B^CC=!YIe7^ed6u%knnUG_Vyd|zhg4P3w8e0{oD;(P)~VeW^ZS_FXTNGrwqI7g8Xq6Oa^*@>ldp{aZdNHA85xmErM0!SdcB_L zRV8bTSwn{YnPjV|sCctX*fojvCcu1seIo(3DHH)<<>j|6rnu(O$*@O{9=)|%(6h_i qp~SJ0pLzc$8UH3Q)yk>r-&R~QGG9=tYD!Un_<_izXyUDiWZvJpP?ysH literal 1348 zcmaJ>dr;C@6lSfIARp`cNY?O`X=;UxuY8~wnr5p>Ci%j0(QUQ0$*7d9O^u~QQgN*q zU3^wHri_+pxk|Vz^jjAdhinm$LQ&KNVQ_mH?Jxh{-7|CUy>rhubH4A~JKwcK@%znT z2p9wcF^`SG;lVxUb3#qP_0hl?e+Xm~JQjydDy(0YDZC&2=qS*QontL$2`dpypZXKK zJPvsK3nySZsh;tU?=0u87Vv#{3hM7W?v-ZYv(VZ7M>`G%gd>Lhq!o`fWpc%ZzQDnT z4|A8eocE!lI{nEP>F0j9dC(?m=+JSX?P{|pZQ41^$HD(b1tKn*;oib$CVmUFb&y3&?mFs&U`)&9a+xfhNaWAx_DITqSL~=6 zQNgICGeN9_d@i0yB&MdO;_>*5jE`$;#g{H2!5Z(SNF?I%N}Qn{9v+!`_}T?@qD?kh z(retph(3Je$Pog8keQiDAiNNZNvN%bY{m5Sv`hx}M^?_ORI0SVV%tO;UMK4No++@x zVmV-~T&th0t^Ep+Oj05@p(T0#{{8`V!ll*s#e=V29lt))Xs@EWOZM2&voBthYv0rf zbJV*YH^to$NhA&yG=V^%Dj?5C#MFEl>4y+%G@6MCYeUtWl^t$Zo~a7BitvySc-XAD z7=XIu_5@o&4F*GmB{0OUu*wRk+fV{wbDOMVqM@hz<;m@~l;MPl!ud*hzE-38iCFDk zLP|?Z6AFdn-rd`)d~9IP#o`FgGiF40VQ6P^dlP{a>zsncV!dih*TJ^7wxIrX@cn!D z7FJfQC{Z^yG8a}USgXd*U=~1{l1NI3I+*^!k3Ff|=);9<8d6`ganvZCnv&(8cdfpR zWKzQ<;zCl6I0j0T^ zb8~_GWN9hyHh%MGwPtf_wOXlE&dj(OsuVAaf8J?RPN&oP{Ajg{_Ei|l%+z#paL5$kAs44Ew^V}9u+kxAqNT&UhyPu3kV{L6M2@SH^ z*M`h)Z*R}Y$Qbv=lrBA;EyCE*o1XmfAtc@G4mcR8ls=p_z7JF4nGzQ_!snYB%Ew#| z zb^%31Ls@loQiWpw+peK472wx7*Dqfn=lUVkE_u*GSF$9`>J1Neo9J6*$V#NJ}D7M7Q( zl)M(t@=wZ1*UYHhHv!BKEK-(!<{EMGxMze?Tb+B6{<% zH+8Y6dMFV!ft*BES7>R-f@ljaNww3YHkq04^ALmzd)eRZIXn+MFYhCaF?{Fw+}voR zfs_~{yImnf{PpX~`STOg)9ga@J;s=4H*S=QMNXf_82Uj%pmq1jlWHzkx_qRc>9e&puUgHIjL6TQF^0p3*}tE`K`}IBZEUD^J4w^krKMMwFaI_>tCX^`+3fVa zdw*TK_D{7M3y~f=qzeT-FrbHq^x$AxEXLh#{o%vEXJ&rCbH{aE`rp}SVSc``XHPqq z+sfzLL9mt2N4_8V{;E=c&dr%!h}~N#KYqMfsc0zyv_@;8wLdZO%atqtv4#J|H^_`Z US}V-Mu>b%707*qoM6N<$g88RqEdT%j literal 736 zcmV<60w4W}P)N+C?jg1Hdz;Tde1OgC6#`9L8fcEyj zwzjXEn>9-WO#>mgy(RIuL8;K)O%w&eAZ#{B5@W0yj|=HE7(*W>;_wiH zfYDKiA~X$)i-<;H7-((9#s-2xND>+w1;eOec~PV;7wmS!=VJ~Bibbrf;OYvg6kA(^ zWzm+Fa$6e|h05}ur*IW}dQypms;a`l0pmDQDj}bTszMNu%b8nSW~n5do#}3ODw#AV zCTb}um&<$M@Vo78Uw=REcEjU=*9%2~B!N;~U!zzwuCIUX?tU8||G2ayNm3mEyWKvu zzW!r&_IDy-5Mp_~)Z?LUH*IdFO-+{1XXtund;90i%%{~=Ns?*_e$qiSnys%dI-LcV ztEeaimrIjnO_tAielHSvK1p8uTWojtJ|3qW2LP0UQbMWR*Y{y^^8b(XD*Xk>8Ab5_ SZOn)O00004%8M+@i!92E zEXs>4*~p*NHK>-nYB4BJ`cwHZpA7-P@wJYlo!(`ew|cW{1YvwF6(do+@_M+j;I7XN zCXB}(mJwP8l%EB!=fQvWwfcp5aGrAlEsmxN5n`{k8F#ZXu#6${NGlt@DLb_}cfV~O zUFRY-Pq+|xWdOF8`n6e?=meHAeD}OxDF%D30@_&k;NI^u0NX1)Qmp&bX5F0?TbKWL ziR-ns)PFhcjdP~eX@6&>Cp#II*V>F5`O12j7gL_>WN5Fv9&UeD263HFb~3cr#)6CU zG{le8WC$-^gY~)CF0T8?ONQ{Omb|B((pVxX8NzG17|=VnjARI}#Yvy)>7^q>cunQ0 zzcI^2hVUAVI?#?pWTK3J$wG$ka(s5*KngO1SI1%6eDTQ;UT1gF2VkQ`a599~$*s<& z9S9M3AFt-pGyqH zBg49Ij;?d{D{d1!LXqMA(Dqt|A2+P~7WWZ{4A*N2uzPI%>=;yA^PdPpMsOn!LipI2 zNI4nVgHMqWcN9`i7NujAX0nJK(bSSf@3^OvY^)cZ6q0|9`(l_jvKU^ZQ$-ffz(ab- zVjHMQ30a&2TWKJRc_1+HWbqH2CYy}PKy!l0XbsFKm5kyCxeXXM1KOvSTBr_os7dm5~<1fEWDAIjNAHXNy&JwCl`Ti`?*a- zzWcd~!gX@6^}kAFP>dIj!ewOMy<2Df^czZVEVwpkhEb*#!CA-sS$nPm(&7O*Zc zQM`aRS#5rR^Q;ue3%HV5*|1tdZx|t#7jPx3ViXe#=LP)8${5AOB6)UJxr;{VIpQJ*=!= z@P};7s^9N7#$Ky{f4szA@SDtvTw7kh%I!8Li1udWR+1f8h5(;ih4!tExl8jXwwH;v zOS5?NUZWgc=Z?F^zjgtCn4YH{UPj*qJRx2H-~`&2Q}gSYSuJ_X#bEKtF7s!1*^{w% znNN<_C_xB~j?tj@+9db=o_&-TS(F!9lowf)7g>}SS(F!9lowf)7g@A0Ox*vVqM2U= Wk!-{!<#xaT00003;fdLDY7R=+S0&U3b}MQ$oD2}8Cv<7`%jmN7yeX=Q^q zWxF=#?6=LM>s*L)aTqeP48YdXpf>9eeabRM@174TMSrhVKr?e6g4=%vV0)!c>UE#m zth2My)5ZUR5|C{z4PH*WQBJlx?d`1eMOVWmTbpr0UtbUNV#sw(*JdsKq&?lM=O0VTn@FQmkmgu#$cs|=xS^hrwFaaYD zC~+2v3@EGhJgwP9|7F3*fTmjg!o=CqRXj4Fqt|7o)0I+@S%c=SG%&eB&<)Xj% zWJ~?CyX;BiE%l`$8^;fz(J>m--m8Sa{U;wqMjS;(97RSPMMfM&MjS;(97RSPMMfM= d{d;86`~m?+Z^*&v$guzb002ovPDHLkV1gnd4fFs2 diff --git a/collects/teachpack/2htdp/scribblings/img/89a0d469a7.png b/collects/teachpack/2htdp/scribblings/img/89a0d469a7.png index 09f2565b2da5800e7a27d8561a1d708ee223f76c..6d8a7de7f880472d5d00ee1648fef30472098356 100644 GIT binary patch literal 159 zcmeAS@N?(olHy`uVBq!ia0vp^#vshW1SGc}US12N(mY)pLn`LHy}6OM!9e6l0H0ye zu^-m*wnD9|muyh4*lRp<+x0}%%3JH!-JO&_d1twFUGOndpmq4PmdKI;Vst0N6D_pa1{> literal 168 zcmeAS@N?(olHy`uVBq!ia0vp^CLqkg1SGwrdiDURd`}n0kcv5P&n*-@Vj#eBFm}3A znMBc|;7YV<0Vda-KjG&0?_-LRjpMgpAb0On&O2*Z7C`^9%O_ zixuRn<_9&3+Qzr9R7NCIdHC`T@sY~$ z#%7*=u2eI{jqSx5OV61GSw+1=H60=u5Rc8Nyx8>M!&=+$)Q0fJwxxfx zT~sxBL-KN}f6TqZ?V>9EUD@;S2KM}anwEmomj2Q0!%W;JyyIAP>w8}Wzz8ACeJd9i7oP2z;Oq|(1f zk$@3GwAUy7=={3%t!iu@`tkQj!%PhKd;31Wyk<*EYZml#QGl69%j)c-T7(dWE7b`Z zsXMbXw!fU#-K#fGPWk)#mL33r@#}ZT8=IpuVkXS=qJ0!*8=4H>%`lFbNqkyLLPn}% zOozFRcw(j?YA}=Zck}Uqag4Os6L+UY69#~ky;;Q5S&a5kEDU>b^YFm{zu*OUFG( z2um+II4668d{mTR0INc^Gb^2)&coOOZc=szu2e?{1_13JQsJi}004xLp|wwb?&>z5 zP9esj)=NrjD32F0dk4zn?KoadOw2?YMhNwPbxnJ-lli=|SJdBo)N`gG(y-xvZ}+K7 zh@#ioh@xc`_4>QA$iZ$C-Y%+gjISN=*3Jgb$yuf@60mQ{^YD`&bho?wFRnX}872R= z6r64={xZCsEWQ`cpssO)M>|b7@W6AF)FjvYbiK4n`zUo&OUKb~ zf}HW-d6=P)<|R1)&rKS_-YSy|le8lv~={vxkdN?x29s?)%hx&rLt) z^xkvs@05iQg8whkTffwc6PE4)$FQClHIh~bIY%HWz+$lwLRd_6d@4U7O~60;n&8+W zLEa%?u|j;+T>q%LM)ubA3f88h5BU6MMW6o8UvB;LeT8pwC1PGq7F)<=3%M%>q5>W> z?lIZs`bTYQ?ZS*L^P>Xs>62_BH-w#XEE`bBO#i8BFRoUdyJl5A4fy<_FJ8&K(K2}T zR?CTs5m|%ZLk2hD8eL0a1+LN2ha2(>)7I{@SCr*-POV{!DkEOIOLM9I{`)od!HIS4 z4S8$tP^+|Z{8szR!NIZg47N%ury7<2wb$q8{u!0$p0V~0?cAp0G2?ATRrlWcoM9t` zFvfE++xfWf!p-;Y)CrGEwmvCB$79B+r6tPabx)d^ZNYsZMvbk~O4o#Gx5kZv?)Sp9 zwY|97(mfE|y2?}JQb*}UlcFyi_VQu>XxphOa*kMs*ZuH^`WspJY&zQS?`kg9GkFpx zS_&(I`xOowAr$cW6(3w+&U>w_Vc@%;!)?bDbmG|z1^@v+#lo12 ze^_k*;2eC_Jz>HC01yH!RBg2DHUPx(lf8D=i$QO{;M|D~0CBt|pKAdF09JGqY*XK% z4FDug#Bvicx+A2`5lI^WNSl)_;9>y47V$`&h@=ew&S5?0a3%%-oa_w8&}1ZSn&-YQ z#sGjP5j(YpNZJrU&y|n&797O@K$L%ER`~?^sR-EsHnnz7x`-{}VF17uauYLBag8oA zHULciq7Z)~1$a?v8t*+)oxi@r_t+NW)J?S)S5saeS}8XuudnS?6)`p)ZW|%g`{j+v z+a2`h)lzfn_pa`gwg|wyyGw z`#sar+bXRz+g8=GzY4K$gmrB?uJIXVd7bLqHOH`iyY_Ums-yIxx<%iBl$@QBRaPWAE(u+hdFNb4d6%)Nhb`nD{Iq1#KM7d4Mz`sD z9$505?yC*IKA1OJ_MXV)0s>+0%STwG*X7Jh@Xv$N&pWxL&OwORv#K%r15 zEBJ7S!(kl9X_{sj<~zzt7>1!JiXe!?!^0}>)zwu1z~<)W&ssmTwY6n17`$HZ7q{E( z?&;~dxVZQ|aS5L1wOXymU27-QmJb9;?FWSH&-kc0fHcMUb+O!vKEU4Q7V~gsP0NHF7zW=HF`}-)0uCK5Eo|WS`ilT;whH|-FY2_nJ;_-NQ zcel&sIz2u8S*sujv$M0!&COn~_j8(k$xum>mX?+<44askD9fDx;N|7z;NW0tYO1NJ zX=Y~T=H{lX095YD=ktEQpCAa6$uvJdzqhwn8ND^gWHK8Y8`IO%27`elNuSRrielBu z>T^qpcsw2og?4v$6NyA;XQ#vAa5|l>t*!buQmNGK?d{#&T{@j+-^gS#0|NsTMU9P( zb#!#p=(Jkycb=c0W3gB?8jVJy*VosAAP9nxN~N?~txl)IFbqXef*?qeBuTQpy}kN` aRKY8uw^8&D%rR2{0000Z;tL1uYpE10gheP1J9|9o+{|2x+WHWCDZVHl3%rKP31 zJcRJ!;UN}_#bU8&G#U&B1A&0aWMUX*e0;pWzaK%692)o@MNxb{Uu$b?TU(pk?dCWR z{s(7gXG=><9UUDGhr{RdDT<;Cywe8)0fHbHhGALuf2<#2S(c`0k|Ylg4|D5RR#pH2 zo12@36~AR`Ys+f2dORMzer|5AtE=nc;^ODr8iF90&F1;}`M-LWW$Wwf@9*z_+O3gF zrBD=IUS59DGYqr7zFr)+2G8>~H8p}DAP~ax^72F?VKSNW-hcu!Gc%*ADu56o2vW?| zH8_rIZf-^(ghrz=olc`@{tH+@WLd7Ns`>>0APC~*W7DiM@L5igiw+so6Y9+dW-hs2L}gxdwXSBemOgrmzMy5ot>Q`xLqz603el0!M8_u ze}5mtu(h?dpA+*uPt)|kz(6{k*1o)}oJb_n-rnwVxlT_{3o8~yae8{Xy1Lrq@x1Ll zec{ToytufCHT zy1F{cEAe>z_V)Jf?k3${+nI&db4*GB#Pf$!c%AEJ$TO6KN$VYn;7 z5R=R!&>P;6dWNBEBg45~(}Ii~#{NLBz^gh3&V+=z>}g}}khD`s*ul77kTJ$h;D-65 z1Ir3o-bgGza7lroxS839N9seGLE}P4wtu{K7bK_8R5YG{rIf*Z?dhFonOS5f1Kr8s M>FVdQ&MBb@0FNI{)Bpeg literal 225 zcmeAS@N?(olHy`uVBq!ia0vp^iXhCv1SD^?g<1fq6`n4RAr*7>Uf<2jY{M-ZC*3u&qXU_;SPACq$Iz^~PseGr=r=5Q!e#-gv zgxqdk$;-bi@xsh)2UF#El`b1coH?+-Ao=l}nMQmwBOj+Zail%VU@$NajZMAQW1DvK zMnYLnXxin7q;I{I&rZxp@#~drOW=|0yO^Hg)}AQk&vP@wsOItXLPM=*hve&+^Br97 Y?GxG~bGk{S6zFCKPgg&ebxsLQ00LQ7*8l(j diff --git a/collects/teachpack/2htdp/scribblings/img/8e7c1870c7.png b/collects/teachpack/2htdp/scribblings/img/8e7c1870c7.png index f7cfd7faf54a5bc11f71a6dc49ba74271c6d1429..16f3c9ea26201c935cbc03f31512c9cfac6975ab 100644 GIT binary patch literal 489 zcmV4q17y#fn_H*`+h8KT?S5N+dIneF0!#pW^6v4@0^8;a^Oa#Bhsa-p@w%Vv^QnQON z9K*F~+T@y#hmeo=eFKzI;90ZaYBy;iWne19z1%0dLJakQASL+fc6iC%qZk?OlF=!{ zZe>4fpV=Ev8}@2iEu+_S)^1~GJO`T+b5%{x3kh@a;b@{On_{HCCg)FgSW_6Lv)h|y zQA$P3<%D?!78|QGDHU127noH>d)>%SlVNMCyM&$D)WUK$x_EwYuR61>tv-&2;NXoH zY}Y25JcQeq`Y0Ck2tH?13yV+S@?XVYZZYxr+lN=3MQnU3vEv*KST)O*tIji0UK!BNe3!JOA&YS02>N6)jb3Rqw_1#7oH$!3Kg?k z1-;sCCj2wOlzGr^=#8AwEZE!iDgEj21Y24?J1?cI#jB%0uRK9eeM-;ouaT~}2=~OV z+hr-kTg!>-5nS>}okPW+en z!*{E}+Xo)>YRq^WXuFxfjNeW=tcna_j^m&_U}AsripZ89vgEN5Xqx%Kn<`6w4*^S_ gV8n_Ku`Mfp0RJ=q%E?{~lK=n!07*qoM6N<$f|o|+_y7O^ diff --git a/collects/teachpack/2htdp/scribblings/img/957fe78565.png b/collects/teachpack/2htdp/scribblings/img/957fe78565.png index ada81569bff79b5d8a9e4e8d80296cdea4ebf838..65aa7da8d8f2971ddbce839484d307e084a2d040 100644 GIT binary patch literal 124 zcmeAS@N?(olHy`uVBq!ia0vp^nn0|@!2~21PJ7A^q?|on978JRyuERd_kaOUgTsnl z|4*G;t$ihkh5L?tY1$8a*NDyYS-)vpqk-RYze7tH!={~+V_*+H$QjO39D}E; KpUXO@geCy3A|~(v literal 130 zcmeAS@N?(olHy`uVBq!ia0vp^T0pGL!2~25|Mso~Ql6eJjv*Cu-riU!$l%Cx*uir0 zzvy$9kGuOUVY_x?r*)OCfpe@x>z}c^eddX+;BY<;E}}ee(r*HU9fw{n+qC1|hmkI^g<`_Kw{%Q|F+;7_FsW@@{Nr+M&n& UWNNBUBhYOOp00i_>zopr0G4T3jQ{`u literal 206 zcmeAS@N?(olHy`uVBq!ia0vp^CLqkg1SGwrdiDURsh%#5Ar*7p-dxDr;vnE~@u`!& zhDmM=w}eRQ0)s6Dd*>`#w3Ok*q#BN%AO8J6B#m$8OfB{cysEi0?bp7!g$c6t^S4WT z^(=0?zLkGrAyQR*ED!>pi!aLgp})Q4&DvOTglM?F%gv+T-CvxQbVrAw6Zc;< Z-#Lr#MaX=UNT355JYD@<);T3K0RVIqQH}rr diff --git a/collects/teachpack/2htdp/scribblings/img/9858b8d5d.png b/collects/teachpack/2htdp/scribblings/img/9858b8d5d.png index 7f5ee10885b5af08e600974a5596186e53437ba1..3fda459e1a08e0b01d9ba6bcdbda033dcfbb0ed9 100644 GIT binary patch literal 777 zcmV+k1NQuhP)*ll@>kz@4il7%A?4S%!8;b1ULGW)7MA+XT2wsLL>q&5GSqZmV6_)b=Hj_qio`FZmqakMH;U!kDHB_4A0a z(byJO>}UX>7HPB^>P;5vO&01+7V1qF>P;5vO%|_ua}D=2G$EHcmdnQF^?rGyzwoQO zSm-PkI`pD|4L>gN0DxExaYdhB@dwxa!L?xMhuFRE4NHs4<_kvQ8o;){*>!h>}U-CEvQ18G)Ye5n0=Z#2(v9}b@2;#c|Dm=E!_npOA4 z8hm=7eYjUtv$$1)H3@W~<2U@n*Z95ct9Ym8jdyoc`KvR=I}v-)$=iXx3solJE^ng% zZ*Hl}k2QjB`!jHvKRp%Tg1c^Rdn;-4#dW21Gw)xB472C&3qo{z`P%YU(&qDVSx!4Y zHuge{qS1s{R!0C}s4zFFxLFzi6&` zXNBq~nb0>S3;<|pM#Ck0H7*CiC39&;0|4~xCAqz@DOkeD4f~5NEMc$4-$?BBn7Sp5 zdd@YTIyizQjD{w7#I~#&-)s=e3{CI=fI=}eIPP=Wr(OofeW4fvD?Tw)cy>v4|CSjZ zU@txuxd4E*o^SyenHI#Tt0$-!MI+OKB@N|uP>3?42{9699rLP5WSHF<48s4AHs<_d2t!<)gda#C$aQIPtALz?(;Xw-6OW@Y_&dIQD?jP#a{P@&*vMdYaYmmk(KIo zO`GTQje9p4`d@*oq26Sn-ejTPWTD<E$GV0;Ui4`_4V3~Q00000NkvXX Hu0mjf%P4nG literal 793 zcmeAS@N?(olHy`uVBq!ia0vp^b|B2b1SJ0~wijk#V0z%`;uumf=j|--Y~etWhVyr3 z`ph~r!#$hRZ0%JO6IYgUt){#!7g~d2wrX5z^8Z@5US3IiW-}*zGdGVDlu!rMB8l>yH92}fBKd1FnmSC3r(?IUl%p- zn(KXJXo%n~be$euSbhD@z0mdV+a)5zc28&8d(z>B@^S6A!Qp0X`@PdQ&p-cUnt$#( zH=oUZKl*z040dg~U#EIM{BuX5PkjHC>L0l;Uc7dm7~bS7yzHQk=KMpK*6cG{zFyti z%>JUrK?!SvS6w~3|6FWqE0ir=(`d3&&PLtTJ@^RvAs9?{qB9^iMf&JcWsq4 zYeliQul==KPp=6$PyczjkpKDJvf|mhCK<-Zgh!bRes?Ztv8|66I26r&YZ_2=zW<4$ zwm%9tc@2Ax2_+rfw}(ek>x{4F+&8=oMQrDNHQS>0>8#d2a>%EEiN{CrnyTWp#U=xo=zR2>*-#aD<#x&CYYY@!os#!ed^(hEzopr03pb3ssI20 diff --git a/collects/teachpack/2htdp/scribblings/img/aac8b78b6e.png b/collects/teachpack/2htdp/scribblings/img/aac8b78b6e.png index f8c1b258afc52a8af12c9960db5b0210e15fe589..0a15fd5fb50abffe69e1a60e4454a350959bd934 100644 GIT binary patch literal 1394 zcmV-&1&#WNP)g+>w$7!!gq-cX}L zNkpIldZF*4IljC{rO=r;JmqdH(wPy0>pLV=xReH8th)`95B; zsH&J31HeQd+S~J z=H{kWtMycy5x%|)fBa&?j;R$>b+?}}RTB9UQ4}kciWyR4dqh#J*Xzg=zRhN{TCIjv z0RSkNgEcAI&ypmSN~LPGTB%e%+)9!pNm8@fY&M$!0D>S0f}m-drfF?|f+R`pY`9!5 z$i0eIpw5*b2(PcN#bU8oEW%$`SeEsAysE|+_Fc))i9a5|l1 zV`IT!(3rjMTosGOY&QG)`U-P~JI7+N3=R&4LLsl$+uea3>JtPZl}f$5ycm)P%h1pe z$8nvXw~kyrK0cnFp31Terws~X_V)Jd>A1>dGTN=CPiQuqnM_7^nvSbJ3|*Z_GU>iW`{C9o)+cl# zNyk+<943f9I-dkVgu`L|Y3+wyE*Hmfh$JC^<2aYgr918adKcC(VaN1=*}B_S%$7v{ zz*MR6OSFWqZP(OlHSHSa5(xX;eUrL%U4%dxm+%n%jNU=a=9#uA^^Z@ zwK|>7Kp+qd27|%i^z<}EL2aCT2Vz(E_xH!g$Ej4RlbvmbVK|OkSy>q$A4jMGAaup^ z{NCPPI-NFfY$Os{TU$feouP4cbab?{vm;58;R-ZOZ)|L=uCBt10Z3dW5{X12fkaI# z7K_DV@O5B2*JLt@$`Sw|kw_$yN%%TYuBz4Q_VzZsh*q|@x2x4EWDzJ=hlhvAKPai! z>xYMjkVT+eU0hs1E{~}!l&eCa0J%J-vVD|u5d!7P@Asq9fwnA^tJ&FE$mKDWg>n^* zMs+`;?G~HO7L7(Bi$J-u+wJjq98$p_#N%A|Kq}-ya#C}XF^TN&?;99G0!CLSCnpAmkbu$E<>jS;AtYdQ z_5A#7UJ4(&j-8+|O`ebTvFYY+wip7+uZG%orF#0!CL$OG^fZ z(15RP>0!t8)7^HDIg^NL%G9X#DB)w-jp;f601s55x12=LJOBUy07*qoM6N<$f~Xy& AJOBUy literal 1395 zcmV-(1&sQMP)p z!dqkQcDqn0+~41q%jF+Y2#eir9~~X_cswSPsq_8+7!w5H;^LyW-#2}*EITzd<#xMY z-}%>=q9{Di3xd!)Z3u9?-G0BHBuSteQxqkW$y6$pUJFBj&1MS*gCt230D$Z3Yh$+5R(0097adV1=$9+aqdh+fOU1pxpU931Sm43wyL2mpZ3=d;;tz1D*Uo6Y9) z`GCPs_pbwjAY5Kv)@rrhY17H47wA`vnNoFPv?TaFMk`xBM3SURrDBjm^J^qYs@Lnt zTLTQk&@>Gr47TT?s!?CdvRo>as?}M{pDz}R#bOcuG{bS6%jI&pTth=cpPd!DM5i%P6mz-U?d>hT ztAgEbA0Hq0dcFD_e%n~FSmb#=pU?kHL(*h24Gj(X{eG9r^}PeT*C&c%I-P!eeEhyV z1Pl)kheDz5cduJxcXxM3M@P+O6G9s-X0v%=VPR}+teeSQ8N0f=IzB#z7KVoT`T5Do zNzG~6g=VQ#N~hB(B%vXlPM1n0&1u@kve~S93F;GCtyVUh)tshntPhK{ZX_AH=kYb2 z)mxv?jU;Vjfk1#D`e=I2?{pD1<^18bYCv!{N}J_W!;>s~9t-dc}ZA za3=;VTi#%_Li0n^)_~gWsnu%g-y}3!11!s0tyY`O)?clG&uBKA=jZ3STrQW(Jv}{@ z%VkND001;i+wJzj!9lOr>-Bo4r>D(k*uKk$pf`4Nb8~QTkWQz&X_d1q8w!P1R#qk^ zCeX@2X-p7=-QC?xCZprnU@*A8zK$?`LuPD$e}8*>Tb5*!=_YpYtVLI!~~ zmP{s*--4;v>&aviG6<}()6-MP2$;gc8Y>hEkP$G2?W58dEwIKs9uE>7$iu=Ko1LA7 zjDRUDtg*GVHO--ThAwY4?KAh5=)R%;{@feiA7NF-vlS|NiVIC(5CE+R>SRKnr# z;^HEFoZlq43j{&f+1WWcIniC3(a6KxVpO9*M(*$ zJ#P(wHhvUEiN#_A0|NsC1F=|4QIsE8^e2o(qtVWfG8&Ekz@pfVB@&7EUz0>4fqPx- z#+H|t-y2(AUdFvHUSmAZfA-tvc^>Q1c*~Z(y*(X6NWg3C@bFN_5EAejJ3BkmF@yxX z#vUFXbPOQ@udy$l1;YK9&~MK}7hgPCg8QKpyv9aGMsy4z0k5%{nHe2JNWg1sX=zEv z5E`)NH9btJev@Fm7`AL_8@14E_oy|1tC`bt{sB!m!kwPN;Qasq002ovPDHLkV1fgR Bl^p;8 diff --git a/collects/teachpack/2htdp/scribblings/img/ab1841ea36.png b/collects/teachpack/2htdp/scribblings/img/ab1841ea36.png index 9eca803a59ecb68a727ca49d7fcd78af2bf09f10..4aab00dbf3ec99b6f14b46a3e043126d528d1c79 100644 GIT binary patch literal 383 zcmV-_0f7FAP)P000>X0ssI2ON$aT0003-NklMIpNK&@ru3T&oqvCQLKgY^>(iSHo%qaR zz!3_+Ki_}6GvLePo&SD+`S<(Fm&ZFF?+p0;`94;&Sg?ws8HX8b1l)xy6o>~Qq-Sp>^i#{d8S d6K@=T000f@y)T1%vf%ovPDHLkV1g@bsqp{+ literal 390 zcmV;10eSw3P)>tVVra;$}Byf_HE~U+Lu{s zz(G$(szY9|B`;WA@w(!?Us-sA1n8eVrDfH+L!yK-Yp7a?*E*uUdG(r kaK_E-hBI#F!F7Mz-;}?=GsPzy_y7O^07*qoM6N<$f*+r->;M1& diff --git a/collects/teachpack/2htdp/scribblings/img/aeddf66d5d.png b/collects/teachpack/2htdp/scribblings/img/aeddf66d5d.png index dfa4c9bb888ee20a7fc748c8c52079f1539fb1a7..0755ac22fc45aba90ab1115c8c8b4bc1934626c8 100644 GIT binary patch literal 460 zcmV;-0W7za;xL*cVFZ_J1(-~0*MZY3tCbanovaO4V)fG-_jQAGZ_T_EI&i^gb-l0 zvPc17_4#dgIRJcEUMIvUUIW1D=L7DC^KR2N z{C#aQ=(P|m}q66ZBmei$9tRnOVPY<S?q+qN_y>H@~Z)&+;&91Nat65Xa zQS-EuY-&kwk1|I7Bo1u5=pJF)#Yr4S%9qPTwQcu^YTI&|jFIP6&Z!0)r#=WB^EYhT z?XoFx{1S7^U$LQgJrFwNn_ANK+5pFp-KLL@Gt)k zY-nAC@%_-?*wDHNWAaXHXm^A$c_%isJHqI*|Lyz&E!uJvm1n(+00000NkvXXu0mjf DO3dK} diff --git a/collects/teachpack/2htdp/scribblings/img/b32ce6fcc5.png b/collects/teachpack/2htdp/scribblings/img/b32ce6fcc5.png index 006ee64d2483bd2741826cff8661caed4f2b8e82..b0fb28f34f61bcdc32fce69b80a9d1e8d2345bc0 100644 GIT binary patch literal 1239 zcmV;|1StE7P)YPh6vqbyQBoD!YFq14ZQZbGYAfIWOB7SPq?)v*5kX6>3$ol7+!&(>!!l3$+}z(Q z1!m6tnKR2d17?~gK*nq~0|3x8jn0Gxj;CFp|E9vM24*kA@!^9W$3y-9*=jgkH=$O*F!gF z5x$JkXk-}1?sda3(D_yPG8~)-onM74!!Qh4miOJ2W!bi)f)la~Ns=4}fUfJ3B!z3y zB4in^ZiC3L!jxf}rt8a=Bnd^l8Kw+bmNiXten!(Yhr#2UFl9hG3<|#rQwHSlMKQ`l zlQEf0AcG23Rkt>d!3j-dn&#{4>-+mV(j;P7U>H^`7B4O?Fbw>MIBo>Qt z9G6O^HZNjZuU}QwPN!oVF#HBGnM|!#BZ%!R;kFEme!t)A^$_hw{Xq~!rBXRPJ+-}S zF9QIeD2gBmi^T$E+h9p1lN`szv?GA@SG;M~f3P%4$yquKs3 z*QseR7`(i^pbMiNpeTytIEGWwTlMBCs+nL{aQ^yGZkYiA18=Y&wi)TfE5t04$eFK@h&a zzC4wJY6^zs^Z9bQ>^z$7%lg=Tn5Nn5_4@sOh&vaGq8g0`%d-B8`;lSs_V(86_579H zf?=5J>uZuEeb?YW-U!jJFboT#0r-}&oB9tz@M8m?GImq{K?r_q;8RBEQE0#l{m9st z`VT_DV*@`j_ND%V5b)T*j|@b4*dWzV*1J5#KS%!DwXfz75&9=~W-S-Rf z{OJpP6m@ub*l0AO(I|XKJRA;>kB_}J33!zOlllh$;5c3`m-G3&^|x3ovMdV|5?jXx zKDLJ5oN7ECyXF^Zn!dlkUu&>PCX+nRXEGV*vYMv(o65b(aP_EcHp}z;!NI}qErKAL z&1S7ui$o$pOxWVhsT@3tB*}Wc?&{guY?fgdhmhFcv4Mx)a7g{LEX(se_^>=LGL5A(}gyZ<-<>l?|Ek#ittm1gJTHP08_*e%6$)IWa?(VKoD0sDMkxr+1 zp5MyG+8S~NR)(S|%jI(O%GudjyWLJC5?)PiLQzz!)!NLB0|1uG<@(DwNMMKf<{KhO zvRbXW&YqB97*;BkSeET{I_ozjiefUEgs%j)H`X#3hJjfDykb>*bab?34iYFC)9G|R zpId8ltJU%}n&BZy^5*8IQmNoLKA+F0(X|9OtQ{{gKP%7={r9K@>&X zWz-g^1W&);&*gH?t8cjIy8iL;0Y3-&&r|&>{sD$Zcz2}L1Ofm6002ovPDHLkV1jLd BSb+cl literal 1238 zcmV;{1S$K8P)T@#iQB+*I-O3ZxUGOcKq5(!BuTiffPaaE!rJ&2?{=l&OPXZxL(^OTpf2*phX&OFT04s?kNvp-mvMk)gf|tbQZ{Wg3vRp35 zcrfF`Mo2H4+!LX3Hco9Aa3!cO@O+`_5T~!ptak$VGJc%sJE|bA93|W=~Hwti& z?DZc^4i+$pWm$V4xh%^#j@$v0D2k%%y8Au4uDeVm-wK!n(sOV)SimHZvl+*v50Yd& z9zz~NG)>#sU!p5W5>Gx8xPuXvWqo{nJUu<_ovA-l6h&1km6MYb!hRvnW;0O~?KsF^ zq+~M5^Sm9kA=VG5udlCfZ*PA^e3c-GLZNVRaX}Eoedw65!^)#!|*)Mvh3bFp-2D#)9Li#;oDluD&)wc7UNb`&fL0KhcO z=jZ2szmL#2ScO8NtE;O_CIer^1Boq3k~*CZ)@Wip9&a=nE|c3)o=E@zi^W0|#m~=A zuNC+Ah9GjeT&YxYpWM!M{q0RG%j$N!ysPni^<8~k zEX!VBU(+=0y9K24Nq`PU5CjSaKq1-AE1(EHC*hxDJFkEu^qho$lE9CzhzV#dcAe^+V#GS3nU;PQnj~qA2hV9S(u z_O8)rv^QEAi^cBm?^hVM5{ZN$2|HLdMbmVxR@>|4nM{UdS(mf4znp}(F>%Q&a2zKH0_0?k#bT{i>-_xO z@v6U^gf|k$m5U_F%gf8#+gpZVJQya)N~N;vOyXmSL?wyEVt03U`F!51VOyzGN)UvN z2(P1|z4Ab!s_J5~ST8v{J8QLC@p#;;)paop(`+`^qwWBJ#bUAgUJp_pX8ihdqG`HP zsqB5FLW&@WVzJ0^T)W*~JuFF*5{U$SBObd63O;3{>UNlYL+}xDQWs)Rkv)N=afv*eeU6Le4qfwscJ&m|OWwTk9WkpexB*}4w zbrfursMqUdvsw4GIanEn@&5h}|5ikbcl{{+2Jjz#J>V?J6951J07*qoM6N<$g2s58WnfR z5;AqT4i`w_XoiF&de;swl~SLrXMgWJU*2aD{qer1-^2Gl!zF&a-NhIW%sATE9)EuZ zEX(pdkH20Y+~#hsUfo@<`S$>>jioQkYyH*Kx8w@R`Z8Gb^=;cu2s=hPgAX66GTQAn z{2>~3beaf)KPMPNp@eb;hB^EC(pdEMYqi>hpLHuond1*}e1MBH@uxw6(-T~N#s1-J zHEaG36TQcfFH(jy>JtkdadC!5oibGO3sJ{~64Du}fE9m$PIIc!P7|&}m8%&s*70T* zh!JdO2K2dpSpX#{f{S zU^DxV8EP*_ucf`56G_L0iTy+D?1}%h8N<#V{iYa7wUzersLmROi8t?2cpaU?gi>v# zy*%3UWIBWLyGRq~OFX<>U1zXTAx=_CdwC@L@mvU{+A_TS^hA8<<6eGz0DnjsIvI64 z&KI?pbJXoPozY&-QMY4gFMmYoj@k~<+@`D#LUa}xmpf!^72Ht+m-rknyXfoN aw*3>L9YBjE7=~Y;B(|guN)2tL)^hL8^7(rvV}0Bw`IU9wGbrWzJ_yy(0pM-<&jXK4 zJKoym(!($e$8mzso1?qJ?e(ksn+^8?z>T)@Wp!h?p81wu&sOdjCx^H^4?pU8 zI6KAFR~#J8mNfBqSj5*1#jwBl%(R-38Be%8N2|%RDe;qtm`fF8bG&-2xg+%2QO6<4m(>tNG0B3~DSjF|7VG)k4J zO1b(vY>Rw7Kt{{}P_1D*|Bo8pzK%hMd_6!`%$kmaBkb*mKfM{l-ah{gGM0iX?duZf z4o%0K_b9!VCpNJZTxnmIK3-;XsJ@fkbdDs$*HyL%7?~J@mD0X0Yj2(lu@qc{ub-WU z&wzoipB%y+^K2T8(lHmyju2ju8g!wwfEQW;nI!)TbNRqFo qeBbZ)`$Av5T=e&Y7kz!xG=Bi0uTErbhFs+U0000U-miR;F;Po?wq-gr|@KdpC)9VxBd3pvfX!K)OUVUrA_a+BR8^n&nXWK1{%fS M>FVdQ&MBb@0H~xV?f?J) literal 130 zcmeAS@N?(olHy`uVBq!ia0vp^S|H591SGu{#_<3tPfr)ekcv5PZ#eQEP!M1^xY$v! zOlx7)ga%n1S$mzBS!bkX{NHw_XIGU=&3nC#&!zl1YYspDSYadAe;h{rKe_$Z+6soX X|2h4qgTe~DWM4f?7=T_ diff --git a/collects/teachpack/2htdp/scribblings/img/d47072011e.png b/collects/teachpack/2htdp/scribblings/img/d47072011e.png index 5e715010af71de9e20c4a39db0a1cc5a345dff6e..a25d217a3e9720c4a705540de32f3711f8079f23 100644 GIT binary patch literal 676 zcmV;V0$crwP)!{lI$aWYA!bS8kPz+T`cY7iR3{8z@p`k?=&Y4ReaL|~oT zGC;xK*FW%25JG{|=n$s~$(%lMW<+?mfbk1HR3Pz2_P>KySBAqnHnd=(`Reeo`TQwH zh*R|tJBDis!_^Wf1M@m(C-uA{xkJ9g86in;JBjc*XCM9<(f>dxC1mfP5#ycVrw2yC z&Q*tpZ#MKGknqU}$#m9Cv?+b}$(Wd-1h>S_XeD3MgN^~+C3eP&>|4=2zTejGt>k_f zA<+a1A=HU(Lvv3Iof%3%ODv44yB^tWl?7U2VHg&H5X$NgCYom%(ZkLdN=Weru*AfW z2*ubEjl?#ZP}zQ;+R}lcdS@pF zGKNdT*wCT|RMRPAzHn(6@T?umP=GZISHqRA9Vyru#K4Zd>`-&rHD$zPCtPl!<8Sqr zOc~1prL>~CM4I_c8Osb;syWMQO`J!JqPbMY>SmR8my8&$+j|Kkd?HXv8+zam4eFiI zO1_5mmIgJV+t$<5^Uhe)T-!Ul>M>k*#xq$9Wjt@VQc91F9L1w&R2?qZ#S4Q=z9u7I zdxq2LZPg@PJ;Rq7vkXY@?4+EXs9+<;9?&~GNk}<7tpjAcWGquMVfZyeDIUx_V6xrP z!aL*0KEFBX83~5=&aS#;S1@<|_QB{a37$FlY>a*#FHZkcFVjD?*1!Ma5kTqy0000< KMNUMnLSTZ{NIrW2 literal 667 zcmV;M0%ZM(P)_fz~91kfaysmQ%<9!~U<-(fMGlobW{m0oKpP^#=tl zZ}e+*CV^4Sm>o(eZ>OIh>US!bHzq)eiU9yx-o`lf z$EX@3W7!@vQ?>V;%&y0l?J+Z&TLA!^>kq;k56pHlWBTEOzge`$zz6_BXedi$`huA` z*EwX^z*w}$z~~zzlQlQvr5Kp)%#7(r2w@!7I)?DZa&a`)O~-`j%!Jia{}i*e-nfdU zEZh51#-cHg=x=D2xzg&|RI4*KLwU&P2HPy7+%7dK>32a(H%1=Gofx34o0^GnR$HvQ zV`hGFQ#1BMxgX6^t!7;NFLQ5EMy|FDbUYvTGdJE8Oo&c=>Erd>bB}^qRxz0!P6be0 zqJml0f0>$*bFC=&n8})3rCkJ#QO=$*<2v~lGQkrSlZo+#O-{T6h6=W~JFIHb@b*xT z_uK)q$Eos2?wV=c2Fx=<*@1b!|1w9MH)2qgj;UIhk((EW3ARUr9(Rn>&Tq`9ZXM&R zF*?TPNbZ!B6qu7SlUN+dox+9aZ}Y#5{vl>rqABCIF*0HA(l-DABIp5U-kF?yelyfD z5wty$yXG<8Hemj--v^U)%ro1iiTS;om;dwU{SSX(!m(b?fsp_J002ovPDHLkV1mE) BLeu~N diff --git a/collects/teachpack/2htdp/scribblings/img/d629961aee.png b/collects/teachpack/2htdp/scribblings/img/d629961aee.png index beb06b3c45a6f57843586dbcf14598cb96ca3244..1b5727c94177f6281eec0999fa4e5e54a8c6bbfe 100644 GIT binary patch literal 989 zcmV<310wv1P) zrSwuu>7|y^OD(0BT1qdqR8oJ^buiNmXGY@5;iy#;wTb}XN6wM&d_Jx0p18ZmUM#Zf zDUGD@s<~oeBA6e)sC(Bv8lGr)n7kD~xr4LF+4?%Tc~JFZCyTC*(@B4BJlNPD+&-+P>K?f$cnttc)4jQ|K&gR-*MEM$H#HKk?+wX~$tS7T0Pv!H z{^)j?u9>;9VA$)gb?cGfJvNiRAD5}a4m4F8#SE96cl z_o}&Kaq1$g_S&s*xx<)D?zJ!xBzYSqPp8S4OycD_m>)uGLuWgQVnZ)bvaHO?)b^}x5)v9U#CcFlw#Ot!^pgW8PCYAaZmw_qq@}vB= zdo0K#UPpee+hh7<60a|(=?k#w(rJdvgr|Rr*QXOVpMLzA4&muv; z=CY&%ZGCU({g1rY7FVG|mei{ctbMHS9D7=O^Pdoz{uL(jNI0uILng@xO#f;xzLHFN zp-^zLGz+UDlcijU7M3ji!o8SeH`?eFknE-#!=jO8u#qklSvG}-;*e!ls3{0pmW8b% zkY!v5w4N;c!s#!vBg15_o>K=ch2}^&t6jrnEA4X~WV#CTwvuT)$gq-3@4=6KWZDnP zEF;U~V9_SBoDO2GA2u%-H>Crer4XlXE09 zeE*&unfc!<@FFws1y*Dvyg-9&IRP0JFAyMmkbsPk7dVj7@&b7>a$cZKM$rpEB%IgX zIzcj`UI1bNf@E~PK$48K7wC~u_X06823{aT1}3BdnfN^%VJ3G%ayZ>{Wo&K`(_RJ)8gb*mBk_vzqub-N32AjNl^I^br8~CLp zQ%*^yoRUmAC7E(cGUb$H$|=c|Q<5pC($AM&2Q$rZW+a{*j#@QQs|Wyoi2k+3aYr zICa_ZdeToeD&qO1KQ|t191LzBRZ~2RVARM4fTii~+*qLWt%lco`LH`R60h$M$(hMV zfouSH)xLOgH%#}Wxv^l_>#gn9Bf-0qD$JNm)7{iwS9#ouR@&W)!+S`virl4))uhqp>ncTP5Y1G)kEcESM>?qVbntj)yuf_ zP&t_&<+mkdp(ZCg_H*4u(^r#|eLL%`a+@NZX1GjvHjtBjIdyYr$BlFd&jxa`y%X;u zG*ICp+e77KvB3KugE=(ic4+p{M2n2g!|HixW;xPnkyA?q;m6L#fteQ#^v1QM@6Ps7 zb?c|GBO+4cnnHJ5-yiz;EAIuzb?B%mkoADI&-I-XPhV^PA0o4X+Mpf@XLV=Dq#A+Q zKzSZ4)zT~-3a*xNwN+%b^b6F&s`a&|FQ!_*+n@rfWw3KBnp!rS?Lw(#R-Y)2T9zf9 zf~aL&1uKGD_Ju?1)wI-F|EL`sR&({7Sm-KGN5Wa%HLSMMzR;njv7&FQn%+YYE7i20 z8`-Cp$5ESQYB`-w+N74>fvz=bxt@XBp_ccx0SnX&+_d1XX6AAVYc*rni}|XVyphdR z&G035j%w!b{j*auPX=ykB*?%@jS3lPs4XW@BSZ!QYL61A(INu}HF9JiuSSs!wAF}` z0f>b2cDGJYjV>90Sb(4!X)=&hqfQ2TY7EFgOpON_$f$u48EB}17a0hsfgKqLsPQ9% zX*HH)FsjCt4Cd4rlfjT0Z!(xrV^40+SF_&gB~@@$)G{aelldORtPd=s^*k`kF1*CD|eUw$bcfZ P00000NkvXXu0mjf+v(#* diff --git a/collects/teachpack/2htdp/scribblings/img/d92d6a49f1.png b/collects/teachpack/2htdp/scribblings/img/d92d6a49f1.png index 178a528a7beb313bd0a5857028824a75708c6da9..879569394ebc2355fdfa6da1d2af6d6af6812ce5 100644 GIT binary patch literal 657 zcmV;C0&e|@P)t2GR`E|yD_<=fv30Pnby1fB<7Z^6B-uEX`E8!w{A=AX?S35QaUu>l#5YxcIU`fV%GHt|}}RA4RJ!7O1Ls z-DQdClmV?eoj$oyHoL2e6MdpT81)8sUGrQXjTg+lYrVn!;XmTz2El9YFyy!XYvaxF z%AMz*xKFpOWi>pKuH1t@5xdm)@4KUj-}j*Z-eJz}-d~vdt>ZMguyDYm-0zOk+KR^66B3iBJc710Sgdp4?}&Wk0lLjXt;e%8}oZgvV^X9KWa^Wz@$?z$#~t|LS4x;=#M zlcg`6Mw<=UHW>y1pT;oAwrR7WENk;{`bYIBBF7gu9M?X6b+@m+mU6p zGJcL_Q4sX0o~Gow9ZOf^x|F6psQW%mCOvwKOeW;}-KiG^d0y|*)p#BiMQimur`2ju zZ;{oC^1Ow5meG99;4Lzrzj=GURL^rx@6x_u?CaHwf@hx8&YV~CzFvLc|7CML?_+h} z=huBm?Hlt^Jxzyrf6Hbvsrgzxs`vW6Y!laQR1X4v#fChrbN*8Ad|lOTEbE1O81l=# zO&HdxI}X3u+c?gXdX}}_Hw+V9|6LtuVw<blynT|szd3EB_*GSYTRoj(z2+K63D#>&r}vBUSR;z~2lZ{LMb`h~;EsrP zJAS{0G#!_cx`))HbZLOpEyxH|ErSu!`K)a5k<=~u3REq$mt(JFdxPM7R*?hN`gSawzVo@*jck+wG=vpy5Ml&Y|;FpE_!-d8e_XrXWhd@B90*7M~^g=Z7sb}Usd^mZ&&W9TnK zDm+gl=GClGFI3GM6N&l8cd6l2cpi<=6x@UqJtv=J z=`~EjO-Rx6^elr7rr;)o0Dxu`n1-mTw~|*)&zfE(alL z9tZ$X&Qj$dB+UZ>fH`&p2ubrm03e-ZUSl96&4ZvB`COj42X z)J<0*86D|4qvxxh+`Mj_{W5JEwkQl=P?B|Yosw+jFDo@w_@=+^hS@j$ z>C{xSEMu19xk7mEq^fIm_sew6Ja@8LK0=9ZAU&50WA}2yw-$MOhi@6NdreX8iJn8g za^=Ebf1vv6pbTp?F64PSS-5+fDuH)z=cbcSe^e8LeR8(2g+o{MnulIaOw$~?`t%oY zB%eoa)Z48%Ry%v+C14;jHm7NYA4Q zWX8}!S0Ehr!UV@bauQjA(Lz@s9M&|)anqB?bfJZ=KnOO^go7tD$aJBFu0VLKX`XO% zGssee7P^AK69RyF(|AJC^T>476wc4)F8!GJd+^C*JPQEfi09QU?K|J?^tB1NR_Y<} z*jryb&t{`2FO*PoLlZb_cGZng}9~oUTNkXj!D^ zD&hGv@$bHl*Nn_&^8KI1rjy$HA4PC&IU$mW+=!J#K98-w<-*Gsll2VSoIex4d@+e^ z%mI-EWS%8~6tJFcVdAlNs(+kDa;kqk@z|Y%!6oH+>CK=0YQoT|3ZbDF&VDtq^cDet zcqC-kJrYl_t}S8gU-hp)X6RLa{V@~!*M-ef;*pRufkzT}tY=Gz7^1F>YSMzubBn~w z9^^bHd$^oo-ndrxZfQMkTubGQrLJd);t_F5#Ur*TNY5<_clXX*MrE#n88v_R&K#~$ z8zPHDV4tD|p2#Bc`j9o>>my^M$dQQ_+7JNnvZvaTwEB^GZuN6x*lL6p+7JL}RhT_n zl6F5b&+UF!+m}xGLnMY1J9FahpVWFu-x##%)EqbE_f-TC4B%RS{^FoeR~D5b0S@HL82o z3mu_Si@ooJXjJ7`k`pJc3=9mhY6k{}PMo*`RcCbFk+y|p^#a~{kE)hdg+%*}sw|a#1SU;{eu2>yEMY(ZB+u_JjS3B-j19By%6^uTiKwpOg0;SVhy( zeFs)`K35!i2M=zckvOr0)xYDFL2o4Jbw)>m-j%hU+XRAS?}54jdk=U6!P@!k-4$AN zzkc_}k=|XU!GHMh_P)N23rn2z^=&+ScsscMxBXRjnE`+hj^-}2^X$gL)56y~yIEka xs-kMHs^J-y_J25_@2um_=n!j?+Mb_n{sY2|Ab`+j9(@1+002ovPDHLkV1nMuwW9z4 literal 1949 zcmV;O2V(e%P)H{?~000MMNkl& zTW=dh6vxlb-ki0Q*s){kCQvKAQMDzsTv`;Mq7NX^3UN`T5~-lRR^l`CjW2){iN}&E zAeBpnT5f_$1uDv=38Ae@dWjrJYKWaUP2#n8*Y@(T?%H1OCNn2a>XzSAG(LaL{C##V zJ2Nq7nkM}J5WGGp6wN>X%1ovg0iZh)c=VBwz;kQZu+@cg&32(^UbvE+Th#25U_kEM z5qn^q6W7w=8>wo~05G?x4c|zuNt4zB7u&aIvdNijeR*;wd)ux2e#B|p1h|^Wctu}L zWFCwG&}n-rwW#I|uV^)IOr;iAxk+n*)Ao3Berdt70rv$pwii?*v!Ho}T4WZq1=aI$ zxL>HTZOzilLK)V~)Y$%KMy1hEhBY%4+p1QWS9KcAysE2OVbz+n7F2Af=5q8hrr;)| zVmo~&PcLH%ZbB-yXXhE5FaNIIBDBE_tc+h~5G!JFl^I57f zyc&e0dAMtvZtAKAA!#1UwinnvASBI0*>*P1y!=2&ng;;@G^1E3G7rmzVo5Vfvgoo= zk^H-O?rc7BqW}Q$&BFczzSzV3%G=sN1OQO6c~kR-EXt0;-!AB%52>Y6c|YRXs6KYt zc%@%?vQJt`LmLYLfSiuBozshslFOHj(M%p0DxXVK6}-|AHJq~IiU<&Z5os9*>vgpRjM>zzgn10-}@d;0Kj0Mv@LAm z=+8Rk5u$0Dqd(vKYhw6nFzn?wz!Qc5@B>|HY z>g0ra?yKoTZ#}&C`3_t~t_T1i^2ljS ztE(OY0FsE@&6PyHh#ilsg%{4Hy*%5T{UmweTpC$f9RvU*0hw({ASJAATbTM+J2f~- zBRMrVnfkXe=Z!1P_R3pu`ok$hry3Uxy>$A+sg>6VmTjMeY`st73D&qJOx#j`|8n($ z7Vrni#5l5-qJ=i)M*G1+V->C_FJ}**$zjEu3^vKutJ-1qk{ov+rfYg z0PDJt*+vT+LfN(~@`}u`Xi;Rry0zj{xKNncKq$=n6i$+{?*dq%O-0|)=A)NY2S3uo zY}=BwwIkOHXrWETcBGxbc6D%kGjk&>Ni@b#V>M`@O~rO+u!UY$9lU89^OD|@Y}lx< z3N6q=n@WonS!h!vnk$uUic~!igd!vwB@XTeh`YfB*R7#Cz}kG(7C`60YmHOeQxrmiqF`v3K8v-MhQqdFPpD zpWR@6S~DbeM*=hz*N64)ktoj?IF9SxQ?@OL+^#(#8dWvB_JjnHGfg;t{M(~PKX&z8 z&+zcn(W4(9KmM(C;8$b2RS`q2&Rc~JLalQBO12|Hwrr>B;aj!~9g#|TUzNA@Z3vOqpKqk?zii%6;(dw|CP> z>am0_U-SB~KNj}am&d~X^={=hp)h&vh-biSNBp6%dsh4QN0#0CKk!DZZ+~SVICgAr ze}C`Nl6w04dygI43#;)X1&)i=06+*wbFsSqFv!B!!h0PCEir*Pa7SxV|8SC;QE|00000NkvXXu0mjf2AsfM diff --git a/collects/teachpack/2htdp/scribblings/img/fa1a9f17b6.png b/collects/teachpack/2htdp/scribblings/img/fa1a9f17b6.png index 3d53897ff08d5ee3bd916391b2e0eabc85cfe402..f8f50625d557c9baa80fd2fd103faafb40b7456b 100644 GIT binary patch literal 1315 zcmaJ>e^Al~6i0K*C;?|hQ^C_kIzceUSvh}UuniG^T`Q+SnmS3#O+$x(t)b)(+|ZoS zQcB#pnp$e5HVHX1A~h89%%-AeW}?7MLBTU>U-$R6clX}A_wK#Vy?39xPg!jA=T2Z( zFbD*4B7Z@Q2XgwRJK6(r0@-~T1aep;6A4FHb;ikQ^queBmCHifEe`hCn;Vi2OkGPy zUCZ705zNPz;!9sVta^9;qk&%#BLn-r2deIrk;^DP6N=3A6{%-b>L<0@tx~y#zx3KR zd0^VI(KI|;r=R<3EKu4hfV~PEObhVUIf47wniQF?jm}KK1+~Bt&jb)Xsbsa`zuW!q zYCVt$1oisJ0yC&45>?&L3PuW*sqG1PR~cYEJw5mCu~;l?)6G3^zQol;Donx3oPvUa z2iw!r(@`jtLZM*GLTe($Vle`N;P=hgY&NZyM!pDvLgkB4>$SN;i{0JCGr)9SULKW7 z1tN_mR-ANpNGU8V1geyjl&mcM`ue&wgIgB0Z_C+aarBr*Gm|exk;{o*z%|)jeNhs- zXL?jouRk9D(z3DThwu|8Jd`z#Ph#_Ec6RpAlPBTOg6*ep5v7rh;P;DMTwK(L>Ae#ISc8TUA&KR1J~hKW zT%;GnO8T6^{MW&$CznW$&ZPFn#`o9?9N5YoG8kG0=Xi9_zNxG;XH=OT5v`ReOLxW2b!9jCnhF}HW3C-2U0FN z$RaMtMB41>=g-g6B{0_?_w5#J~R@0h=zCd z^YJ;4T)`d}T4*$y$z&=c+Ota|Fj#D7M+c$R>eyh4gB2%WE-XGZ$UTERjQJaDYx$Vn zMaY$H7}=s;f9&Yd`eR%O1t(DO7P}3cHgiC&>YUtzt(b2!KV4wL;czuNw4@O}Y+7Kt z{?qN2%avyl8(R|C;<~!}!lV}{jI6V>^K_t_89c{0b;_CK%vN~AY+(;`j{EG)%*^B= zSDcA5M^B^CC=!YIe7^ed6u%knnUG_Vyd|zhg4P3w8e0{oD;(P)~VeW^ZS_FXTNGrwqI7g8Xq6Oa^*@>ldp{aZdNHA85xmErM0!SdcB_L zRV8bTSwn{YnPjV|sCctX*fojvCcu1seIo(3DHH)<<>j|6rnu(O$*@O{9=)|%(6h_i qp~SJ0pLzc$8UH3Q)yk>r-&R~QGG9=tYD!Un_<_izXyUDiWZvJpP?ysH literal 1348 zcmaJ>dr;C@6lSfIARp`cNY?O`X=;UxuY8~wnr5p>Ci%j0(QUQ0$*7d9O^u~QQgN*q zU3^wHri_+pxk|Vz^jjAdhinm$LQ&KNVQ_mH?Jxh{-7|CUy>rhubH4A~JKwcK@%znT z2p9wcF^`SG;lVxUb3#qP_0hl?e+Xm~JQjydDy(0YDZC&2=qS*QontL$2`dpypZXKK zJPvsK3nySZsh;tU?=0u87Vv#{3hM7W?v-ZYv(VZ7M>`G%gd>Lhq!o`fWpc%ZzQDnT z4|A8eocE!lI{nEP>F0j9dC(?m=+JSX?P{|pZQ41^$HD(b1tKn*;oib$CVmUFb&y3&?mFs&U`)&9a+xfhNaWAx_DITqSL~=6 zQNgICGeN9_d@i0yB&MdO;_>*5jE`$;#g{H2!5Z(SNF?I%N}Qn{9v+!`_}T?@qD?kh z(retph(3Je$Pog8keQiDAiNNZNvN%bY{m5Sv`hx}M^?_ORI0SVV%tO;UMK4No++@x zVmV-~T&th0t^Ep+Oj05@p(T0#{{8`V!ll*s#e=V29lt))Xs@EWOZM2&voBthYv0rf zbJV*YH^to$NhA&yG=V^%Dj?5C#MFEl>4y+%G@6MCYeUtWl^t$Zo~a7BitvySc-XAD z7=XIu_5@o&4F*GmB{0OUu*wRk+fV{wbDOMVqM@hz<;m@~l;MPl!ud*hzE-38iCFDk zLP|?Z6AFdn-rd`)d~9IP#o`FgGiF40VQ6P^dlP{a>zsncV!dih*TJ^7wxIrX@cn!D z7FJfQC{Z^yG8a}USgXd*U=~1{l1NI3I+*^!k3Ff|=);9<8d6`ganvZCnv&(8cdfpR zWKzQ<;zCl6I0j0T^ zb8~_GWN9hyHh%MGwPtf_wOXlE&dj(OsuVAaf8J?RPN&oP{Ajg{_Ei|l%+z#paL5$kAs44Ew^V}9u+kxAqNT&UhyPu3kV{L6M2@SH^ z*M`h)Z*R}Y$Qbv=lrBA;EyCE*o1XmfAtc@G4mcR8ls=p_z7JF4nGzQ_!snYB%Ew#| z zb^%31Ls@loQiWpw+peK472wx7*Dqfn=lUVkE_u*GSF$9`>J1Neo9J6*$V#NJ}D7M7Q( zl)M(t@=wZ1*UYHhHv& z>rN9v6vwBnFMu&o6D}5`(WoIxkjiJHK83!L51|7F_l%=FYDiXu{>wYU!<2WBQ`2ZI z?purbq{r-0aCU5Q+5cM1Crt;I)B(X||M&`X6xt!U>K|Wci-IBoCI9$UhA7A*Xzw4l zVTFPW0yX||OC~6^B2e!ix3@lpCInjj<6ai0aDjl#KkjQ~3K#*6e>{R^DL4^?e@Pal z;Cl1!6^MUHiTnX_px&N7r~wU7=QV;>S#B=4KD_^k94L`L036g>bHRxa^0>!5gTPB* z3(W=mMzAx5i_ZevQfT@(v?qnuZv-1skoi)y8wL6M0$Wi~yfv~9g?4v`Hlfhr2H6f2 zINkEa8ZHLga`@vxA5?)DG_Z6itwnh|76nW?~Jm8+7)OBNF8)6}T@ z1zC3`(NNHaAYaaT{S%e?Iax4C@l32x&YNd7r2)ao`H9y*Uapl0!nA1nc&k(`nS_E` z1gDjv*Z=9PdZsmik~Wg-yuh1*f+_^1TFDz2FII{~St-ipbeUm)p)-Q>dfDqAFO&-u zS;@#VI3`tncAY{81Qo90^-ttVS?a8s)bNj=c9lXq1U0@k6`07JrGc`-YVnURc8`K0 zf;wOS9GFZMk3qAN_m5xd5(Rk#oWRYjPaT~c!Y0(lKW@+s3Ni?Ik^d5$hOJOQD*WSS zhEr%oAc(?zaCR@d3!8*W|G2TS6q*o-NL&cb#WGRY@S6PNE(TI)La?~`HIn)Z8<@a9 z?r0Q+3j|By#jSr~*pS5jad$%~U<51M%b~*!*kF|Y@gVwBa3X}hM^@Jp0oX7g{_#*c zQ*gb0`|{V`PuKu}{w4MH^yybg=yW)s50|0+<6(7}3zC3KHFfeY33e_tQiUwl)YU%@ zp+l-*rJ4r#$AO?zg(=lE%s&nXnkqo4rosMkP`FfSOEtUVABP4?m8w*;i~ex}5UG-v zYIfZ}PJ=pC!ct9>_?JYPDoLrPsr*Z#NmX;HrV0H^B2HCXsitZDOCn2E)gOO0#xk>i iNd&1nRQ~-d!};tw^N(z>4p-^hCltN1{d+}jU zxU9SF?#$Wl?yTpDwli~1zLa)nHm3naQHbv&XntrkyAsW=*jI{!amD1gXm%wk06{o3 zZd*OhgsJz!MS`fn;X7im!bJjjhC7G>3jY$o^L#<{Q!pZcS2=<(ROn9tV|ankS1>~W zBe{UkQ7}&c3D72pom& za(ZcFQMc7XlzQ9c^wV3+~m=R^s%;4j8BU{P79DBu*@!vp!pjRj~ z3bSj|qSP}#<*-%TtL0wZc|)C4H`pO46-vj&nfO#!>{3iTsOMjY!gP6!f)Rp7q1voW z$EP}Chc0ElzF$5ry$QXgn{E^=5SA4VTeV1RvfVqS%cn-RBGg-l?%8x%Q#d+3io_;b z-6lmQO>7l6o1LahAS@^xw;PezyOYj|)f`5#o?nw>$qf)@6`I{_9HFGhkR zZa9xHrEuD7MPd{6R-Lvg{RrP3R~u9vhZwBT7Tb~7WUX0ct4bSZ1n|&Nhye;+sXHB? zteliFsyYu10X*p(L_dX|)O#PFDm99DRS{x9053TNVW=R=;_TXV;phOjralBPzzGO_ z1xb-UBxd#x_i(EjNC3lz4xytUEAm2OZnwIFTZc&k7(84Et%5?7#pJwD$>3ICi2$Yy z5kjl5wDB=r`i+~Lf&eBC3*wT(a%ySwPYO3HH33W?3dFg>=dDl4gLT||j0CWV{Sct= zE&XL}KaQITg#eba86rps`5}D&nOnupfk*%g+6fUPgaiWE_wTU@U|Aa=)WGj5wTS>0 zx2II(u2NeGAcYO3Vs@1dfdCR=mx|U^Iy3@EhgvF5SLu)mASqs{2wkO)5I}0AQdzr7 z9VCDPFiK_WDs`Ly%3v;)zN^$F1ZpsrO4(KFDgrfFN~P&4bs>Qo)TLVPDs?S^8g!+a q{l(L><=jl521TiX|GxoD2>A=V>n8TzU5pR_0000DY_di#^ni^>NVpD2Nqj6a{Q`EGVNygFM89kSEzZHrXCfL`Xui`wt2EoXCDR-~E2c zZub9MU{MqW=t7X=PVex9-{kh2Cj4d(Y4ehH4{7%WTx5_Sg9I7$1gSuf3Q&Lq0I&cD zve=Nt=0H9N;v9%`*&;qCjmJsjbEHB{A;6SEOeyAN;hc2ZsQ>`1=vxuwxY^x1PCT{} z2CL_Z!#n5?5KN980gR1HcsVluG8wK($CoPv+L(II(aPx?9(Hz(IJ;lC?z?=?8K zh`V@^=pB`~BuiW>=4M6SIdm(l$6y$5G1{+Li6`+1$p{&~Or7?=CcQ?+*M!{RjaC#0 z7{*(A%qPtgz4Mij5elKUNU>d$Uc&DynodSbiMHGIVBP2_1t4>34vE- zEQ+H1L07x+fYH{TxL^oSOLaQ+AqtBfugObTQFwrsM0@TPhCOQL3ChNdrRbz&rFwtSqkRd26 zRy6_uAO;2X`ORvnF42*gqL%9F^P4d!0JHAGKRdl63C%`_(0Adf7b&=6nodfsZfBEH zlSoJi(qeW$cr`T|9NwWgPmS3!z9ueHV`K=@;`EM8_+PmF<_W*qLt4G0gVuyE;d5j{ zOd-G<r(kr@}dM+Nok|MR*;iziyY_4?gNOzFYH1UsvLcsG9&b1N1_Q5`*h{C?#-=3YqnWW)F6MISRXfrF;r zlUMg6350}`SN9K^n65(E1@8sp_eDnoilUr^W%XP2OiW<^P$#NDs9+u`MW0*bWtSy7 z!%Ub*g0*FPAY{+I<9q=jyS8i(QsNCoQ9WLwf(}&TT z9zT89;j*Ijj0yItbxZE|-9~Fll7246)8?aG1jPir^WXJ&_{PaLO5liTARfMPvW=1y zeQu#r=ElP}PPS13i{Gw@hi{y0qXcfO*n#tfXiagxaAU;|w4N~mB_i3bhJ9#FcQx#j zh-7FzV*&yIbY+{j)$K;**ifg}m2F1lMvs(U-A*!Ue)ikBBVDv6kSQJIIK4`7^sb+@I@^wq~it2=9Vh#iV9QyOn zY$4>vg#zpw?d$08m@Rblcl3?+&3_;yz{@?C!)XzuBnRFy+zO{fkdho2;WS&oXW)n} z>_0_Ekdhqe^n`tw9zjZSQuMinm@f{eMUavlsFJF}X%VC(2Nq-&gwrBONe*1ASsPA^ zASF4lwx~9o7C}mKU_oXMm@S0dxKMxqfa(?1dfgj;9n|ae i3wO8zAhjp_6ytx6CBo``BZ{m50000$ zT})GF9LE2B+e3T$MN4VL0;5_aB5cu(4@DEYfgtGgLfLfgV&2S>n9beHEKB?#Sr&J* zxR`*uaTjwsKQ44Cg1AAVC?A_<10hNk1S+;bOTSJ_zji@IgtpM0x3tvX<#|q@^E^E# zJ@5MmhS%$bc!Wjs^OS4c>=?E>bvCEY>eSm^Mu%&{?wXi%TU;K><)K_2yT|MHc->xb z0RRJ7h`~e*CJS*`h-4u$fyw8v64|Uo4ok!%q+CMABV+=0D#=Qs6O0kk9iv?1dRzB6 z_1HjZ4E84`$Dq?q(YbsO2qr0Hr;9l&#iTNcTqWh^gj99@V&=)=VRO6I-0{NluVwN% zy|lF8CoEsae@8CJPZbmh5>kVo9I%+duF;G)^iTX{pq@k^BwfVhN=4%P%A|5JN9p&3 z*~Prz){HlF>Cfq{-HVctE>d1ju5`CDshk1Kna5u%_QZIzefWgg5zXf}^>;6Nrld zpi^5LAFTjj)Yj9ftpxxC02;%MXy?JnR2>xU7?A=2fKt3A+A(l4RR;k;p1eAln;q>u zcu3}E=gF&Ksu+Q|+p_8uB2|<_(MBOsZOf`75EuNtpnozuw9(5JCIMg2)5PbJY9{fv z2%by4ZCm_8xyJOihc7pp8k1uv!W+#rF-IAxjb?Bt*O=L%wK`weoO-KMZ+96SE>l>e z0U?Ja<`GgZA>|Rv1Z+9UlF$hj;vI9ChDUpKhJL-V-)J70uZ1>i zN`z@x++G#?=h3w@jo&z&HY~p3!6vwS%f5d%Yb$*#U$NG%-+#OLEqyyIe6snwqTG*Z znjioe)ODY`br?q^Je<3Acu+@orHTNczU`#PonURyTDvw|#EKb~o|1UupyjHB~&ZS>2{xIou zgl(5Vus_@Nb?L^PII_{=Rk8EeYcF0ug~hb0Qe9Q4#$pvVzHLi$+Z9}`0N}#)y5_bk zxZJ`60f5P3IDO$bUfr2_KH(Ji(^$ZCF0GiE|9pMdB|lMk+6=C?E*mnkoR_RB&;K3yFd^CY$@JDa(H-sNe*vI z@gBUMA%Oru$QSRcI)vAEU)3QYUyRo?Bz!*}s>1END)-|ut*TV33b*5O3y(Ko5j@3+ z{@JgWPqc@%Z7En=@@Z^tTc+t7=xVxs@!o?b8)cc-f=lw(uPrUzv@51Jnlo9_qXF=~ z#O-m{T&OrYOdC}J#Oz(=G7gmK2u%STsK`Q|R2cBR$BzARY_8__;8FnrK<`LzYhUYJt+lVUccgdGBjEu7Kz&zzAUTK> z;~)UItGOFU4kE=kzDF^TytE%htuf%gZ3mHJ90UMnd%yvG5Glrq>zRjuBM2l1kzyPK z0CJH$kQ_vcaS#BkPFWpD4kE=k2mm%HHw2P{NHGoqfQsCTKynZ%#_>IhMVUo&wW7?T zrTr)Zz>yD+%+>rJTq^jAm8~gLt6uvXq*|q3x|=b8H(@joXZ#P0IL~pkKI)eM0000< KMNUMnLSTZjuMtoH diff --git a/collects/teachpack/2htdp/scribblings/img/ff2fcb7b87.png b/collects/teachpack/2htdp/scribblings/img/ff2fcb7b87.png index 9448fa6c247fb39a1a82baef90b7bdfbd1a4b037..69a7750b4595508268f6005a2edc8382d6299b97 100644 GIT binary patch literal 202 zcmeAS@N?(olHy`uVBq!ia0vp^#vshW1SGc}US12NCVIL!hE&XXdt)PSgMtV{py|2f z^s^G@5*{m+nenAQb=lF7#Fw;W$917It!(?=Zty$1Id_im>eCz3-}`bamfW1ZKTR?n z4PLMR{_@L|31wF7Pd4;y2Ex_b*Sz4<_<8&Ds(Z#DJ_uItWcIrENp%kMrif#aKzKF! h+A)d$c{|D(56=_0{9b+LU7+I_JYD@<);T3K0RZydRv-WX literal 207 zcmeAS@N?(olHy`uVBq!ia0vp^CLqkg1SGwrdiDURX`U{QAr*7p-rUIBY#`teD7?{s z)s?tr(To`?p|g0VY6;KeJ$K2zaovygrrY*qtZ7c|xwtASI{W;0F`JK-Zx6ou`1{e` zjrV>t=kIGQoPq|gRK0xpu|@E=wR6F-KoDH|c$2xyGwVwsFU`|sQo+!4zoJpGLz}Tn j6IgS|%N n) - #:description (format "nat > ~s" n) +(define-syntax-class (Nat> n) + #:description (format "Nat > ~s" n) (pattern x:nat #:fail-unless (> (syntax-e #'x) n) #f)) (syntax-parse #'(1 2 3) [(a:nat b0:nat c0:nat) #:with b #'b0 - #:declare b (nat> (syntax-e #'a)) + #:declare b (Nat> (syntax-e #'a)) #:with c #'c0 - #:declare c (nat> (syntax-e #'b0)) + #:declare c (Nat> (syntax-e #'b0)) (void)]) + +(define-syntax-class (nat> bound) + #:opaque + #:description (format "natural number greater than ~s" bound) + (pattern n:nat + #:when (> (syntax-e #'n) bound))) + +(define-conventions nat-convs + [N (nat> 0)]) + +(syntax-parse #'(5 4) #:conventions (nat-convs) + [(N ...) (void)]) + +(let/ec escape + (with-handlers ([exn? (compose escape void)]) + (syntax-parse #'(4 -1) #:conventions (nat-convs) + [(N ...) (void)])) + (error 'test-conv1 "didn't work")) diff --git a/collects/web-server/scribblings/stateless-usage.scrbl b/collects/web-server/scribblings/stateless-usage.scrbl index 85df06777f..5f8f1d9e04 100644 --- a/collects/web-server/scribblings/stateless-usage.scrbl +++ b/collects/web-server/scribblings/stateless-usage.scrbl @@ -51,7 +51,9 @@ because parameterizations are not serializable. Fourth, and related, this process only runs on your code, not on the code you @scheme[require]. Thus, your continuations---to be serializable---must not -be in the context of another module. For example, the following will not work: +be in the context of another module. For example, the following will fail with an @as-index{"unsafe context"} +exception: + @schemeblock[ (define requests (map (lambda (rg) (send/suspend/url rg)) From d00e3432d960ea24ea6b25f34bbedd2002ba4041 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 23 Jan 2010 18:31:10 +0000 Subject: [PATCH 63/78] Replaced #%variable-reference with quote-module-path for unit contract blame. svn: r17781 --- collects/mzlib/unit.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index dec63d26fa..d13d748174 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -16,6 +16,7 @@ (require mzlib/etc scheme/contract/base scheme/stxparam + unstable/location "private/unit-contract.ss" "private/unit-keywords.ss" "private/unit-runtime.ss" @@ -1294,7 +1295,7 @@ (((wrap-code ...) ...) (map (λ (os ov tbs) (define rename-bindings - (get-member-bindings def-table os #'(#%variable-reference))) + (get-member-bindings def-table os #'(quote-module-path))) (map (λ (tb i v c) (if c (with-syntax ([ctc-stx From bd9b6e9e9776433d922b3f87d07edda6db38b3dc Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 23 Jan 2010 18:31:32 +0000 Subject: [PATCH 64/78] Made unit contract test regular expressions more robust. svn: r17782 --- collects/tests/units/test-unit-contracts.ss | 55 +++++++++------------ 1 file changed, 23 insertions(+), 32 deletions(-) diff --git a/collects/tests/units/test-unit-contracts.ss b/collects/tests/units/test-unit-contracts.ss index 5ba743dd0c..e2129d3090 100644 --- a/collects/tests/units/test-unit-contracts.ss +++ b/collects/tests/units/test-unit-contracts.ss @@ -2,24 +2,14 @@ scheme/unit scheme/contract) -(define temp-unit-blame #rx"(unit temp[0-9]*)") +(define temp-unit-blame-re "\\(unit temp[0-9]*\\)") (define top-level "top-level") -(define (get-blame msg) - (cond - [(regexp-match #rx"(^| )(.*) broke" msg) - => - (λ (x) (caddr x))] - [else (error 'test-contract-error - (format "no blame in error message: \"~a\"" msg))])) +(define (match-blame re msg) + (regexp-match? (string-append "(^| )" re " broke") msg)) -(define (get-obj msg) - (cond - [(regexp-match #rx"(^| )on (.*);" msg) - => - (λ (x) (caddr x))] - [else (error 'test-contract-error - (format "no object in error message: \"~a\"" msg))])) +(define (match-obj re msg) + (regexp-match? (string-append "(^| )on " re ";") msg)) (define (get-ctc-err msg) (cond @@ -29,28 +19,29 @@ [else (error 'test-contract-error (format "no specific error in message: \"~a\"" msg))])) -(define-syntax test-contract-error +(define-syntax-rule (test-contract-error blame obj err expr) + (test-contract-error/regexp + (regexp-quote blame) (regexp-quote obj) (regexp-quote err) + expr)) + +(define-syntax test-contract-error/regexp (syntax-rules () ((_ blame obj err expr) (with-handlers ((exn:fail:contract? (lambda (exn) - (let ([exn-blame (get-blame (exn-message exn))] - [exn-obj (get-obj (exn-message exn))]) + (let ([msg (exn-message exn)]) (cond - [(and (string? blame) - (not (equal? blame exn-blame))) - (error 'test-contract-error "expected blame ~a, got ~a" - blame exn-blame)] - [(and (regexp? blame) - (not (regexp-match blame exn-blame))) - (error 'test-contract-error "expected blame ~a, got ~a" - blame exn-blame)] - [(not (equal? obj exn-obj)) - (error 'test-contract-error "expected object ~a, got ~a" - obj exn-obj)] + [(not (match-blame blame msg)) + (error 'test-contract-error + "blame \"~a\" not found in:~n\"~a\"" + blame msg)] + [(not (match-obj obj msg)) + (error 'test-contract-error + "object \"~a\" not found in:~n\"~a\"" + obj msg)] [else (printf "contract error \"~a\" on ~a blaming ~a: ok\n\t\"~a\"\n\n" - err obj exn-blame (get-ctc-err (exn-message exn)))]))))) + err obj blame (get-ctc-err msg))]))))) expr (error 'test-contract-error "expected contract error \"~a\" on ~a, got none" @@ -123,7 +114,7 @@ (invoke-unit (compound-unit (import) (export) (link (((S1 : sig1)) unit1) (() unit2 S1))))) -(test-contract-error temp-unit-blame "a" "not a number" +(test-contract-error/regexp temp-unit-blame-re "a" "not a number" (invoke-unit (compound-unit (import) (export) (link (((S3 : sig3) (S4 : sig4)) (unit (import) (export sig3 sig4) @@ -133,7 +124,7 @@ (define (b t) (if t 3 0)))) (() unit3 S3 S4))))) -(test-contract-error temp-unit-blame "g" "not a boolean" +(test-contract-error/regexp temp-unit-blame-re "g" "not a boolean" (invoke-unit (compound-unit (import) (export) (link (((S3 : sig3) (S4 : sig4)) (unit (import) (export sig3 sig4) From ae54797717dc47e62ad1a567b197562ed8788510 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 23 Jan 2010 21:06:29 +0000 Subject: [PATCH 65/78] Fixed use of (contract ...) in web-server collects where I got arguments in wrong order. svn: r17786 --- collects/web-server/insta/insta.ss | 4 ++-- collects/web-server/servlet/setup.ss | 18 +++++++++--------- 2 files changed, 11 insertions(+), 11 deletions(-) diff --git a/collects/web-server/insta/insta.ss b/collects/web-server/insta/insta.ss index 57a0cdb90e..4cb3622ba6 100644 --- a/collects/web-server/insta/insta.ss +++ b/collects/web-server/insta/insta.ss @@ -61,7 +61,7 @@ (provide/contract (#,start (request? . -> . response/c))) (serve/servlet (contract (request? . -> . response/c) #,start 'you 'web-server - (make-srcloc #f #f #f #f #f) - "start") + "start" + #f) #:extra-files-paths (if extra-files-path (list extra-files-path) empty) #:launch-browser? launch-browser?))))])) diff --git a/collects/web-server/servlet/setup.ss b/collects/web-server/servlet/setup.ss index f50d740005..cf3b097915 100644 --- a/collects/web-server/servlet/setup.ss +++ b/collects/web-server/servlet/setup.ss @@ -136,47 +136,47 @@ (contract (symbols 'v1 'v2 'stateless) (dynamic-require module-name 'interface-version) pos-blame neg-blame - loc "interface-version")]) + "interface-version" loc)]) (case version [(v1) (let ([timeout (contract number? (dynamic-require module-name 'timeout) pos-blame neg-blame - loc "timeout")] + "timeout" loc)] [start (contract (request? . -> . response/c) (dynamic-require module-name 'start) pos-blame neg-blame - loc "start")]) + "start" loc)]) (make-v1.servlet (directory-part a-path) timeout start))] [(v2) (let ([start (contract (request? . -> . response/c) (dynamic-require module-name 'start) pos-blame neg-blame - loc "start")] + "start" loc)] [manager (contract manager? (dynamic-require module-name 'manager) pos-blame neg-blame - loc "manager")]) + "manager" loc)]) (make-v2.servlet (directory-part a-path) manager start))] [(stateless) (let ([start (contract (request? . -> . response/c) (dynamic-require module-name 'start) pos-blame neg-blame - loc "start")] + "start" loc)] [manager (contract manager? (dynamic-require module-name 'manager (lambda () (create-none-manager (lambda (req) (error "No continuations!"))))) pos-blame neg-blame - loc "manager")] + "manager" loc)] [stuffer (contract (stuffer/c serializable? bytes?) (dynamic-require module-name 'stuffer (lambda () default-stuffer)) pos-blame neg-blame - loc "stuffer")]) + "stuffer" loc)]) (make-stateless.servlet (directory-part a-path) stuffer manager start))]))] [else (make-v1.servlet (directory-part a-path) timeouts-default-servlet (v0.response->v1.lambda (contract response/c s pos-blame neg-blame - loc path-string) + path-string loc) a-path))]))))) From a197b987068ec36f701816b7aab726f1e71de7c9 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 23 Jan 2010 21:33:06 +0000 Subject: [PATCH 66/78] Fixed permissive/c, which I had ported to the wrong kind of contract. svn: r17787 --- collects/xml/private/structures.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/xml/private/structures.ss b/collects/xml/private/structures.ss index 24aa3b6513..7d24f2b383 100644 --- a/collects/xml/private/structures.ss +++ b/collects/xml/private/structures.ss @@ -58,7 +58,7 @@ (define permissive-xexprs (make-parameter #f)) (define permissive/c - (simple-flat-contract + (simple-contract #:name 'permissive/c #:projection (lambda (blame) From 2772ffccbae3a2fe070f512e0154c2fd5bb0c0e6 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 30 Jan 2010 21:14:27 +0000 Subject: [PATCH 67/78] Restored legacy functions for custom contracts. svn: r17900 --- collects/scheme/contract/base.ss | 5 + collects/scheme/contract/private/base.ss | 55 +++------ collects/scheme/contract/private/helpers.ss | 20 +--- collects/scheme/contract/private/legacy.ss | 126 ++++++++++++++++++++ collects/tests/mzscheme/contract-test.ss | 59 ++++++++- 5 files changed, 204 insertions(+), 61 deletions(-) create mode 100644 collects/scheme/contract/private/legacy.ss diff --git a/collects/scheme/contract/base.ss b/collects/scheme/contract/base.ss index 2608c0bc73..b6e83b931c 100644 --- a/collects/scheme/contract/base.ss +++ b/collects/scheme/contract/base.ss @@ -8,6 +8,7 @@ "private/misc.ss" "private/provide.ss" "private/guts.ss" + "private/legacy.ss" "private/ds.ss" "private/opt.ss") @@ -26,6 +27,10 @@ check-unary-between/c) (all-from-out "private/provide.ss") (all-from-out "private/base.ss") + (except-out (all-from-out "private/legacy.ss") + unpack-blame + unpack-source + unpack-name) (except-out (all-from-out "private/guts.ss") check-flat-contract check-flat-named-contract)) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index b1bf9dcdb8..bfba306647 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -18,7 +18,7 @@ improve method arity mismatch contract violation error messages? unstable/srcloc unstable/location "guts.ss" - "helpers.ss") + "legacy.ss") (define-syntax-parameter current-contract-region (λ (stx) #'(quote-module-path))) @@ -30,19 +30,20 @@ improve method arity mismatch contract violation error messages? (apply-contract c v pos neg name loc))] [(_ c v pos neg) (syntax/loc stx - (apply-contract c v pos neg #f (build-source-location #f)))] - [(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e) - #| + (apply-contract c + v + (unpack-blame pos) + (unpack-blame neg) + #f + (build-source-location #f)))] + [(_ c v pos neg src) (syntax/loc stx - (let* ([info src-info-e]) - (contract a-contract-e - to-check - pos-blame-e - neg-blame-e - (unpack-source info) - (unpack-name info)))) - |# - (raise-syntax-error 'contract "upgrade to new calling convention" stx)])) + (apply-contract c + v + (unpack-blame pos) + (unpack-blame neg) + (unpack-name src) + (unpack-source src)))])) (define (apply-contract c v pos neg name loc) (let* ([c (coerce-contract 'contract c)] @@ -92,34 +93,6 @@ improve method arity mismatch contract violation error messages? "all arguments: ~e") v-name v x args)]))))) -(define (unpack-source info) - (cond - [(syntax? info) (build-source-location info)] - [(list? info) - (let ([loc (list-ref info 0)]) - (if (syntax? (srcloc-source loc)) - (struct-copy - srcloc loc - [source - (resolved-module-path-name - (module-path-index-resolve - (syntax-source-module - (srcloc-source loc))))]) - loc))] - [else - (error 'contract - "expected a syntax object or list of two elements, got: ~e" - info)])) - -(define (unpack-name info) - (cond - [(syntax? info) (and (identifier? info) (syntax-e info))] - [(list? info) (list-ref info 1)] - [else - (error 'contract - "expected a syntax object or list of two elements, got: ~e" - info)])) - (define-syntax (recursive-contract stx) (syntax-case stx () [(_ arg) diff --git a/collects/scheme/contract/private/helpers.ss b/collects/scheme/contract/private/helpers.ss index a4c23e30dc..a1efe65e3b 100644 --- a/collects/scheme/contract/private/helpers.ss +++ b/collects/scheme/contract/private/helpers.ss @@ -1,7 +1,6 @@ #lang scheme/base -(provide unpack-blame - mangle-id mangle-id-for-maker +(provide mangle-id mangle-id-for-maker build-struct-names lookup-struct-info nums-up-to @@ -128,23 +127,6 @@ (string-append source ":" location) (or location source))))) -;; unpack-blame : any/c -> any/c -;; Constructs an S-expression for use in the blame error messages. -;; A variable reference represents a module or top-level context. -;; Other representations of blame are returned as-is. -(define (unpack-blame blame) - (if (variable-reference? blame) - (let ([rp (variable-reference->resolved-module-path blame)]) - (cond - [(not rp) - 'top-level] - [else - (let ([resolved (resolved-module-path-name rp)]) - (cond - [(symbol? resolved) `(quote ,resolved)] - [else `(file ,(path->string resolved))]))])) - blame)) - (define build-struct-names (lambda (name-stx fields omit-sel? omit-set? srcloc-stx) (let ([name (symbol->string (syntax-e name-stx))] diff --git a/collects/scheme/contract/private/legacy.ss b/collects/scheme/contract/private/legacy.ss new file mode 100644 index 0000000000..95a00f11cf --- /dev/null +++ b/collects/scheme/contract/private/legacy.ss @@ -0,0 +1,126 @@ +#lang scheme/base + +(require "guts.ss" "blame.ss" unstable/srcloc) + +(provide make-proj-contract + raise-contract-error + contract-proc + + proj-prop proj-get proj-pred? + name-prop name-get name-pred? + stronger-prop stronger-get stronger-pred? + first-order-prop first-order-get first-order-pred? + flat-prop flat-get flat-pred? + + unpack-blame unpack-source unpack-name + + ) + +(define (raise-contract-error x src pos name fmt . args) + (apply raise-blame-error + (make-blame (unpack-source src) + (unpack-name src) + name + (unpack-blame pos) + "<>" + #f) + x + fmt + args)) + +(define (make-proj-contract name proj test) + (simple-contract + #:name name + #:first-order test + #:projection + (lambda (blame) + (proj (blame-guilty blame) + (blame-innocent blame) + (list (blame-source blame) (blame-value blame)) + (blame-contract blame) + (not (blame-swapped? blame)))))) + +(define (contract-proc c) + (let* ([proj (contract-projection c)]) + (lambda (pos neg src name original?) + (proj (make-blame (unpack-source src) + (unpack-name src) + name + (unpack-blame (if original? pos neg)) + (unpack-blame (if original? neg pos)) + (not original?)))))) + +(define (legacy-property name) + (define-values [ prop pred get ] + (make-struct-type-property + name + (lambda (impl info) + (error + name + (string-append + "this property is a legacy implementation; " + "use prop:contract or prop:flat-contract instead."))))) + prop) + +(define proj-prop (legacy-property 'proj-prop)) +(define name-prop (legacy-property 'name-prop)) +(define stronger-prop (legacy-property 'stronger-prop)) +(define first-order-prop (legacy-property 'first-order-prop)) +(define flat-prop (legacy-property 'flat-prop)) + +(define proj-pred? contract-struct?) +(define name-pred? contract-struct?) +(define stronger-pred? contract-struct?) +(define first-order-pred? contract-struct?) +(define flat-pred? contract-struct?) + +(define (proj-get c) contract-proc) +(define (name-get c) contract-name) +(define (stronger-get c) contract-stronger?) +(define (first-order-get c) contract-first-order) +(define (flat-get c) flat-contract-predicate) + +;; unpack-blame : any/c -> any/c +;; Constructs an S-expression for use in the blame error messages. +;; A variable reference represents a module or top-level context. +;; Other representations of blame are returned as-is. +(define (unpack-blame blame) + (if (variable-reference? blame) + (let ([rp (variable-reference->resolved-module-path blame)]) + (cond + [(not rp) + 'top-level] + [else + (let ([resolved (resolved-module-path-name rp)]) + (cond + [(symbol? resolved) `(quote ,resolved)] + [else `(file ,(path->string resolved))]))])) + blame)) + +(define (unpack-source info) + (cond + [(syntax? info) (build-source-location info)] + [(list? info) + (let ([loc (list-ref info 0)]) + (if (syntax? (srcloc-source loc)) + (struct-copy + srcloc loc + [source + (resolved-module-path-name + (module-path-index-resolve + (syntax-source-module + (srcloc-source loc))))]) + loc))] + [else + (error 'contract + "expected a syntax object or list of two elements, got: ~e" + info)])) + +(define (unpack-name info) + (cond + [(syntax? info) (and (identifier? info) (syntax-e info))] + [(list? info) (list-ref info 1)] + [else + (error 'contract + "expected a syntax object or list of two elements, got: ~e" + info)])) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 41023d5ed0..ed53e149bd 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -7160,7 +7160,64 @@ so that propagation occurs. 'pos (compose blame-guilty exn:fail:contract:blame-object) (with-handlers ((void values)) (contract not #t 'pos 'neg)))) - + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;; + ;;;; + ;;;; Legacy Contract Constructor tests + ;;;; + ;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; make-proj-contract + ;; + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + (contract-eval + '(define proj:add1->sub1 + (make-proj-contract + 'proj:add1->sub1 + (lambda (pos neg src name blame) + (lambda (f) + (unless (and (procedure? f) (procedure-arity-includes? f 1)) + (raise-contract-error f src pos name + "expected a unary function, got: ~e" + f)) + (lambda (x) + (unless (and (integer? x) (exact? x)) + (raise-contract-error x src neg name + "expected an integer, got: ~e" + x)) + (let* ([y (f (add1 x))]) + (unless (and (integer? y) (exact? y)) + (raise-contract-error y src pos name + "expected an integer, got: ~e" + y)) + (sub1 y))))) + (lambda (f) + (and (procedure? f) (procedure-arity-includes? f 1)))))) + + (test/spec-passed/result + 'make-proj-contract-1 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 15) + 3) + + (test/pos-blame + 'make-proj-contract-2 + '(contract proj:add1->sub1 'dummy 'pos 'neg)) + + (test/pos-blame + 'make-proj-contract-3 + '((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2)) + + (test/neg-blame + 'make-proj-contract-4 + '((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy)) + (report-errs) )) From 7d577d9d02fdd3c5239fec5970591de9a18783f9 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sat, 30 Jan 2010 21:45:52 +0000 Subject: [PATCH 68/78] Removed an unnecessary require. svn: r17901 --- collects/scheme/contract/private/blame.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index 73df3ad37a..22f63a0de1 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -1,6 +1,6 @@ #lang scheme/base -(require unstable/srcloc scheme/pretty setup/main-collects) +(require unstable/srcloc scheme/pretty) (provide blame? make-blame From 29b628cb0ac7e9959903e76d5758a4c134b1a237 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 31 Jan 2010 00:29:37 +0000 Subject: [PATCH 69/78] Fixed legacy projections to allow 4 or 5 arguments. svn: r17903 --- collects/scheme/contract/private/legacy.ss | 26 ++++++++++++++++------ 1 file changed, 19 insertions(+), 7 deletions(-) diff --git a/collects/scheme/contract/private/legacy.ss b/collects/scheme/contract/private/legacy.ss index 95a00f11cf..bf873d5b1e 100644 --- a/collects/scheme/contract/private/legacy.ss +++ b/collects/scheme/contract/private/legacy.ss @@ -33,16 +33,28 @@ #:name name #:first-order test #:projection - (lambda (blame) - (proj (blame-guilty blame) - (blame-innocent blame) - (list (blame-source blame) (blame-value blame)) - (blame-contract blame) - (not (blame-swapped? blame)))))) + (cond + [(procedure-arity-includes? proj 5) + (lambda (blame) + (proj (blame-guilty blame) + (blame-innocent blame) + (list (blame-source blame) (blame-value blame)) + (blame-contract blame) + (not (blame-swapped? blame))))] + [(procedure-arity-includes? proj 4) + (lambda (blame) + (proj (blame-guilty blame) + (blame-innocent blame) + (list (blame-source blame) (blame-value blame)) + (blame-contract blame)))] + [else + (error 'make-proj-contract + "expected a projection that accepts 4 or 5 arguments; got: ~e" + proj)]))) (define (contract-proc c) (let* ([proj (contract-projection c)]) - (lambda (pos neg src name original?) + (lambda (pos neg src name [original? #t]) (proj (make-blame (unpack-source src) (unpack-name src) name From 0e697067cb8c33102d2dc2fef0d6f6fe59f7935b Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 31 Jan 2010 00:30:00 +0000 Subject: [PATCH 70/78] Uniformly "unpack" contract blame party names. svn: r17904 --- collects/scheme/contract/private/base.ss | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index bfba306647..b311f2ae10 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -27,7 +27,12 @@ improve method arity mismatch contract violation error messages? (syntax-case stx () [(_ c v pos neg name loc) (syntax/loc stx - (apply-contract c v pos neg name loc))] + (apply-contract c + v + (unpack-blame pos) + (unpack-blame neg) + name + loc))] [(_ c v pos neg) (syntax/loc stx (apply-contract c From f8df3608d40f72ff73e6dd4f85ca81cd4454192c Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 31 Jan 2010 01:47:07 +0000 Subject: [PATCH 71/78] Hide "make-blame" from normal export. svn: r17906 --- collects/scheme/contract/private/guts.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/scheme/contract/private/guts.ss b/collects/scheme/contract/private/guts.ss index 431f0f1601..1d3d2225ad 100644 --- a/collects/scheme/contract/private/guts.ss +++ b/collects/scheme/contract/private/guts.ss @@ -8,7 +8,8 @@ (require (for-syntax scheme/base "helpers.ss")) -(provide (all-from-out "blame.ss" "prop.ss") +(provide (except-out (all-from-out "blame.ss") make-blame) + (all-from-out "prop.ss") coerce-contract coerce-contracts From bf308563d2aee6524013f837ccf27f94d3c1a35c Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 31 Jan 2010 01:47:48 +0000 Subject: [PATCH 72/78] Hide make-blame; remove blame-positive and blame-negative; make blame objects transparent (but allow equal?). svn: r17907 --- collects/scheme/contract/private/blame.ss | 21 ++++++++++++++++++--- 1 file changed, 18 insertions(+), 3 deletions(-) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index 22f63a0de1..3a3dd187fd 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -9,8 +9,6 @@ blame-innocent blame-contract blame-value - blame-positive - blame-negative blame-swapped? blame-swap @@ -18,9 +16,26 @@ current-blame-format (struct-out exn:fail:contract:blame)) +(define (blame=? a b equal?/recur) + (and (equal?/recur (blame-guilty a) (blame-guilty b)) + (equal?/recur (blame-innocent a) (blame-innocent b)) + (equal?/recur (blame-contract a) (blame-contract b)) + (equal?/recur (blame-value a) (blame-value b)) + (equal?/recur (blame-source a) (blame-source b)) + (equal?/recur (blame-swapped? a) (blame-swapped? b)))) + +(define (blame-hash b hash/recur) + (bitwise-xor (hash/recur (blame-guilty b)) + (hash/recur (blame-innocent b)) + (hash/recur (blame-contract b)) + (hash/recur (blame-value b)) + (hash/recur (blame-source b)) + (hash/recur (blame-swapped? b)))) + (define-struct blame [source value contract positive negative swapped?] - #:transparent) + #:property prop:equal+hash + (list blame=? blame-hash blame-hash)) (define (blame-guilty b) (if (blame-swapped? b) From d5329eb2a6c101b6bcaa9f46213e0e0514e9506f Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 31 Jan 2010 01:48:08 +0000 Subject: [PATCH 73/78] Make contract form more permissive; import make-blame. svn: r17908 --- collects/scheme/contract/private/base.ss | 46 ++---------------------- 1 file changed, 3 insertions(+), 43 deletions(-) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index b311f2ae10..c29f3192b1 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -18,6 +18,7 @@ improve method arity mismatch contract violation error messages? unstable/srcloc unstable/location "guts.ss" + "blame.ss" "legacy.ss") (define-syntax-parameter current-contract-region @@ -51,53 +52,12 @@ improve method arity mismatch contract violation error messages? (unpack-source src)))])) (define (apply-contract c v pos neg name loc) - (let* ([c (coerce-contract 'contract c)] - [args (list c v pos neg name loc)]) - (check-sexp! 'contract "positive blame" pos args) - (check-sexp! 'contract "negative blame" neg args) - (check-sexp! 'contract "value name" name args) - (check-srcloc! 'contract "source location" loc args) + (let* ([c (coerce-contract 'contract c)]) + (check-source-location! 'contract loc) (((contract-projection c) (make-blame loc name (contract-name c) pos neg #f)) v))) -(define (check-srcloc! f-name v-name v args) - (unless (source-location? v) - (error f-name - "expected ~a to be a source location, got: ~e; all arguments: ~e" - v-name v args)) - (check-sexp! f-name - (format "source file of ~a" v-name) - (source-location-source v) - args)) - -(define (check-sexp! f-name v-name v args) - (let loop ([seen #hasheq()] [x v]) - (unless (or (null? x) (boolean? x) (number? x) - (string? x) (bytes? x) (regexp? x) (char? x) - (symbol? x) (keyword? x) - (path? x)) - (when (hash-has-key? seen x) - (error f-name - (string-append "expected ~a to be acyclic, " - "found a cycle in ~e at ~e; " - "all arguments: ~e") - v-name v x args)) - (let ([seen (hash-set seen x #t)]) - (cond - [(pair? x) (loop seen (car x)) (loop seen (cdr x))] - [(mpair? x) (loop seen (mcar x)) (loop seen (mcdr x))] - [(vector? x) (for ([y (in-vector x)]) (loop seen y))] - [(box? x) (loop seen (unbox x))] - [(hash? x) (for ([(y z) (in-hash x)]) (loop seen y) (loop seen z))] - [(prefab-struct-key x) => - (lambda (k) (loop seen k) (loop seen (struct->vector x)))] - [else (error f-name - (string-append "expected ~a to be an s-expression, " - "~e contained ~e; " - "all arguments: ~e") - v-name v x args)]))))) - (define-syntax (recursive-contract stx) (syntax-case stx () [(_ arg) From 1d4cdbeb4594639af9834577ec48a1fbd88aadf4 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 31 Jan 2010 03:03:30 +0000 Subject: [PATCH 74/78] Exports from scheme/contract/private/blame: removed constructor; fixed confusing selector names. svn: r17909 --- collects/drscheme/private/debug.ss | 2 +- collects/mzlib/private/unit-contract.ss | 6 +-- collects/scheme/contract/private/base.ss | 2 +- collects/scheme/contract/private/blame.ss | 42 +++++++++---------- collects/scheme/contract/private/legacy.ss | 12 +++--- collects/scheme/contract/private/object.ss | 4 +- .../tests/mzscheme/contract-mzlib-test.ss | 2 +- collects/tests/mzscheme/contract-test.ss | 2 +- 8 files changed, 35 insertions(+), 37 deletions(-) diff --git a/collects/drscheme/private/debug.ss b/collects/drscheme/private/debug.ss index 18a44362d0..9bc312d2cf 100644 --- a/collects/drscheme/private/debug.ss +++ b/collects/drscheme/private/debug.ss @@ -337,7 +337,7 @@ profile todo: (define (print-planet-icon-to-stderr exn) (when (exn:fail:contract:blame? exn) (let ([table (parse-gp exn - (blame-guilty + (blame-positive (exn:fail:contract:blame-object exn)))]) (when table (let ([gp-url (bug-info->ticket-url table)]) diff --git a/collects/mzlib/private/unit-contract.ss b/collects/mzlib/private/unit-contract.ss index 966e059a18..d21c0c2e79 100644 --- a/collects/mzlib/private/unit-contract.ss +++ b/collects/mzlib/private/unit-contract.ss @@ -39,9 +39,9 @@ var)]) #`(let ([old-v/c (#,vref)]) (contract sig-ctc-stx (car old-v/c) - (cdr old-v/c) (blame-guilty #,blame-id) + (cdr old-v/c) (blame-positive #,blame-id) (quote #,var) (quote-syntax #,var))))) - (blame-innocent #,blame-id)) + (blame-negative #,blame-id)) (wrap-with-proj ctc #`(#,vref)))) vref))) (for ([tagged-info (in-list import-tagged-infos)] @@ -53,7 +53,7 @@ #`(vector-ref #,v #,index))))) (with-syntax ((((eloc ...) ...) (for/list ([target-sig import-sigs]) - (let ([rename-bindings (get-member-bindings def-table target-sig #`(blame-guilty #,blame-id))]) + (let ([rename-bindings (get-member-bindings def-table target-sig #`(blame-positive #,blame-id))]) (for/list ([target-int/ext-name (in-list (car target-sig))] [sig-ctc (in-list (cadddr target-sig))]) (let* ([var (car target-int/ext-name)] diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index c29f3192b1..570b20b421 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -55,7 +55,7 @@ improve method arity mismatch contract violation error messages? (let* ([c (coerce-contract 'contract c)]) (check-source-location! 'contract loc) (((contract-projection c) - (make-blame loc name (contract-name c) pos neg #f)) + (make-blame loc name (contract-name c) pos neg #t)) v))) (define-syntax (recursive-contract stx) diff --git a/collects/scheme/contract/private/blame.ss b/collects/scheme/contract/private/blame.ss index 3a3dd187fd..9c917adb34 100644 --- a/collects/scheme/contract/private/blame.ss +++ b/collects/scheme/contract/private/blame.ss @@ -5,10 +5,11 @@ (provide blame? make-blame blame-source - blame-guilty - blame-innocent + blame-positive + blame-negative blame-contract blame-value + blame-original? blame-swapped? blame-swap @@ -17,38 +18,35 @@ (struct-out exn:fail:contract:blame)) (define (blame=? a b equal?/recur) - (and (equal?/recur (blame-guilty a) (blame-guilty b)) - (equal?/recur (blame-innocent a) (blame-innocent b)) + (and (equal?/recur (blame-positive a) (blame-positive b)) + (equal?/recur (blame-negative a) (blame-negative b)) (equal?/recur (blame-contract a) (blame-contract b)) (equal?/recur (blame-value a) (blame-value b)) (equal?/recur (blame-source a) (blame-source b)) - (equal?/recur (blame-swapped? a) (blame-swapped? b)))) + (equal?/recur (blame-original? a) (blame-original? b)))) (define (blame-hash b hash/recur) - (bitwise-xor (hash/recur (blame-guilty b)) - (hash/recur (blame-innocent b)) + (bitwise-xor (hash/recur (blame-positive b)) + (hash/recur (blame-negative b)) (hash/recur (blame-contract b)) (hash/recur (blame-value b)) (hash/recur (blame-source b)) - (hash/recur (blame-swapped? b)))) + (hash/recur (blame-original? b)))) (define-struct blame - [source value contract positive negative swapped?] + [source value contract positive negative original?] #:property prop:equal+hash (list blame=? blame-hash blame-hash)) -(define (blame-guilty b) - (if (blame-swapped? b) - (blame-negative b) - (blame-positive b))) - -(define (blame-innocent b) - (if (blame-swapped? b) - (blame-positive b) - (blame-negative b))) - (define (blame-swap b) - (struct-copy blame b [swapped? (not (blame-swapped? b))])) + (struct-copy + blame b + [original? (not (blame-original? b))] + [positive (blame-negative b)] + [negative (blame-positive b)])) + +(define (blame-swapped? b) + (not (blame-original? b))) (define-struct (exn:fail:contract:blame exn:fail:contract) [object] #:transparent) @@ -62,14 +60,14 @@ (define (default-blame-format b x custom-message) (let* ([source-message (source-location->prefix (blame-source b))] - [guilty-message (show/display (blame-guilty b))] + [positive-message (show/display (blame-positive b))] [contract-message (show/write (blame-contract b))] [value-message (if (blame-value b) (format " on ~a" (show/display (blame-value b))) "")]) (format "~a~a broke the contract ~a~a; ~a" source-message - guilty-message + positive-message contract-message value-message custom-message))) diff --git a/collects/scheme/contract/private/legacy.ss b/collects/scheme/contract/private/legacy.ss index bf873d5b1e..3dcc229283 100644 --- a/collects/scheme/contract/private/legacy.ss +++ b/collects/scheme/contract/private/legacy.ss @@ -23,7 +23,7 @@ name (unpack-blame pos) "<>" - #f) + #t) x fmt args)) @@ -36,15 +36,15 @@ (cond [(procedure-arity-includes? proj 5) (lambda (blame) - (proj (blame-guilty blame) - (blame-innocent blame) + (proj (blame-positive blame) + (blame-negative blame) (list (blame-source blame) (blame-value blame)) (blame-contract blame) (not (blame-swapped? blame))))] [(procedure-arity-includes? proj 4) (lambda (blame) - (proj (blame-guilty blame) - (blame-innocent blame) + (proj (blame-positive blame) + (blame-negative blame) (list (blame-source blame) (blame-value blame)) (blame-contract blame)))] [else @@ -60,7 +60,7 @@ name (unpack-blame (if original? pos neg)) (unpack-blame (if original? neg pos)) - (not original?)))))) + original?))))) (define (legacy-property name) (define-values [ prop pred get ] diff --git a/collects/scheme/contract/private/object.ss b/collects/scheme/contract/private/object.ss index 5bf3e0b149..005a726288 100644 --- a/collects/scheme/contract/private/object.ss +++ b/collects/scheme/contract/private/object.ss @@ -18,9 +18,9 @@ (let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))] [cf (-> integer? integer?)] [m-proj ((contract-projection cm) - (make-blame #'here #f "whatever" 'pos 'neg #f))] + (make-blame #'here #f "whatever" 'pos 'neg #t))] [f-proj ((contract-projection cf) - (make-blame #'here #f "whatever" 'pos 'neg #f))] + (make-blame #'here #f "whatever" 'pos 'neg #t))] [cls (make-wrapper-class 'wrapper-class '(m) (list diff --git a/collects/tests/mzscheme/contract-mzlib-test.ss b/collects/tests/mzscheme/contract-mzlib-test.ss index fa7a9139af..f42cfe3396 100644 --- a/collects/tests/mzscheme/contract-mzlib-test.ss +++ b/collects/tests/mzscheme/contract-mzlib-test.ss @@ -5126,7 +5126,7 @@ so that propagation occurs. (contract-eval `(,test 'pos - (compose blame-guilty exn:fail:contract:blame-object) + (compose blame-positive exn:fail:contract:blame-object) (with-handlers ((void values)) (contract not #t 'pos 'neg)))) (report-errs) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index ed53e149bd..485b377237 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -7158,7 +7158,7 @@ so that propagation occurs. (contract-eval `(,test 'pos - (compose blame-guilty exn:fail:contract:blame-object) + (compose blame-positive exn:fail:contract:blame-object) (with-handlers ((void values)) (contract not #t 'pos 'neg)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From a2226c965adc5e129814243906a7a43c6c2446fd Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 31 Jan 2010 04:30:55 +0000 Subject: [PATCH 75/78] Updated documentation for "contract" form. svn: r17910 --- .../scribblings/reference/contracts.scrbl | 40 ++++++------------- 1 file changed, 13 insertions(+), 27 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 6e9a8aa3fd..d97b87d753 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -817,7 +817,7 @@ The @scheme[define-struct/contract] form only allows a subset of the positive-blame-expr negative-blame-expr) (contract contract-expr to-protect-expr positive-blame-expr negative-blame-expr - contract-source-info)]]{ + value-name-expr source-location-expr)]]{ The primitive mechanism for attaching a contract to a value. The purpose of @scheme[contract] is as a target for the expansion of some @@ -830,35 +830,21 @@ is the result of the @scheme[to-protect-expr] expression, but with the contract specified by @scheme[contract-expr] enforced on @scheme[to-protect-expr]. -The values of @scheme[positive-blame-expr] and -@scheme[negative-blame-expr] must be symbols indicating how to assign -blame for positive and negative positions of the contract specified by -@scheme[contract-expr]. +The values of @scheme[positive-blame-expr] and @scheme[negative-blame-expr] +indicate how to assign blame for positive and negative positions of the contract +specified by @scheme[contract-expr]. They may be any value, and are formatted +as by @scheme[display] for purposes of contract violation error messages. -If specified, @scheme[contract-source-info], indicates where the -contract was assumed. Its value must be a either: -@itemize[ -@item{a list of two elements: @scheme[srcloc] struct and -either a string or @scheme[#f]. The srcloc struct indicates -where the contract was assumed. Its @tt{source} field -should be a syntax object, and @scheme[module-path-index-resolve] -is called on it to extract the path of syntax object. +If specified, @scheme[value-name-expr] indicates a name for the protected value +to be used in error messages. If not supplied, or if @scheme[value-name-expr] +produces @scheme[#f], no name is printed. Otherwise, it is also formatted as by +@scheme[display]. -If the second element of -the list is not @scheme[#f], it is used as the name of the -identifier whose contract was assumed.} +If specified, @scheme[source-location-expr] indicates the source location +reported by contract violations. The expession must produce a @scheme[srcloc] +structure, @tech{syntax object}, @scheme[#f], or a list or vector in the format +accepted by the third argument to @scheme[datum->syntax]. -@item{a syntax object specifying the -source location of the location where the contract was assumed. If the -syntax object wraps a symbol, the symbol is used as the name of the -primitive whose contract was assumed.} -] - -If absent, it defaults to the source location of the -@scheme[contract] expression with no identifying name. - -The second form above is not recommended, because mzscheme strips -source location information from compiled files. } @; ------------------------------------------------------------------------ From 2e64069d1459a5ed885da8640028551464e748b4 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Wed, 3 Feb 2010 17:08:26 +0000 Subject: [PATCH 76/78] Re-disabled legacy (contract ...) form. svn: r17960 --- collects/scheme/contract/base.ss | 5 +--- collects/scheme/contract/private/base.ss | 28 ++++++---------------- collects/scheme/contract/private/legacy.ss | 2 -- 3 files changed, 8 insertions(+), 27 deletions(-) diff --git a/collects/scheme/contract/base.ss b/collects/scheme/contract/base.ss index b6e83b931c..cc331a8588 100644 --- a/collects/scheme/contract/base.ss +++ b/collects/scheme/contract/base.ss @@ -27,10 +27,7 @@ check-unary-between/c) (all-from-out "private/provide.ss") (all-from-out "private/base.ss") - (except-out (all-from-out "private/legacy.ss") - unpack-blame - unpack-source - unpack-name) + (all-from-out "private/legacy.ss") (except-out (all-from-out "private/guts.ss") check-flat-contract check-flat-named-contract)) diff --git a/collects/scheme/contract/private/base.ss b/collects/scheme/contract/private/base.ss index 570b20b421..508ea1b38e 100644 --- a/collects/scheme/contract/private/base.ss +++ b/collects/scheme/contract/private/base.ss @@ -18,8 +18,7 @@ improve method arity mismatch contract violation error messages? unstable/srcloc unstable/location "guts.ss" - "blame.ss" - "legacy.ss") + "blame.ss") (define-syntax-parameter current-contract-region (λ (stx) #'(quote-module-path))) @@ -28,28 +27,15 @@ improve method arity mismatch contract violation error messages? (syntax-case stx () [(_ c v pos neg name loc) (syntax/loc stx - (apply-contract c - v - (unpack-blame pos) - (unpack-blame neg) - name - loc))] + (apply-contract c v pos neg name loc))] [(_ c v pos neg) (syntax/loc stx - (apply-contract c - v - (unpack-blame pos) - (unpack-blame neg) - #f - (build-source-location #f)))] + (apply-contract c v pos neg #f (build-source-location #f)))] [(_ c v pos neg src) - (syntax/loc stx - (apply-contract c - v - (unpack-blame pos) - (unpack-blame neg) - (unpack-name src) - (unpack-source src)))])) + (raise-syntax-error 'contract + (string-append + "please update contract application to new protocol " + "(either 4 or 6 arguments)"))])) (define (apply-contract c v pos neg name loc) (let* ([c (coerce-contract 'contract c)]) diff --git a/collects/scheme/contract/private/legacy.ss b/collects/scheme/contract/private/legacy.ss index 3dcc229283..8ebaf215eb 100644 --- a/collects/scheme/contract/private/legacy.ss +++ b/collects/scheme/contract/private/legacy.ss @@ -12,8 +12,6 @@ first-order-prop first-order-get first-order-pred? flat-prop flat-get flat-pred? - unpack-blame unpack-source unpack-name - ) (define (raise-contract-error x src pos name fmt . args) From a4a25ba1e9003c2f82939b5fb6f6078c83164aea Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Wed, 3 Feb 2010 21:02:02 +0000 Subject: [PATCH 77/78] Wrote documentation for new contract interface. Still needs proofreading, etc. svn: r17961 --- .../scribblings/reference/contracts.scrbl | 459 +++++++++++------- 1 file changed, 274 insertions(+), 185 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index d97b87d753..cd63b5b182 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -889,34 +889,30 @@ Although these projections have the right error behavior, they are not quite ready for use as contracts, because they do not accomodate blame, and do not provide good error messages. In order to accomodate these, contracts do not -just use simple projections, but use functions that accept +just use simple projections, but use functions that accept a +@deftech{blame object} encapsulating the names of two parties that are the candidates for blame, as well as a record of the source location where the contract was established and the name of the contract. They can then, in turn, pass that information -to @scheme[raise-contract-error] to signal a good error +to @scheme[raise-blame-error] to signal a good error message. Here is the first of those two projections, rewritten for use in the contract system: - @schemeblock[ -(define (int-proj pos neg src-info name positive-position?) +(define (int-proj blame) (lambda (x) (if (integer? x) x - (raise-contract-error + (raise-blame-error + blame val - src-info - pos - name "expected , given: ~e" val)))) ] - -The first two new arguments specify who is to be blamed for -positive and negative contract violations, -respectively. +The new argument specifies who is to be blamed for +positive and negative contract violations. Contracts, in this system, are always established between two parties. One party provides some @@ -925,28 +921,24 @@ value, also according to the contract. The first is called the ``positive'' person and the second the ``negative''. So, in the case of just the integer contract, the only thing that can go wrong is that the value provided is not an -integer. Thus, only the positive argument can ever accrue -blame (and thus only @scheme[pos] is passed -to @scheme[raise-contract-error]). +integer. Thus, only the positive party can ever accrue +blame. The @scheme[raise-blame-error] function always blames +the positive party. Compare that to the projection for our function contract: @schemeblock[ -(define (int->int-proj pos neg src-info name positive-position?) - (let ([dom (int-proj neg pos src-info - name (not positive-position?))] - [rng (int-proj pos neg src-info - name positive-position?)]) +(define (int->int-proj blame) + (let ([dom (int-proj (blame-swap blame))] + [rng (int-proj blame)]) (lambda (f) (if (and (procedure? f) (procedure-arity-includes? f 1)) (lambda (x) (rng (f (dom x)))) - (raise-contract-error + (raise-blame-error + blame val - src-info - pos - name "expected a procedure of one argument, given: ~e" val))))) ] @@ -956,17 +948,16 @@ where either a non-procedure is supplied to the contract, or where the procedure does not accept one argument. As with the integer projection, the blame here also lies with the producer of the value, which is -why @scheme[raise-contract-error] gets @scheme[pos] and -not @scheme[neg] as its argument. +why @scheme[raise-blame-error] is passed @scheme[blame] unchanged. The checking for the domain and range are delegated to the @scheme[int-proj] function, which is supplied its arguments in the first two line of the @scheme[int->int-proj] function. The trick here is that, even though the @scheme[int->int-proj] function always -blames what it sees as positive we can reverse the order of -the @scheme[pos] and @scheme[neg] arguments so that the -positive becomes the negative. +blames what it sees as positive we can swap the blame parties by +calling @scheme[blame-swap] on the given @tech{blame object}, replacing +the positive party with the negative party and vice versa. This is not just a cheap trick to get this example to work, however. The reversal of the positive and the negative is a @@ -982,8 +973,8 @@ travelling back from the requiring module to the providing module! And finally, when the function produces a result, that result flows back in the original direction. Accordingly, the contract on the domain reverses -the positive and the negative, just like the flow of values -reverses. +the positive and the negative blame parties, just like the flow +of values reverses. We can use this insight to generalize the function contracts and build a function that accepts any two contracts and @@ -991,21 +982,17 @@ returns a contract for functions between them. @schemeblock[ (define (make-simple-function-contract dom-proj range-proj) - (lambda (pos neg src-info name positive-position?) - (let ([dom (dom-proj neg pos src-info - name (not positive-position?))] - [rng (range-proj pos neg src-info - name positive-position?)]) + (lambda (blame) + (let ([dom (dom-proj (blame-swap blame))] + [rng (range-proj blame)]) (lambda (f) (if (and (procedure? f) (procedure-arity-includes? f 1)) (lambda (x) (rng (f (dom x)))) - (raise-contract-error + (raise-blame-error + blame val - src-info - pos - name "expected a procedure of one argument, given: ~e" val)))))) ] @@ -1014,37 +1001,90 @@ Projections like the ones described above, but suited to other, new kinds of value you might make, can be used with the contract library primitives below. -@defproc[(make-proj-contract [name any/c] - [proj (or/c (-> symbol? symbol? any/c any/c any/c) - (-> symbol? symbol? any/c any/c boolean? any/c))] - [first-order-test (-> any/c any/c)]) - contract?]{ +@deftogether[( +@defproc[(simple-contract + [#:name name any/c 'simple-contract] + [#:first-order test (-> any/c any/c) (λ (x) #t)] + [#:projection proj (-> blame? (-> any/c any/c)) + (λ (b) + (λ (x) + (if (test x) + x + (raise-blame-error + b x "expected <~a>, given: ~e" name x))))]) + contract?] +@defproc[(simple-flat-contract + [#:name name any/c 'simple-flat-contract] + [#:first-order test (-> any/c any/c) (λ (x) #t)] + [#:projection proj (-> blame? (-> any/c any/c)) + (λ (b) + (λ (x) + (if (test x) + x + (raise-blame-error + b x "expected <~a>, given: ~e" name x))))]) + flat-contract?] +)]{ -Builds a new contract. - -The first argument is the name of the contract. It can be an -arbitrary S-expression. The second is a projection (see -above). +These functions build simple procedure-based contracts and flat contracts, +respectively. They both take the same set of three optional arguments: a name, +a first order predicate, and a blame-tracking projection. -If the projection only takes four arguments, then the -positive position boolean is not passed to it (this is -for backwards compatibility). +The @scheme[name] argument is any value to be rendered using @scheme[display] to +describe the contract when a violation occurs. The default name for simple +higher order contracts is @schemeresult[simple-contract], and for flat contracts +is @schemeresult[simple-flat-contract]. -The final argument is a predicate that is a -conservative, first-order test of a value. It should be a -function that accepts one argument and returns a boolean. If -it returns @scheme[#f], its argument must be guaranteed to -fail the contract, and the contract should detect this right -when the projection is invoked. If it returns true, -the value may or may not violate the contract, but any -violations must not be signaled immediately. +The first order predicate @scheme[test] can be used to determine which values +the contract applies to; usually this is the set of values for which the +contract fails immediately without any higher-order wrapping. This test is used +by @scheme[contract-first-order-passes?], and indirectly by @scheme[or/c] to +determine which of multiple higher order contracts to wrap a value with. The +default test accepts any value. + +The projection @scheme[proj] defines the behavior of applying the contract. It +is a curried function of two arguments: the first application accepts a blame +object, and the second accepts a value to protect with the contract. The +projection must either produce the value, suitably wrapped to enforce any +higher-order aspects of the contract, or signal a contract violation using +@scheme[raise-blame-error]. The default projection produces an error when the +first order test fails, and produces the value unchanged otherwise. + +Projections for flat contracts must fail precisely when the first order test +does, and must produce the input value unchanged otherwise. Applying a flat +contract may result in either an application of the predicate, or the +projection, or both; therefore, the two must be consistent. The existence of a +separate projection only serves to provide more specific error messages. Most +flat contracts do not need to supply an explicit projection. + +@defexamples[#:eval (contract-eval) +(define int/c + (simple-flat-contract #:name 'int/c #:first-order integer?)) +(contract 1 int/c 'positive 'negative) +(contract "not one" int/c 'positive 'negative) +(int/c 1) +(int/c "not one") +(define int->int/c + (simple-contract + #:name 'int->int/c + #:first-order + (λ (x) (and (procedure? x) (procedure-arity-includes? x 1))) + #:projection + (λ (b) + (let ([domain ((contract-projection int/c) (blame-swap b))] + [range ((contract-projection int/c) blame)]) + (λ (f) + (if (and (procedure? f) (procedure-arity-includes? f 1)) + (λ (x) (range (f (domain x)))) + (raise-blame-error + b f "expected a function of one argument, got: ~e" f))))))) +(contract "not fun" int->int/c 'positive 'negative) +(define halve (contract (λ (x) (/ x 2)) int->int/c 'positive 'negative)) +(halve 2) +(halve 1) +(halve 1/2) +] -This function is a convenience function, implemented -using @scheme[proj-prop], @scheme[name-prop], -@scheme[first-order-prop], and @scheme[stronger-prop]. -Consider using those directly (as well as @scheme[flat-prop] as necessary), -as they allow more flexibility -and generally produce more efficient contracts. } @defproc[(build-compound-type-name [c/s any/c] ...) any]{ @@ -1086,31 +1126,71 @@ contracts. The error messages assume that the function named by the value cannot be coerced to a contract. } -@defproc[(raise-contract-error [val any/c] - [src-info any/c] - [to-blame symbol?] - [contract-name any/c] - [fmt string?] - [arg any/c] ...) - any]{ +@subsection{Blame Objects} -Signals a contract violation. The first argument is the value that -failed to satisfy the contract. The second argument is is the -@scheme[src-info] passed to the projection and the third should be -either @scheme[pos] or @scheme[neg] (typically @scheme[pos], see the -beginning of this section) that was passed to the projection. The -fourth argument is the @scheme[contract-name] that was passed to the -projection and the remaining arguments are used with @scheme[format] -to build an actual error message.} +@defproc[(blame? [x any/c]) boolean?]{ +This predicate recognizes @tech{blame objects}. +} -@;{ -% to document: -% proj-prop proj-pred? proj-get -% name-prop name-pred? name-get -% stronger-prop stronger-pred? stronger-get -% flat-prop flat-pred? flat-get -% first-order-prop first-order-get -% contract-stronger? +@deftogether[( +@defproc[(blame-positive [b blame?]) any/c] +@defproc[(blame-negative [b blame?]) any/c] +)]{ +These functions produce printable descriptions of the current positive and +negative parties of a blame object. +} + +@defproc[(blame-contract [b blame?]) any/c]{ +This function produces a description of the contract associated with a blame +object (the result of @scheme[contract-name]). +} + +@defproc[(blame-value [b blame?]) any/c]{ +This function produces the name of the value to which the contract was applied, +or @scheme[#f] if no name was provided. +} + +@defproc[(blame-source [b blame?]) srcloc?]{ +This function produces the source location associated with a contract. If no +source location was provided, all fields of the structure will contain +@scheme[#f]. +} + +@defproc[(blame-swap [b blame?]) blame?]{ +This function swaps the positive and negative parties of a @tech{blame object}. +} + +@deftogether[( +@defproc[(blame-original? [b blame?]) boolean?] +@defproc[(blame-swapped? [b blame?]) boolean?] +)]{ + +These functions report whether the current blame of a given blame object is the +same as in the original contract invocation (possibly of a compound contract +containing the current one), or swapped, respectively. Each is the negation of +the other; both are provided for convenience and clarity. + +} + +@defproc[(raise-blame-error [b blame?] [x any/c] [fmt string?] [v any/c] ...) + none/c]{ + +Signals a contract violation. The first argument, @scheme[b], records the +current blame information, including positive and negative parties, the name of +the contract, the name of the value, and the source location of the contract +application. The second argument, @scheme[x], is the value that failed to +satisfy the contract. The remaining arguments are a format string, +@scheme[fmt], and its arguments, @scheme[v ...], specifying an error message +specific to the precise violation. + +} + +@defproc[(exn:fail:contract:blame? [x any/c]) boolean?]{ +This predicate recognizes exceptions raised by @scheme[raise-blame-error]. +} + +@defproc[(exn:fail:contract:blame-object [e exn:fail:contract:blame?]) blame?]{ +This accessor extracts the blame object associated with a contract violation. } @subsection{Contracts as structs} @@ -1118,98 +1198,104 @@ to build an actual error message.} @emph{@bold{Note:} The interface in this section is unstable and subject to change.} -A contract is an arbitrary struct that has all of the -struct properties -(see @secref["structprops"] in the reference manual) -in this section -(except that @scheme[flat-prop] is optional). - -Generally speaking, the contract should be a struct with -fields that specialize the contract in some way and then -properties that implement all of the details of checking -the contract and reporting errors, etc. - -For example, an @scheme[between/c] contract is a struct that -holds the bounds on the number and then has the properties below -that inspect the bounds and take the corresponding action -(the @scheme[proj-prop] checks the numbers, the @scheme[name-prop] - constructs a name to print out for the contract, etc.). - -@deftogether[(@defthing[proj-prop struct-type-property?] - @defproc[(proj-pred? [v any/c]) boolean?]{} - @defproc[(proj-get [v proj-pred?]) - (-> proj-prop? - (-> symbol? symbol? (or/c #f syntax?) string? boolean? - (-> any/c any/c)))]{})]{ - -This is the workhorse property that implements the contract. -The property should be bound to a function that accepts -the struct and then returns a projection, as described -in the docs for @scheme[make-proj-contract] above. - - -} -@deftogether[(@defthing[name-prop struct-type-property?]{} - @defproc[(name-pred? [v any/c]) boolean?]{} - @defproc[(name-get [v name-pred?]) (-> name-pred? printable/c)]{})]{ - -This property should be a function that accepts the struct and returns - an s-expression representing the name of the property. - - @mz-examples[#:eval (contract-eval) - (write (between/c 1 10)) - (let ([c (between/c 1 10)]) - ((name-get c) c))] - -} -@deftogether[(@defthing[stronger-prop struct-type-property?]{} - @defproc[(stronger-pred? [v any/c]) boolean?]{} - @defproc[(stronger-get [v stronger-pred?]) (-> stronger-pred? stronger-pred? boolean?)]{})]{ - -This property is used when optimizing contracts, in order to tell if some contract is stronger than another one. -In some situations, if a contract that is already in place is stronger than one about to be put in place, -then the new one is ignored. - +@para{ +The property @scheme[prop:contract] allows arbitrary structures to act as +contracts. The property @scheme[prop:flat-contract] allows arbitrary structures +to act as flat contracts; @scheme[prop:flat-contract] inherits both +@scheme[prop:contract] and @scheme[prop:procedure], so flat contract structures +may also act as general contracts and as predicate procedures. } -@deftogether[(@defthing[flat-prop struct-type-property?]{} - @defproc[(flat-pred? [v any/c]) boolean?]{} - @defproc[(flat-get [v flat-pred?]) (-> flat-pred? (-> any/c boolean?))]{})]{ - -This property should only be present if the contract is a flat contract. In the case that it is - a flat contract, the value of the property should be a predicate that determines if the - contract holds. - - @mz-examples[#:eval (contract-eval) - (flat-pred? (-> integer? integer?)) - (let* ([c (between/c 1 10)] - [pred ((flat-get c) c)]) - (list (pred 9) - (pred 11)))] +@deftogether[( +@defthing[prop:contract struct-type-property?] +@defthing[prop:flat-contract struct-type-property?] +)]{ +These properties declare structures to be contracts or flat contracts, +respectively. The value for @scheme[prop:contract] must be a @tech{contract +property} constructed by @scheme[build-contract-property]; likewise, the value +for @scheme[prop:flat-contract] must be a @tech{flat contract property} +constructed by @scheme[build-flat-contract-property]. } -@deftogether[(@defthing[first-order-prop struct-type-property?]{} - @defproc[(first-order-pred? [v any/c]) boolean?]{} - @defproc[(first-order-get [v proj-pred?]) (-> first-order-pred? (-> any/c boolean?))]{})]{ +@deftogether[( +@defproc[(build-flat-contract-property + [#:name + get-name + (-> contract? any/c) + (λ (c) 'anonymous-flat-contract)] + [#:first-order + get-first-order + (-> contract? (-> any/c boolean?)) + (λ (c) (λ (x) #t))] + [#:projection + get-projection + (-> contract? (-> blame? (-> any/c any/c))) + (λ (c) + (λ (b) + (λ (x) + (if ((get-first-order c) x) + x + (raise-blame-error + b x "expected <~a>, given: ~e" (get-name c) x)))))]) + flat-contract-property?] +@defproc[(build-contract-property + [#:name + get-name + (-> contract? any/c) + (λ (c) 'anonymous-contract)] + [#:first-order + get-first-order + (-> contract? (-> any/c boolean?)) + (λ (c) (λ (x) #t))] + [#:projection + get-projection + (-> contract? (-> blame? (-> any/c any/c))) + (λ (c) + (λ (b) + (λ (x) + (if ((get-first-order c) x) + x + (raise-blame-error + b x "expected <~a>, given: ~e" (get-name c) x)))))]) + contract-property?] +)]{ -This property is used with @scheme[or/c] to determine which branch of the - @scheme[or/c] applies. These don't have to be precise (i.e., returning @scheme[#f] is always safe), - but the more often a contract can honestly return @scheme[#t], the more often - it will work with @scheme[or/c]. - - For example, function contracts typically check arity in their @scheme[first-order-prop]s. +These functions build the arguments for @scheme[prop:contract] and +@scheme[prop:flat-contract], respectively. +A @deftech{contract property} specifies the behavior of a structure when used as +a contract. It is specified in terms of three accessors: @scheme[get-name], +which produces a description to @scheme[display] during a contract violation; +@scheme[get-first-order], which produces a first order predicate to be used by +@scheme[contract-first-order-passes?]; and @scheme[get-projection], which +produces a blame-tracking projection defining the behavior of the contract. +These accessors are passed as (optional) keyword arguments to +@scheme[build-contract-property], and are applied to instances of the +appropriate structure type by the contract system. Their results are used +analogously to the arguments of @scheme[simple-contract]. + +A @deftech{flat contract property} specifies the behavior of a structure when +used as a flat contract. It is specified using +@scheme[build-flat-contract-property], and accepts exactly the same set of +arguments as @scheme[build-contract-property]. The only difference is that the +projection accessor is expected not to wrap its argument in a higher order +fashion, analogous to the constraint on projections in +@scheme[simple-flat-contract]. + +} + +@deftogether[( +@defproc[(contract-property? [x any/c]) boolean?] +@defproc[(flat-contract-property? [x any/c]) boolean?] +)]{ +These predicates detect whether a value is a @tech{contract property} or a +@tech{flat contract property}, respectively. } @; ------------------------------------------------------------------------ @section{Contract Utilities} -@defproc[(guilty-party [exn exn?]) any]{ - -Extracts the name of the guilty party from an exception -raised by the contract system.} - @defproc[(contract? [v any/c]) boolean?]{ Returns @scheme[#t] if its argument is a contract (i.e., constructed @@ -1246,6 +1332,18 @@ may or may not hold. If the contract is a first-order contract, a result of @scheme[#t] guarantees that the contract holds.} +@defproc[(contract-name [c contract?]) any/c]{ +Produces the name used to describe the contract in error messages. +} + +@defproc[(contract-first-order [c contract?]) (-> any/c boolean?)]{ +Produces the first order test used by @scheme[or/c] to match values to higher +order contracts. +} + +@defproc[(contract-projection [c contract?]) (-> blame? (-> any/c any/c))]{ +Produces the projection defining a contract's behavior on protected values. +} @defproc[(make-none/c [sexp-name any/c]) contract?]{ @@ -1253,31 +1351,22 @@ Makes a contract that accepts no values, and reports the name @scheme[sexp-name] when signaling a contract violation.} -@defparam[contract-violation->string +@defparam[current-blame-format proc - (-> any/c any/c (or/c #f any/c) any/c string? string?)]{ + (-> blame? any/c string?)]{ This is a parameter that is used when constructing a contract violation error. Its value is procedure that -accepts five arguments: +accepts three arguments: @itemize[ -@item{the value that the contract applies to,} -@item{a syntax object representing the source location where -the contract was established, } -@item{the name of the party that violated the contract (@scheme[#f] indicates that the party is not known, not that the party's name is @scheme[#f]), } -@item{an sexpression representing the contract, and } -@item{a message indicating the kind of violation. -}] +@item{the blame object for the violation,} +@item{the value that the contract applies to, and} +@item{a message indicating the kind of violation.}] The procedure then returns a string that is put into the contract error message. Note that the value is often already included in the message that indicates the violation. -If the contract was establised via -@scheme[provide/contract], the names of the party to the -contract will be sexpression versions of the module paths -(as returned by @scheme[collapse-module-path]). - } From 137f9a327904cf5015f19ba05ae4de3f98dff3b9 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Thu, 4 Feb 2010 02:17:15 +0000 Subject: [PATCH 78/78] Fixed bugs in contract construction examples. svn: r17963 --- collects/scribblings/reference/contracts.scrbl | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index cd63b5b182..80cb7caa74 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -1060,8 +1060,8 @@ flat contracts do not need to supply an explicit projection. @defexamples[#:eval (contract-eval) (define int/c (simple-flat-contract #:name 'int/c #:first-order integer?)) -(contract 1 int/c 'positive 'negative) -(contract "not one" int/c 'positive 'negative) +(contract int/c 1 'positive 'negative) +(contract int/c "not one" 'positive 'negative) (int/c 1) (int/c "not one") (define int->int/c @@ -1072,14 +1072,14 @@ flat contracts do not need to supply an explicit projection. #:projection (λ (b) (let ([domain ((contract-projection int/c) (blame-swap b))] - [range ((contract-projection int/c) blame)]) + [range ((contract-projection int/c) b)]) (λ (f) (if (and (procedure? f) (procedure-arity-includes? f 1)) (λ (x) (range (f (domain x)))) (raise-blame-error b f "expected a function of one argument, got: ~e" f))))))) -(contract "not fun" int->int/c 'positive 'negative) -(define halve (contract (λ (x) (/ x 2)) int->int/c 'positive 'negative)) +(contract int->int/c "not fun" 'positive 'negative) +(define halve (contract int->int/c (λ (x) (/ x 2)) 'positive 'negative)) (halve 2) (halve 1) (halve 1/2)