From ad2928e32a2e373840654a80a2905440e14b8ac7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 28 Sep 2008 22:59:34 +0000 Subject: [PATCH 01/50] typo (PR9789) svn: r11898 --- collects/mrlib/scribblings/hierlist/list.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mrlib/scribblings/hierlist/list.scrbl b/collects/mrlib/scribblings/hierlist/list.scrbl index 0988b3a7f9..de9b6b0a3e 100644 --- a/collects/mrlib/scribblings/hierlist/list.scrbl +++ b/collects/mrlib/scribblings/hierlist/list.scrbl @@ -19,8 +19,8 @@ Creates a hierarchical-list control. Creates the control.} -@defmethod[(selected) (or/c (is-a?/c hierarchical-list-item<%>) - false/c)]{ +@defmethod[(get-selected) (or/c (is-a?/c hierarchical-list-item<%>) + false/c)]{ Returns the currently selected item, if any.} From 772760f197cc112ec1b76f34d166f9ff21ab3a87 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 29 Sep 2008 07:50:10 +0000 Subject: [PATCH 02/50] Welcome to a new PLT day. svn: r11899 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 56bb61c48b..c3710d722c 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "28sep2008") +#lang scheme/base (provide stamp) (define stamp "29sep2008") From cad726031f1abada81b698d29127cd711ae9cda0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 29 Sep 2008 12:19:38 +0000 Subject: [PATCH 03/50] fix two macro-expansion bugs, one related to the top level, and one related to internal-definition positions svn: r11900 --- src/mzscheme/src/env.c | 17 +++++++++++++---- src/mzscheme/src/eval.c | 4 ++++ src/mzscheme/src/syntax.c | 26 +++++++++++++++----------- 3 files changed, 32 insertions(+), 15 deletions(-) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index e3c2fe7757..e49d9bb5f4 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -2513,10 +2513,19 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, /* Used out of context? */ if (SAME_OBJ(modidx, scheme_undefined)) { - if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) - scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, - "identifier used out of context"); - return NULL; + if (!env->genv->module && SCHEME_STXP(find_id)) { + /* Looks like lexically bound, but double-check that it's not bound via a tl_id: */ + find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL); + if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id))) + modidx = NULL; /* yes, it is bound */ + } + + if (modidx) { + if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) + scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, + "identifier used out of context"); + return NULL; + } } if (modidx) { diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 9b2fe75ef1..e9270db361 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -6399,6 +6399,9 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, result = scheme_make_pair(result, scheme_null); SCHEME_EXPAND_OBSERVE_BLOCK_TO_LETREC(rec[drec].observer, result); return scheme_expand_list(result, env, rec, drec); + } else { + result = scheme_make_pair(result, scheme_null); + return scheme_datum_to_syntax(result, forms, forms, 0, 0); } } } @@ -6420,6 +6423,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, rest = scheme_datum_to_syntax(rest, forms, forms, 0, 0); first = scheme_compile_expr(first, env, recs, 0); + #if EMBEDDED_DEFINES_START_ANYWHERE forms = scheme_compile_expand_block(rest, env, recs, 1); #else diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 4cd2a3bbbd..e095659f65 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -4464,6 +4464,9 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, int drec) { +#if 0 + /* This attempt at a shortcut is wrong, because the sole expression might expand + to a `begin' that needs to be spliced into an internal-definition context. */ try_again: if (SCHEME_STX_PAIRP(forms) && SCHEME_STX_NULLP(SCHEME_STX_CDR(forms))) { @@ -4471,7 +4474,7 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, Scheme_Object *first, *val; first = SCHEME_STX_CAR(forms); - first = scheme_check_immediate_macro(first, env, rec, drec, 0, &val, NULL, NULL); + first = scheme_check_immediate_macro(first, env, rec, drec, 1, &val, NULL, NULL); if (SAME_OBJ(val, scheme_begin_syntax) && SCHEME_STX_PAIRP(first)) { /* Flatten begin: */ @@ -4485,17 +4488,18 @@ Scheme_Object *scheme_compile_sequence(Scheme_Object *forms, } return scheme_compile_expr(first, env, rec, drec); + } +#endif + + if (scheme_stx_proper_list_length(forms) < 0) { + scheme_wrong_syntax(scheme_begin_stx_string, NULL, + scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0), + "bad syntax (" IMPROPER_LIST_FORM ")"); + return NULL; } else { - if (scheme_stx_proper_list_length(forms) < 0) { - scheme_wrong_syntax(scheme_begin_stx_string, NULL, - scheme_datum_to_syntax(cons(begin_symbol, forms), forms, forms, 0, 0), - "bad syntax (" IMPROPER_LIST_FORM ")"); - return NULL; - } else { - Scheme_Object *body; - body = scheme_compile_block(forms, env, rec, drec); - return scheme_make_sequence_compilation(body, 1); - } + Scheme_Object *body; + body = scheme_compile_block(forms, env, rec, drec); + return scheme_make_sequence_compilation(body, 1); } } From 0ad2b06c66f48d1589834ed2b0b2467300b94dd1 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 29 Sep 2008 13:51:42 +0000 Subject: [PATCH 04/50] added shift-return to go backwards svn: r11901 --- collects/framework/private/frame.ss | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 99dc0a430e..6e1a611381 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1933,6 +1933,11 @@ (λ (text evt) (send (send text get-top-level-window) search 'forward))) +(send search/replace-keymap map-function "s:return" "prev") +(send search/replace-keymap add-function "prev" + (λ (text evt) + (send (send text get-top-level-window) search 'backward))) + (send search/replace-keymap map-function "c:return" "insert-return") (send search/replace-keymap map-function "a:return" "insert-return") (send search/replace-keymap add-function "insert-return" From 5844ef4a3de32b1658d61db0a3730704167e48a4 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Mon, 29 Sep 2008 15:09:29 +0000 Subject: [PATCH 05/50] Corrected error in using libraries svn: r11902 --- collects/profj/tool.ss | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/profj/tool.ss b/collects/profj/tool.ss index 411bd10be3..2ae863f5aa 100644 --- a/collects/profj/tool.ss +++ b/collects/profj/tool.ss @@ -872,8 +872,7 @@ eof (begin (set! executed? #t) - (errortrace-annotate - (syntax-as-top + (syntax-as-top (compile-interactions-ast (parse-interactions port name level) name level types #t) @@ -881,7 +880,7 @@ #;(datum->syntax #f `(parse-java-interactions ,(parse-interactions port name level) ,name) - #f)))))))) + #f))))))) (define/public (front-end/finished-complete-program settings) (void)) (define (get-defn-editor port-name) From b81ba54daedae6f6ed697abd2bced6f70ea386eb Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 29 Sep 2008 15:15:50 +0000 Subject: [PATCH 06/50] fix for automated running svn: r11903 --- collects/tests/match/plt-match-tests.ss | 459 ++++++++++++------------ 1 file changed, 229 insertions(+), 230 deletions(-) diff --git a/collects/tests/match/plt-match-tests.ss b/collects/tests/match/plt-match-tests.ss index d50f65f05c..06276f5684 100644 --- a/collects/tests/match/plt-match-tests.ss +++ b/collects/tests/match/plt-match-tests.ss @@ -1,233 +1,232 @@ -(module plt-match-tests mzscheme - (require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) - (require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 10))) +#lang scheme/base - (require mzlib/plt-match) - - (require "match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss") - - (require (planet "views.ss" ("cobbe" "views.plt" 1 1))) - - (define reg-tests - (make-test-suite "Tests for regressions" - (make-test-case "quote in qp" - (assert eq? #t (match '(tile a b c) - [`(tile ,@'(a b c)) - #t] - [else #f])) - (assert eq? #t (match '(tile a b c) - [`(tile ,@`(a b c)) - #t] - [else #f]))))) - (define cons-tests - (make-test-suite "Tests for cons pattern" - (make-test-case "simple" - (assert = 3 (match (cons 1 2) [(cons a b) (+ a b)]))))) - - (define match-expander-tests - (make-test-suite - "Tests for define-match-expander" - (make-test-case "Trivial expander" - (let () - (define-match-expander bar (lambda (x) #'_) +) - (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works - (assert-true (match 3 [(bar) #t])) ; (bar) matches anything - (assert = 12 (bar 3 4 5)) - (assert = 12 (apply bar '(3 4 5))))) ; bar works like + - - (make-test-case "Trivial expander w/ keywords" - (let () - (define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +) - (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works - (assert-true (match 3 [(bar) #t])) ; (bar) matches anything - (assert = 12 (bar 3 4 5)) - (assert = 12 (apply bar '(3 4 5))))) ; bar works like + - - ;; gross hack to check for syntax errors - (make-test-case "Only one xform gives syntax error" - (assert-exn exn:fail:syntax? - (lambda () - (expand #'(let () - (define-match-expander bar (lambda (x) #'_)) - (bar 3 4)))))) +(require (for-syntax scheme/base)) - ;; more complex example from Dale - (make-test-case "Point structs" - (let () - (define-struct point (x y)) - (define-match-expander Point - (lambda (x) - (syntax-case x () - ((Point a b) #'(struct point (a b))))) - make-point) - ;; check that it works as expression and as pattern - (assert = 5 (match (Point 2 3) - [(Point x y) (+ x y)])) - ;; check that sub-patterns still work - (assert = 7 (match (make-point 2 3) - [(Point (app add1 x) (app add1 y)) (+ x y)])) - ;; check that it works inside a list - (assert = 7 (match (list (make-point 2 3)) - [(list (Point (app add1 x) (app add1 y))) (+ x y)])) - )) - - ;; from richard's view documentation - - (make-test-case "Natural number views" - (let () - (define natural-number? - (lambda (x) - (and (integer? x) - (>= x 0)))) - (define natural-zero? (lambda (x) (and (integer? x) (zero? x)))) - - (define-view peano-zero natural-zero? ()) - (define-view peano-succ natural-number? (sub1)) - - (define factorial - (match-lambda - [(peano-zero) 1] - [(and (peano-succ pred) n) (* n (factorial pred))])) - (assert = 120 (factorial 5)))) - - ;; more complex example from Dale - (make-test-case "Point structs with keywords" - (let () - (define-struct point (x y)) - (define-match-expander Point - #:plt-match - (lambda (x) - (syntax-case x () - ((Point a b) #'(struct point (a b))))) - #:expression make-point) - ;; check that it works as expression and as pattern - (assert = 5 (match (Point 2 3) - [(Point x y) (+ x y)])) - ;; check that sub-patterns still work - (assert = 7 (match (make-point 2 3) - [(Point (app add1 x) (app add1 y)) (+ x y)])) - ;; check that it works inside a list - (assert = 7 (match (list (make-point 2 3)) - [(list (Point (app add1 x) (app add1 y))) (+ x y)])) - )) - )) - - (define simple-tests - (make-test-suite - "Some Simple Tests" - (make-test-case "Trivial" - (assert = 3 (match 3 [x x]))) - (make-test-case "no order" - (assert equal? #t (match '(1 2 3 1) - [(list-no-order 3 2 1 1) #t] - [_ #f]))) - (make-test-case "app pattern" - (assert = 4 (match 3 [(app add1 y) y]))) - (make-test-case "struct patterns" - (let () - (define-struct point (x y)) - (define (origin? pt) - (match pt - ((struct point (0 0)) #t) - (else #f))) - (assert-true (origin? (make-point 0 0))) - (assert-false (origin? (make-point 1 1))))) - )) - - (define nonlinear-tests - (make-test-suite - "Non-linear patterns" - (make-test-case "Very simple" - (assert = 3 (match '(3 3) [(list a a) a]))) - (make-test-case "Fails" - (assert-exn exn:misc:match? (lambda () (match '(3 4) [(list a a) a])))) - (make-test-case "Use parameter" - (parameterize ([match-equality-test eq?]) - (assert = 5 (match '((3) (3)) [(list a a) a] [_ 5])))) - (make-test-case "Nonlinear patterns use equal?" - (assert equal? '(3) (match '((3) (3)) [(list a a) a] [_ 5]))))) - - - (define doc-tests - (make-test-suite - "Tests from Help Desk Documentation" - (make-test-case "match-let" - (assert = 6 (match-let ([(list x y z) (list 1 2 3)]) (+ x y z)))) - (make-test-case "lambda calculus" - (let () - (define-struct Lam (args body)) - (define-struct Var (s)) - (define-struct Const (n)) - (define-struct App (fun args)) - - (define parse - (match-lambda - [(and s (? symbol?) (not 'lambda)) - (make-Var s)] - [(? number? n) - (make-Const n)] - [(list 'lambda (and args (list (? symbol?) ...) (not (? repeats?))) body) - (make-Lam args (parse body))] - [(list f args ...) - (make-App - (parse f) - (map parse args))] - [x (error 'syntax "invalid expression")])) - - (define repeats? - (lambda (l) - (and (not (null? l)) - (or (memq (car l) (cdr l)) (repeats? (cdr l)))))) - - (define unparse - (match-lambda - [(struct Var (s)) s] - [(struct Const (n)) n] - [(struct Lam (args body)) `(lambda ,args ,(unparse body))] - [(struct App (f args)) `(,(unparse f) ,@(map unparse args))])) - - (assert equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x)))))) - - (make-test-case "counter : match-define" - (let () - (match-define (list inc value reset) - (let ([val 0]) - (list - (lambda () (set! val (add1 val))) - (lambda () val) - (lambda () (set! val 0))))) - (inc) - (inc) - (assert = 2 (value)) - (inc) - (assert = 3 (value)) - (reset) - (assert = 0 (value)))) - - )) - - (define plt-match-tests - (make-test-suite "Tests for plt-match.ss" - doc-tests - cons-tests - simple-tests - nonlinear-tests - match-expander-tests - reg-tests +(require (planet "test-compat2.ss" ("schematics" "schemeunit.plt" 2 10))) +(require (planet "text-ui.ss" ("schematics" "schemeunit.plt" 2 10))) + +(require mzlib/plt-match) + +(require "match-tests.ss" "other-plt-tests.ss" "other-tests.ss" "examples.ss") + +(require (planet "views.ss" ("cobbe" "views.plt" 1 1))) + +(define reg-tests + (make-test-suite "Tests for regressions" + (make-test-case "quote in qp" + (assert eq? #t (match '(tile a b c) + [`(tile ,@'(a b c)) + #t] + [else #f])) + (assert eq? #t (match '(tile a b c) + [`(tile ,@`(a b c)) + #t] + [else #f]))))) +(define cons-tests + (make-test-suite "Tests for cons pattern" + (make-test-case "simple" + (assert = 3 (match (cons 1 2) [(cons a b) (+ a b)]))))) + +(define match-expander-tests + (make-test-suite + "Tests for define-match-expander" + (make-test-case "Trivial expander" + (let () + (define-match-expander bar (lambda (x) #'_) +) + (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works + (assert-true (match 3 [(bar) #t])) ; (bar) matches anything + (assert = 12 (bar 3 4 5)) + (assert = 12 (apply bar '(3 4 5))))) ; bar works like + + + (make-test-case "Trivial expander w/ keywords" + (let () + (define-match-expander bar #:plt-match (lambda (x) #'_) #:expression +) + (assert = 4 (match 3 [(app add1 x) x])) ; other stuff still works + (assert-true (match 3 [(bar) #t])) ; (bar) matches anything + (assert = 12 (bar 3 4 5)) + (assert = 12 (apply bar '(3 4 5))))) ; bar works like + + + ;; gross hack to check for syntax errors + (make-test-case "Only one xform gives syntax error" + (assert-exn exn:fail:syntax? + (lambda () + (expand #'(let () + (define-match-expander bar (lambda (x) #'_)) + (bar 3 4)))))) + + ;; more complex example from Dale + (make-test-case "Point structs" + (let () + (define-struct point (x y)) + (define-match-expander Point + (lambda (x) + (syntax-case x () + ((Point a b) #'(struct point (a b))))) + make-point) + ;; check that it works as expression and as pattern + (assert = 5 (match (Point 2 3) + [(Point x y) (+ x y)])) + ;; check that sub-patterns still work + (assert = 7 (match (make-point 2 3) + [(Point (app add1 x) (app add1 y)) (+ x y)])) + ;; check that it works inside a list + (assert = 7 (match (list (make-point 2 3)) + [(list (Point (app add1 x) (app add1 y))) (+ x y)])) )) - - (define (run-tests) - (test/text-ui (make-test-suite "Match Tests" - plt-match-tests - match-tests - new-tests - ;; from bruce - other-tests - other-plt-tests - ))) - (if (getenv "PLT_TESTS") - (unless (parameterize ([current-output-port (open-output-string)]) - (= 0 (run-tests))) - (error "Match Tests did not pass.")) - (run-tests)) - ) + + ;; from richard's view documentation + + (make-test-case "Natural number views" + (let () + (define natural-number? + (lambda (x) + (and (integer? x) + (>= x 0)))) + (define natural-zero? (lambda (x) (and (integer? x) (zero? x)))) + + (define-view peano-zero natural-zero? ()) + (define-view peano-succ natural-number? (sub1)) + + (define factorial + (match-lambda + [(peano-zero) 1] + [(and (peano-succ pred) n) (* n (factorial pred))])) + (assert = 120 (factorial 5)))) + + ;; more complex example from Dale + (make-test-case "Point structs with keywords" + (let () + (define-struct point (x y)) + (define-match-expander Point + #:plt-match + (lambda (x) + (syntax-case x () + ((Point a b) #'(struct point (a b))))) + #:expression make-point) + ;; check that it works as expression and as pattern + (assert = 5 (match (Point 2 3) + [(Point x y) (+ x y)])) + ;; check that sub-patterns still work + (assert = 7 (match (make-point 2 3) + [(Point (app add1 x) (app add1 y)) (+ x y)])) + ;; check that it works inside a list + (assert = 7 (match (list (make-point 2 3)) + [(list (Point (app add1 x) (app add1 y))) (+ x y)])) + )) + )) + +(define simple-tests + (make-test-suite + "Some Simple Tests" + (make-test-case "Trivial" + (assert = 3 (match 3 [x x]))) + (make-test-case "no order" + (assert equal? #t (match '(1 2 3 1) + [(list-no-order 3 2 1 1) #t] + [_ #f]))) + (make-test-case "app pattern" + (assert = 4 (match 3 [(app add1 y) y]))) + (make-test-case "struct patterns" + (let () + (define-struct point (x y)) + (define (origin? pt) + (match pt + ((struct point (0 0)) #t) + (else #f))) + (assert-true (origin? (make-point 0 0))) + (assert-false (origin? (make-point 1 1))))) + )) + +(define nonlinear-tests + (make-test-suite + "Non-linear patterns" + (make-test-case "Very simple" + (assert = 3 (match '(3 3) [(list a a) a]))) + (make-test-case "Fails" + (assert-exn exn:misc:match? (lambda () (match '(3 4) [(list a a) a])))) + (make-test-case "Use parameter" + (parameterize ([match-equality-test eq?]) + (assert = 5 (match '((3) (3)) [(list a a) a] [_ 5])))) + (make-test-case "Nonlinear patterns use equal?" + (assert equal? '(3) (match '((3) (3)) [(list a a) a] [_ 5]))))) + + +(define doc-tests + (make-test-suite + "Tests from Help Desk Documentation" + (make-test-case "match-let" + (assert = 6 (match-let ([(list x y z) (list 1 2 3)]) (+ x y z)))) + (make-test-case "lambda calculus" + (let () + (define-struct Lam (args body)) + (define-struct Var (s)) + (define-struct Const (n)) + (define-struct App (fun args)) + + (define parse + (match-lambda + [(and s (? symbol?) (not 'lambda)) + (make-Var s)] + [(? number? n) + (make-Const n)] + [(list 'lambda (and args (list (? symbol?) ...) (not (? repeats?))) body) + (make-Lam args (parse body))] + [(list f args ...) + (make-App + (parse f) + (map parse args))] + [x (error 'syntax "invalid expression")])) + + (define repeats? + (lambda (l) + (and (not (null? l)) + (or (memq (car l) (cdr l)) (repeats? (cdr l)))))) + + (define unparse + (match-lambda + [(struct Var (s)) s] + [(struct Const (n)) n] + [(struct Lam (args body)) `(lambda ,args ,(unparse body))] + [(struct App (f args)) `(,(unparse f) ,@(map unparse args))])) + + (assert equal? '(lambda (x y) x) (unparse (parse '(lambda (x y) x)))))) + + (make-test-case "counter : match-define" + (let () + (match-define (list inc value reset) + (let ([val 0]) + (list + (lambda () (set! val (add1 val))) + (lambda () val) + (lambda () (set! val 0))))) + (inc) + (inc) + (assert = 2 (value)) + (inc) + (assert = 3 (value)) + (reset) + (assert = 0 (value)))) + + )) + +(define plt-match-tests + (make-test-suite "Tests for plt-match.ss" + doc-tests + cons-tests + simple-tests + nonlinear-tests + match-expander-tests + reg-tests + )) + +(define (run-tests) + (test/text-ui (make-test-suite "Match Tests" + plt-match-tests + match-tests + new-tests + ;; from bruce + other-tests + other-plt-tests + ))) +(unless (= 0 (run-tests)) + (error "Match Tests did not pass.")) From f64fb9ff460cfbc85b10c7fea6c866b5bab5a919 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 29 Sep 2008 17:41:34 +0000 Subject: [PATCH 07/50] prepare for 4.1.1 svn: r11904 --- src/mzscheme/src/schvers.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index d443cd80a4..4011b70b47 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.0.4" +#define MZSCHEME_VERSION "4.1.1.0" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 -#define MZSCHEME_VERSION_Z 0 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_Z 1 +#define MZSCHEME_VERSION_W 0 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) From 09427ab88fc0a655f257df5f44f66760238aaf66 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 29 Sep 2008 17:42:12 +0000 Subject: [PATCH 08/50] typo svn: r11905 --- src/mzscheme/src/schvers.h | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 4011b70b47..b8152b8875 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,7 +13,7 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.1.0" +#define MZSCHEME_VERSION "4.1.1" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 From 3f4c0997e356dcdc38fc9410e743fd344365e875 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 29 Sep 2008 17:42:26 +0000 Subject: [PATCH 09/50] Welcome to a new PLT day. svn: r11906 --- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 6 files changed, 20 insertions(+), 20 deletions(-) diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 856377cb90..5c7900ae7a 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Mon, 29 Sep 2008 18:44:27 +0000 Subject: [PATCH 10/50] removed the (useless) mouse-over-the-overview-window-and-it-shows-you-one-line-of-text feature because it made the window jump around in annoying ways and made clicking on the overview window not work properly svn: r11907 --- collects/framework/private/frame.ss | 24 +----------------------- 1 file changed, 1 insertion(+), 23 deletions(-) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index 6e1a611381..a203326d93 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -1435,29 +1435,7 @@ (send evt get-x) (send evt get-y))]) (send delegate-frame click-in-overview - (send text find-position editor-x editor-y)))] - [(or (send evt entering?) - (send evt moving?)) - (when (send evt entering?) - (send delegate-frame open-status-line 'plt:delegate)) - (let-values ([(editor-x editor-y) - (send text dc-location-to-editor-location - (send evt get-x) - (send evt get-y))]) - (let* ([b (box #f)] - [pos (send text find-position editor-x editor-y #f b)]) - (cond - [(unbox b) - (let* ([para (send text position-paragraph pos)] - [start-pos (send text paragraph-start-position para)] - [end-pos (send text paragraph-end-position para)]) - (send delegate-frame update-status-line 'plt:delegate - (at-most-200 (send text get-text start-pos end-pos))))] - [else - (send delegate-frame update-status-line 'plt:delegate #f)])))] - [(send evt leaving?) - (send delegate-frame update-status-line 'plt:delegate #f) - (send delegate-frame close-status-line 'plt:delegate)]))))) + (send text find-position editor-x editor-y)))]))))) (super-new))) (define (at-most-200 s) From 07cfcb4f0701dae0716847bab1e8de1718aad335 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 29 Sep 2008 21:06:13 +0000 Subject: [PATCH 11/50] updated tests for newest stuff svn: r11908 --- collects/tests/drscheme/repl-test.ss | 30 ++++++++++++++-------------- collects/tests/framework/main.ss | 2 +- 2 files changed, 16 insertions(+), 16 deletions(-) diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index 795b3d7087..4a6f5e0b54 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -133,12 +133,12 @@ This produces an ACK message void) (mktest "(" - ("{stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)'" - "{stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)'") + ("{stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)' to close `('" + "{stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: read: expected a `)' to close `('") 'definitions #f void @@ -467,12 +467,12 @@ This produces an ACK message ;; error in the middle (mktest "1 2 ( 3 4" - ("1\n2\n{stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)'" - "1\n2\n{stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} read: expected a `)'" - "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)'") + ("1\n2\n{stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)' to close `('" + "1\n2\n{stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} read: expected a `)' to close `('" + "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: read: expected a `)' to close `('") 'definitions #f void @@ -1382,10 +1382,10 @@ This produces an ACK message (let* ([end (- (get-int-pos) 1)] [output (fetch-output drscheme-frame start end)] - [expected "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x"]) - (unless (equal? output expected) + [expected #rx"reference to undefined identifier: x"]) + (unless (regexp-match expected output) (failure) - (fprintf (current-error-port) "callcc-test: expected ~s, got ~s\n" expected output))))) + (fprintf (current-error-port) "callcc-test: expected something matching ~s, got ~s\n" expected output))))) (define (random-seed-test) (define expression diff --git a/collects/tests/framework/main.ss b/collects/tests/framework/main.ss index a290b77360..5b10ada2c7 100644 --- a/collects/tests/framework/main.ss +++ b/collects/tests/framework/main.ss @@ -53,7 +53,7 @@ (cond [all? all-files] [batch? (remove* interactive-files all-files)] [else files])))) - `("Names of the tests; defaults to all tests")) + `("Names of the tests; defaults to all non-interactive tests")) (when (file-exists? preferences-file) (debug-printf admin " saving preferences file ~s to ~s\n" From cd8e24b02b75df103b89897809f1c702d8578d82 Mon Sep 17 00:00:00 2001 From: Chongkai Zhu Date: Tue, 30 Sep 2008 01:46:37 +0000 Subject: [PATCH 12/50] fix equal? svn: r11909 --- collects/srfi/63/63.ss | 71 ++++++++++++++++++++++-------------------- 1 file changed, 37 insertions(+), 34 deletions(-) diff --git a/collects/srfi/63/63.ss b/collects/srfi/63/63.ss index 373a126416..79a6e1706d 100644 --- a/collects/srfi/63/63.ss +++ b/collects/srfi/63/63.ss @@ -136,40 +136,43 @@ (vector? obj) (my-array? obj))) - (define (s:equal? obj1 obj2) - (or (equal? obj1 obj2) - (and (box? obj1) - (box? obj2) - (s:equal? (unbox obj1) - (unbox obj2))) - (and (pair? obj1) - (pair? obj2) - (s:equal? (car obj1) (car obj2)) - (s:equal? (cdr obj1) (cdr obj2))) - (if (vector? obj1) - (and (vector? obj2) - (equal? (vector-length obj1) (vector-length obj2)) - (let lp ((idx (sub1 (vector-length obj1)))) - (or (negative? idx) - (and (s:equal? (vector-ref obj1 idx) - (vector-ref obj2 idx)) - (lp (sub1 idx)))))) - ;; Not a vector - (or (and (array? obj1) - (array? obj2) - (equal? (array-dimensions obj1) (array-dimensions obj2)) - (s:equal? (array->vector obj1) (array->vector obj2))) - (and (struct? obj1) - (struct? obj2) - (let-values (((obj1-type obj1-skipped?) - (struct-info obj1)) - ((obj2-type obj2-skipped?) - (struct-info obj2))) - (and (eq? obj1-type obj2-type) - (not obj1-skipped?) - (not obj2-skipped?) - (s:equal? (struct->vector obj1) - (struct->vector obj2))))))))) + (define (s:equal? obj1 obj2) + (or (equal? obj1 obj2) + (cond ((and (box? obj1) + (box? obj2)) + (s:equal? (unbox obj1) + (unbox obj2))) + ((and (pair? obj1) + (pair? obj2)) + (and (s:equal? (car obj1) (car obj2)) + (s:equal? (cdr obj1) (cdr obj2)))) + ((and (vector? obj1) + (vector? obj2)) + (and (equal? (vector-length obj1) (vector-length obj2)) + (let lp ((idx (sub1 (vector-length obj1)))) + (or (negative? idx) + (and (s:equal? (vector-ref obj1 idx) + (vector-ref obj2 idx)) + (lp (sub1 idx))))))) + ((and (string? obj1) + (string? obj2)) + (string=? obj1 obj2)) + ((and (array? obj1) + (array? obj2)) + (and (equal? (array-dimensions obj1) (array-dimensions obj2)) + (s:equal? (array->vector obj1) (array->vector obj2)))) + ((and (struct? obj1) + (struct? obj2)) + (let-values (((obj1-type obj1-skipped?) + (struct-info obj1)) + ((obj2-type obj2-skipped?) + (struct-info obj2))) + (and (eq? obj1-type obj2-type) + (not obj1-skipped?) + (not obj2-skipped?) + (s:equal? (struct->vector obj1) + (struct->vector obj2))))) + (else #f)))) (define (array-rank obj) (if (array? obj) (length (array-dimensions obj)) 0)) From 2ee9f2979c9f6e95582c0efbd36b5d2691190087 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 30 Sep 2008 07:50:08 +0000 Subject: [PATCH 13/50] Welcome to a new PLT day. svn: r11910 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index c3710d722c..8057221cb8 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "29sep2008") +#lang scheme/base (provide stamp) (define stamp "30sep2008") From a529b45e7c39cd1baa66078306e5738012705f32 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Sep 2008 12:08:09 +0000 Subject: [PATCH 14/50] add __isnan and __isinf (PR 9802) svn: r11911 --- collects/compiler/private/xform.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/compiler/private/xform.ss b/collects/compiler/private/xform.ss index c024cb9d13..116b3df357 100644 --- a/collects/compiler/private/xform.ss +++ b/collects/compiler/private/xform.ss @@ -835,8 +835,8 @@ ;; So we can ignore them: strlen cos sin exp pow log sqrt atan2 - isnan isinf fpclass _fpclass _isnan __isfinited __isnanl - __isinff __isinfl isnanf isinff __isinfd __isnanf __isnand + isnan isinf fpclass _fpclass _isnan __isfinited __isnanl __isnan + __isinff __isinfl isnanf isinff __isinfd __isnanf __isnand __isinf floor ceil round fmod fabs __maskrune _errno __errno isalpha isdigit isspace tolower toupper fread fwrite socket fcntl setsockopt connect send recv close From 32cee3c658b06e575313c4cb4f29200cec34ff65 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Tue, 30 Sep 2008 14:18:51 +0000 Subject: [PATCH 15/50] history updated svn: r11912 --- doc/release-notes/teachpack/HISTORY.txt | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index f1f612fe15..e50f737849 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -1,3 +1,8 @@ +------------------------------------------------------------------------ +Version 4.1.1 [Tue Sep 30 10:17:26 EDT 2008] + +* world.ss: big-bang can now be re-run after the world has stopped + ------------------------------------------------------------------------ Version 4.1 [Sun Aug 10 12:56:58 EDT 2008] From 4a7967d60311b0392a7f5f41cc2c23ff02ac7413 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Sep 2008 14:35:44 +0000 Subject: [PATCH 16/50] update mz/mr notes for 4.1.1 svn: r11913 --- doc/release-notes/mred/HISTORY.txt | 6 ++++++ doc/release-notes/mzscheme/HISTORY.txt | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index cb3f7764c1..5dcbd5342f 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1,3 +1,9 @@ +Version 4.1.1, October 2008 + +Minor bug fixes + +---------------------------------------------------------------------- + Version 4.1, August 2008 Added auto-resize init argument and method to message% diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 14e1caab2b..e568c4828e 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,4 +1,4 @@ -Version 4.1.0.4 +Version 4.1.1, October 2008 Added read-language Added module-compiled-language-info, module->language-info, and 'module-language property support From d6ba5a2820c2c89df52e92d9ebf7d5a6b3fcc357 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Sep 2008 14:37:46 +0000 Subject: [PATCH 17/50] minor typos in FFI doc svn: r11914 --- collects/scribblings/foreign/types.scrbl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index f25a32b24c..9594ceeb45 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -293,12 +293,12 @@ default; other possible values are @scheme['stdcall] and especially important on Windows, where most system functions are @scheme['stdcall], which is not the default. -The optional @scheme[wrapper-proc], if provided, is expected to be a function that +The optional @scheme[wrapper], if provided, is expected to be a function that can change a callout procedure: when a callout is generated, the wrapper is applied on the newly created primitive procedure, and its result is used as the -new function. Thus, @scheme[wrapper-proc] is a hook that can perform various argument +new function. Thus, @scheme[wrapper] is a hook that can perform various argument manipulations before the foreign function is invoked, and return different -results (for example, grabbing a value stored in an `output' pointer and +results (for example, grabbing a value stored in an ``output'' pointer and returning multiple values). It can also be used for callbacks, as an additional layer that tweaks arguments from the foreign code before they reach the Scheme procedure, and possibly changes the result values too.} From cab3740acf0841400e5319a5fa3e73ac061b835b Mon Sep 17 00:00:00 2001 From: John Clements Date: Tue, 30 Sep 2008 17:08:46 +0000 Subject: [PATCH 18/50] reversed order of entries in history file and updated it svn: r11915 --- doc/release-notes/stepper/DESIGN-NOTES | 1 + doc/release-notes/stepper/HISTORY.txt | 145 +++++++++++++------------ 2 files changed, 79 insertions(+), 67 deletions(-) diff --git a/doc/release-notes/stepper/DESIGN-NOTES b/doc/release-notes/stepper/DESIGN-NOTES index 5b5b8e0d2d..5ee1b1bedc 100644 --- a/doc/release-notes/stepper/DESIGN-NOTES +++ b/doc/release-notes/stepper/DESIGN-NOTES @@ -910,4 +910,5 @@ harder than I expected. Don't ask me about lazy scheme. Or Advanced. Grr! 2008-05-08 +************** diff --git a/doc/release-notes/stepper/HISTORY.txt b/doc/release-notes/stepper/HISTORY.txt index add9b03cd8..6fd01607ee 100644 --- a/doc/release-notes/stepper/HISTORY.txt +++ b/doc/release-notes/stepper/HISTORY.txt @@ -1,61 +1,55 @@ Stepper ------- -Changes for v101: +Changes for v4.1.1: -all steps scroll to bottom automatically. -constants like 'pi' are explicitly expanded in a step. -stepper uses fewer threads internally. +Check-expect now reduces to a boolean in the stepper. Also, this history file +now appears with the most recent entries at the top.... -Changes for v102: - -Stepper handles intermediate level. -UI redesigned to use "side-by-side" reduction. - -Changes for v103: - -PRs fixed: 1564, 1277, 1536, 1500, 1561, 1468, 1599, 1631 - -Changes for v200: - -Total rewrite for new syntax. Addition of test suites. -Addition of somewhat more systematic macro unwinding. -Lots of bug fixes. - -Changes for v201: - -Minor bug fixes. - -Changes for v203: - -Much more systematic unwinding, intermediate almost ready, redesigned test suite - -Changes for v204: +Changes for v4.1: none. -Changes for v205: +Changes for v4.0.1: -v. minor bug fixes. +none. -Changes for v206: +Changes for v4.0: -Stepper supports intermediate, minor bug fixes, major rewrite of interface - between reconstruct and display. +overhauled support for check-expect, check-within, check-error. -Changes for v206p1: +Changes for v372: + +support for check-expect, check-within, and check-error + +Changes for v371: None. -Changes for v207: +Changes for v370: -None. +Added "End" button to stepper interface. -Changes for v208: +Stepper supports "begin0". Again, you'll never know it unless you use +the PLTSTEPPERUNSAFE environment variable. -minor bug fixes. +There's a known bug with expressions of the form (let (begin +...)). (It's displayed as (let () X) rather than (begin X).) -Changes for v209: +Changes for v361: + +Bug fix for test cases + +Changes for v360: + +Stepper supports 'begin'. You'll never know it unless you use the +PLTSTEPPERUNSAFE environment variable, though. + +Changes for v351: + +Minor bug fixes + +Changes for v350: None. @@ -72,43 +66,60 @@ presence of mutation, it's no longer the case that the "finished" expressions never change, which means that they can't always be shared between the left and right hand sides. -Changes for v350: +Changes for v209: None. -Changes for v351: +Changes for v208: -Minor bug fixes +minor bug fixes. -Changes for v360: - -Stepper supports 'begin'. You'll never know it unless you use the -PLTSTEPPERUNSAFE environment variable, though. - -Changes for v361: - -Bug fix for test cases - -Changes for v370: - -Added "End" button to stepper interface. - -Stepper supports "begin0". Again, you'll never know it unless you use -the PLTSTEPPERUNSAFE environment variable. - -There's a known bug with expressions of the form (let (begin -...)). (It's displayed as (let () X) rather than (begin X). - -Changes for v371: +Changes for v207: None. -Changes for v372: support for check-expect, check-within, and check-error +Changes for v206p1: -Changes for v4.0: overhauled support for check-expect, check-within, -check-error. +None. -Changes for v4.0.1: none. +Changes for v206: -Changes for v4.1: none. +Stepper supports intermediate, minor bug fixes, major rewrite of interface + between reconstruct and display. +Changes for v205: + +v. minor bug fixes. + +Changes for v204: + +none. + +Changes for v203: + +Much more systematic unwinding, intermediate almost ready, redesigned test suite + +Changes for v201: + +Minor bug fixes. + +Changes for v200: + +Total rewrite for new syntax. Addition of test suites. +Addition of somewhat more systematic macro unwinding. +Lots of bug fixes. + +Changes for v103: + +PRs fixed: 1564, 1277, 1536, 1500, 1561, 1468, 1599, 1631 + +Changes for v102: + +Stepper handles intermediate level. +UI redesigned to use "side-by-side" reduction. + +Changes for v101: + +all steps scroll to bottom automatically. +constants like 'pi' are explicitly expanded in a step. +stepper uses fewer threads internally. From 33d52cb3796dcec2f9be4296b4a6ea5a6df84f52 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 30 Sep 2008 20:18:55 +0000 Subject: [PATCH 19/50] performance improvement svn: r11916 --- collects/htdp/world.ss | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/collects/htdp/world.ss b/collects/htdp/world.ss index daa3bea1c5..e79d2d6d38 100644 --- a/collects/htdp/world.ss +++ b/collects/htdp/world.ss @@ -918,9 +918,11 @@ Matthew (define m (mouse-event->symbol e)) (when (and (<= 0 x WIDTH) (<= 0 y HEIGHT)) (with-handlers ([exn:break? break-handler][exn? exn-handler]) - (set! the-world (f the-world x y m)) - (add-event MOUSE x y m) - (redraw-callback))))))) + (let ([new-world (f the-world x y m)]) + (unless (eq? new-world the-world) + (set! the-world new-world) + (add-event MOUSE x y m) + (redraw-callback))))))))) ;; MouseEvent -> MouseEventType (define (mouse-event->symbol e) From 086f3c3b44b14ec2d6071ec3609c1f5ccc255c50 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 30 Sep 2008 22:03:55 +0000 Subject: [PATCH 20/50] fix int-def context binding problems, fix scheme/splicing, change rnrs/base-6 to use scheme/splicing svn: r11917 --- collects/rnrs/base-6.ss | 51 +++----------- collects/scheme/splicing.ss | 56 +++++++-------- collects/tests/mzscheme/syntax.ss | 51 ++++++++++++++ src/mzscheme/src/stxobj.c | 110 +++++++++++++++++++++++------- 4 files changed, 170 insertions(+), 98 deletions(-) diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index f44e68ecc5..d8d5ebdbae 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -3,6 +3,7 @@ (require (for-syntax (rename-in r6rs/private/base-for-syntax [syntax-rules r6rs:syntax-rules]) scheme/base) + scheme/splicing r6rs/private/qq-gen r6rs/private/exns (prefix-in r5rs: r5rs) @@ -546,54 +547,20 @@ ;; ---------------------------------------- -;; let[rec]-syntax needs to be splicing, ad it needs the +;; let[rec]-syntax needs to be splicing, and it needs the ;; same transformer wrapper as in `define-syntax' -(define-for-syntax (do-let-syntax stx rec?) +(define-syntax (r6rs:let-syntax stx) (syntax-case stx () [(_ ([id expr] ...) body ...) - (if (eq? 'expression (syntax-local-context)) - (with-syntax ([let-stx (if rec? - #'letrec-syntax - #'let-syntax)]) - (syntax/loc stx - (let-stx ([id (wrap-as-needed expr)] ...) - (#%expression body) - ...))) - (let ([sli (if (list? (syntax-local-context)) - syntax-local-introduce - values)]) - (let ([ids (map sli (syntax->list #'(id ...)))] - [def-ctx (syntax-local-make-definition-context)] - [ctx (list (gensym 'intdef))]) - (syntax-local-bind-syntaxes ids #f def-ctx) - (let* ([add-context - (lambda (expr) - (let ([q (local-expand #`(quote #,expr) - ctx - (list #'quote) - def-ctx)]) - (syntax-case q () - [(_ expr) #'expr])))]) - (with-syntax ([(id ...) - (map sli (map add-context ids))] - [(expr ...) - (let ([exprs (syntax->list #'(expr ...))]) - (if rec? - (map add-context exprs) - exprs))] - [(body ...) - (map add-context (syntax->list #'(body ...)))]) - #'(begin - (define-syntax id (wrap-as-needed expr)) - ... - body ...))))))])) - -(define-syntax (r6rs:let-syntax stx) - (do-let-syntax stx #f)) + (syntax/loc stx + (splicing-let-syntax ([id (wrap-as-needed expr)] ...) body ...))])) (define-syntax (r6rs:letrec-syntax stx) - (do-let-syntax stx #t)) + (syntax-case stx () + [(_ ([id expr] ...) body ...) + (syntax/loc stx + (splicing-letrec-syntax ([id (wrap-as-needed expr)] ...) body ...))])) ;; ---------------------------------------- diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss index 906587efd1..7124f054be 100644 --- a/collects/scheme/splicing.ss +++ b/collects/scheme/splicing.ss @@ -49,36 +49,32 @@ (let-stx ([ids expr] ...) (#%expression body) ...))) - (let ([sli (if (list? (syntax-local-context)) - syntax-local-introduce - values)]) - (let ([all-ids (map (lambda (ids) (map sli ids)) all-ids)] - [def-ctx (syntax-local-make-definition-context)] - [ctx (list (gensym 'intdef))]) - (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) - (let* ([add-context - (lambda (expr) - (let ([q (local-expand #`(quote #,expr) - ctx - (list #'quote) - def-ctx)]) - (syntax-case q () - [(_ expr) #'expr])))]) - (with-syntax ([((id ...) ...) - (map (lambda (ids) - (map sli (map add-context ids))) - all-ids)] - [(expr ...) - (let ([exprs (syntax->list #'(expr ...))]) - (if rec? - (map add-context exprs) - exprs))] - [(body ...) - (map add-context (syntax->list #'(body ...)))]) - #'(begin - (define-syntaxes (id ...) expr) - ... - body ...)))))))])) + (let ([def-ctx (syntax-local-make-definition-context)] + [ctx (list (gensym 'intdef))]) + (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) + (let* ([add-context + (lambda (expr) + (let ([q (local-expand #`(quote #,expr) + ctx + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ expr) #'expr])))]) + (with-syntax ([((id ...) ...) + (map (lambda (ids) + (map add-context ids)) + all-ids)] + [(expr ...) + (let ([exprs (syntax->list #'(expr ...))]) + (if rec? + (map add-context exprs) + exprs))] + [(body ...) + (map add-context (syntax->list #'(body ...)))]) + #'(begin + (define-syntaxes (id ...) expr) + ... + body ...))))))])) (define-syntax (splicing-let-syntax stx) (do-let-syntax stx #f #f)) diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss index f13f177a17..b3cf53c677 100644 --- a/collects/tests/mzscheme/syntax.ss +++ b/collects/tests/mzscheme/syntax.ss @@ -1128,6 +1128,57 @@ ((car procs) 'x2 'z2) ((cadr procs) 'x10 'z10)))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(require scheme/splicing) + +(define abcdefg 10) +(test 12 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) 12])]) + (abcdefg))) +(test 13 'splicing-letrec-syntax (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) (abcdefg 10)] + [(_ x) (+ 3 x)])]) + (abcdefg))) +(test 13 'splicing-letrec-syntax (let ([abcdefg 9]) + (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) (abcdefg 10)] + [(_ x) (+ 3 x)])]) + (abcdefg)))) +(test 12 'splicing-let-syntax (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 12])]) + (abcdefg))) +(test 12 'splicing-let-syntax (let ([abcdefg (lambda () 9)]) + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 12])]) + (abcdefg)))) +(test 11 'splicing-let-syntax (let ([abcdefg (lambda (x) x)]) + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) (+ 2 (abcdefg 9))] + [(_ ?) 77])]) + (abcdefg)))) +(splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 8])]) + (define hijklmn (abcdefg))) +(test 8 'hijklmn hijklmn) +(test 30 'local-hijklmn (let () + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 8])]) + (define hijklmn (abcdefg))) + (define other 22) + (+ other hijklmn))) +(test 8 'local-hijklmn (let () + (splicing-let-syntax ([abcdefg (syntax-rules () + [(_) 8])]) + (begin + (define hijklmn (abcdefg)) + hijklmn)))) + +(test 9 'splicing-letrec-syntax (let ([abcdefg (lambda () 9)]) + (splicing-letrec-syntax ([abcdefg (syntax-rules () + [(_) 0])]) + (define x 10)) + (abcdefg))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 41a2e8ee5c..c483f01bc6 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -3247,6 +3247,35 @@ static Module_Renames *extract_renames(Module_Renames_Set *mrns, Scheme_Object * return NULL; } +static int nonempty_rib(Scheme_Lexical_Rib *rib) +{ + rib = rib->next; + + while (rib) { + if (SCHEME_RENAME_LEN(rib->rename)) + return 1; + rib = rib->next; + } + + return 0; +} + +static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) +{ + while (skip_ribs) { + if (SAME_OBJ(SCHEME_CAR(skip_ribs), timestamp)) + return 1; + skip_ribs = SCHEME_CDR(skip_ribs); + } + + return 0; +} + +static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) +{ + return scheme_make_raw_pair(timestamp, skip_ribs); +} + #define QUICK_STACK_SIZE 10 #define EXPLAIN_RESOLVE 0 @@ -3275,7 +3304,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, If neither, result is #f and get_names[0] is either unchanged or NULL. */ { WRAP_POS wraps; - Scheme_Object *o_rename_stack = scheme_null; + Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs; Scheme_Object *mresult = scheme_false; Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; Scheme_Object *rename_stack[QUICK_STACK_SIZE]; @@ -3286,7 +3315,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *bdg = NULL, *floating = NULL; Scheme_Hash_Table *export_registry = NULL; - EXPLAIN(printf("Resolving %s:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)))); + EXPLAIN(printf("Resolving %s [skips: %s]:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), + scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); if (_wraps) { WRAP_POS_COPY(wraps, *_wraps); @@ -3553,17 +3583,15 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else if (rib || (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) && !no_lexical)) { /* Lexical rename: */ - Scheme_Object *rename, *renamed, *recur_skip_ribs; + Scheme_Object *rename, *renamed; int ri, c, istart, iend, is_rib; if (rib) { rename = rib->rename; - recur_skip_ribs = rib->timestamp; rib = rib->next; is_rib = 1; } else { rename = WRAP_POS_FIRST(wraps); - recur_skip_ribs = skip_ribs; is_rib = 0; } @@ -3658,19 +3686,23 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, rib = (Scheme_Lexical_Rib *)WRAP_POS_FIRST(wraps); EXPLAIN(printf("Rib: %p...\n", rib)); if (skip_ribs) { - if (scheme_bin_gt_eq(rib->timestamp, skip_ribs)) { + if (in_skip_set(rib->timestamp, skip_ribs)) { EXPLAIN(printf("Skip rib\n")); rib = NULL; } } if (rib) { - if (SAME_OBJ(did_rib, rib)) { - EXPLAIN(printf("Did rib\n")); - rib = NULL; - } else { - did_rib = rib; - rib = rib->next; /* First rib record has no rename */ - } + if (nonempty_rib(rib)) { + if (SAME_OBJ(did_rib, rib)) { + EXPLAIN(printf("Did rib\n")); + rib = NULL; + } else { + recur_skip_ribs = add_skip_set(rib->timestamp, recur_skip_ribs); + did_rib = rib; + rib = rib->next; /* First rib record has no rename */ + } + } else + rib = NULL; } } else if (SCHEME_NUMBERP(WRAP_POS_FIRST(wraps))) { did_rib = NULL; @@ -4372,7 +4404,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca WRAP_POS w; WRAP_POS prev; WRAP_POS w2; - Scheme_Object *stack = scheme_null, *key, *old_key; + Scheme_Object *stack = scheme_null, *key, *old_key, *skip_ribs = scheme_null, *orig_skip_ribs; Scheme_Object *v, *v2, *v2l, *stx, *name, *svl; long size, vsize, psize, i, j, pos; @@ -4380,9 +4412,15 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca we can simplify it in the context of a particular wrap suffix. (But don't mutate the wrap list, because that will stomp on tables that might be needed by a propoagation.) + + In addition to depending on the rest of the wraps, a + simplifciation can depend on preceding wraps due to rib + skipping. So the lex_cache maps a wrap to another hash table that + maps a skip list to a simplified rename. A lex_cache maps wrap starts w to simplified tables. A lex_cache - is modified by this function, only. */ + is modified by this function, only, but it's also read in + datum_to_wraps. */ WRAP_POS_INIT(w, wraps); WRAP_POS_INIT_END(prev); @@ -4396,9 +4434,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca key = WRAP_POS_KEY(w); if (!SAME_OBJ(key, old_key)) { v = scheme_hash_get(lex_cache, key); + if (v) + v = scheme_hash_get((Scheme_Hash_Table *)v, skip_ribs); } else v = NULL; old_key = key; + orig_skip_ribs = skip_ribs; if (v) { /* Tables here are already simplified. */ @@ -4412,6 +4453,8 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca if (SCHEME_RIBP(v)) { /* A rib certainly isn't simplified yet. */ add = 1; + if (nonempty_rib((Scheme_Lexical_Rib *)v)) + skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)v)->timestamp, skip_ribs); } else { /* Need to simplify this vector? */ if (SCHEME_VEC_SIZE(v) == 1) @@ -4425,7 +4468,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca if (add) { /* Need to simplify, but do deepest first: */ if (SCHEME_NULLP(stack) || !SAME_OBJ(SCHEME_CAR(stack), key)) { - stack = CONS(key, stack); + stack = CONS(CONS(key, orig_skip_ribs), stack); } } else { /* This is already simplified. Remember it and stop, because @@ -4442,8 +4485,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca while (!SCHEME_NULLP(stack)) { key = SCHEME_CAR(stack); + orig_skip_ribs = SCHEME_CDR(key); + key = SCHEME_CAR(key); v2l = scheme_null; + skip_ribs = orig_skip_ribs; + WRAP_POS_REVINIT(w, key); while (!WRAP_POS_REVEND_P(w)) { @@ -4460,14 +4507,15 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca if (SCHEME_RIBP(v)) { init_rib = (Scheme_Lexical_Rib *)v; - skip_ribs = init_rib->timestamp; - rib = init_rib->next; - vsize = 0; - while (rib) { - vsize += SCHEME_RENAME_LEN(rib->rename); - rib = rib->next; - } - rib = init_rib->next; + if (nonempty_rib(init_rib)) + skip_ribs = scheme_make_pair(init_rib->timestamp, skip_ribs); + rib = init_rib->next; + vsize = 0; + while (rib) { + vsize += SCHEME_RENAME_LEN(rib->rename); + rib = rib->next; + } + rib = init_rib->next; } else vsize = SCHEME_RENAME_LEN(v); @@ -4611,7 +4659,12 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca WRAP_POS_DEC(w); } - scheme_hash_set(lex_cache, key, v2l); + v = scheme_hash_get(lex_cache, key); + if (!v) { + v = (Scheme_Object *)scheme_make_hash_table_equal(); + scheme_hash_set(lex_cache, key, v); + } + scheme_hash_set((Scheme_Hash_Table *)v, skip_ribs, v2l); stack = SCHEME_CDR(stack); } @@ -4622,7 +4675,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, Scheme_Hash_Table *rns, int just_simplify) { - Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null; + Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null, *skip_ribs = scheme_null; WRAP_POS w; Scheme_Hash_Table *lex_cache, *reverse_map; int stack_size = 0; @@ -4690,8 +4743,13 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, of simplified tables for the current wrap segment. */ if (SCHEME_NULLP(simplifies)) { simplifies = scheme_hash_get(lex_cache, old_key); + simplifies = scheme_hash_get((Scheme_Hash_Table *)simplifies, skip_ribs); /* assert: a is not NULL; see the simplify_lex_rename() call above */ } + if (SCHEME_RIBP(a)) { + if (nonempty_rib((Scheme_Lexical_Rib *)a)) + skip_ribs = scheme_make_pair(((Scheme_Lexical_Rib *)a)->timestamp, skip_ribs); + } a = SCHEME_CAR(simplifies); /* used up one simplification: */ simplifies = SCHEME_CDR(simplifies); From 1097cb35a66d2acf37edccfd75940070a25192a9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Oct 2008 13:03:06 +0000 Subject: [PATCH 21/50] add ++xref-in flag to scribble svn: r11918 --- collects/scribble/run.ss | 68 +++++++++++++++++++++++++++++----------- 1 file changed, 50 insertions(+), 18 deletions(-) diff --git a/collects/scribble/run.ss b/collects/scribble/run.ss index 28e08c4df8..e2bd9ccf61 100644 --- a/collects/scribble/run.ss +++ b/collects/scribble/run.ss @@ -2,6 +2,7 @@ (module run mzscheme (require "struct.ss" "base-render.ss" + "xref.ss" mzlib/cmdline mzlib/class mzlib/file @@ -29,11 +30,21 @@ (make-parameter #f)) (define current-info-input-files (make-parameter null)) + (define current-xref-input-modules + (make-parameter null)) (define current-style-file (make-parameter #f)) (define current-redirect (make-parameter #f)) + (define (read-one str) + (let ([i (open-input-string str)]) + (with-handlers ([exn:fail:read? (lambda (x) #f)]) + (let ([v (read i)]) + (if (eof-object? (read i)) + v + #f))))) + (define (get-command-line-files argv) (command-line "scribble" @@ -59,9 +70,23 @@ [("--info-out") file "write format-specific link information to " (current-info-output-file file)]] [multi - [("++info-in") file "load format-specific link information form " + [("++info-in") file "load format-specific link information from " (current-info-input-files - (cons file (current-info-input-files)))]] + (cons file (current-info-input-files)))] + [("++xref-in") module-path proc-id "load format-specific link information by" + "calling as exported by " + (let ([mod (read-one module-path)] + [id (read-one proc-id)]) + (unless (module-path? mod) + (raise-user-error 'scribble + "bad module path for ++ref-in: ~s" + module-path)) + (unless (symbol? id) + (raise-user-error 'scribble + "bad procedure identifier for ++ref-in: ~s" + proc-id)) + (current-xref-input-modules + (cons (cons mod id) (current-xref-input-modules))))]] [args (file . another-file) (cons file another-file)])) (define (build-docs-files files) @@ -90,19 +115,26 @@ fn)))) files)] [info (send renderer collect docs fns)]) - (let ([info (let loop ([info info] - [files (reverse (current-info-input-files))]) - (if (null? files) - info - (loop (let ([s (with-input-from-file (car files) read)]) - (send renderer deserialize-info s info) - info) - (cdr files))))]) - (let ([r-info (send renderer resolve docs fns info)]) - (send renderer render docs fns r-info) - (when (current-info-output-file) - (let ([s (send renderer serialize-info r-info)]) - (with-output-to-file (current-info-output-file) - (lambda () - (write s)) - 'truncate/replace)))))))))) + (for-each (lambda (file) + (let ([s (with-input-from-file file read)]) + (send renderer deserialize-info s info))) + (reverse (current-info-input-files))) + (for-each (lambda (mod+id) + (let ([get-xref (dynamic-require (car mod+id) (cdr mod+id))]) + (let ([xr (get-xref)]) + (unless (xref? xr) + (raise-user-error 'scribble + "result from `~s' of `~s' is not an xref: ~e" + (cdr mod+id) + (car mod+id) + xr)) + (xref-transfer-info renderer info xr)))) + (reverse (current-xref-input-modules))) + (let ([r-info (send renderer resolve docs fns info)]) + (send renderer render docs fns r-info) + (when (current-info-output-file) + (let ([s (send renderer serialize-info r-info)]) + (with-output-to-file (current-info-output-file) + (lambda () + (write s)) + 'truncate/replace))))))))) From 01c2214d802977d2c2eac05f177abe88d9ef714d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Oct 2008 15:54:36 +0000 Subject: [PATCH 22/50] doc clarifications on dc-path svn: r11919 --- collects/scribblings/gui/dc-intf.scrbl | 17 ++++++++++------- collects/scribblings/gui/dc-path-class.scrbl | 3 ++- collects/scribblings/gui/gui.scrbl | 13 +++++++++++++ 3 files changed, 25 insertions(+), 8 deletions(-) diff --git a/collects/scribblings/gui/dc-intf.scrbl b/collects/scribblings/gui/dc-intf.scrbl index 14a73d9b27..92b6c4c97b 100644 --- a/collects/scribblings/gui/dc-intf.scrbl +++ b/collects/scribblings/gui/dc-intf.scrbl @@ -199,9 +199,10 @@ See also @method[dc<%> set-smoothing] for information on the void?]{ Draws the sub-paths of the given @scheme[dc-path%] object, adding - @scheme[xoffset] and @scheme[yoffset] to each point. The current pen - is used for drawing the path as a line, and the current brush is used - for filling the area bounded by the path. + @scheme[xoffset] and @scheme[yoffset] to each point. (See + @scheme[dc-path%] for general information on paths and sub-paths.) + The current pen is used for drawing the path as a line, and the + current brush is used for filling the area bounded by the path. If both the pen and brush are non-transparent, the path is filled with the brush before the outline is drawn with the pen. The filling and @@ -350,11 +351,13 @@ See also @method[dc<%> set-smoothing] for information on the [y3 real?]) void?]{ -Draws a spline from (@scheme[x1], @scheme[y1]) to (@scheme[x3], @scheme[y3]) - using (@scheme[x2], @scheme[y2]) as the control point. +@index['("drawing curves")]{Draws} a spline from (@scheme[x1], + @scheme[y1]) to (@scheme[x3], @scheme[y3]) using (@scheme[x2], + @scheme[y2]) as the control point. See also @method[dc<%> set-smoothing] for information on the -@scheme['aligned] smoothing mode. + @scheme['aligned] smoothing mode. See also @scheme[dc-path%] and + @method[dc<%> draw-path] for drawing more complex curves. @|DrawSizeNote| @@ -918,7 +921,7 @@ Starts a page, relevant only when drawing to a printer or PostScript device (including to a PostScript file). For printer or PostScript output, an exception is raised if - @scheme[start-doc] is called when a page is already started, or when + @scheme[start-page] is called when a page is already started, or when @method[dc<%> start-doc] has not been called, or when @method[dc<%> end-doc] has been called already. In addition, in the case of PostScript output, Encapsulated PostScript (EPS) cannot contain diff --git a/collects/scribblings/gui/dc-path-class.scrbl b/collects/scribblings/gui/dc-path-class.scrbl index 131bf593f8..e37bf31158 100644 --- a/collects/scribblings/gui/dc-path-class.scrbl +++ b/collects/scribblings/gui/dc-path-class.scrbl @@ -14,7 +14,8 @@ A path consists of zero or more @deftech{closed sub-paths}, and possibly one @deftech{open sub-path}. Some @scheme[dc-path%] methods extend the open sub-path, some @scheme[dc-path%] methods close the open sub-path, and some @scheme[dc-path%] methods add closed - sub-paths. + sub-paths. This approach to drawing formulation is inherited from + PostScript @cite["Adobe99"]. When a path is drawn as a line, a closed sub-path is drawn as a closed figure, analogous to a polygon. An open sub-path is drawn with diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index 0b319e650e..aadaf8f21e 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -31,6 +31,19 @@ provides; this library cannot run in MzScheme.} @include-section["config.scrbl"] @include-section["dynamic.scrbl"] + +@;------------------------------------------------------------------------ + +@(bibliography + + (bib-entry #:key "Adobe99" + #:author "Adobe Systems Incorporated" + #:title @italic{PostScript Language Reference, third edition} + #:url "http://partners.adobe.com/public/developer/en/ps/PLRM.pdf" + #:date "1999") + + ) + @;------------------------------------------------------------------------ @index-section[] From 7c88dd9c2afe766c39b09e530024b7df31dad7e1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Oct 2008 15:56:17 +0000 Subject: [PATCH 23/50] fix PS citation typesetting svn: r11920 --- collects/scribblings/gui/gui.scrbl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index aadaf8f21e..06abcca664 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -38,7 +38,8 @@ provides; this library cannot run in MzScheme.} (bib-entry #:key "Adobe99" #:author "Adobe Systems Incorporated" - #:title @italic{PostScript Language Reference, third edition} + #:title "PostScript Language Reference, third edition" + #:is-book? #t #:url "http://partners.adobe.com/public/developer/en/ps/PLRM.pdf" #:date "1999") From 6c2f070bb80a3fda26267730da577d10e72ae430 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Oct 2008 15:59:46 +0000 Subject: [PATCH 24/50] fix docs for bib-entry svn: r11921 --- collects/scribblings/scribble/manual.scrbl | 17 ++++++++++------- 1 file changed, 10 insertions(+), 7 deletions(-) diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index d0bb66dcdb..05981f761e 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -970,9 +970,9 @@ order as given} @defproc[(bib-entry [#:key key string?] [#:title title any/c] [#:is-book? is-book? any/c #f] - [#:author author any/c] - [#:location location any/c] - [#:date date any/c] + [#:author author any/c #f] + [#:location location any/c #f] + [#:date date any/c #f] [#:url url any/c #f]) bib-entry?]{ @@ -990,18 +990,21 @@ the entry: order (as opposed to ``last, first''), and separate multiple names with commas using ``and'' before the last name (where there are multiple names). The @scheme[author] is typeset in - the bibliography as given.} + the bibliography as given, or it is omitted if given as + @scheme[#f].} @item{@scheme[location] names the publication venue, such as a conference name or a journal with volume, number, and pages. The @scheme[location] is typeset in the bibliography as - given.} + given, or it is omitted if given as @scheme[#f].} @item{@scheme[date] is a date, usually just a year (as a string). It - is typeset in the bibliography as given.} + is typeset in the bibliography as given, or it is omitted if + given as @scheme[#f].} @item{@scheme[url] is an optional URL. It is typeset in the - bibliography using @scheme[tt] and hyperlinked.} + bibliography using @scheme[tt] and hyperlinked, or it is + omitted if given as @scheme[#f].} }} From 37d6c770661a88696d065a0f0658678759d7cdd4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Oct 2008 16:04:05 +0000 Subject: [PATCH 25/50] fix docs for bibliography svn: r11922 --- collects/scribblings/scribble/manual.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 05981f761e..3676d8549e 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -959,13 +959,13 @@ combination of @scheme[envvar] and @scheme[as-index].} Links to a bibliography entry, using @scheme[key] both to indicate the bibliography entry and, in square brackets, as the link text.} -@defproc[(bibliography [#:tag string? "doc-bibliography"] +@defproc[(bibliography [#:tag tag string? "doc-bibliography"] [entry bib-entry?] ...) part?]{ Creates a bibliography part containing the given entries, each of which is created with @scheme[bib-entry]. The entries are typeset in -order as given} +order as given.} @defproc[(bib-entry [#:key key string?] [#:title title any/c] From ab864d488838205c04171382fa1fafabb24828bd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 1 Oct 2008 22:17:45 +0000 Subject: [PATCH 26/50] declare htdp/image as original source for docs svn: r11923 --- collects/teachpack/htdp/scribblings/image.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/teachpack/htdp/scribblings/image.scrbl b/collects/teachpack/htdp/scribblings/image.scrbl index 31a73a6395..08b0f8450d 100644 --- a/collects/teachpack/htdp/scribblings/image.scrbl +++ b/collects/teachpack/htdp/scribblings/image.scrbl @@ -8,7 +8,7 @@ @teachpack["image"]{Manipulating Images} -@declare-exporting[teachpack/htdp/image] +@declare-exporting[teachpack/htdp/image #:use-sources (htdp/image)] The teachpack provides primitives for constructing and manipulating images. Basic, colored images are created as outlines or solid From e99645136b08ae07b4d1233427dae4b7a57d75df Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 2 Oct 2008 11:54:03 +0000 Subject: [PATCH 27/50] fix sirmail header checking, since encoding was moved to later svn: r11924 --- collects/sirmail/sendr.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/sirmail/sendr.ss b/collects/sirmail/sendr.ss index bb2b1c250b..3f648394e6 100644 --- a/collects/sirmail/sendr.ss +++ b/collects/sirmail/sendr.ss @@ -741,7 +741,7 @@ [body-lines (regexp-split #rx"\n" (substring message-str (cdar m) (string-length message-str)))]) - (validate-header header) + (validate-header (regexp-replace #rx"[^\x0-\xFF]" header "_")) (let* ([to* (sm-extract-addresses (extract-field "To" header))] [to (map encode-for-header (map car to*))] [cc* (sm-extract-addresses (extract-field "CC" header))] @@ -762,6 +762,8 @@ [new-header (append-headers std-header prop-header)] [tos (map cdr (append to* cc* bcc*))]) + (validate-header new-header) + (as-background enable (lambda (break-bad break-ok) From a7217aed0e936d0d9a5246bc4abf796002074f2a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 2 Oct 2008 19:49:33 +0000 Subject: [PATCH 28/50] improved error checking when the response is badly malformed svn: r11925 --- collects/planet/resolver.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/planet/resolver.ss b/collects/planet/resolver.ss index 2725b9b052..5cdb3a166c 100644 --- a/collects/planet/resolver.ss +++ b/collects/planet/resolver.ss @@ -628,7 +628,7 @@ subdirectory. (min-hi . ,(get pkg-spec-minor-hi)) (path . ,(get pkg-spec-path))))) -;; get-http-response-code : header[from net/head] -> string +;; get-http-response-code : header[from net/head] -> string or #f ;; gets the HTTP response code in the given header (define (get-http-response-code header) (let ([parsed (regexp-match #rx"^HTTP/[^ ]* ([^ ]*)" header)]) @@ -656,7 +656,8 @@ subdirectory. [ip (get-impure-port target)] [head (purify-port ip)] [response-code/str (get-http-response-code head)] - [response-code (string->number response-code/str)]) + [response-code (and response-code/str + (string->number response-code/str))]) (define (abort msg) (close-input-port ip) From df9ce08681f336b653e0b4187ff8cfebbd28d53f Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 2 Oct 2008 20:21:15 +0000 Subject: [PATCH 29/50] revised world documentation svn: r11926 --- collects/teachpack/door-real.png | Bin 0 -> 4851 bytes collects/teachpack/door-sim.png | Bin 0 -> 5106 bytes .../teachpack/htdp/scribblings/world.scrbl | 343 +++++++++++++++++- collects/teachpack/world.png | Bin 0 -> 19925 bytes 4 files changed, 330 insertions(+), 13 deletions(-) create mode 100644 collects/teachpack/door-real.png create mode 100644 collects/teachpack/door-sim.png create mode 100644 collects/teachpack/world.png diff --git a/collects/teachpack/door-real.png b/collects/teachpack/door-real.png new file mode 100644 index 0000000000000000000000000000000000000000..1514131ad0aeffea24c079438aabb3d0c6832c2d GIT binary patch literal 4851 zcmb7IcTiJJyFV0ZQlcUVNRy6&O7*2kM+hx1h9X6}B7`D@-a-cvQ949Q2t_Hk3 z(2#@cgthAr2)g(|TU`a|`+6%+k12itaVAu;#PGTsKqa5ywP{@kR*PPbn4Z z{Z7zBCCShCo*bu4(C_*$AML> zWL-Tku~?2PSMK=lkeo-~J&|H3JWLo3N&q@v=wll688b3V)!kZr`X?h#o)s@#*olL9Du=k0QR&&?Oqvf)+_?=u_9R3lXUAE1twQ31IDKoG44~gpO=~?VeQ*yJYH6x&xhx)Uq zJUzGT>gtvhvA1nnEG4A$bOQqetE#I5LZZN4%uP)d+$MT@;Lw|rk`+Dp4NUmZP~7_b zfUugmxw(f&Ra{&gQdCb@7xm;xYi9zt()!Yp5KA1PscC(>g?OCQ(a|C8JTf!7|9hHS zDY&VuY|Y$_P%!AY(b^u(#KfiGJCLga;%c+qxO0)+VXVSNO&7l2 z=#RI$y1JHDj4JMq-&Q^zkH;PNXUThddZvk6KAUbnJN+{|J6ljt;8e?gcJQ{O#Js`X z#>wf|+K+l{W@b#_+sEy}kum-#j;5w2dc{VUA9dOVh7ki>i@gFDwF3egaSE;+;+7v4 zR#z>IjiZ=~hn<|ASLWvCwzjrvokzt@DE8BsiWY+Jrmc>S4jL^LyfQye0X^=2%_i-{ ztTTRg-7&cpG{kONax(puTgp7JJM!{A;{>>l&Usqej5|-~ux`z?5D3HC+FFr*mWPLj zMDi;w{*dEMYWeOnc}EmSTU#4ABWd<{O?-Dx4;=%;ISh$J0*l_+K}W#WBj(%eK0hC? zcbk6wk0;&v^JE{Vr>A>+SHOE)83H^#B_T>`>ZPTn`KZ}#qLR@57ypP8x(mBwG73RQ z=&gnB1Ky5~*h|;1Uw;}3(uOWl)x^Z)-o4JSF!Dz&ywcLc z@6DF0EG$tlkaAfvE}0n_8A(ZB-&rXcE&AQeu!mt?@gg=f2^A7&22XNxb3cxbrXkT15;T#j zue2gU+U~cVp8R>-m#!izS7`-L64bkPr+GTGs;a85uMeb6qHfqp4mAz#y2(4!2M;c@ zvR;bq&#$XvftpYD%&!fGu2wrnz_OX1F7yL8U5)Y-V3%^z^Y)Vz-V?+JuOQwUXt2i^A&+1sKhvQ6k zv(4W6B=*%S+}GtAvo)~#m<8qE)>O_QF?jg-7rI{Y`Pw>rc}ZgjX_+1k@Tu9^;Z1M+ z-1G%0kJpShEEz^=F4-S&Yc00BIBQ&ZO^^K8t$gnPyp{HB%(RBzFVf#Fvt&21_xdkdr9b8L}F6X z0Wr z-n{7&W@9hT>`lAbviX^#k945A^z-N3XkpA0=f}3AD8Nep;x%b0!|o+;-A>?^_ojzR z%gTa+fs`2|GzT4Wxr3@)bHq-dKIpEQ3Ma8XSRs0|li3B2|si}Fo)qAtg zES zJw(IE$Vf~3pwc!{8}Ac)n>(zorY0T08oOUinBDX>E2{&N(id)4HZn2sI*V54%a<>G zBn2*mqOa1jvUb|0;Q=fsO76tGe;RO#a{o<_d3eI(8ForVDcB}q?@iSp&mxYjL)H)9^Pf?78TKoNe>llEMaT$)r+)F$*|fD> z>`11yptF;GfL=`noF;y};VGYvWK9lru>(mS!5^-QqhVqK3FwJNPrUaO+QzRxmo_dn z1rm4LeMY&dhWw!}Q+x~0LBO~&fN)NZ6#_8;bShiHFU;qM%<6Z7>!h5O)pUtTdC#Ip zhHjn5B0K_NV}omK3{X>R|5{{_17;E>y?%XT;E)kc>FG`q;=bb!@gmL5uV0LnkdXN1 zv|E%DOef_s5Fg_+E!QC?EDT}5bCOJZsM3EC2x|uiuelCdwL{i^HHymWzWjZlhIez6 zTqhdV@2;Urd6T*g4GpjH@d+7ZHwEmw3JDdlep90$J>htrm9^`C@&zl~cwD1n#{eB1 z%qIYSG!h*a$_XT=XNm`qo&e#Hl)MD-U+kXmOc+1nI=g6Q4+wQ?Y6>gs=IZFE9P*nP zm8)YH4=hOveDT*WInSTEDe!YQYoe(J24#36=;-L02m}`tD&O!498Tw-S_v=|MIZzz zD`Rv8C0BEfZ2cU0=F|cv715>d-qlrCuXq$_Kel6tcxm_+?e0!OY-wx`Ky$si4Yvj8 zALBQf>=mUj)q@{j?hZixniRsD1DIwPyvm3g#Rcv@W#%zQ*#3aBR2PP3+!4Juz(Zrh z2KHYuDfUN(ol`*yrnnhA_qEpm(mCVN0YK-E9) z5<6>+t;55YfA4F(zAF}Pz55rlx|oe|||%zj7Si==1wwOK^~rljz8@QdRKD5%_d3ZoR!< zG%_+WNA~Ue_wRo>biDfU;nw1X3m5n_pVKffOx8TP1X+AQ1G_o--m?gY@ z&>faBH8=14^lAM2_x|+T_(pc6Ten~kBllg@m?h^A*XLJmx8DlpMFoXv2tQ398u?f93e1-%+&9#VxEA#`la^ybZSAgrjVCN}Qne(&~% zEB(az&1851F4on_iCw{WW31Bd(#4DP&PHRcNQs)dx;ZNmKR-XrP-X|z0Dq5VM&o3o~KH6F4yZ1usU$~`hu@&5( z5IkPx0NP&@4u4Q#-MTtn4ZQ19OG+q?MNCv!xWQ{>WQJ4b74Q}Dra7j{9QhYX)1dd06w^--% z3(kPeIgOteR?!Ya$>|tvp)O#TAc$UHGreDvH#_qGxa_udcVtSSL{uLIO_gA){sx(DCdK7g}ek?kXoi?Ty z0vd~uct)Nylh`Qm~0x94ffNyK7* zfWZBpcrR(+1=}m9QFNiOVH+uZu-!_{Ju^B+NY^91=b$lx$Fbhb{>QTrs47CZgKG=b z*1f^>XK$@the%FNPEW08<2iWvdIt$#aDc_Cx160eD)U^Ca(rnao+J5~ajN+lacTQG zbq+C2iyw$}^t*4E`bG@i8wS6YjjcIU#)%RPg_D+60WsIS$|Hod{cd1*vdilIcV_)bq zcx-r5C><$91&7eZ%6u6a@jlp?z4zj3D|J0;JTW;rIWci=VL{4cp{uP;HBf<%uf4ao zx4XOh)^)bDiRPe2AVFGMS{fSXGRg<#g;U6Qnc3JxQsBVPH2UxU0uH2i(E~z=rcg6+ zeOpEYpS8WQVOob`gMgV5;ODn@aLBqFBqt!CQD!`!xV*f4czCFEcI;_x&N21ym6O)4 zMLJrG;tZRXnmShx#N&*FPk^bG7?(YJ_N`KVaGNR6f-KOYpE3X;MXFrpmsjKG6|{PXqqpQ}GTJ&iK^RAFWd_6*EVP0dbU zhGb-9Bw(0>236e0n?Q6nr%0)(silw3juE2mA44fP*xBic6mU2k*kJkO)?oJbCc&$PxP-T~v>-(l0}pONpz?Uw9Ows-b$|zyV_Omrsu}Gh!Og>CP})sQ zOl&U^=gDuBb4k%9Pcf+CHln$M)8&2E>s)?t-3?3!RK>;hLTPT(7r2fe3Tj6CcZpwD zc0vEeix-3(c3p#;nW>GqMu%unom+DGpwX-D5yT~+1^ajN^o#6VxECI)M$!{}hGSx5 zTT4#QJ$j!M5{>*~3HT2crsal8q52=2C9RL6T literal 0 HcmV?d00001 diff --git a/collects/teachpack/door-sim.png b/collects/teachpack/door-sim.png new file mode 100644 index 0000000000000000000000000000000000000000..014d4a7a9a6b82b5c470cdadbc0fe70e5c5fc860 GIT binary patch literal 5106 zcmb7|i9b|-^#89VTWA`R%AV|58l>!F?3BjHge;RSi7X*mCfit&Jwyx=V@a}Q&CVpk z*gw`R*|RSxzVH5k-{bfFz8{adXYPGG?tS0)d7tw-&vPS;ZfUbHU1WkFh(%Wig$6bR z{8|~P!LcuZCmn*=s&!H77@zdDx6iO_9VZ=xCql3ff_&G5IDCk3B0K8z-By~9JnTky z#GOw06^%t=+J+*9D~j)uWK~pl^LO+6RW_d)MV(`>K>9;XKbrVy1@Uye3?bqje~z&e z3+GwSe(Tv;X*k{(HSpTsW^{FM@bOZQGqeJL-;2qlm(VmepFlJtZUl9G}R4-Ze#(eWsHG0#}d-e5mr zWYE*ogCNrn7V7YNsr_G54$_>|FCbk{HP+MW@PMYEQ?=f|wBWvcVq#*SEnJL^*>&wed&d%c>ZCb?NI&l&p$YuPq z+hQ+&G*Vevx!U5mAkX)$(UfJJA&0J|Wd`sFnj|4Ej*yo2$u(w~g)z(=|2@hxNZsmh z&40lV*~RubIyyQj>0Iy&eHER?`3^+|g?G8R57~zX2fI^bTE@r6TUusUN6S!I7LvCO z4WGKZUz3yjI~{yRmi1n(*IMP{|H9W04n3c1YF=HGbDC=KpDWeX)wPfu25zmZvq)2Q z{A^?;KGSGQv-KtiP4e^edo6i?Y+%51c|epS$^?z3<{xkHS0uFDc)FZuAS5m&WvVKO zKu|h5^2*BCkO!-y2z~vo`1p9>Uo$LLCl}2yGt)w-udnaw>MATO3=RrSQ5w> zQ&ZDnu%hqZZ_mc=?08>oXPw8cn=6p7REQJU;z zdmhb~VXeDwNDBTu{F-blz^JUCsi|pcX_=p$b2gZ4`w3gr-mWFsM?bUJm*erXNAn!_ zJ#QUHN0H|1^ncOD#vbeA)$?7+IR-($)94v&)YV^MC>i4nb4?``q!1 z&|2};kXX*>&FLl@3}fuTz`zp)E{vWUS1TUIL`%&RlN=lSWM$}TwZ$zr&uWW+m7!vg zqms!{MvUPWFH0JJM~*l;IgK^=*Oru&v?tJ>0&6?^{oCcg%Hq<}ID__qfy6&L7sA`r z%rDam$jHQzZH0t{K*Ihp&1e+OA(0;LEcQ)IOoWAnRa8{uXhmmB$krFU5;CuJ=D$0I zljal^6&(;(i`taRyPbKw(Q<|gisHBmX9@)ut=`M3kKEB2{{JZFCGZS8)Q3%6aW5r4Z?;9t3bKLZ(pAc4hOu908s|v^YVm$gp}|12m-y7k?HI1j{ajR2#-Kz zhn_wk?`CXl9C);Loxuj^Er{&B_$7THl^D!G2qRl_OG`_0Gb@i013xWXN#8_3G27Pghn}$o_(GT~Hn%VqPBMM;wMs zCQtcoceh7hLLd+zp`9N-)J^<3Hz#=I%AHik7hY1vT3T8$ysCTq`z1w1%&e>nPZVlu zY9Pqf)wQ^tn+b*lDgwd~oQ5K2rl%Y2%OXmQ?rT^Fe@H36=q+OLB|uqTes8Sek;lR}Q4x_8Fn0^#Ohm~$GzpnSRJpQd`Tp9qYpAZ{@yMn&KY6Ekz& z)0MklwsXoOhkm_J)XUY&?dJ@8;Oxu{Ev~N8LMUx*2V2{Nqaz^7j*1spfYQsj{b)_Q z?s_XlTD{(Hto-4P8#ma6x4D?sIeym%cJ}lLRo2$ll6afsVGw?Da)x&eeR8=I48rBe>Qpd<2(4v`AKF4D^M|0=m^d||1n_mD_x$a?cfo4vjL zfG}PTvlp(;a9+yNpva`j_L^xCR^4qU8Tpr&Rv?`+JU+fUH#b0`Jg~LJ7#nNM4^(Gu z*zX$NGdJ((=s=`?yQ2R(RmjgF4`sZ6!Dwhj*Nf|-_U$@5!@ ziR_Asist73RXiHr+u4E5r^!Ed_woYU{QK|zR7CvAy9CBY=PQ+4TkiMoPt48DfteyB zBVWB@-OcUsULBd4pMQF^x2EX5e(?ME`}gmW3{g>0Z`0Gq#>PMt{+=VVDNqY1sKY5@ z(098{dFK(}pCr92_p&9!3Jb*#^L?fpsm#sI8Eo#{i38#XlCe`GY|ZwX4$kb9wH;m) zZEAX+on6*w_KvCP&)HcGXCPdWZMbTS^_7*h*RSQD@2#dH9OUKXsN{qbIy*b}_PqMZ zv;^Io!T7hFA*N)tsVyI+Pv=NQMdcqq@(Eq?+Z%NN#DXRzrljjBq>lSHMV=FH3~VCP zD#~Q%#XafO-v-4m)!;oS_!SjT z!BTzGHg}dNB;!1|{d$7%Z6OY#vd025p=EP>dwX~Hs)U5#9#=*Jc{<|Z8T>Z70BE8> z9P^G=WpObJL{v$k+H<&bjafJ$S?K*0M?^w^58KiEe>SVz;FuRgizJ8^U_v@;HTWLe zXVdx00JBBiiUU-1w*Cb+H5KSsYDx;`?p^esVKs>`@M1cGNI-sDTU$FjJ6MS!P?tnm zS$g-z#zsfwWMzqwlgR+1_NM}^vWz^vy-yB*X6m>T+k9>Tk!+1%>v(wqfKgBSjbK4~ zvzI>yhKGfPg`fNQfO#s)%lXJJIA(8vs)8#W0n9Qun6ya9 zwW0RxJ~*Fk&u4(=n6;X;kXc<@<5dlKDdzj7t{TUA=@L-Xs>;f2J))GWOB$7QEqZrn zr@X4lquL_mMlVi@{!oso7Z+Q%gtOkwe^J*2d3N)ijcRk2zf_#u`Uv)5#PSMzl=_~+ za$@2?2~<>M(|DMv;(zht#jiiN&+w`!tzwMP=$hKvL%-u({bcZz2wO8V zGyCruYtz#kL*}l4^5VsfG8NpYBX|{{%RUt01Tv3mK%HY>_VfMqVzY{6a)K~ZC^eE3 z4$nrD!u{cJ_$zKjI(|V*x4d`nXzA!8QQ38MN&wveT9;xaIHLGN{8TbI)201?@7%BT z5>5J=k-@`YV`erMqk23-p|t$mR=jyL?CsSAvY@bTlvEv&N4jh$0FEI&-pW@dV;Y%mx=`!M}v$)zP_D{o~<$)3JG zxBhp!pfPBf5n*RCHm0PfbLFD%Sy@d@PG)3gW+o=KT1zuCGeZ!NDbQ?~SGgp0&7;b8 zY5);*y}tUOY_#=+k(EFh8mfFU(+qr`_U27PyPAeA3dj7z1Zl?8+R<^EHV8N|-eW~) zXLt9pv$LdC0~ZGeh&X!}7glI-ecfJ~b2(TQY{Q{nfRT}ruP^ZYkq&%_SYQ8^Q+Z-? zk`=Np#kyD50VuDm+>_I~aPuKco0^&c`dayIp1Q*Wha-EU0dfNLWoMuT zFO6c9sm`yi9&K!F932Je5olTEavy_9%*e<g?3HefxW7Cqtdj0AFQ`xlyPaY@D&9YgA{R>kdN+*p!Vbj8OV;)9%sK<(zm9 z4emLdb-y(ql!}!II9jWU z3mJmkx<^36c)0yjTucljW&&_No@;{y_!(Q_WMW_d`gh3$^1Dgqw|E!C@qB08WiKx; zv81oxzsE=nWOV3EA!dycklIbrOd^RyZfy;rc1;MF(C_c>@0?-FhZKrpiL7>$LJFUg z9r4MW1JBclPo?@GDVbQGG(J!8k9a@Fhz2t$ls~R7tL8jPWJS8Nm9Jm9IE_Xa74t?o zh3c?K7hIS&sWY^ca-7hYZPa9Dq1%){C-qy}e6NLip7eKazV8-gX$B$>Ia|h zf;yILL7&pt-EAns4nVBDyxeiM2qV^pbDPqYX*q4kf@1wV@Um%YWocz)f92W(YwKQb zA?4tvkENv-a2BCR^}l))nirv*EgSNOGX!2GWo2!ii^b0)=&-WW;2I+f3wLMSQj*$= zWi}ND4nj=|VgE%~&2A7Zw2IMeAI<{Zo#2l(b7h+Y!DKB=H_%YUsPZqaMCb-SRq0yo z!wn#8H0!gLrWI}lmd2k$ujzVm)~Bx0X#qp~zcte#@~;<(&rHIv``_GAH1#`B?V;J~ VLR-v6f^T_{uI4S&2c&h-{{ShH!E^us literal 0 HcmV?d00001 diff --git a/collects/teachpack/htdp/scribblings/world.scrbl b/collects/teachpack/htdp/scribblings/world.scrbl index 3c2842257a..f99fde8905 100644 --- a/collects/teachpack/htdp/scribblings/world.scrbl +++ b/collects/teachpack/htdp/scribblings/world.scrbl @@ -1,6 +1,8 @@ #lang scribble/doc -@(require scribble/manual "shared.ss" +@(require scribble/manual + "shared.ss" + scribble/struct (for-label scheme teachpack/htdp/image teachpack/htdp/world @@ -10,9 +12,15 @@ @emph{Note}: For a quick and educational introduction to the teachpack, see @link["http://www.ccs.neu.edu/home/matthias/HtDP/Prologue/book.html"]{How -to Design Programs, Second Edition: Prologue}. The purpose of this -documentation is to give experienced Schemers a concise overview for using -the library and for incorporating it elsewhere. +to Design Programs, Second Edition: Prologue}. As of August 2008, we also +have a series of projects available as a small booklet on +@link["http://world.cs.brown.edu/"]{How to Design Worlds}. + +The purpose of this documentation is to give experienced Schemers a concise +overview for using the library and for incorporating it elsewhere. The last +section presents a working example for an extremely simple domain and is +suited for a novice who knows how to design conditional functions for +symbols. The teachpack provides two sets of tools. The first allows students to create and display a series of animated scenes, i.e., a simulation. The @@ -20,6 +28,7 @@ second one generalizes the first by adding interactive GUI features. @declare-exporting[teachpack/htdp/world #:use-sources (teachpack/htdp/image)] +@; ----------------------------------------------------------------------------- @section[#:tag "basics"]{Basics} The teachpack assumes working knowledge of the basic image manipulation @@ -48,6 +57,7 @@ pinholes are at position @scheme[(0,0)]. @scheme[(x,y)] are comp. graph. coordinates, i.e., they count right and down from the upper-left corner.} +@; ----------------------------------------------------------------------------- @section[#:tag "simulations"]{Simple Simulations} @defproc[(run-simulation @@ -86,13 +96,28 @@ Example: @;----------------------------------------------------------------------------- @section[#:tag "interactive"]{Interactions} -An animation starts from a given ``world'' and generates new ones in response to events on the -computer. This teachpack keeps track of the ``current world'' and recognizes three kinds of events: -clock ticks; keyboard presses and releases; and mouse movements, mouse clicks, etc. Your program may -deal with such events via the @emph{installation} of @emph{handlers}. The teachpack provides for the -installation of three event handlers: @scheme[on-tick-event], @scheme[on-key-event], and -@scheme[on-mouse-event]. In addition, it provides for the installation of a @scheme[draw] handler, -which is called every time your program should visualize the current world. +An animation starts from a given ``world'' and generates new ones in + response to events on the computer. This teachpack keeps track of the + ``current world'' and recognizes three kinds of events: clock ticks; + keyboard presses and releases; and mouse movements, mouse clicks, + etc. + +Your program may deal with such events via the @emph{installation} of + @emph{handlers}. The teachpack provides for the installation of three + event handlers: @scheme[on-tick-event], @scheme[on-key-event], and + @scheme[on-mouse-event]. In addition, it provides for the installation of + a @scheme[draw] handler, which is called every time your program should + visualize the current world. + +The following picture provides an intuitive overview of the workings of + "world". + +@image["world.png"] + + The @scheme[big-bang] function installs @emph{World_0} as the initial + world; the callbacks @emph{tock}, @emph{react}, and @emph{click} transform + one world into another one; @emph{done} checks each time whether the world + is final; and @emph{draw} renders each world as a scene. @deftech{World} @scheme[any/c] @@ -191,10 +216,12 @@ Example: The following examples shows that @scheme[(run-simulation 100 100 Exercise: Add a condition for stopping the flight of the UFO when it reaches the bottom. +@; ----------------------------------------------------------------------------- @section{Scenes and Images} -For the creation of scenes from the world, use the functions from @secref["image"]. The following two -functions have turned out to be useful for the creation of scenes, too. +For the creation of scenes from the world, use the functions from +@secref["image"]. The following two functions have turned out to be useful +for the creation of scenes, too. @defproc[(nw:rectangle [width natural-number/c] [height natural-number/c] [solid-or-filled Mode] [c Color]) image?]{ @@ -209,3 +236,293 @@ functions have turned out to be useful for the creation of scenes, too. in contrast to the @scheme[add-line] function, this one cuts off those portions of the line that go beyond the boundaries of the given @scheme[s].} + +@; ----------------------------------------------------------------------------- + +@(define (table* . stuff) + ;; (list paragraph paragraph) *-> Table + (define (flow* x) (make-flow (list x))) + (make-blockquote 'blockquote + (list + (make-table (make-with-attributes 'boxed + '((cellspacing . "6"))) + ;list + (map (lambda (x) (map flow* x)) stuff) + #;(map flow* (map car stuff)) + #;(map flow* (map cadr stuff)))))) + +@; ----------------------------------------------------------------------------- +@section[#:tag "example"]{A First Example} + + +@subsection{Understanding a Door} + +Say we want to represent a door with an automatic door closer. If this kind + of door is locked, you can unlock it. While this doesn't open the door per + se, it is now possible to do so. That is, an unlocked door is closed and + pushing at the door opens it. Once you have passed through the door and + you let go, the automatic door closer takes over and closes the door + again. Of course, at this point you could lock it again. + +Here is a picture that translates our words into a graphical + representation: + +@image["door-real.png"] + +The picture displays a so-called "state machine". The three circled words + are the states that our informal description of the door identified: + locked, closed (and unlocked), and open. The arrows specify how the door + can go from one state into another. For example, when the door is open, + the automatic door closer shuts the door as time passes. This transition + is indicated by the arrow labeled "time passes." The other arrows + represent transitions in a similar manner: + +@itemize[ + +@item{"push" means a person pushes the door open (and let's go);} + +@item{"lock" refers to the act of inserting a key into the lock and turning +it to the locked position; and} + +@item{"unlock" is the opposite of "lock".} + +] + +@; ----------------------------------------------------------------------------- +@subsection{Simulations of the World} + +Simulating any dynamic behavior via a program demands two different + activities. First, we must tease out those portions of our "world" that + change over time or in reaction to actions, and we must develop a data + representation @deftech{D} for this information. Keep in mind that a good data + definition makes it easy for readers to map data to information in the + real world and vice versa. For all others aspects of the world, we use + global constants, including graphical or visual constants that are used in + conjunction with the rendering operations. + +Second, we must translate the "world" actions---the arrows in the above + diagram---into interactions with the computer that the world teachpack can + deal with. Once we have decided to use the passing of time for one aspect + and mouse movements for another, we must develop functions that map the + current state of the world---represented as data---into the next state of + the world. Since the data definition @tech{D} describes the class of data + that represents the world, these functions have the following general + contract and purpose statements: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; tick : @tech{D} -> @tech{D} +;; deal with the passing of time +(define (tick w) ...) + +;; click : @tech{D} @scheme{Number} @scheme{Number} @tech{MouseEvent} -> @tech{D} +;; deal with a mouse click at (x,y) of kind @scheme{me} +;; in the current world @scheme{w} +(define (click w x y me) ...) + +;; control : @tech{D} @tech{KeyEvent} -> @tech{D} +;; deal with a key event (symbol, char) @scheme{ke} +;; in the current world @scheme{w} +(define (control w ke) ...) +)) + +That is, the contracts of the various hooks dictate what the contracts of +these functions are once we have defined how to represent the world in +data. + +A typical program does not use all three of these actions and functions but + often just one or two. Furthermore, the design of these functions provides + only the top-level, initial design goal. It often demands the design of + many auxiliary functions. + +@; ----------------------------------------------------------------------------- +@subsection{Simulating a Door: Data} + +Our first and immediate goal is to represent the world as data. In this + specific example, the world consists of our door and what changes about + the door is whether it is locked, unlocked but closed, or open. We use + three symbols to represent the three states: + +@deftech{SD} + +@(begin +#reader scribble/comment-reader +(schemeblock +;; DATA DEF. +;; The state of the door (SD) is one of: +;; -- @scheme['locked] +;; -- @scheme['closed] +;; -- @scheme['open] +)) + +Symbols are particularly well-suited here because they directly express + the state of the door. + +Now that we have a data definition, we must also decide which computer + actions and interactions should model the various actions on the door. + Our pictorial representation of the door's states and transitions, + specifically the arrow from "open" to "closed" suggests the use of a + function that simulates time. For the other three arrows, we could use + either keyboard events or mouse clicks or both. Our solution uses three + keystrokes: +@scheme{#\u} for unlocking the door, +@scheme{#\l} for locking it, and +@scheme{#\space} for pushing it open. + We can express these choices graphically by translating the above "state + machine" from the world of information into the world of data: + +@image["door-sim.png"] + +@; ----------------------------------------------------------------------------- +@subsection{Simulating a Door: Functions} + +Our analysis and data definition leaves us with three functions to design: + +@itemize[ + +@item{@scheme{automatic-closer}, which closes the time during one tick;} + +@item{@scheme{door-actions}, which manipulates the time in response to +pressing a key; and} + +@item{@scheme{render}, which translates the current state of the door into +a visible scene.} + +] + +Let's start with @scheme{automatic-closer}. We know its contract and it is +easy to refine the purpose statement, too: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; automatic-closer : SD -> SD +;; closes an open door over the period of one tick +(define (automatic-closer state-of-door) ...) +)) + + Making up examples is trivial when the world can only be in one of three + states: + +@table*[ + @list[@t{ given state } @t{ desired state }] + @list[@t{ 'locked } @t{ 'locked }] + @list[@t{ 'closed } @t{ 'closed }] + @list[@t{ 'open } @t{ 'closed }] +] + +@(begin +#reader scribble/comment-reader +(schemeblock +;; automatic-closer : SD -> SD +;; closes an open door over the period of one tick + +(check-expect (automatic-closer 'locked) 'locked) +(check-expect (automatic-closer 'closed) 'closed) +(check-expect (automatic-closer 'open) 'closed) + +(define (automatic-closer state-of-door) ...) +)) + + The template step demands a conditional with three clauses: + +@(begin +#reader scribble/comment-reader +(schemeblock +(define (automatic-closer state-of-door) + (cond + [(symbol=? 'locked state-of-door) ...] + [(symbol=? 'closed state-of-door) ...] + [(symbol=? 'open state-of-door) ...])) +)) + + The examples basically dictate what the outcomes of the three cases must + be: + +@(begin +#reader scribble/comment-reader +(schemeblock +(define (automatic-closer state-of-door) + (cond + [(symbol=? 'locked state-of-door) 'locked] + [(symbol=? 'closed state-of-door) 'closed] + [(symbol=? 'open state-of-door) 'closed])) +)) + + Don't forget to run the example-tests. + +For the remaining three arrows of the diagram, we design a function that + reacts to the three chosen keyboard events. As mentioned, functions that + deal with keyboard events consume both a world and a keyevent: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; door-actions : SD Keyevent -> SD +;; key events simulate actions on the door +(define (door-actions s k) ...) +)) + +@table*[ + @list[@t{ given state } @t{ given keyevent } @t{ desired state }] + +@list[ @t{ 'locked } @t{ #\u } @t{ 'closed}] +@list[ @t{ 'closed } @t{ #\l } @t{ 'locked} ] +@list[ @t{ 'closed } @t{ #\space} @t{ 'open } ] +@list[ @t{ 'open } @t{ --- } @t{ 'open } ]] + + The examples combine what the above picture shows and the choices we made + about mapping actions to keyboard events. + +From here, it is straightforward to turn this into a complete design: + +@schemeblock[ +(define (door-actions s k) + (cond + [(and (symbol=? 'locked s) (key=? #\u k)) 'closed] + [(and (symbol=? 'closed s) (key=? #\l k)) 'locked] + [(and (symbol=? 'closed s) (key=? #\space k)) 'open] + [else s])) + +(check-expect (door-actions 'locked #\u) 'closed) +(check-expect (door-actions 'closed #\l) 'locked) +(check-expect (door-actions 'closed #\space) 'open) +(check-expect (door-actions 'open 'any) 'open) +(check-expect (door-actions 'closed 'any) 'closed) +] + +Last but not least we need a function that renders the current state of the +world as a scene. For simplicity, let's just use a large enough text for +this purpose: + +@(begin +#reader scribble/comment-reader +(schemeblock +;; render : @tech{SD} -> @scheme{Scene} +;; translate the current state of the door into a large text +(define (render s) + (text (symbol->string s) 40 'red)) + +(check-expecy (render 'closed) (text "closed" 40 'red)) +)) + The function @scheme{symbol->string} translates a symbol into a string, + which is needed because @scheme{text} can deal only with the latter, not + the former. A look into the language documentation revealed that this + conversion function exists, and so we use it. + +Once everything is properly designed, it is time to @emph{run} the +program. In the case of the world teachpack, this means we must specify +which function takes care of tick events, key events, and redraws: + +@(begin +#reader scribble/comment-reader +(schemeblock +(big-bang 100 100 1 'locked) +(on-tick-event automatic-closer) +(on-key-event door-actions) +(on-redraw render) +)) + +Now it's time for you to collect the pieces and run them in DrScheme to see +whether it all works. diff --git a/collects/teachpack/world.png b/collects/teachpack/world.png new file mode 100644 index 0000000000000000000000000000000000000000..82dd678265d584fc645a40f2b9201fab3e50adb5 GIT binary patch literal 19925 zcmdtKWn7hC*EPBoMMM-t3_!{R5fKIH5GmK{VYkJc&PX=Dm63R_l{P(4!t=-+zgI^bZ^{+NY^SZjawuO2v{|s+!Z7qt9 z7V%h#;;|m>!a38@(tLuFr32~c=|5XX3%gxlk*MfjTU$%KQ z?;mk-arsc)6-&s>beSFy7O!7lU6KxD?ElJ@ANgj`Yg736@zmj%v9U1`5s|s!M*6c? zU-y+>-^pU#nZw4;Zf(DhkhSx6#MU)wXJ@{3-{)yRKZc(_{5T{aAV8V*Q*$#fFK@NW z+%T@5jD<#0*mXX`VWg?Z!LF~Q@#9B1W-6ci_Z#CyH^U7*FU!a<`}p|!3i9)NtS@w> z?A#1qn(Uct&s5_{Z;s;m*w!}tXJ%+#uO}(7_ewiOS`>qzQ&~mD%JMRUsAo(b`eoM{vhIuO8jAR@=%_^%b3{Moh-PoT%HSthJ)E!`A_J1&*0XwvQF{y z_h25{Qsq2W7uO4pDrb+5j&9#|fP(g%Nk^83FC|kPw`E%d*R{9r-Yxy=?|ZDbMVXFo zWXo?w4Gj%5vowGIUF(apKR+%mE?&HNF_200ginrcu@ye*6ExA4FUZH|IMuu0&sp_n zV|98$SFgBcda!!1+G`V6<+<2nK2MRDn7Fz$ecQAidRh<~5zE$&p97#;l-C%pQl+@aB4neOe#9Ojo<_~gawm2B+lT3Wp4&kxNl&-Y;x zm7=&m^z`WH_Hf6=#}9U7YwcvYeEIU-yLUf)_}~*%R>tS$cD%KUU zfB*itxH#*sywHuUEhTpSR@T-NLqpFZBXuS;srT*ML2*cojF!*-YXChj8Oxb7XCfmb zWgWilOmIn@B{+|~@!pZER~lATd3*ZG&6_uI|H(;7WGs@BlE;r9_X(=6ufH|XdHlo) zznbq|`G#G^C072?k&!j;-+#ea{OW({$ni8f`sKB{C%X=wadvatTpo#E$nWXu;$>m^ zHZxQgD{yPPGgl8sUf+DV`sdG&pFf4YHePkc`$;7I_A)5HnL12?xk~dAxIQ2>_8z}B zA$~e@bc(V)HrC2ZN=iygZy(iCt;Xuz{4*4Y75(PToB5DRwvx`kba9r>L05I{x9=Nn8N+BMJY5oS4SyXHTDQ;2@KeHhxLJ1}gP5 zG$akhpE73bXV=s(ziB#H<>4+;J*<^4c|^t4RlvXoLuF9y85=iHacg1+B_sFE{4MI_ zc_oBb4x1Yua&mHGefd=@4fXY-pOr*ID;W~Y%KmJuuVOt}Sy|x<(>T|ze<|Z)XZMdw zygfbe?!oTt^0LfKw)kdIuMKysLq)|W$;n4qhzr)t%*>#|(PeQ`C)YY`c5cr9(W4s< z4if{Ft624RNQNU#vAE3kVon-KeDhJwcU`ZnygbGO2c)V!XTD1|(&`%+jL}}H_T&)0 zZES4ZmTxF3F7q*rBh^9n7&Wr+*xV^bA!lV}<(71%_zF$cYEcXYCJ>1P=k^K0&{K;a zK75#B_img@Pg~o<*jRPqUU6;h(2VQiq|5rs!j~`lD`vqVAv7mXo)oV~%7~4L=`Fpk zM7BJd9H({$ZmPS9M7-cGeDOkFPA-{~ zbjzL7>WqYG$I0$sktJq1H8nLoJ-ro8W-1E{i;T?m5%rCAv~5ApYxL;ls*|B|Eg9Es$DO?Oai?9|t<%3W3ZFP#FYjIUi& zn@~bBM<6Oyi`ah^Yorx$nv`i~b_-9%gen2;SW zwd%++Z;oq>Jb#j(Uq?;t{D~7MI60dK2I8pNk|g~_H`mS!3BBsvZXFOn^?hQ3o}S(s zStT*CwcG)vXd_ZYWgcnQ!^6XsQCL`brKu%qhv?Cx$r{<33)^yVPIL2s);Eu@yQ$gEAp7+^HxE3-C4T8ra;Mtf;yfK$q|?uziK!SXYpgT3&(LdKW6Eip z&XHgXgovTX!hVCE`q0EgBMXaBq_wCCmV%?wPi*>1ru_D^v-$~Oyl&o{C62s^M}^V5 z2b5*zpPQSnH^&M0zr20Y$JxaN@fMgTM7o>KaiWu>P+ML_-QC?iS7TSDv#RP-nPaZ2 zi?#@b+&RbTf%UidcliXNj4X_{ddL02ZM#x$OK7lfBKgXoprGL3FgHK%xWb-;sTzFc z;(!wuUaK=PU!5u)OiD^}7P^AyoGAA%=>6`!gYrt5{Wts>C)3Qo!azl(>=3-tH90ZC ze!#z@y&ZYn6iaXLgihm+56>3n=TEV-laP=cJfr_-qb@-Nd2DHJ?x@cpI=VO!4_$$E zOjsP>jimJS^ykm#5Vu=NNTSOU4Lz4@-n~mkc|pkvxv~kM@LtQ%BlOv`ONOf!CN@aA z)Q^1fgpeCL(-i0h%B7^FFs2>SOdctDc>~GPlm`!n>sCJ<`udd^av0ze%w*>jwRoCB z^aZEMZrleV57jS(>S=JWk)2(WSkI1xht8uKTg1q|&1`s`rrEzAi5U6$N%P3W*jQ+I zxV5#lmf*VBU=MP-h`Y0lOg*ZrbzVVd4g0B6qwJjX2PLe}bVTqtXj)oYUc7i01-+s| zps$cyQ$r(E;z(glF3WCqt66K|f7q_fW=2W;ZbZFtQy1Kf*e*Hpfv99&9{aI>uRkhKO1<|ZZ{P?R) zCQ`qoAMGCMp4OxXP-24KGNchYc!u}JE1cdlK1O&e)}x}U>-ziao0XAobIV79Wd?!? zcgO(;e>1gJaop6<+CgPTLql`gpyI`wo&%g$K8c+rBv>iC5Qt#q4^sXoCz?q>v*#rx zY1iYo5iF!Kga`w{Q+-dLKK=gdmz}k>AO;s`LRBw1Gz#IsYunpi<+1ws@#B<~W0(_Q zG#MtPE6+(DPOc4lEX9V0het>ErOJf^Uyh!bV&e<^=XOrFuaqV9i`frbR{bocf)I1v&@MrNE1UOF|_*O$31o$>HX zx;|KS@_k{%uz5V9KI?&7Op&7+k0S$fqR~D^F;hcuD zN`>nFi{ESf-}zE%X=yPDIiIau&<*!{_^_b3IMo~<+P;2FlW=GFo_WO9S4XG%R5dlz zGBYoWw#)Uld#{x?l4m9x>{>s}k*J)JmNq;zbg5Zt{1@Sf$1hFPp6F=3z7pH9Qa~}$ z+rRV`6`O$9J&}df(iOLF-`-JdgPgp&IOT!d?MmH%o)PVv^bC&+>Bal}g=X z)R?*Sw6r}80_sj17!q?6lf%H?z_^ZD2fe&D`5lJ&`1!}i$MMx$7pNTS-@o6shxw?~?zQC5a;{ z06W54)MzwRR8(vq=!SovTMiBmroUkGnnWXddz=wD^Zhpjv3j>fTb1ppsi{#>QI1}M z76SjIqpy@C^|YRE2r2gQJH&1UjP=dF$;!&Y_#Lla;0=$u(XdcJxHB$BOg;*e#FZk& ztGkbETk!zZDe6aN&2j7BW-7go6_M}SMPKgR$VbU26cHBIDfDK`9r8>6{?a*<`k?l9 zb@7K!o+#Sc+0E4~d<(A6T8@pXU7dX1oTeBnD{8_(`07oB+v$%y^!5OTfs)-Aszs>f zBqhE5{P|g272*K%-rd*t(dnVbpWjBx%0bGkIpuLyQ|g`hhSk^V_N+*&rO5+bC<0$1 zGWx%K!LsBPC#%dw@S?Ol+1OfObF8hSDVjGQM{R7Jn(TRwY&HBT5(~oK(NV}@SpM4g z_Rh}5-@h|-8VQ6~OymSsKgM0aruYP_u<6&=ck2R~4wBy=stX*fbmNs&85kHKA*FC$ z81Hyt`56~tIN`dszP@kYJ~qEooSeK|T#2l*tTZJyJ?BJ3;ye|UI5{|O-M(GzvFen| z{wOeT^T#u#W7HpznVMq-!((E;q$@G`CCSRky>uKy<_|+6MEOZn9vvPACD*)iB`-0N z3-JHxQ{>=MAk7{bld;j!7EV;p;pu5ZRn?ndyE}IHO4XKouCIX7c>cbqY5J#Nd(hkS z@>>QndrBo06l{^A+!iO7=RYewl0O-OOte@0g58&h&`?RvzL&SB0cAS$&Gq&5p#iup zj7yTWwzW}{ZSx7b{Op86tN^Hg0M*TvdCRePmyrtuaXpxYFb=)2=;-M9c&~47?}MUN z$oc#F);&Eg2XFzD|7~a}IX%79tdR~_+s$niiK^n|%dYD5lS*+Ed-hy7d)EHu&9<&C zFBCqok@3K1RK}K;E;HY2(wNK%%BI8`W*Jt+(Ge0BMn_BgK`~h7*pc8-P^fu5X=!Oo zCO#k-RXxGby+@@E^WXe2KlXXPKOber(f1$|Q#>-{UU6=2?okW+<*)g?*9T-s(ry>L z;oHfAqy>T+pd(5UGe8l2^?AOEV`XIpxS~jH>(;GRf4=*#t+_imIJo*nMd`}R%TEtf zqN<2kwjC4v`|6RjDpA|HYgaV4<6Z{NPTi-@wbXCvyj-c8uRb?E5mTzWu}xp`6LQ1!88XC(jPk15^gqnfh*v# z1E4dK8eRc||5|k^XAcp`E)IrCy*9EW|8I$>%sJjSDvB=f#{36!XU>KwHg49;%r{Qw z`T6<1))&GjX%5#8C*_bR++z0bu;)5g5@-8%(UYAq^^^L()e_bW($#XAzOon$(x(V6 z9&;4n)rBrY({wPNw49tAT5ok7S^gGv@^jj|53*Ad4)7FS_rGW5E*gH(n{*unIUv#j zU&MSUkdYHY_7O2iRCnq9I0S_-hy(xwC^ax{acODwjUiH&l!Ah@e0<%twYA{zM~`|_ z-Nc|?uU-$kqP!wev^+QR^5sjp>Q@!EeHWyq>k0}AphM`EYUldOK^Q~P+{r@yCHn8glX0-wNt2m^7yen$j!5p zN?81Rm_+2sJ~TG=gBsl5b?{YX<(PDAXGnCk+uENQh&p|JeZCJK*kOG_U=Y0h>zEI) zRH*0V3f39oRgnyM6yY*|uQ^`yqz|MD2L7AJAcJsm1yiZ2sLaeYi{iV2$Bvl*LKWNH zz`sUDMv!Nq{XsZzTl(d@hvA6N`02IFgvy9mirEs<5yS6?g@3)ESl7G^IU3O60EezbwQYaJ z0`6agbw45DMaUX$+L2(^^XETzc9!%W-F?TJ?`fvlSYMIzj4{|JST(W(D$9%OgK@lkNpS-gNNlE$96f1}<%i<&C{wK(@*AgKoy8L6G_(RlSG3J)8u6)`LmiJ7wfwl7NGglbyI?0{;z@gu8x2^Zb+`)R!(@ zf-Znp&qNDi{pXBx(Me}WIN*ZCly%cpt9ig=@g9ph0Nlubl4OzR%@v{O%5UD)ot{d! z(#b3BkCinWFPz!kq^zUEMn!h+{P|S1mXTB!wnj0v8&Kcow{*3%oIQIs!4OqFPSF>z zCpUL0giUSK|CJ9Fa(vGZS7+yz%}=a$D`lQdLtTbmxh^jUpD+kwy;p*BAg()#zheF` z*!Iq^EjwV8?us$5hftD}3*7wi@bFPhjfUXNv?be2X?y$Mq3l|R85qX)EP%9;l9J+_ zCwwNm3ojj`-YX6u^f({@0wt=*EiBSIckTe)t*)-hF`d$N@b7RfqY{6M*SmMfqoA~Q zR#r&RU0^rMfBv-Zi+&OB?Y#Z3n7q5 zrE2QxuJ>2)fJv>yTPR=|L1@FJ`cN_8-o^~CK0acWHRho=z84}n;0~ZI<|eGF5R1Nw zmX;PE23qmF%R|(DNa;`LcpC7ktCI$@J$1^eCE+5d1e2(zdv11a&pT7}0#HB?3p$+^ zeg{q#&Y^b!5N`_!Y5T&Ij-}|qu@ErG`SFgAPzP{=dD}A`?E;r@-M1&Zx!nK!hQ|N+ zF$F4WOh-7cG6e-GPe>)sVEMFl95`?Q z+NqpC<*Qe(TzJ)O??atv9?^OB;o$Kq!~#XWtBB?wW6%druW6=6(?u{5QR>&u|ZgE?d+^V5)w8rG~5KZ zZ0q^b-;Z3W)Dd0fdZA&vzUWAyZC?oyMMZJ5v9R2Yn*|3}ia2{wL179KX=?R3<#6N= zFVHEZpFfadiK@jTPQxl8dtgtJ9p8tBelon0Rf&?PrKgvx9+M?=8Fad_JF7&TF)%$l zThCUuaZ{RpjZ(u9!P9voK*u{cSf$aIaU2-&c3@{}9BtM5qTaP@Lo2-G({h%ibnWBs zAMJx|20&ZwJd@<>EA2hUZh^>(mqvP2JV)Gv_O#+Rsn$uq-vya zbf!{HW@Tr890*cW37L=Iwq1d#tJy{UIkfUScL>PM!ornEp|_D!Ht6E1zK@LX-WqSO z-rR@|CVbmub4-hBv;Q&Lnhd1Yc!;7afqqvy>%5qE)QjTcKFEIz43*9^-;ozv_n}pV zESWlotPN4Kkml;#*A;$B9e0sUTw`A{WLu9BG=)OUM4y9(gDlLb=FyxNXC zwB)gD71wvIPk-H^4L!cHQg}j(7V+`o#fzw!Uql>A{b+t+0g4Ngh`V;zRNm`j_Zcme z0}~PwK#dh6&VGZIH$Fa&?uU6(%<{@ae!%0$)YQ~K`BRgV-A@WH(~QN`;iC|!O_?aq znth5$N;)!jFcv(2G@l3eKUNz+kIHz<(b4hdO=|y|d9|dSEa{4|Pd!(cv4G5tc-8NS zo6GXAl%TsKu^69{rdMcO0~L*o1uzVO_so-nN;{>6WcPR}ustYDJ|r`$S%@WM_r;+{ zAg8~6{TczIOYeF}GU?VF_E~&Dyv4IR#l$~m>SAO&O`tfd{8DaN7XHTB2>*@+m%JAA)KFP}) zp2P}biKqd@p`t2)bb?l5qOy!iJEiDafmO#TR}D5cHY9-S<9oHZ^fQFYs#Q$yQ)nj3 zEV&Ts^`6h$CQj_Exai(k%Z}dD3@VNElf&qFd0hbt1zCgQ7D`IBe?KBQ^ZWPjlKuxO zp{+E8vLpCDB2Jr|tL?vu%gB%g)@65Q;LfF$l&(W20RjX|Ln3s%eLMfwGyukMbG#B+ zX3wXZ_V$qGk$6!rl!a5cnYK1i?G1>L%4%xaF3-vO15zU?g$WrHM6Hh4Pq7p4`%}fy z_G=NH$7Dlwb#)UnGxGay0Uc%N^Z!2 z7FJea;o+cyalc-OFAYOydLMjLS}|UPC@IcfPY#2wweshW<9Pccs-(oki@v%_Ob5gt z&PO}9nVp$GLnV%`6+a3k3OrW8(}C?gJjE4pruXbl6Iy8WbA$ln)|nD+_OiayQ{UPU zP6Vyz9ELw3O2O?upj7AeI7@12-G(A%=sr`kxv?ZF{;;s{25_e7K_*-cvN2daYyW4k z5Y!w?E2}n+?^!%niG9tQ$@%$)&Eam=7aSfvd4m3m6IvV~6E((#nVFeTdx0JwasNpF!wN}Kb*f6x}|j>&0^RaA5kfQ^%Lnj|b#=9tZN>35YX zc^<97FmznLeEEW5>*{s>`AkU!iMI}Z?3q{t(=CnuQFk*RL z;_8Fh-P{`96q-v$zTVMCjvPV0#J}Bpw$Z(QBfpn_$u`(Fy2xwOvqzyFqD*J?7%6@6 z?`8Lu;T9>WX%(8j8l|~< z^m%|xPxUCe0MMd=jb9e9AG5&sC{=+Kg1Xcyji%I6u+9bX*(Ut_y zhM0?C&E?!o7_}9*K=fWx6BAkbzKO+_MY5e44A?GvM`Yy9F}pq77DC6H5@z*n6S=%( z_lZ!P+y0tB!7Z5{LaQE^%>nnwYY#{%1i~Hu|It6lbzDHcz#fC9SQCuuX$T}|TWDgl zOqE&K1JQ3lv!aM$J2yq-)~f{4s3f&wic=;(x8SzPWrI%Z>&c!^-EBjvujqe){xjLBZ(Q7LET5Y6WcyO&#RtgQvBb z5BMX4jzF+ernxoM%L6$Y{T5JOem*{B8c1jz9VkK9uUv^k7S=v}fNUGo1$Pmzf019C zX&+g!G{T`fchg4IFL?VoHVysX1pL6dqdqZ0F6W>;piqDKa2Ws-xz#5K?Q~*oK<^V7 za_e2@GiRP8LBGxbeMZOr{#2~;&VL4{!A#kEiZE~qZ8$JBlXR@NG@y!kYv3$oF=}xD zno%~#BOgD0RFId4cu&Rx_WoEZCo71JKzcQSO(3)};YjS<@3}cSqNxSC!lO9q!-wUy z-2bCx@r09;k--!3dua)LYrL$*BNF%orEP`H%Hqw0m{FIo=xYne>@NH}+A)KqK zs$O~J%yPg#J1gtQ-eZAvYG@y6X_c0gKoCE~XMYv#AJmuU*JX5A)Cf0^P(M0@&yTgG zrlh1mF8et=40(VtusqP(RS$R<(KFSO=v@lo3|5$p_2L&VB6f;J62n&1bL~^)d639Y zO-*5g(#MyVKC523^bVrh=g;S%1a}u0fsD^~YpU6g#z>=SAR!?ENZuU7f8KGl1**pW z0|y|7qZ28+=NR>6h-1(uMjJsEng#|uQ5`w2yt=w7W6yAIJM&2puy`Kpu>1GX24V+r zK+BZa&Ph~e4VL-AT{TYU2m{P9Y6IwRATu~GqNAvw;LmXM^>gRWb&JT5Cud|>G{x`( zkBWkZ-Pu9{zIvi7PzFF{k&0~k4u8EgOIE8 zT#w2o7``y!%!Gs~fN>z$1uFQg0x1^`C_`x>^w31+UdUhTJjPSE|HFzkW6*LkQ?-FjFlZ zw7rOdOj1Q%O6oymWDme*_Z}aAgoO)!eGnVlpK|#buBqoq>K2r<*bBB%p`jg+2D_i! ze+don+O=!XLP8{}(Z>ZB6$K6H%2YdPYikRS31eW_tCM@3h2o%rp$5Xo#ErHx*z2xs zTP=lfC&+jPW%ev`b;$yY?15Mf;9ii;3K{AJ#S>dTe6W1~aIbM;#FRGQw#cnPz6f&| zr_g74I3+gl4qlCgg$1Qpff^@feHwcD?BwKUv9Ss&AHRxzq#28Z?(4(H_ zjt~rtm!zdnLOz`m6CoZALLkU-Bd$gT{vsoziznx6{14jpzUYCh`jTZG9xWeYFKxxv z$S5&1bpJ%?ndney35oZmgPtFa3A-y?7qW_ri}jVBux&FTPv{8^3+wIaVIWpXv8W&5 zCSdyLnqL#7Qj7qDM<&MY%#ZG6@j1GraqQSJI6khx7v$+S{E2qQjva~0^~N$e8jL_W zXvLY#tnLlqwrbBq%_z#d$;picW5zvK#?pb!TjGOeW@a!2r%B)SK6~F3 zCoE{weYONsjyS@l%ge}I6{PB9RwFdpL0ScbE^ia^yA4|z>Ld->Hk%!9)6SbWQ80<< zv(n`0JReSv_aq)3R2*Im+>IRBSVuM{av1mCL;j$+;V4X&DDF14>yfXU@|$AS z_Lkqm%^5870)GH}D`Jp&egp2urKR-iX6iav9q3g*3Z;-aFgtg#^Z-wOw2l|#Aa;pH_K3>xMJ2Y~IS0P_HJ z4%zWGvL10D8RVwWwSs;X9Tg=@HikGdHa?;kT%hKnOrxQrlL^74p>r_&*|UA?jkosu z;EG@3jC&6A0Z2vZAWc8VtEdQRf(H#q2!QPqc`J8{=5pW=qSvoa!zx#je08@ZvDuB6 zzR2at;o-%vZ%E!QrXRNs-9flxxb7jk4zkPcIWEXQ*JM--QVScVp*Cx)+IOo`|kg#gLXp}2lG$>5k-jRaP z6)RQZVU$#X7e)WiyIS&Wv#S zXiEJ&p!E*UJ)JKCb0U0dK0&aNJ?AUX;863E>p0gD!nIJPeb_rIOw+U`wBcP-)35sA zqw^C;Z+g1AvR<%4#y)%YIU*EUC`RB`*6{ql?U%PWiXr2{1ooKr{E4$?3y|i8Nv@MZ z{LRkDuy=4ki^T>o)!x1UR<8W~>rzsrEIvsYfHS%}I>6rO3@TQ%L$L6^ch5(hJKahN6Bv*A8cTGdcDYYE=LY_2~?rU~-8;etVVF3JOwzL&Ek$w5W zjnrA7TDVlst*>C|!dnE*{I4x^d}88beiPEwBwzqQ6p%Ms*URfmgC8v~EolFj7S?N! zS9JDgkt?BvK+TAudWt4KJ$-ag&~LP!Aj!1)!%P$aThysjS-4IL>5rOeWGv_m_q@E# z>3>p)hFvX7zVKYl_lQ%htP#A|uMCZt-=;XFth+xW%4ECNsX(MdG}!ivzc-$l8)=3+ zA6`>MGJda(H5l(C$UZbR?V+Hs=_xXWl0?ZMAi-G-Nf5(zM!Vp3cXwGYdAzXO@Wh0* zvGF;hw?3{-CSX5MBITu}eW_-9%;VSLLz?ZWt`$HAg8GW8SofF~{E5~t39#q@H8nhQ za%3>lrI@25-i8_jCq_hIP_F!5aY(;*78b05u`7fx%``1#@oWd`+Pe#{Elu@>2L-j% zE0>=q<&V?co^?X!4Hn7Z;3jGolz*TJWKuYiS0ND8S6>TE%7DW_PVOVbHOSIS`%cJ1 zBs}i(%5&Wnw*`R_^e40AEfA1^pdiu4L&tLp?$W#?!uS`cVcuF#4^Uwc0np$eP5=8} zR#fqa=ry9)nVOnfT4tgrIVtoP8VY-^MTC;|G|+U}i>iqYd8TO}Rs&KnEVz2n*|`i> z_6d;-f=|*l?q*%qv`?M2=*o)?2vBf$Uqd$t)?hTgme5`Gmq zcG~l1@(@#W zf9xRIgg3u53s_iM;(qsv-}Ck!Yu@Wx2bc{tRxyT;#VuG>L4o7MiD6Jl+^o5Xddaz( zz2qTm`_siDjc?1tyDNPpI0w!uCu1|S;Y+kd=F>f?td^2II-+^%j6PK0u;?VgUkw=x z-gROp28V+B36Kmh15^vRmM{WIuDPKh$?)S9(PtH&>lI;PVYq#7dRsUFE??fc9+k)c z>C>kubFYCqG#dce+!4LMfBz;{TrhaZaD$$!94sm5ghM);{r!8iuXOs`JKwQoluGn_ zHUK@_OnKgEf1r_O)l5^5G&c3C;ezT(&HhwqyLncoSdAU{Srdv%KH#(0YK`))Bt-ckh!ePXNHDq2xnWN zgg_?N(V_Ja$YTV82cy`zzJiDa=h%Jb2&L%yyxNT$h1hfe*#;N7ed`vF379-CUAl&w zfs*;Tr6qy$N?Yl!V%xq&cmh88%4#?KuZ!>J>Oi9rUj%fM*?bnZ!SaJ{yDYnbLKV~^ z2%~Vl0uGp!MNyEG(_!<+^GUhqL!JDA0I$Fz6XWBv&O)4=`Is9d9BOeinSjT~rVpY~ z18~g2%9;_U0s92-HZDi*NHBN-C-6!h|4I1>dw8crpqvuZlPC;W!vndspgF2)tDBB8 zbx%V8qUPh+%+{IvuAx+Q9iv~pfK|D=Oc+EsV03OMt%L$9;+}A?KuZ}kScoW^l9+a zJW<^aiA}jTvGP0*r$}l+;21zzm*l9kJ^y^$Q4&ZiNMk2od9Wn#jCG3T@pB(w;pm4Q zTCy5m>_p@e?bB(4unr(@diwgX-vxKjw(lT^E?ATH*!QCASeQKA+%Vy$$w#8sRSM{< z8%XRTf{vW_czI(;N?Zocw&KGYZf}IPXA5;FX}4bJN5eA{-^|Tr*t<7Tdo>U5#oDA{ ze?$+Y#FVmY<7OTF?#ui4 zK1r-&{?Le_oa5Tr=+)+9;TWMC|M z<*c&k_L%(Q*!k3`AWhTPZMUsxzGh1o(XjWXt-=F{z9Rg@iT1)Li0?dWq=`#xGW8Qo z8}O%|*3Gp_3tg4IWB*mJxU9F0RfsWgii(&;k5Z8ZvHeQkY-T@m#!N7%R=3FHkyS~y zM%ljxz0LCHM*IbRTa{xr9S?GXE?ixM*RxyX_jJINcO7ewd~3KQP0iAvSM%bVYa!x+ znM-dMgUv$5Q;J=_#YiUugDaqFbK7(mz{U-MgT1qg9q*ltW-GaNcZKy=ge#})E9>H{ zNX=hNTh7GHiT!M4jR`1$#STWh&bnougH6BOa{1^vNFwi<-R0__iRtI5ZENT`%3O25 zfkaD>rZ0%)5-ch`PqxxMkY^(|k!54ajk(w0ZR!|agQ|`0K9x8oWq5S-(18PCP#(zm z9Y=$JFVS8^Q$?nkvoC7~-3g)*g4ga#k?F_oFFQK!{BtPT`yZljm=u*Q9nZC^7-@g@y&zKf=x`0NvgnI2DpK8P*PNsWc9)-g|%UDP?U>HMX|6oh>dRP z{C4hN=Kn;b%G zhUL)cqH^i#0QiurA|eizT+`w}tbR313t6}rPa}C*Nv?iB?`QG=-w_vX@^`H$3Xm__ z^5K|(17If$Y%x$DQlzq_R%+Ro4L(Ywjlap1zbMQX%Jz4&ZAkt`{l||Ew{M#ldC+yW z$$oQT4Dfbf)IY``=R@Usdaw9sp#eil7!;H0 zmBp!#PNy3uvF#Gq4rIgKcemiqMh1<4jiYDJo^(a%p2TfVii&$ARsI^vB0|r0^N+mg z4v=XC;Vp#<_i14H<2g%`TELm3YWfeZ6#I!^P=o&wj>Bt$B#n=gGWMNRl#rHw?vX;P zF_o-pKzzY76EkJg&W08xAeK*n+_j?a<>a?RGu%8pmnv*nx93I&Jc{1Fya_{1kkMJk7i&a@R6px)a;p*lF87kRCsTcQ=CKj%x9%GY+ z);=#}$bUI@4_vak0x#w2+FUaR*|Ny8xUdlXXK{Z1-$X&@aTX)i8o&Kl0?Q95eK?mn zJ4L5rikq`DjE#lG3rjcQ21`g_Cdv=zwzs@Oj|88Ci-NR-#PR~RVpThiwE@*a(o+Bk zl9QK*nOWrK53;_(_Frqub3n@T2CvaiXMl1A8Aj8Ef{vRN8;Ejqd9TRIHXy&RudNZ) zmU(e2RSM#7xvxei*IHkHLB>AP@ybaJ*S` zQy;b+R8Agl^@_dPD5ThWr>olw-_5gU&k&cNoFq02;a7`@h`_lR19{=}g0bb{L$b~! zqnW&~*#Bz`)%-MRO9Hw8R{dMl_hFbOu^;oAt!?gTzdNucFr&xZutEvRHy^MaxIHd0 zQ}OZft-%&x<2%;`Qy1vLufb|1m3Bza*tE+`L$34Kx3S?U+WGD6+;G{}92#e#A%|q? z{`>325)vaO2>X=i45PE1u*t}pgfu)lF|j%AwFzxA4=L&F`SUNa72xL0B53Gx zJ+mr2FTjWRTmYwAw-&HFwuHpxI@0UEWM=-pyY?SJjbNn4Z98B~pLjiRd3OMW-BxTw z0>4GJI`$L>ndS&C@BSdxPIgMaq}o8H>5-AYk{9zP7b=~S=(_qb>OuxGU*d`FM_X9_ zF8-c9KZH}#(_u9yHZrEf$}GSrVG!JU_bXN+2rSshKE2?Uz~#hdCvZ{RtdxX={kQWm z>kXHV1j7;ZzPC5(=)tl3;@=<>_kqsAF;{Z!+W`}DF-5280b66^x53Zmc4Od`CpvR) z1gA2BxWS&s4%QFP;pg-~cx_+^h@>FqX4t!kqHq4s(2x*$Y-;KA} z;HL$b7z|#MQqVTqp)6oH?dOWNPCzi`FTXt<_wuD1Ry253_mfmbWDe~6#dbznMMX2g z19_{zUQR>*M7!l^unY{#lVf8&5Q(t_WBG0zIe8L{m3w*^O&{z$dbIB(`W)9G5Pti1 z1LNh&PFxa&g^^s>9%!Go8wl_`tEkTS0ur;1o?hT#{->dRDOlEsMq5+U`}F(iA%E6; zYoCT&-vb>5Sd)l0H=b3dbjlOKGN`O)@py&v=bvN4_1DwajvBmjZhiBHg_)TddpVLa zLPA20%Y{)K=4)wa$m*f5g_liFM`t%4Oz`39aisbrlCqmWW$o?l;oa1(PJKbw88@QB zepl=_61iP>K_WI3!Q6`B1ffP=4wW7>@=Ll>l9g{y=iO;{KN5Eca5iPwrM>e%FDXZH)cB2mww1GECi5G{u> zd@40e2N$cb%MsxXbuK?Mla`LI7uf?{KA150Q=cYfz?%V@i4hToo0OFX^DqZncUN26 z)4E}iL#3xE=_FO);Sh%UgY9dW|0o!YG&DLU^;FO*M0zYOU7DRGCnpC7xn`rzz8kB| z6B0EH$e}SYF(^v-ys|QLuuMeH3;Yju6EJzahY>?dC&w!HYg9jqKDJ9oMnwF9!i0{P zi@Q3tI7%gSD7bZTeIh3HR0rZ!bw$r;GAg_oV(VjMWB;ei%yzzBcklp|SmlfVqb&~q z8yDZ8?=so{vNS2_-hXvLw3+;Msc>P@;EdkJ;RjWG{hhwG>#}3JQ(bzR;!yHh=5ZE!11x z5}OZ0Gw5Sjoq_4l$lCg2?Evffe=ndtwCZ;nE-6fHa_+=_!)PqRKY#w(!bTs#B<@26 z^cY(WyJ(SrS49XQ<{F6>|G!NI4CgWkp}y*3Vy~edtgo*_zZ#F^z>^+u7uAR=s1ZZq z_ssqoAXpjpXU?{CbOiYM!RrtN!KSKe16D=r*eM9($P2_wJMmuX%=SjIf2=G$6sLa7 z3H{6DV7;uvP8I<3uY(D<^%YxG3bo;^Un6$WvGsFLY$7Nl0<^cg8$1ne ztB|;J(7(|U!J~0tA!+#ttQ;rgLIm7+KN1hKaEyg{7>d(*Uf#{Y&5gQR5w?G3b`R~E z7fm)D#Z{Peu|>9eZPwqh0j5tpl!NH-6N!i81iPn+y9%&dZXNMQY#Q&`lV*<0_M)T& zlnRavR~Q$dK!ZT5s00@l&HxC*wA_U)>O?C1AYI^}**7WRD!bwWbcKo!mWp1K6f>1F zO$Us^zkl2JxIl3yZlFW}KYeO!VuD97Nvee45j{B4C@rK-G~MM?+R@CwP7%n?c!8xg zLjdRI66%2S;NST&Ao0zbPS_IG4@@dwfH2V*#u;<83xRynQFe>w){ta@nNTi|`)KRw z!Ez1z36(hP7ZS}aNs_z#@NgQSAQ=enxZ8Ai56@Sem)-sE>~V>7CyRc*kOd$DTr|Rv z#^H&9@`Tn39txm6ri2JEhuzk+A%wK+8f-y7emLUcDK4bhZT}3#{$}R%>9Yz@z0k`y zOixYi>FuQ!2UNk7&Z8wOE@NcG!eWAX!8JlyJnHihu2OCNE^_Gry8W};#cqeUn>x0 A1^@s6 literal 0 HcmV?d00001 From b51e02b81a87f02cf2d0dccb71b33971fdecf140 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 2 Oct 2008 20:25:20 +0000 Subject: [PATCH 30/50] revised world documentation svn: r11927 --- collects/teachpack/htdp/scribblings/world.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/teachpack/htdp/scribblings/world.scrbl b/collects/teachpack/htdp/scribblings/world.scrbl index f99fde8905..3f763651a7 100644 --- a/collects/teachpack/htdp/scribblings/world.scrbl +++ b/collects/teachpack/htdp/scribblings/world.scrbl @@ -18,7 +18,7 @@ have a series of projects available as a small booklet on The purpose of this documentation is to give experienced Schemers a concise overview for using the library and for incorporating it elsewhere. The last -section presents a working example for an extremely simple domain and is +section presents @secref["example"] for an extremely simple domain and is suited for a novice who knows how to design conditional functions for symbols. From f2756fca3c70fe84c39c65748b71011f1f6bbea3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 3 Oct 2008 19:52:51 +0000 Subject: [PATCH 31/50] properly mark callback memory as executable svn: r11930 --- src/foreign/foreign.c | 50 ++++++++++++++++++++++++++++++++++++++----- 1 file changed, 45 insertions(+), 5 deletions(-) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 8f4a910d73..ff643ae59f 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -4,6 +4,8 @@ ** to make changes, edit that file and ** run it to generate an updated version ** of this file. + ** NOTE: This is no longer true, foreign.ssc needs to be updated to work with + ** the scribble/text preprocessor instead. ********************************************/ @@ -2233,6 +2235,9 @@ static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *ar len, 0); } +/* *** Calling Scheme code while the GC is working leads to subtle bugs, so + *** this is implemented now in Scheme using will executors. */ + /* internal: apply Scheme finalizer */ void do_scm_finalizer(void *p, void *finalizer) { @@ -2263,9 +2268,6 @@ void do_ptr_finalizer(void *p, void *finalizer) /* (Only needed in cases where pointer aliases might be created.) */ /* - *** Calling Scheme code while the GC is working leads to subtle bugs, so - *** this is implemented now in Scheme using will executors. - (defsymbols pointer) (cdefine register-finalizer 2 3) { @@ -2519,7 +2521,7 @@ typedef struct closure_and_cif_struct { void free_cl_cif_args(void *ignored, void *p) { /* - scheme_warning("Releaseing cl+cif+args %V %V (%d)", + scheme_warning("Releasing cl+cif+args %V %V (%d)", ignored, (((closure_and_cif*)p)->data), SAME_OBJ(ignored,(((closure_and_cif*)p)->data))); @@ -2530,6 +2532,44 @@ void free_cl_cif_args(void *ignored, void *p) free(p); } +/* This is a temporary hack to allocate a piece of executable memory, */ +/* it should be removed when mzscheme's core will include a similar function */ +#ifndef WINDOWS_DYNAMIC_LOAD +#include +#endif +void *malloc_exec(size_t size) { + static long pagesize = -1; + void *p, *pp; + if (pagesize == -1) { +#ifndef WINDOWS_DYNAMIC_LOAD + pagesize = getpagesize(); +#else + { + SYSTEM_INFO info; + GetSystemInfo(&info); + pagesize = info.dwPageSize; + } +#endif + } + p = malloc(size); + if (p == NULL) + scheme_signal_error("internal error: malloc failed (malloc_exec)"); + /* set pp to the beginning of the page */ + pp = (void*)(((long)p) & ~(pagesize-1)); + /* set size to a pagesize multiple, in case the block is more than a page */ + size = ((((long)p)+size+pagesize-1) & ~(pagesize-1)) - ((long)pp); +#ifndef WINDOWS_DYNAMIC_LOAD + if (mprotect(pp, size, PROT_READ|PROT_WRITE|PROT_EXEC)) + perror("malloc_exec mprotect failure"); +#else + { + DWORD old; + VirtualProtect(pp, size, PAGE_EXECUTE_READWRITE, &old); + } +#endif + return p; +} + /* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ @@ -2586,7 +2626,7 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) rtype = CTYPE_PRIMTYPE(base); abi = GET_ABI(MYNAME,3); /* malloc space for everything needed, so a single free gets rid of this */ - cl_cif_args = malloc(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*)); + cl_cif_args = malloc_exec(sizeof(closure_and_cif) + nargs*sizeof(ffi_cif*)); cl = &(cl_cif_args->closure); /* cl is the same as cl_cif_args */ cif = &(cl_cif_args->cif); atypes = (ffi_type **)(((char*)cl_cif_args) + sizeof(closure_and_cif)); From 2886a9531844f75faf563516447524bb893c9796 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 4 Oct 2008 19:01:17 +0000 Subject: [PATCH 32/50] * Exported `cvector-ptr' * Added `#:hold' to `_fun' for callbacks (will be changed to `#:keep' soon, but better to have a checkpoint) * _cprocedure also has a `hold' argument, and is now using keyword arguments (it was getting crowded in the optional arguments department) * Documented everything that changed, with a longish descrption for options for holding callback values. * More tests, including tests for callbacks that would crash if the callback values are not held. svn: r11931 --- collects/mzlib/foreign.ss | 60 +++++++++----- collects/scribblings/foreign/derived.scrbl | 15 +++- collects/scribblings/foreign/types.scrbl | 96 ++++++++++++++++++---- collects/tests/mzscheme/foreign-test.c | 21 +++++ collects/tests/mzscheme/foreign-test.ss | 89 ++++++++++---------- 5 files changed, 196 insertions(+), 85 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index ba49128b32..4353030192 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -467,14 +467,26 @@ ;; Creates a simple function type that can be used for callouts and callbacks, ;; optionally applying a wrapper function to modify the result primitive ;; (callouts) or the input procedure (callbacks). -(define* (_cprocedure itypes otype [abi #f] [wrapper #f]) - (if wrapper +(define* (_cprocedure itypes otype + #:abi [abi #f] #:wrapper [wrapper #f] #:holder [holder #f]) + (_cprocedure* itypes otype abi wrapper holder)) + +;; for internal use +(define held-callbacks (make-weak-hasheq)) +(define (_cprocedure* itypes otype abi wrapper holder) + (define-syntax-rule (make-it wrap) (make-ctype _fpointer - (lambda (x) (ffi-callback (wrapper x) itypes otype abi)) - (lambda (x) (wrapper (ffi-call x itypes otype abi)))) - (make-ctype _fpointer - (lambda (x) (ffi-callback x itypes otype abi)) - (lambda (x) (ffi-call x itypes otype abi))))) + (lambda (x) + (let ([cb (ffi-callback (wrap x) itypes otype abi)]) + (cond [(eq? holder #t) (hash-set! held-callbacks x cb)] + [(box? holder) + (let ([x (unbox holder)]) + (set-box! holder + (if (or (null? x) (pair? x)) (cons cb x) cb)))] + [(procedure? holder) (holder cb)]) + cb)) + (lambda (x) (wrap (ffi-call x itypes otype abi))))) + (if wrapper (make-it wrapper) (make-it begin))) ;; Syntax for the special _fun type: ;; (_fun [{(name ... [. name]) | name} [-> expr] ::] @@ -500,6 +512,7 @@ (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) (define xs #f) (define abi #f) + (define holder #f) (define inputs #f) (define output #f) (define bind '()) @@ -557,15 +570,16 @@ ;; parse keywords (let loop () (let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))]) - (when (keyword? k) + (define-syntax-rule (kwds [key var] ...) (case k - [(#:abi) (if abi - (err "got a second #:abi keyword" (car xs)) - (begin (set! abi (cadr xs)) - (set! xs (cddr xs)) - (loop)))] - [else (err "unknown keyword" (car xs))])))) - (unless abi (set! abi #'#f)) + [(key) (if var + (err (format "got a second ~s keyword") 'key (car xs)) + (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] + ... + [else (err "unknown keyword" (car xs))])) + (when (keyword? k) (kwds [#:abi abi] [#:holder holder])))) + (unless abi (set! abi #'#f)) + (unless holder (set! holder #'#t)) ;; parse known punctuation (set! xs (map (lambda (x) (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) @@ -655,9 +669,10 @@ body 'inferred-name (string->symbol (string-append "ffi-wrapper:" n))) body))]) - #`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi - (lambda (ffi) #,body))) - #`(_cprocedure (list #,@(filter-map car inputs)) #,(car output) #,abi))) + #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) + #,abi (lambda (ffi) #,body) #,holder)) + #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) + #,abi #f #,holder))) (syntax-case stx () [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) @@ -961,7 +976,7 @@ (define-struct cvector (ptr type length)) -(provide* cvector? cvector-length cvector-type +(provide* cvector? cvector-length cvector-type cvector-ptr ;; make-cvector* is a dangerous operation (unsafe (rename-out [make-cvector make-cvector*]))) @@ -1264,10 +1279,13 @@ ;; Simple structs: call this with a list of types, and get a type that marshals ;; C structs to/from Scheme lists. (define* (_list-struct . types) - (let ([stype (make-cstruct-type types)] - [offsets (compute-offsets types)]) + (let ([stype (make-cstruct-type types)] + [offsets (compute-offsets types)] + [len (length types)]) (make-ctype stype (lambda (vals) + (unless (and (list vals) (= len (length vals))) + (raise-type-error 'list-struct (format "list of ~a items" len) vals)) (let ([block (malloc stype)]) (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val)) types offsets vals) diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index d01425c895..2b64510041 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/collects/scribblings/foreign/derived.scrbl @@ -66,8 +66,8 @@ obtain a tag. The tag is the string form of @schemevarfont{id}.} @declare-exporting[scribblings/foreign/unsafe-foreign] -@defproc*[([(cpointer-has-tag? [cptr any/c][tag any/c]) boolean?] - [(cpointer-push-tag! [cptr any/c][tag any/c]) void])]{ +@defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?] + [(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{ These two functions treat pointer tags as lists of tags. As described in @secref["foreign:pointer-funcs"], a pointer tag does not have any @@ -125,7 +125,12 @@ Returns the length of a C vector.} Returns the C type object of a C vector.} -@defproc[(cvector-ref [cvec cvector?][k exact-nonnegative-integer?]) any]{ +@defproc[(cvector-ptr [cvec cvector?]) cpointer?]{ + +Returns the pointer that points at the beginning block of the given C vector.} + + +@defproc[(cvector-ref [cvec cvector?] [k exact-nonnegative-integer?]) any]{ References the @scheme[k]th element of the @scheme[cvec] C vector. The result has the type that the C vector uses.} @@ -154,7 +159,9 @@ Converts the list @scheme[lst] to a C vector of the given @declare-exporting[scribblings/foreign/unsafe-foreign] -@defproc[(make-cvector* [cptr any/c][type ctype?][length exact-nonnegative-integer?]) cvector?]{ +@defproc[(make-cvector* [cptr any/c] [type ctype?] + [length exact-nonnegative-integer?]) + cvector?]{ Constructs a C vector using an existing pointer object. This operation is not safe, so it is intended to be used in specific diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 9594ceeb45..664a17b4c8 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -267,8 +267,14 @@ Otherwise, @scheme[_cprocedure] should be used (it is based on @defproc[(_cprocedure [input-types (list ctype?)] [output-type ctype?] - [abi (or/c symbol/c false/c) #f] - [wrapper (or false/c (procedure? . -> . procedure?)) #f]) any]{ + [#:abi abi (or/c symbol/c false/c) #f] + [#:wrapper wrapper (or/c false/c + (procedure? . -> . procedure?)) + #f] + [#:holder holder (or/c boolean? box? + (any/c . -> . any/c)) + #t]) + any]{ A type constructor that creates a new function type, which is specified by the given @scheme[input-types] list and @scheme[output-type]. @@ -286,27 +292,81 @@ function pointer that calls the given Scheme procedure when it is used. There are no restrictions on the Scheme procedure; in particular, its lexical context is properly preserved. -The optional @scheme[abi] argument determines the foreign ABI that is -used. @scheme[#f] or @scheme['default] will use a platform-dependent -default; other possible values are @scheme['stdcall] and -@scheme['sysv] (the latter corresponds to ``cdecl''). This is -especially important on Windows, where most system functions are -@scheme['stdcall], which is not the default. +The optional @scheme[abi] keyword argument determines the foreign ABI +that is used. @scheme[#f] or @scheme['default] will use a +platform-dependent default; other possible values are +@scheme['stdcall] and @scheme['sysv] (the latter corresponds to +``cdecl''). This is especially important on Windows, where most +system functions are @scheme['stdcall], which is not the default. -The optional @scheme[wrapper], if provided, is expected to be a function that -can change a callout procedure: when a callout is generated, the wrapper is -applied on the newly created primitive procedure, and its result is used as the -new function. Thus, @scheme[wrapper] is a hook that can perform various argument -manipulations before the foreign function is invoked, and return different -results (for example, grabbing a value stored in an ``output'' pointer and -returning multiple values). It can also be used for callbacks, as an -additional layer that tweaks arguments from the foreign code before they reach -the Scheme procedure, and possibly changes the result values too.} +The optional @scheme[wrapper], if provided, is expected to be a +function that can change a callout procedure: when a callout is +generated, the wrapper is applied on the newly created primitive +procedure, and its result is used as the new function. Thus, +@scheme[wrapper] is a hook that can perform various argument +manipulations before the foreign function is invoked, and return +different results (for example, grabbing a value stored in an +``output'' pointer and returning multiple values). It can also be +used for callbacks, as an additional layer that tweaks arguments from +the foreign code before they reach the Scheme procedure, and possibly +changes the result values too. + +Sending Scheme functions as callbacks to foreign code is achieved by +translating them to a foreign ``closure'', which foreign code can call +as plain C functions. Additional care must be taken in case the +foreign code might hold on to the callback function. In these cases +you must arrange for the callback value to not be garbage-collected, +or the held callback will become invalid. The optional +@scheme[holder] keyword argument is used to achieve this. It can have +the following values: +@itemize[ + +@item{@scheme[#t] makes the callback value stay in memory as long as + the converted function is. In order to use this, you need to hold + on to the original function, for example, have a binding for it. + Note that each function can hold onto one callback value (it is + stored in a weak hash table), so if you need to use a function in + multiple callbacks you will need to use one of the the last two + options below. (This is the default, as it is fine in most cases.)} + +@item{@scheme[#f] means that the callback value is not held. This may + be useful for a callback that is only used for the duration of the + foreign call --- for example, the comparison function argument to + the standard C library @tt{qsort} function is only used while + @tt{qsort} is working, and no additional references to the + comparison function are kept. Use this option only in such cases, + when no holding is necessary and you want to avoid the extra cost.} + +@item{A box holding @scheme[#f] (or a callback value) --- in this case + the callback value will be stored in the box, overriding any value + that was in the box (making it useful for holding a single callback + value). When you know that it is no longer needed, you can + `release' the callback value by changing the box contents, or by + allowing the box itself to be garbage-collected. This is can be + useful if the box is held for a dynamic extent that corresponds to + when the callback is needed; for example, you might encapsulate some + foreign functionality in a Scheme class or a unit, and keep the + callback box as a field in new instances or instantiations of the + unit.} + +@item{A box holding @scheme[null] (or any list) -- this is similar to + the previous case, except that new callback values are consed onto + the contents of the box. It is therefore useful in (rare) cases + when a Scheme function is used in multiple callbacks (that is, sent + to foreign code to hold onto multiple times).} + +@item{Finally, if a one-argument function is provided as the + @scheme[holder], it will be invoked with the callback value when it + is generated. This allows you to grab the value directly and use it + in any way.} + +]} @defform/subs[#:literals (-> :: :) (_fun fun-option ... maybe-args type-spec ... -> type-spec maybe-wrapper) - ([fun-option (code:line #:abi abi-expr)] + ([fun-option (code:line #:abi abi-expr) + (code:line #:holder holder-expr)] [maybe-args code:blank (code:line (id ...) ::) (code:line id ::) diff --git a/collects/tests/mzscheme/foreign-test.c b/collects/tests/mzscheme/foreign-test.c index cb1dc07906..d0da456d43 100644 --- a/collects/tests/mzscheme/foreign-test.c +++ b/collects/tests/mzscheme/foreign-test.c @@ -57,3 +57,24 @@ X int use_g3(int x) { return ((int(*)(int))g3)(x); } X int hoho(int x, int(*(*f)(int))(int)) { return (f(x+1))(x-1); } X int grab7th(void *p) { return ((char *)p)[7]; } + +X int vec4(int x[]) { return x[0]+x[1]+x[2]+x[3]; } + +typedef struct _char_int { unsigned char a; int b; } char_int; +X int charint_to_int(char_int x) { return ((int)x.a) + x.b; } +X char_int int_to_charint(int x) { + char_int result; + result.a = (unsigned char)x; + result.b = x; + return result; +} +X char_int charint_swap(char_int x) { + char_int result; + result.a = (unsigned char)x.b; + result.b = (int)x.a; + return result; +} + +int(*grabbed_callback)(int) = NULL; +X void grab_callback(int(*f)(int)) { grabbed_callback = f; } +X int use_grabbed_callback(int n) { return grabbed_callback(n); } diff --git a/collects/tests/mzscheme/foreign-test.ss b/collects/tests/mzscheme/foreign-test.ss index e141bbd5b9..1cce9a4ba2 100644 --- a/collects/tests/mzscheme/foreign-test.ss +++ b/collects/tests/mzscheme/foreign-test.ss @@ -48,16 +48,19 @@ (compile-extension #t c o '()) (link-extension #t (list o) so))) -(let* ([lib (ffi-lib "./foreign-test")] - [ffi (lambda (name type) (get-ffi-obj name lib type))] - [test* (lambda (expected name type proc) - (test expected name (proc (ffi name type))))] - [t (lambda (expected name type . args) - (test* expected name type (lambda (p) (apply p args))))] - [tc (lambda (expected name type arg1 . args) - ;; curry first argument - (test* expected name type (lambda (p) (apply (p arg1) args))))] - [sqr (lambda (x) (* x x))]) +(define test-lib (ffi-lib "./foreign-test")) + +(for ([n (in-range 5)]) + (define (ffi name type) (get-ffi-obj name test-lib type)) + (define (test* expected name type proc) + (test expected name (proc (ffi name type)))) + (define (t expected name type . args) + (test* expected name type (lambda (p) (apply p args)))) + (define (tc expected name type arg1 . args) + ;; curry first argument + (test* expected name type (lambda (p) (apply (p arg1) args)))) + (define (sqr x) (when (zero? (random 4)) (collect-garbage)) (* x x)) + (define b (box #f)) ;; --- (t 2 'add1_int_int (_fun _int -> _int ) 1) (t 2 'add1_byte_int (_fun _byte -> _int ) 1) @@ -98,7 +101,7 @@ (test* 14 'ho (_fun (_fun _int -> _int) _int -> (_fun _int -> _int)) (lambda (p) ((p (ffi 'add1_byte_byte (_fun _byte -> _byte)) 3) 10))) ;; --- - (set-ffi-obj! "g3" lib (_fun _int -> _int) add1) + (set-ffi-obj! "g3" test-lib (_fun _int -> _int) add1) (t 4 'use_g3 (_fun _int -> _int) 3) (test* 4 'g3 _pointer (lambda (p) ((ptr-ref p (_fun _int -> _int)) 3))) ;; --- @@ -120,11 +123,40 @@ (lambda (x y) (let ([x (ptr-ref x _int)] [y (ptr-ref y _int)]) (cond [(< x y) -1] [(> x y) +1] [else 0]))))) - ;; --- - (t 55 'grab7th (_fun _pointer -> _int ) #"012345678") - (t 56 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" 1)) - (t 52 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" -3)) + ;; test vectors + (t 55 'grab7th (_fun _pointer -> _int ) #"012345678") + (t 56 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" 1)) + (t 52 'grab7th (_fun _pointer -> _int ) (ptr-add #"012345678" -3)) + (t 10 'vec4 (_fun (_list i _int) -> _int) '(1 2 3 4)) + (t 10 'vec4 (_fun (_vector i _int) -> _int) '#(1 2 3 4)) + (t 10 'vec4 (_fun _cvector -> _int) (list->cvector '(1 2 3 4) _int)) + (t 10 'vec4 (_fun _pointer -> _int) + (cvector-ptr (list->cvector '(1 2 3 4) _int))) + ;; --- + ;; test passing and receiving structs + (let ([_charint (_list-struct _byte _int)]) + (t 1212 'charint_to_int (_fun _charint -> _int) '(12 1200)) + (t '(123 123) 'int_to_charint (_fun _int -> _charint) 123) + (t '(255 1) 'charint_swap (_fun _charint -> _charint) '(1 255))) + ;; --- + ;; test sending a callback for C to hold, preventing the callback from GCing + (let ([with-holder + (lambda (h) + (t (void) 'grab_callback + (_fun (_fun #:holder h _int -> _int) -> _void) sqr) + (t 9 'use_grabbed_callback (_fun _int -> _int) 3) + (collect-garbage) ; make sure it survives a GC + (t 25 'use_grabbed_callback (_fun _int -> _int) 5) + (collect-garbage) + (t 81 'use_grabbed_callback (_fun _int -> _int) 9))]) + (with-holder #t) + (with-holder (box #f))) + ;; --- + ;; test exposing internal mzscheme functionality + (test '(1 2) + (get-ffi-obj 'scheme_make_pair #f (_fun _scheme _scheme -> _scheme)) + 1 '(2)) ) ;; test setting vector elements @@ -184,7 +216,6 @@ The following is some random Scheme and C code, with some things that should be added. ------------------------------------------------------------------------------- -(define _foo (_list-struct (list _byte _int))) (define foo-struct1 (get-ffi-obj "foo_struct1" "junk/foo.so" (_fun _foo -> _int))) (define foo-struct2 @@ -284,12 +315,6 @@ added. (string-set! x2 1 #\X) (foo-test "foo_string" '(#f) '(string) 'string) -(newline) -(printf ">>> scheme_make_pair(1,2) -> ~s\n" - ((ffi-call (ffi-obj libself "scheme_make_pair") - '(scheme scheme) 'scheme) - 1 2)) - (newline) (printf ">>> sizeof(int) = ~s\n" (ffi-size-of 'int)) '(let loop ((l '())) @@ -312,7 +337,6 @@ added. (ffi-ptr-set! block1 'ulong 1 22) (ffi-ptr-set! block1 'ulong 2 33) (ffi-ptr-set! block1 'ulong 3 44) -(foo-test "foo_vect" (list block1) '(pointer) 'int) ;(ffi-ptr-set! block1 'ulong 'abs 1 22) (printf ">>> [0] -> ~s\n" (ffi-ptr-ref block1 'ulong 0)) (printf ">>> [1] -> ~s\n" (ffi-ptr-ref block1 'ulong 1)) @@ -393,26 +417,7 @@ char* foo_string (char* x) { } } -int foo_vect(int x[]) { - return x[0]+x[1]+x[2]+x[3]; -} - int foo_foo(int x) { return x^1; } -typedef struct _char_int { - unsigned char a; - int b; -} char_int; - -int foo_struct1(char_int x) { - return ((int)x.a) + x.b; -} - -char_int foo_struct2(char_int x) { - char_int result; - result.a = (unsigned char)x.b; - result.b = (int)x.a; - return result; -} ------------------------------------------------------------------------------- |# From 8d06e0c707295a6dee60e722dfafe40c4e2d7992 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 4 Oct 2008 19:10:38 +0000 Subject: [PATCH 33/50] rename holder -> keep svn: r11932 --- collects/mzlib/foreign.ss | 28 ++++---- collects/scribblings/foreign/types.scrbl | 20 +++--- collects/tests/mzscheme/foreign-test.ss | 10 +-- .../private/type-effect-printer.ss | 2 +- collects/typed-scheme/rep/rep-utils.ss | 1 - collects/typed-scheme/rep/type-rep.ss | 2 +- collects/typed-scheme/typecheck/tc-if-unit.ss | 3 +- .../typed-scheme/utils/planet-requires.ss | 71 ------------------- 8 files changed, 31 insertions(+), 106 deletions(-) delete mode 100644 collects/typed-scheme/utils/planet-requires.ss diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 4353030192..be4163e98b 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -468,22 +468,22 @@ ;; optionally applying a wrapper function to modify the result primitive ;; (callouts) or the input procedure (callbacks). (define* (_cprocedure itypes otype - #:abi [abi #f] #:wrapper [wrapper #f] #:holder [holder #f]) - (_cprocedure* itypes otype abi wrapper holder)) + #:abi [abi #f] #:wrapper [wrapper #f] #:keep [keep #f]) + (_cprocedure* itypes otype abi wrapper keep)) ;; for internal use (define held-callbacks (make-weak-hasheq)) -(define (_cprocedure* itypes otype abi wrapper holder) +(define (_cprocedure* itypes otype abi wrapper keep) (define-syntax-rule (make-it wrap) (make-ctype _fpointer (lambda (x) (let ([cb (ffi-callback (wrap x) itypes otype abi)]) - (cond [(eq? holder #t) (hash-set! held-callbacks x cb)] - [(box? holder) - (let ([x (unbox holder)]) - (set-box! holder + (cond [(eq? keep #t) (hash-set! held-callbacks x cb)] + [(box? keep) + (let ([x (unbox keep)]) + (set-box! keep (if (or (null? x) (pair? x)) (cons cb x) cb)))] - [(procedure? holder) (holder cb)]) + [(procedure? keep) (keep cb)]) cb)) (lambda (x) (wrap (ffi-call x itypes otype abi))))) (if wrapper (make-it wrapper) (make-it begin))) @@ -512,7 +512,7 @@ (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) (define xs #f) (define abi #f) - (define holder #f) + (define keep #f) (define inputs #f) (define output #f) (define bind '()) @@ -577,9 +577,9 @@ (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] ... [else (err "unknown keyword" (car xs))])) - (when (keyword? k) (kwds [#:abi abi] [#:holder holder])))) - (unless abi (set! abi #'#f)) - (unless holder (set! holder #'#t)) + (when (keyword? k) (kwds [#:abi abi] [#:keep keep])))) + (unless abi (set! abi #'#f)) + (unless keep (set! keep #'#t)) ;; parse known punctuation (set! xs (map (lambda (x) (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) @@ -670,9 +670,9 @@ (string->symbol (string-append "ffi-wrapper:" n))) body))]) #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi (lambda (ffi) #,body) #,holder)) + #,abi (lambda (ffi) #,body) #,keep)) #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi #f #,holder))) + #,abi #f #,keep))) (syntax-case stx () [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index 664a17b4c8..d8003bbcbd 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -271,9 +271,8 @@ Otherwise, @scheme[_cprocedure] should be used (it is based on [#:wrapper wrapper (or/c false/c (procedure? . -> . procedure?)) #f] - [#:holder holder (or/c boolean? box? - (any/c . -> . any/c)) - #t]) + [#:keep keep (or/c boolean? box? (any/c . -> . any/c)) + #t]) any]{ A type constructor that creates a new function type, which is @@ -316,10 +315,9 @@ translating them to a foreign ``closure'', which foreign code can call as plain C functions. Additional care must be taken in case the foreign code might hold on to the callback function. In these cases you must arrange for the callback value to not be garbage-collected, -or the held callback will become invalid. The optional -@scheme[holder] keyword argument is used to achieve this. It can have -the following values: -@itemize[ +or the held callback will become invalid. The optional @scheme[keep] +keyword argument is used to achieve this. It can have the following +values: @itemize[ @item{@scheme[#t] makes the callback value stay in memory as long as the converted function is. In order to use this, you need to hold @@ -355,8 +353,8 @@ the following values: when a Scheme function is used in multiple callbacks (that is, sent to foreign code to hold onto multiple times).} -@item{Finally, if a one-argument function is provided as the - @scheme[holder], it will be invoked with the callback value when it +@item{Finally, if a one-argument function is provided as + @scheme[keep], it will be invoked with the callback value when it is generated. This allows you to grab the value directly and use it in any way.} @@ -365,8 +363,8 @@ the following values: @defform/subs[#:literals (-> :: :) (_fun fun-option ... maybe-args type-spec ... -> type-spec maybe-wrapper) - ([fun-option (code:line #:abi abi-expr) - (code:line #:holder holder-expr)] + ([fun-option (code:line #:abi abi-expr) + (code:line #:keep keep-expr)] [maybe-args code:blank (code:line (id ...) ::) (code:line id ::) diff --git a/collects/tests/mzscheme/foreign-test.ss b/collects/tests/mzscheme/foreign-test.ss index 1cce9a4ba2..9e8913921a 100644 --- a/collects/tests/mzscheme/foreign-test.ss +++ b/collects/tests/mzscheme/foreign-test.ss @@ -141,17 +141,17 @@ (t '(255 1) 'charint_swap (_fun _charint -> _charint) '(1 255))) ;; --- ;; test sending a callback for C to hold, preventing the callback from GCing - (let ([with-holder - (lambda (h) + (let ([with-keeper + (lambda (k) (t (void) 'grab_callback - (_fun (_fun #:holder h _int -> _int) -> _void) sqr) + (_fun (_fun #:keep k _int -> _int) -> _void) sqr) (t 9 'use_grabbed_callback (_fun _int -> _int) 3) (collect-garbage) ; make sure it survives a GC (t 25 'use_grabbed_callback (_fun _int -> _int) 5) (collect-garbage) (t 81 'use_grabbed_callback (_fun _int -> _int) 9))]) - (with-holder #t) - (with-holder (box #f))) + (with-kepper #t) + (with-keeper (box #f))) ;; --- ;; test exposing internal mzscheme functionality (test '(1 2) diff --git a/collects/typed-scheme/private/type-effect-printer.ss b/collects/typed-scheme/private/type-effect-printer.ss index 812f58a684..6b29c7c6da 100644 --- a/collects/typed-scheme/private/type-effect-printer.ss +++ b/collects/typed-scheme/private/type-effect-printer.ss @@ -2,7 +2,7 @@ (require "../utils/utils.ss") (require (rep type-rep effect-rep rep-utils) - (utils planet-requires tc-utils) + (utils tc-utils) scheme/match) ;; do we attempt to find instantiations of polymorphic types to print? diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/rep/rep-utils.ss index 2f49dba9f6..8e4124b37e 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/rep/rep-utils.ss @@ -4,7 +4,6 @@ (require mzlib/struct mzlib/plt-match syntax/boundmap - (utils planet-requires) "free-variance.ss" "interning.ss" mzlib/etc diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 6e744cfa52..5536a84417 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -1,7 +1,7 @@ #lang scheme/base (require "../utils/utils.ss") -(require (utils planet-requires tc-utils) +(require (utils tc-utils) "rep-utils.ss" "effect-rep.ss" "free-variance.ss" mzlib/trace scheme/match (for-syntax scheme/base)) diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss index e1d75c236c..bbae72978d 100644 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ b/collects/typed-scheme/typecheck/tc-if-unit.ss @@ -1,8 +1,7 @@ #lang scheme/unit (require (rename-in "../utils/utils.ss" [infer r:infer])) -(require (utils planet-requires) - "signatures.ss" +(require "signatures.ss" (rep type-rep effect-rep) (private type-effect-convenience subtype union type-utils type-comparison mutated-vars) (env lexical-env) diff --git a/collects/typed-scheme/utils/planet-requires.ss b/collects/typed-scheme/utils/planet-requires.ss deleted file mode 100644 index eb6f7b26e7..0000000000 --- a/collects/typed-scheme/utils/planet-requires.ss +++ /dev/null @@ -1,71 +0,0 @@ -#lang scheme/base - -(require (for-syntax scheme/base scheme/require-transform) - scheme/require-syntax) - -(define-for-syntax (splice-requires specs) - (define subs (map (compose cons expand-import) specs)) - (values (apply append (map car subs)) (apply append (map cdr subs)))) - -(define-syntax define-module - (syntax-rules () - [(_ nm spec ...) - - (define-syntax nm - (make-require-transformer - (lambda (stx) - (splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...))))) - #; - (define-require-syntax nm - (lambda (stx) - (syntax-case stx () - [(_) (datum->syntax stx (syntax->datum #'(combine-in spec ...)))])))])) - -#; -(define-syntax define-module - (lambda (stx) - (syntax-case stx () - [(_ nm spec ...) - (syntax/loc stx - (define-syntax nm - (make-require-transformer - (lambda (stx) - (splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...))))))]))) - -(define-syntax planet/multiple - (make-require-transformer - (lambda (stx) - (syntax-case stx () - [(_ plt files ...) - (let ([mk (lambda (spc) - (syntax-case spc (prefix-in) - [e - (string? (syntax-e #'e)) - (datum->syntax spc `(planet ,#'e ,#'plt) spc)] - [(prefix-in p e) - (datum->syntax spc `(prefix-in ,#'p (planet ,#'e ,#'plt)) spc)]))]) - (splice-requires (map mk (syntax->list #'(files ...)))))])))) - - -(provide galore schemeunit) -;; why is this neccessary? -(provide planet/multiple) - -(define-module galore - (prefix-in table: "tables.ss")) - -(require (galore)) - -(void (table:alist->eq '())) - -(define-module schemeunit - (planet/multiple ("schematics" "schemeunit.plt" 2 3) - "test.ss" - ;"graphical-ui.ss" - "text-ui.ss" - "util.ss") - ;; disabled until Carl updates to v4 - #; - (planet/multiple ("cce" "fasttest.plt" 1 2) - "random.ss" - "schemeunit.ss")) From 4dbd674671f76a04b3b2807a172b2ff87cea2804 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 4 Oct 2008 19:16:54 +0000 Subject: [PATCH 34/50] Welcome to a new PLT day. svn: r11933 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 8057221cb8..fb188bb189 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "30sep2008") +#lang scheme/base (provide stamp) (define stamp "4oct2008") From 202535a7f4ff9d6d23abbead6e6f7340b5334378 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 4 Oct 2008 20:33:22 +0000 Subject: [PATCH 35/50] typo svn: r11934 --- collects/tests/mzscheme/foreign-test.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/mzscheme/foreign-test.ss b/collects/tests/mzscheme/foreign-test.ss index 9e8913921a..bb624d4ddb 100644 --- a/collects/tests/mzscheme/foreign-test.ss +++ b/collects/tests/mzscheme/foreign-test.ss @@ -150,7 +150,7 @@ (t 25 'use_grabbed_callback (_fun _int -> _int) 5) (collect-garbage) (t 81 'use_grabbed_callback (_fun _int -> _int) 9))]) - (with-kepper #t) + (with-keeper #t) (with-keeper (box #f))) ;; --- ;; test exposing internal mzscheme functionality From 76172dd0f3669dd9011c7ecb4e4e864d6e3d85cf Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 4 Oct 2008 21:20:35 +0000 Subject: [PATCH 36/50] bad hack to make compilation go through svn: r11935 --- collects/scribble/latex-render.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index b52d1bb09e..6c2aff5a24 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -304,7 +304,9 @@ null) (define/override (render-blockquote t part ri) - (let ([kind (or (blockquote-style t) "quote")]) + (let* ([kind (or (blockquote-style t) "quote")] + ;; FIXME temporary hack to avoid a \begin{blockquote} + [kind (if (eq? 'blockquote kind) "quote" kind)]) (printf "\n\n\\begin{~a}\n" kind) (parameterize ([current-table-mode (list "blockquote" t)]) (for ([e (blockquote-paragraphs t)]) (render-block e part ri #f))) From 0d6a9d73dc4616d5f2b321abf06102cf67c3e609 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 5 Oct 2008 02:23:21 +0000 Subject: [PATCH 37/50] proper fix for the latex problem (blockquote was used unnecessarily) svn: r11936 --- collects/scribble/latex-render.ss | 4 +--- collects/teachpack/htdp/scribblings/world.scrbl | 17 ++++++++--------- 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index 6c2aff5a24..b52d1bb09e 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -304,9 +304,7 @@ null) (define/override (render-blockquote t part ri) - (let* ([kind (or (blockquote-style t) "quote")] - ;; FIXME temporary hack to avoid a \begin{blockquote} - [kind (if (eq? 'blockquote kind) "quote" kind)]) + (let ([kind (or (blockquote-style t) "quote")]) (printf "\n\n\\begin{~a}\n" kind) (parameterize ([current-table-mode (list "blockquote" t)]) (for ([e (blockquote-paragraphs t)]) (render-block e part ri #f))) diff --git a/collects/teachpack/htdp/scribblings/world.scrbl b/collects/teachpack/htdp/scribblings/world.scrbl index 3f763651a7..a0f6584c97 100644 --- a/collects/teachpack/htdp/scribblings/world.scrbl +++ b/collects/teachpack/htdp/scribblings/world.scrbl @@ -240,16 +240,15 @@ for the creation of scenes, too. @; ----------------------------------------------------------------------------- @(define (table* . stuff) - ;; (list paragraph paragraph) *-> Table + ;; (list paragraph paragraph) *-> Table (define (flow* x) (make-flow (list x))) - (make-blockquote 'blockquote - (list - (make-table (make-with-attributes 'boxed - '((cellspacing . "6"))) - ;list - (map (lambda (x) (map flow* x)) stuff) - #;(map flow* (map car stuff)) - #;(map flow* (map cadr stuff)))))) + (make-blockquote #f + (list + (make-table (make-with-attributes 'boxed '((cellspacing . "6"))) + ;; list + (map (lambda (x) (map flow* x)) stuff) + #;(map flow* (map car stuff)) + #;(map flow* (map cadr stuff)))))) @; ----------------------------------------------------------------------------- @section[#:tag "example"]{A First Example} From 2899c1f1cce30f7aacb5032e92c87cf06378722c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 5 Oct 2008 03:40:55 +0000 Subject: [PATCH 38/50] planet-requires moved to tests/typed-scheme/util-tests svn: r11937 --- collects/tests/typed-scheme/main.ss | 2 +- .../typed-scheme/unit-tests/all-tests.ss | 6 +- .../typed-scheme/unit-tests/infer-tests.ss | 9 ++- .../typed-scheme/unit-tests/module-tests.ss | 3 +- .../typed-scheme/unit-tests/new-fv-tests.ss | 8 +-- .../unit-tests/parse-type-tests.ss | 9 ++- .../unit-tests/planet-requires.ss | 64 +++++++++++++++++++ .../unit-tests/remove-intersect-tests.ss | 8 +-- .../typed-scheme/unit-tests/subst-tests.ss | 9 ++- .../typed-scheme/unit-tests/subtype-tests.ss | 9 +-- .../typed-scheme/unit-tests/test-utils.ss | 7 +- .../unit-tests/type-annotation-test.ss | 9 ++- .../unit-tests/type-equal-tests.ss | 8 +-- .../unit-tests/typecheck-tests.ss | 9 ++- 14 files changed, 107 insertions(+), 53 deletions(-) create mode 100644 collects/tests/typed-scheme/unit-tests/planet-requires.ss diff --git a/collects/tests/typed-scheme/main.ss b/collects/tests/typed-scheme/main.ss index b4fe5d20c1..76e7a139f0 100644 --- a/collects/tests/typed-scheme/main.ss +++ b/collects/tests/typed-scheme/main.ss @@ -86,7 +86,7 @@ (define (go) (test/gui tests)) (define (go/text) (test/text-ui tests)) - +(go/text) (when (getenv "PLT_TESTS") (unless (parameterize ([current-output-port (open-output-string)]) (= 0 (go/text))) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index 1fe728d05b..ec859fed7f 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -2,6 +2,7 @@ (require "test-utils.ss" + "planet-requires.ss" "typecheck-tests.ss" "subtype-tests.ss" ;; done "type-equal-tests.ss" ;; done @@ -12,9 +13,8 @@ "subst-tests.ss" "infer-tests.ss") -(require (utils planet-requires) (r:infer infer infer-dummy)) - -(require (schemeunit)) +(require (r:infer infer infer-dummy) + (schemeunit)) (provide unit-tests) diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index aef624b748..bf3b7b95ec 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -1,11 +1,10 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) - (rep type-rep) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (rep type-rep) (r:infer infer) (private type-effect-convenience union type-utils) - (prefix-in table: (utils tables))) -(require (schemeunit)) + (prefix-in table: (utils tables)) + (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/module-tests.ss b/collects/tests/typed-scheme/unit-tests/module-tests.ss index 490c1c2a89..decc67820c 100644 --- a/collects/tests/typed-scheme/unit-tests/module-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/module-tests.ss @@ -1,6 +1,5 @@ #lang scheme -(require "test-utils.ss") -(require (utils planet-requires)) +(require "test-utils.ss" "planet-requires.ss") (require (schemeunit)) (provide module-tests) diff --git a/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss b/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss index 7e24d23ca2..d9ca47239b 100644 --- a/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/new-fv-tests.ss @@ -1,8 +1,8 @@ (module new-fv-tests mzscheme - (require "test-utils.ss") - (require/private type-rep rep-utils planet-requires type-effect-convenience meet-join subtype union) - (require-schemeunit) - + (require "test-utils.ss" "planet-requires.ss") + (require/private type-rep rep-utils type-effect-convenience meet-join subtype union) + (require-schemeunit) + (define variance-gen (random-uniform Covariant Contravariant Invariant Constant)) (define alpha-string (random-string (random-char (random-int-between 65 90)) (random-size 1))) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index fedf84fb81..b40e131b1f 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -1,17 +1,16 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires tc-utils) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (utils tc-utils) (env type-alias-env type-environments type-name-env init-envs) (rep type-rep) (private type-comparison parse-type subtype - union type-utils)) + union type-utils) + (schemeunit)) (require (rename-in (private type-effect-convenience) [-> t:->]) (except-in (private base-types) Un) (for-template (private base-types))) -(require (schemeunit)) - (provide parse-type-tests) ;; HORRIBLE HACK! diff --git a/collects/tests/typed-scheme/unit-tests/planet-requires.ss b/collects/tests/typed-scheme/unit-tests/planet-requires.ss new file mode 100644 index 0000000000..038b3fb17e --- /dev/null +++ b/collects/tests/typed-scheme/unit-tests/planet-requires.ss @@ -0,0 +1,64 @@ +#lang scheme/base + +(require (for-syntax scheme/base scheme/require-transform) + scheme/require-syntax) + +(define-for-syntax (splice-requires specs) + (define subs (map (compose cons expand-import) specs)) + (values (apply append (map car subs)) (apply append (map cdr subs)))) + +(define-syntax define-module + (syntax-rules () + [(_ nm spec ...) + + (define-syntax nm + (make-require-transformer + (lambda (stx) + (splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...))))) + #; + (define-require-syntax nm + (lambda (stx) + (syntax-case stx () + [(_) (datum->syntax stx (syntax->datum #'(combine-in spec ...)))])))])) + +#; +(define-syntax define-module + (lambda (stx) + (syntax-case stx () + [(_ nm spec ...) + (syntax/loc stx + (define-syntax nm + (make-require-transformer + (lambda (stx) + (splice-requires (list (syntax-local-introduce (quote-syntax spec)) ...))))))]))) + +(define-syntax planet/multiple + (make-require-transformer + (lambda (stx) + (syntax-case stx () + [(_ plt files ...) + (let ([mk (lambda (spc) + (syntax-case spc (prefix-in) + [e + (string? (syntax-e #'e)) + (datum->syntax spc `(planet ,#'e ,#'plt) spc)] + [(prefix-in p e) + (datum->syntax spc `(prefix-in ,#'p (planet ,#'e ,#'plt)) spc)]))]) + (splice-requires (map mk (syntax->list #'(files ...)))))])))) + + +(provide schemeunit) +;; why is this neccessary? +(provide planet/multiple) + +(define-module schemeunit + (planet/multiple ("schematics" "schemeunit.plt" 2 3) + "test.ss" + ;"graphical-ui.ss" + "text-ui.ss" + "util.ss") + ;; disabled until Carl updates to v4 + #; + (planet/multiple ("cce" "fasttest.plt" 1 2) + "random.ss" + "schemeunit.ss")) diff --git a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss index 20da5c73c3..e18cd04b91 100644 --- a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss @@ -1,11 +1,9 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (rep type-rep) - (utils planet-requires) (r:infer infer) - (private type-effect-convenience remove-intersect subtype union)) - -(require (schemeunit)) + (private type-effect-convenience remove-intersect subtype union) + (schemeunit)) (define-syntax (restr-tests stx) (syntax-case stx () diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.ss b/collects/tests/typed-scheme/unit-tests/subst-tests.ss index 10a35fc98a..91d42cd426 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -1,10 +1,9 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) - (rep type-rep) - (private type-utils type-effect-convenience)) -(require (schemeunit)) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (rep type-rep) + (private type-utils type-effect-convenience) + (schemeunit)) (define-syntax-rule (s img var tgt result) (test-eq? "test" (substitute img 'var tgt) result)) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index 83bb3e9a51..6aac041abb 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -1,15 +1,12 @@ #lang scheme/base -(require "test-utils.ss") +(require "test-utils.ss" "planet-requires.ss") (require (private subtype type-effect-convenience union) (rep type-rep) - (utils planet-requires) (env init-envs type-environments) - (r:infer infer infer-dummy)) - - -(require (schemeunit) + (r:infer infer infer-dummy) + (schemeunit) (for-syntax scheme/base)) (provide subtype-tests) diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.ss b/collects/tests/typed-scheme/unit-tests/test-utils.ss index b160cacdf9..9c40943939 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -1,15 +1,16 @@ #lang scheme/base (provide (all-defined-out)) -(require scheme/require-syntax +(require "planet-requires.ss" + scheme/require-syntax scheme/match typed-scheme/utils/utils (for-syntax scheme/base)) -(require (utils planet-requires) (private type-comparison type-utils)) +(require (private type-comparison type-utils) + (schemeunit)) (provide private typecheck (rename-out [infer r:infer]) utils env rep) -(require (schemeunit)) (define (mk-suite ts) (match (map (lambda (f) (f)) ts) diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss index 167db51eb7..9f5398e72a 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -1,12 +1,11 @@ #lang scheme/base -(require "test-utils.ss" +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) (require (private type-annotation type-effect-convenience parse-type) (env type-environments type-name-env init-envs) - (utils planet-requires tc-utils) - (rep type-rep)) - -(require (schemeunit)) + (utils tc-utils) + (rep type-rep) + (schemeunit)) (provide type-annotation-tests) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index 899b8e1e97..1e4c5c2202 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -1,9 +1,9 @@ #lang scheme/base -(require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) (rep type-rep) - (private type-comparison type-effect-convenience union subtype)) -(require (schemeunit)) +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base)) +(require (rep type-rep) + (private type-comparison type-effect-convenience union subtype) + (schemeunit)) (provide type-equal-tests) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index 5506b1ff4f..0be4c518f5 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -1,21 +1,20 @@ #lang scheme/base -(require "test-utils.ss" +(require "test-utils.ss" "planet-requires.ss" (for-syntax scheme/base) (for-template scheme/base)) (require (private base-env mutated-vars type-utils union prims type-effect-convenience type-annotation) (typecheck typechecker) (rep type-rep effect-rep) - (utils tc-utils planet-requires) - (env type-name-env type-environments init-envs)) + (utils tc-utils) + (env type-name-env type-environments init-envs) + (schemeunit)) (require (for-syntax (utils tc-utils) (typecheck typechecker) (env type-env) (private base-env)) (for-template (private base-env base-types))) -(require (schemeunit)) - From a1bbd7dd3c17b48ddd0cad18baf2a173c33b5066 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 5 Oct 2008 03:41:17 +0000 Subject: [PATCH 39/50] oops, revert this line svn: r11938 --- collects/tests/typed-scheme/main.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/typed-scheme/main.ss b/collects/tests/typed-scheme/main.ss index 76e7a139f0..b4fe5d20c1 100644 --- a/collects/tests/typed-scheme/main.ss +++ b/collects/tests/typed-scheme/main.ss @@ -86,7 +86,7 @@ (define (go) (test/gui tests)) (define (go/text) (test/text-ui tests)) -(go/text) + (when (getenv "PLT_TESTS") (unless (parameterize ([current-output-port (open-output-string)]) (= 0 (go/text))) From 9c92ce8cc99a091375c384e93fb3e2c980f62b83 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 5 Oct 2008 04:17:26 +0000 Subject: [PATCH 40/50] disable htdp languages context for now svn: r11939 --- collects/lang/htdp-langs.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 78ecc63e33..82004b4038 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -524,6 +524,9 @@ keywords] [(drscheme:teachpack-menu-items) htdp-teachpack-callbacks] [(drscheme:special:insert-lambda) #f] + #; + ;; FIXME: disable context for now, re-enable when it is possible + ;; to have the context search the teachpack manual too. [(drscheme:help-context-term) (let* ([m (get-module)] [m (and m (pair? m) (pair? (cdr m)) (cadr m))] From 062152e71123d468e3e99f5f6eb082a28e7fbaee Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 5 Oct 2008 04:42:48 +0000 Subject: [PATCH 41/50] fixed PR9806 and PR9807 svn: r11940 --- collects/mred/private/path-dialog.ss | 3 ++- collects/scheme/private/list.ss | 8 ++------ 2 files changed, 4 insertions(+), 7 deletions(-) diff --git a/collects/mred/private/path-dialog.ss b/collects/mred/private/path-dialog.ss index 336c201c72..464eedc840 100644 --- a/collects/mred/private/path-dialog.ss +++ b/collects/mred/private/path-dialog.ss @@ -40,7 +40,8 @@ (apply simplify-path (regexp-replace* #rx"/" (if (path? p) (path->string p) p) "\\\\") more)) - (compose simplify-path expand-path*))) + (lambda (p . more) + (apply simplify-path (expand-path* p) more)))) (define directory-exists*? (compose directory-exists? expand-path*)) (define file-exists*? (compose file-exists? expand-path*)) diff --git a/collects/scheme/private/list.ss b/collects/scheme/private/list.ss index b6b8b0aa8e..a5202a47f8 100644 --- a/collects/scheme/private/list.ss +++ b/collects/scheme/private/list.ss @@ -247,13 +247,9 @@ (lambda args (f (apply g args)))) (if (eqv? 1 (procedure-arity g)) ; optimize: single input (lambda (a) - (call-with-values - (lambda () (g a)) - f)) + (call-with-values (lambda () (g a)) f)) (lambda args - (call-with-values - (lambda () (apply g args)) - f)))))] + (call-with-values (lambda () (apply g args)) f)))))] [(f . more) (if (procedure? f) (let ([m (apply compose more)]) From 115e2d9b91cc73785fa429b8a4f3750e1998b041 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 5 Oct 2008 04:43:23 +0000 Subject: [PATCH 42/50] Welcome to a new PLT day. svn: r11941 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index fb188bb189..21c2263581 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "4oct2008") +#lang scheme/base (provide stamp) (define stamp "5oct2008") From 2b5e42850d43c4cae2fb43f798447e352be4188c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 5 Oct 2008 20:21:13 +0000 Subject: [PATCH 43/50] post 4.1.1 svn: r11943 --- src/mzscheme/src/schvers.h | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index b8152b8875..e071a13ecb 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.1" +#define MZSCHEME_VERSION "4.1.1.1" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 1 -#define MZSCHEME_VERSION_W 0 +#define MZSCHEME_VERSION_W 1 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) From baf98c4136f86066062b84300587c93324a75c33 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 5 Oct 2008 20:32:26 +0000 Subject: [PATCH 44/50] added chat noir svn: r11944 --- collects/games/chat-noir/chat-noir-unit.ss | 21 + collects/games/chat-noir/chat-noir.png | Bin 0 -> 1479 bytes collects/games/chat-noir/chat-noir.ss | 1005 ++++++++++++++++++++ collects/games/chat-noir/hash.ss | 2 + collects/games/chat-noir/info.ss | 5 + collects/games/scribblings/chat-noir.scrbl | 59 ++ collects/games/scribblings/std-games.scrbl | 1 + 7 files changed, 1093 insertions(+) create mode 100644 collects/games/chat-noir/chat-noir-unit.ss create mode 100644 collects/games/chat-noir/chat-noir.png create mode 100644 collects/games/chat-noir/chat-noir.ss create mode 100644 collects/games/chat-noir/hash.ss create mode 100644 collects/games/chat-noir/info.ss create mode 100644 collects/games/scribblings/chat-noir.scrbl diff --git a/collects/games/chat-noir/chat-noir-unit.ss b/collects/games/chat-noir/chat-noir-unit.ss new file mode 100644 index 0000000000..2e9e3cbe14 --- /dev/null +++ b/collects/games/chat-noir/chat-noir-unit.ss @@ -0,0 +1,21 @@ +#lang scheme/base +(require scheme/unit + scheme/runtime-path + (prefix-in x: lang/htdp-intermediate-lambda) + (prefix-in x: htdp/world)) + + +(provide game@) +(define orig-namespace (current-namespace)) +(define-runtime-path chat-noir "chat-noir.ss") + +(define-unit game@ + (import) + (export) + (define ns (make-base-namespace)) + (parameterize ([current-namespace ns]) + (namespace-attach-module orig-namespace + '(lib "htdp-intermediate-lambda.ss" "lang")) + (namespace-attach-module orig-namespace + '(lib "world.ss" "htdp")) + (dynamic-require chat-noir #f))) \ No newline at end of file diff --git a/collects/games/chat-noir/chat-noir.png b/collects/games/chat-noir/chat-noir.png new file mode 100644 index 0000000000000000000000000000000000000000..cb5d82358c266d5503f317f0d170581dd70a77a1 GIT binary patch literal 1479 zcmV;&1vvVNP)ZX>A1hL>YT%GT*3K@LRLIu!w6e;wImaSICP> z1r-dEOY>1=p2s0C&jgSUNhT>FbwrE~B5#nnWPlqzzD*0qYEtBz_xnb_!+Z>!sUVS) zv*cHDpF{))2Rp*T!tmtD6HcFs!C-*LQ!`gbv@f($iwq~h2-EZBB4Y= zLIU#h^HE$}jQIF?ZJ-$P`0-=eekNid4MRjk1dK)_Mn*=^-rkP=`}d=}yLlpCCJRogm|N(yaJvn4-6&)oLik(zka$Sreu>c z8_ddXx2ua6FRI?&Ud11vcI?=pY{52#5U8NngOoMRs$hg-YN*494=Z|6g@lAik$pi- z&olB{9w;VuVw-W;#xOPI<>jfqzCKk}Rwh4Jg=dE=N3TOU{&c96-&0grdYE3XsHjjk zZro6pFJIPkW2jLruV1bl*BxqY|5}xJFj223B_-)|`}XZqEHGJ1n(@u)M=3_J=W_}1 zC&WqKC1XSqs-C=Rv)MLORaJqCbWU*%uG=oSN8B)lnBW=nz;#z=0nBEz&dGp)0PsDG zyT;)fav?A#kUtBU7@CmRA^UE(8{4*RlQ5&czP^&nZxd-ln@KE*B+}Zx5(DK6wLX?| z6!J-y1m-#M(KBG0Bjpo{Ei)#gZjUbb5&ArTW6(w1_mNEH5HAGjXFo!?4@J;M&2Z%vw%nyCle`_ z9|`MSw>u91{YUW*=W_QZ$Off~h?4s<@kuntG7`x)u~n|MEnBu|k4lbBUv-iKaz`IJ zbVwV@Q17`3&cxiN;oGgNgimage : world -> image +(define (world->image w) + (chop-whiskers + (overlay (board->image (world-board w) (world-size w)) + (move-pinhole + (cond + [(equal? (world-state w) 'cat-won) happy-cat] + [(equal? (world-state w) 'cat-lost) sad-cat] + [else thinking-cat]) + (- (cell-center-x (world-cat w))) + (- (cell-center-y (world-cat w))))))) + +(check-expect + (world->image + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'playing + 2)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2) + (move-pinhole thinking-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) +(check-expect + (world->image + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'cat-won + 2)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2) + (move-pinhole happy-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) +(check-expect + (world->image + (make-world (list (make-cell (make-posn 0 1) false)) + (make-posn 0 1) + 'cat-lost + 2)) + (overlay + (board->image (list (make-cell (make-posn 0 1) false)) + 2) + (move-pinhole sad-cat + (- (cell-center-x (make-posn 0 1))) + (- (cell-center-y (make-posn 0 1)))))) + +;; chop-whiskers : image -> image +;; crops the image so that anything above or to the left of the pinhole is gone +(define (chop-whiskers img) + (shrink img + 0 + 0 + (- (image-width img) (pinhole-x img) 1) + (- (image-height img) (pinhole-y img) 1))) +(check-expect (chop-whiskers (rectangle 5 5 'solid 'black)) + (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) +(check-expect (chop-whiskers (rectangle 6 6 'solid 'black)) + (put-pinhole (rectangle 3 3 'solid 'black) 0 0)) + +(check-expect + (pinhole-x + (world->image + (make-world + (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false)) + (make-posn 0 0) + 'playing + 2))) + 0) +(check-expect + (pinhole-x + (world->image + (make-world + (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false)) + (make-posn 0 1) + 'playing + 2))) + 0) + + +;; board->image : board number -> image +(define (board->image cs world-size) + (foldl overlay + (nw:rectangle (world-width world-size) + (world-height world-size) + 'outline + 'black) + (map cell->image cs))) + +(check-expect (board->image (list (make-cell (make-posn 0 0) false)) 3) + (overlay + (cell->image + (make-cell (make-posn 0 0) false)) + (nw:rectangle (world-width 3) + (world-height 3) + 'outline + 'black))) + + +;; cell->image : cell -> image +(define (cell->image c) + (local [(define x (cell-center-x (cell-p c))) + (define y (cell-center-y (cell-p c)))] + (move-pinhole + (cond + [(cell-blocked? c) + (circle circle-radius 'solid 'black)] + [else + (circle circle-radius 'solid 'lightblue)]) + (- x) + (- y)))) + +(check-expect (cell->image (make-cell (make-posn 0 0) false)) + (move-pinhole (circle circle-radius 'solid 'lightblue) + (- circle-radius) + (- circle-radius))) +(check-expect (cell->image (make-cell (make-posn 0 0) true)) + (move-pinhole (circle circle-radius 'solid 'black) + (- circle-radius) + (- circle-radius))) + +;; world-width : number -> number +;; computes the width of the drawn world in terms of its size +(define (world-width board-size) + (local [(define rightmost-posn + (make-posn (- board-size 1) (- board-size 2)))] + (+ (cell-center-x rightmost-posn) circle-radius))) +(check-expect (world-width 3) 150) + +;; world-height : number -> number +;; computes the height of the drawn world in terms of its size +(define (world-height board-size) + (local [(define bottommost-posn + (make-posn (- board-size 1) (- board-size 1)))] + (+ (cell-center-y bottommost-posn) circle-radius))) +(check-expect (world-height 3) 116.208) + + + +; +; +; +; +; +; ;;;;;;;;;; +; ;;; ;;; +; ;;; ;;; +; ;;;;;; ;;;;; ;;; ;;; ; ;;;; ;;;;; ;;;;;; +; ;;; ;;;;;;; ;;; ;;; ;;; ;;;;;;;;; ;;;;;;; ;;; ;;; +; ;;; ;;;;;;;; ;;; ;;; ;;; ;; ;; ;;;;;;;; ;;; +; ;;; ;;;;;;;;;;;; ;;; ;;; ; ;; ;; ; ;;;;;;;;; +; ;;; ;;; ;; ;; ; ;;; ; ;; ;;;; +; ;;; ; ;;; ;;; ;;; ;;; ;;;;;;; ;;;;;;;; ;;;;; ;;; +; ;;; ; ;; ;;; ;;;; ;;;; ;; ;;; ;;;;;; ;;;; ;; +; ;;;; ;;;; ;; ;;;; ;;;;;; +; ;; +; ; +; + + +;; cell-center : cell -> number +(define (cell-center-x p) + (local [(define x (posn-x p)) + (define y (posn-y p))] + (+ circle-radius + (* x circle-spacing 2) + (if (odd? y) + circle-spacing + 0)))) + +(check-expect (cell-center-x (make-posn 0 0)) + circle-radius) +(check-expect (cell-center-x (make-posn 0 1)) + (+ circle-spacing circle-radius)) +(check-expect (cell-center-x (make-posn 1 0)) + (+ (* 2 circle-spacing) circle-radius)) +(check-expect (cell-center-x (make-posn 1 1)) + (+ (* 3 circle-spacing) circle-radius)) + +;; cell-center-y : cell -> number +(define (cell-center-y p) + (local [(define y (posn-y p))] + (+ circle-radius + (* y circle-spacing 2 + .866 ;; .866 is an exact approximate to sin(pi/3) + )))) + +(check-expect (cell-center-y (make-posn 1 1)) + (+ circle-radius (* 2 circle-spacing .866))) +(check-expect (cell-center-y (make-posn 1 0)) + circle-radius) + + +; +; +; +; +; +; ;;;;; +; ;;;; +; ;;; +; ;;;; ;;; ; ;;;; ;;;; ;; ; ;;;; ;;; ; +; ;;;;;;; ;;;;;; ;;;; ;;;;;;;;; ;;;;;;;;; ;;; ;;; +; ; ;;;; ;;; ;;;;;;;;;;;;;;; ;; ;; ;;; ;;;; +; ;; ;;; ;;; ;;;; ;;; ;;; ; ;; ;;;; ;;; +; ;;;;;;; ;;; ;; ;;;; ; ;;; ;;; ;;; +; ;;; ;;; ;;;;;;;;;; ;;;;;;; ;; ;;; +; ;;;; ;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; ;; ;;; +; ;;;;; ;;; ;;;;; ;; ;;;; ;;; +; ;;;; ;;; ;; ;; +; ;;;;;; ; +; + +;; a distance-map is +;; (listof dist-cells) + +;; a dist-cell is +;; - (make-dist-cell posn number) +(define-struct dist-cell (p n)) + +;; build-table/fast : world -> distance-map +(define (build-table/fast world) + (local [(define board-size (world-size world)) + (define blocked (make-hash)) + (define ht (make-hash)) + (define (search p) + (cond + [(hash-ref blocked p) + '∞] + [(on-boundary? p board-size) + ((lambda (a b) b) + (hash-set! ht p 0) + 0)] + [(not (boolean? (hash-ref ht p #f))) + (hash-ref ht p)] + [else + ((lambda (a b c) c) + (hash-set! ht p '∞) + (hash-set! + ht + p + (add1/f (min-l (map search + (adjacent p board-size))))) + (hash-ref ht p))]))] + ((lambda (a b c) c) + (for-each (lambda (cell) + (hash-set! blocked + (cell-p cell) + (cell-blocked? cell))) + (world-board world)) + (search (world-cat world)) + (hash-map ht make-dist-cell)))) + +;; build-table : world -> distance-map +(define (build-table world) + (build-distance (world-board world) + (world-cat world) + '() + '() + (world-size world))) + +;; build-distance : board posn table (listof posn) number -> distance-map +(define (build-distance board p t visited board-size) + (cond + [(cell-blocked? (lookup-board board p)) + (add-to-table p '∞ t)] + [(on-boundary? p board-size) + (add-to-table p 0 t)] + [(in-table? t p) + t] + [(member p visited) + (add-to-table p '∞ t)] + [else + (local [(define neighbors (adjacent p board-size)) + (define neighbors-t (build-distances + board + neighbors + t + (cons p visited) + board-size))] + (add-to-table p + (add1/f + (min-l + (map (lambda (neighbor) + (lookup-in-table neighbors-t neighbor)) + neighbors))) + neighbors-t))])) + +;; build-distances : board (listof posn) distance-map (listof posn) number +;; -> distance-map +(define (build-distances board ps t visited board-size) + (cond + [(empty? ps) t] + [else + (build-distances board + (rest ps) + (build-distance board (first ps) t visited board-size) + visited + board-size)])) + +(check-expect (build-distance (list (make-cell (make-posn 0 0) false)) + (make-posn 0 0) + '() + '() + 1) + (list (make-dist-cell (make-posn 0 0) 0))) + +(check-expect (build-distance (list (make-cell (make-posn 0 0) true)) + (make-posn 0 0) + '() + '() + 1) + (list (make-dist-cell (make-posn 0 0) '∞))) + +(check-expect (build-distance (list (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 0) false) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 2 1) false) + (make-cell (make-posn 2 2) false)) + (make-posn 1 1) + '() + '() + 3) + (list (make-dist-cell (make-posn 1 0) 0) + (make-dist-cell (make-posn 2 0) 0) + (make-dist-cell (make-posn 0 1) 0) + (make-dist-cell (make-posn 2 1) 0) + (make-dist-cell (make-posn 1 2) 0) + (make-dist-cell (make-posn 2 2) 0) + (make-dist-cell (make-posn 1 1) 1))) + +(check-expect (build-distance (list (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 0) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + '() + '() + 3) + (list (make-dist-cell (make-posn 1 0) '∞) + (make-dist-cell (make-posn 2 0) '∞) + (make-dist-cell (make-posn 0 1) '∞) + (make-dist-cell (make-posn 2 1) '∞) + (make-dist-cell (make-posn 1 2) '∞) + (make-dist-cell (make-posn 2 2) '∞) + (make-dist-cell (make-posn 1 1) '∞))) + +(check-expect (build-distance + (append-all + (build-list + 5 + (lambda (i) + (build-list + 5 + (lambda (j) + (make-cell (make-posn i j) false)))))) + (make-posn 2 2) + '() + '() + 5) + (list (make-dist-cell (make-posn 1 0) 0) + (make-dist-cell (make-posn 2 0) 0) + (make-dist-cell (make-posn 0 1) 0) + (make-dist-cell (make-posn 3 0) 0) + (make-dist-cell (make-posn 1 1) 1) + (make-dist-cell (make-posn 4 0) 0) + (make-dist-cell (make-posn 2 1) 1) + (make-dist-cell (make-posn 4 1) 0) + (make-dist-cell (make-posn 3 1) 1) + (make-dist-cell (make-posn 2 2) 2) + (make-dist-cell (make-posn 4 2) 0) + (make-dist-cell (make-posn 3 2) 1) + (make-dist-cell (make-posn 0 2) 0) + (make-dist-cell (make-posn 0 3) 0) + (make-dist-cell (make-posn 1 3) 1) + (make-dist-cell (make-posn 1 2) 1) + (make-dist-cell (make-posn 2 3) 1) + (make-dist-cell (make-posn 1 4) 0) + (make-dist-cell (make-posn 2 4) 0) + (make-dist-cell (make-posn 4 3) 0) + (make-dist-cell (make-posn 3 4) 0) + (make-dist-cell (make-posn 4 4) 0) + (make-dist-cell (make-posn 3 3) 1))) + +;; add-to-table : posn number table -> table +(define (add-to-table p n t) + (cond + [(empty? t) (list (make-dist-cell p n))] + [else + (cond + [(equal? p (dist-cell-p (first t))) + (cons (make-dist-cell p (min/f (dist-cell-n (first t)) n)) + (rest t))] + [else + (cons (first t) (add-to-table p n (rest t)))])])) + +(check-expect (add-to-table (make-posn 1 2) 3 '()) + (list (make-dist-cell (make-posn 1 2) 3))) +(check-expect (add-to-table (make-posn 1 2) + 3 + (list (make-dist-cell (make-posn 1 2) 4))) + (list (make-dist-cell (make-posn 1 2) 3))) +(check-expect (add-to-table (make-posn 1 2) + 3 + (list (make-dist-cell (make-posn 1 2) 2))) + (list (make-dist-cell (make-posn 1 2) 2))) +(check-expect (add-to-table (make-posn 1 2) + 3 + (list (make-dist-cell (make-posn 2 2) 2))) + (list (make-dist-cell (make-posn 2 2) 2) + (make-dist-cell (make-posn 1 2) 3))) + +;; in-table : table posn -> boolean +(define (in-table? t p) (number? (lookup-in-table t p))) + +(check-expect (in-table? empty (make-posn 1 2)) false) +(check-expect (in-table? (list (make-dist-cell (make-posn 1 2) 3)) + (make-posn 1 2)) + true) +(check-expect (in-table? (list (make-dist-cell (make-posn 2 1) 3)) + (make-posn 1 2)) + false) + +;; lookup-in-table : table posn -> number or '∞ +;; looks for the distance as recorded in the table t, +;; if not found returns a distance of '∞ +(define (lookup-in-table t p) + (cond + [(empty? t) '∞] + [else (cond + [(equal? p (dist-cell-p (first t))) + (dist-cell-n (first t))] + [else + (lookup-in-table (rest t) p)])])) + +(check-expect (lookup-in-table empty (make-posn 1 2)) '∞) +(check-expect (lookup-in-table (list (make-dist-cell (make-posn 1 2) 3)) + (make-posn 1 2)) + 3) +(check-expect (lookup-in-table (list (make-dist-cell (make-posn 2 1) 3)) + (make-posn 1 2)) + '∞) + +;; on-boundary? : posn number -> boolean +(define (on-boundary? p board-size) + (or (= (posn-x p) 0) + (= (posn-y p) 0) + (= (posn-x p) (- board-size 1)) + (= (posn-y p) (- board-size 1)))) + +(check-expect (on-boundary? (make-posn 0 1) 13) true) +(check-expect (on-boundary? (make-posn 1 0) 13) true) +(check-expect (on-boundary? (make-posn 12 1) 13) true) +(check-expect (on-boundary? (make-posn 1 12) 13) true) +(check-expect (on-boundary? (make-posn 1 1) 13) false) +(check-expect (on-boundary? (make-posn 10 10) 13) false) + +;; adjacent : posn number -> (listof posn) +(define (adjacent p board-size) + (local [(define x (posn-x p)) + (define y (posn-y p))] + (filter (lambda (x) (in-bounds? x board-size)) + (cond + [(even? y) + (list (make-posn (- x 1) (- y 1)) + (make-posn x (- y 1)) + (make-posn (- x 1) y) + (make-posn (+ x 1) y) + (make-posn (- x 1) (+ y 1)) + (make-posn x (+ y 1)))] + [else + (list (make-posn x (- y 1)) + (make-posn (+ x 1) (- y 1)) + (make-posn (- x 1) y) + (make-posn (+ x 1) y) + (make-posn x (+ y 1)) + (make-posn (+ x 1) (+ y 1)))])))) + +(check-expect (adjacent (make-posn 1 1) 11) + (list (make-posn 1 0) + (make-posn 2 0) + (make-posn 0 1) + (make-posn 2 1) + (make-posn 1 2) + (make-posn 2 2))) +(check-expect (adjacent (make-posn 2 2) 11) + (list (make-posn 1 1) + (make-posn 2 1) + (make-posn 1 2) + (make-posn 3 2) + (make-posn 1 3) + (make-posn 2 3))) + +;; in-bounds? : posn number -> boolean +(define (in-bounds? p board-size) + (and (<= 0 (posn-x p) (- board-size 1)) + (<= 0 (posn-y p) (- board-size 1)) + (not (equal? p (make-posn 0 0))) + (not (equal? p (make-posn 0 (- board-size 1)))))) +(check-expect (in-bounds? (make-posn 0 0) 11) false) +(check-expect (in-bounds? (make-posn 0 1) 11) true) +(check-expect (in-bounds? (make-posn 1 0) 11) true) +(check-expect (in-bounds? (make-posn 10 10) 11) true) +(check-expect (in-bounds? (make-posn 0 -1) 11) false) +(check-expect (in-bounds? (make-posn -1 0) 11) false) +(check-expect (in-bounds? (make-posn 0 11) 11) false) +(check-expect (in-bounds? (make-posn 11 0) 11) false) +(check-expect (in-bounds? (make-posn 10 0) 11) true) +(check-expect (in-bounds? (make-posn 0 10) 11) false) + +;; min-l : (listof number-or-symbol) -> number-or-symbol +(define (min-l ls) (foldr (lambda (x y) (min/f x y)) '∞ ls)) +(check-expect (min-l (list)) '∞) +(check-expect (min-l (list 10 1 12)) 1) + +;; <=/f : (number or '∞) (number or '∞) -> (number or '∞) +(define (<=/f a b) (equal? a (min/f a b))) +(check-expect (<=/f 1 2) true) +(check-expect (<=/f 2 1) false) +(check-expect (<=/f '∞ 1) false) +(check-expect (<=/f 1 '∞) true) +(check-expect (<=/f '∞ '∞) true) + +;; min/f : (number or '∞) (number or '∞) -> (number or '∞) +(define (min/f x y) + (cond + [(equal? x '∞) y] + [(equal? y '∞) x] + [else (min x y)])) +(check-expect (min/f '∞ 1) 1) +(check-expect (min/f 1 '∞) 1) +(check-expect (min/f '∞ '∞) '∞) +(check-expect (min/f 1 2) 1) + +;; add1/f : number or '∞ -> number or '∞ +(define (add1/f n) + (cond + [(equal? n '∞) '∞] + [else (add1 n)])) +(check-expect (add1/f 1) 2) +(check-expect (add1/f '∞) '∞) + +; +; +; +; +; +; ;;;;; ;;;; ;;;;;; +; ;;; ;;;;; ;;;; +; ;;; ;;; +; ;;;;;; ;;; ; ;;;;;; ;;; ;;;; +; ;;; ;;;; ;;; ;;;;; ;;; ;;;; ;;; ;;;;;; +; ;;; ;;;;; ;;; ;;; ;;; ;;;;; ;;; ;;;;; +; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;;; +; ;;; ;; ;;; ;;; ;;;;;; +; ;;; ; ;;; ;;;; ;;; ; ;; ;; +; ;;; ; ;;;; ;;;;;;;;;; ; ;;;;; ;;;; +; ;;;; ;;;; +; +; +; + + +(define (clack world x y evt) + (cond + [(equal? evt 'button-up) + (cond + [(equal? 'playing (world-state world)) + (move-cat + (make-world (add-obstacle (world-board world) x y) + (world-cat world) + (world-state world) + (world-size world)))] + [else + world])] + [else + world])) + +(check-expect (clack (make-world '() (make-posn 0 0) 'playing 1) + 10 + 10 + 'button-down) + (make-world '() (make-posn 0 0) 'playing 1)) +(check-expect (clack (make-world '() (make-posn 0 0) 'cat-lost 1) + 10 + 10 + 'button-up) + (make-world '() (make-posn 0 0) 'cat-lost 1)) +(check-expect (clack + (make-world + (list (make-cell (make-posn 1 0) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'playing + 3) + 10 10 'button-up) + (make-world + (list (make-cell (make-posn 1 0) true) + (make-cell (make-posn 2 0) true) + (make-cell (make-posn 0 1) true) + (make-cell (make-posn 1 1) false) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) true)) + (make-posn 1 1) + 'cat-lost + 3)) + +;; move-cat : board -> board +(define (move-cat world) + (local [(define cat-position (world-cat world)) + (define table (build-table/fast world)) + (define neighbors (adjacent cat-position (world-size world))) + (define next-cat-position + (find-best-position (first neighbors) + (lookup-in-table table (first neighbors)) + (rest neighbors) + (map (lambda (p) (lookup-in-table table p)) + (rest neighbors))))] + (make-world (world-board world) + (cond + [(boolean? next-cat-position) + cat-position] + [else next-cat-position]) + (cond + [(boolean? next-cat-position) + 'cat-lost] + [(on-boundary? next-cat-position (world-size world)) + 'cat-won] + [else 'playing]) + (world-size world)))) + +(check-expect + (move-cat + (make-world (list (make-cell (make-posn 1 0) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 3 0) false) + (make-cell (make-posn 4 0) false) + + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 3 1) false) + (make-cell (make-posn 4 1) false) + + (make-cell (make-posn 0 2) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) false) + (make-cell (make-posn 3 2) true) + (make-cell (make-posn 4 2) false) + + (make-cell (make-posn 0 3) false) + (make-cell (make-posn 1 3) true) + (make-cell (make-posn 2 3) false) + (make-cell (make-posn 3 3) false) + (make-cell (make-posn 4 3) false) + + (make-cell (make-posn 1 4) false) + (make-cell (make-posn 2 4) false) + (make-cell (make-posn 3 4) false) + (make-cell (make-posn 4 4) false)) + (make-posn 2 2) + 'playing + 5)) + (make-world (list (make-cell (make-posn 1 0) false) + (make-cell (make-posn 2 0) false) + (make-cell (make-posn 3 0) false) + (make-cell (make-posn 4 0) false) + + (make-cell (make-posn 0 1) false) + (make-cell (make-posn 1 1) true) + (make-cell (make-posn 2 1) true) + (make-cell (make-posn 3 1) false) + (make-cell (make-posn 4 1) false) + + (make-cell (make-posn 0 2) false) + (make-cell (make-posn 1 2) true) + (make-cell (make-posn 2 2) false) + (make-cell (make-posn 3 2) true) + (make-cell (make-posn 4 2) false) + + (make-cell (make-posn 0 3) false) + (make-cell (make-posn 1 3) true) + (make-cell (make-posn 2 3) false) + (make-cell (make-posn 3 3) false) + (make-cell (make-posn 4 3) false) + + (make-cell (make-posn 1 4) false) + (make-cell (make-posn 2 4) false) + (make-cell (make-posn 3 4) false) + (make-cell (make-posn 4 4) false)) + (make-posn 2 3) + 'playing + 5)) + +;; find-best-position : (nelistof posn) (nelistof number or '∞) +;; -> posn or #f +;; returns #f if there is no non-infinite move, otherwise returns +;; the next step for the cat. +(define (find-best-position best-posn score rest-posns scores) + (cond + [(empty? rest-posns) + (cond + [(equal? score '∞) + false] + [else + best-posn])] + [else (cond + [(<=/f score (first scores)) + (find-best-position best-posn + score + (rest rest-posns) + (rest scores))] + [else + (find-best-position (first rest-posns) + (first scores) + (rest rest-posns) + (rest scores))])])) + +(check-expect (find-best-position (make-posn 1 1) + 1 + (list (make-posn 2 2)) + (list 2)) + (make-posn 1 1)) +(check-expect (find-best-position (make-posn 2 2) + 2 + (list) + (list)) + (make-posn 2 2)) +(check-expect (find-best-position (make-posn 2 2) + 2 + (list (make-posn 1 1)) + (list 1)) + (make-posn 1 1)) +(check-expect (find-best-position (make-posn 2 2) + '∞ + (list (make-posn 1 1)) + (list 1)) + (make-posn 1 1)) +(check-expect (find-best-position (make-posn 2 2) + 2 + (list (make-posn 1 1)) + (list '∞)) + (make-posn 2 2)) + +;; add-obstacle : board number number -> board +(define (add-obstacle board x y) + (cond + [(empty? board) board] + [else + (local [(define cell (first board)) + (define cx (cell-center-x (cell-p cell))) + (define cy (cell-center-y (cell-p cell)))] + (cond + [(and (<= (- cx circle-radius) x (+ cx circle-radius)) + (<= (- cy circle-radius) y (+ cy circle-radius))) + (cons (make-cell (cell-p cell) true) + (rest board))] + [else + (cons cell (add-obstacle (rest board) x y))]))])) + +(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false)) + circle-spacing circle-spacing) + (list (make-cell (make-posn 0 0) true))) +(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false)) 100 100) + (list (make-cell (make-posn 0 0) false))) +(check-expect (add-obstacle (list (make-cell (make-posn 0 0) false) + (make-cell (make-posn 0 1) false)) + circle-spacing circle-spacing) + (list (make-cell (make-posn 0 0) true) + (make-cell (make-posn 0 1) false))) + +; +; +; ;; +; ;; +; ;;;; ;;;; ;;;;; +; ;; ; ;; ;; +; ;; ;; ;; +; ;; ;;;;; ;; +; ;; ;; ;; ;; +; ;;; ; ;; ;; ;; +; ;;; ;;;;;; ;;; +; +; +; + +;; cat : symbol -> image +(define (cat mode) + (local [(define face-color + (cond + [(symbol=? mode 'sad) 'pink] + [else 'lightgray])) + + (define left-ear (regular-polygon 3 8 'solid 'black (/ pi -3))) + (define right-ear (regular-polygon 3 8 'solid 'black 0)) + (define ear-x-offset 14) + (define ear-y-offset 9) + + (define eye (overlay (ellipse 12 8 'solid 'black) + (ellipse 6 4 'solid 'limegreen))) + (define eye-x-offset 8) + (define eye-y-offset 3) + + (define nose (regular-polygon 3 5 'solid 'black (/ pi 2))) + + (define mouth-happy + (overlay (ellipse 8 8 'solid face-color) + (ellipse 8 8 'outline 'black) + (move-pinhole + (rectangle 10 5 'solid face-color) + 0 + 4))) + (define mouth-no-expression + (overlay (ellipse 8 8 'solid face-color) + (ellipse 8 8 'outline face-color) + (rectangle 10 5 'solid face-color))) + + (define mouth + (cond + [(symbol=? mode 'happy) mouth-happy] + [else mouth-no-expression])) + (define mouth-x-offset 4) + (define mouth-y-offset -5)] + + (add-line + (add-line + (add-line + (add-line + (add-line + (add-line + (overlay (move-pinhole left-ear (- ear-x-offset) ear-y-offset) + (move-pinhole right-ear (- ear-x-offset 1) ear-y-offset) + (ellipse 40 26 'solid 'black) + (ellipse 36 22 'solid face-color) + (move-pinhole mouth (- mouth-x-offset) mouth-y-offset) + (move-pinhole mouth mouth-x-offset mouth-y-offset) + (move-pinhole eye (- eye-x-offset) eye-y-offset) + (move-pinhole eye eye-x-offset eye-y-offset) + (move-pinhole nose -1 -4)) + 6 4 30 12 'black) + 6 4 30 4 'black) + 6 4 30 -4 'black) + -6 4 -30 12 'black) + -6 4 -30 4 'black) + -6 4 -30 -4 'black))) + +(define happy-cat (cat 'happy)) +(define sad-cat (cat 'sad)) +(define thinking-cat (cat 'thinking)) + +; +; ;;; ;;; +; ;; ;; +; ;; ;; +; ;;;;; ;;;; ;;;; ;;; ;; ;;;;; +; ;; ;; ;; ;; ;; ;;;;; ;; ;; +; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;;;;; ;; ;; ;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;; ;; ;; ;; ;; ;; ;; ;; ;; +; ;;;;; ;;;; ;;;;;; ;;;; ;;;;;; +; +; +; + +;; lookup-board : board posn -> cell-or-false +(define (lookup-board board p) + (cond + [(empty? board) (error 'lookup-board "did not find posn")] + [else + (cond + [(equal? (cell-p (first board)) p) + (first board)] + [else + (lookup-board (rest board) p)])])) + +(check-expect (lookup-board (list (make-cell (make-posn 2 2) false)) + (make-posn 2 2)) + (make-cell (make-posn 2 2) false)) +(check-error (lookup-board '() (make-posn 0 0)) + "lookup-board: did not find posn") + +;; append-all : (listof (list X)) -> (listof X) +(define (append-all ls) + (foldr append empty ls)) + +(check-expect (append-all empty) empty) +(check-expect (append-all (list (list 1 2 3))) (list 1 2 3)) +(check-expect (append-all (list (list 1) (list 2) (list 3))) + (list 1 2 3)) + +(define dummy + (local + [(define board-size 11) + (define initial-board + (foldl + (lambda (c l) + (cond + [(and (= 0 (posn-x (cell-p c))) + (or (= 0 (posn-y (cell-p c))) + (= (- board-size 1) + (posn-y (cell-p c))))) + l] + [else (cons c l)])) + '() + (append-all + (build-list + board-size + (lambda (i) + (build-list + board-size + (lambda (j) + (let ([cat-cell? (and (= i (quotient board-size 2)) + (= j (quotient board-size 2)))]) + (make-cell (make-posn i j) + (and (not cat-cell?) + (zero? (random 30)))))))))))) + (define initial-world + (make-world initial-board + (make-posn (quotient board-size 2) + (quotient board-size 2)) + 'playing + board-size))] + + (and + + ;((lambda (x) true) (time (build-table initial-world))) + ;((lambda (x) true) (time (build-table/fast initial-world))) + + (big-bang (world-width board-size) + (world-height board-size) + 1 + initial-world) + (on-redraw world->image) + (on-mouse-event clack)))) \ No newline at end of file diff --git a/collects/games/chat-noir/hash.ss b/collects/games/chat-noir/hash.ss new file mode 100644 index 0000000000..8903bb9415 --- /dev/null +++ b/collects/games/chat-noir/hash.ss @@ -0,0 +1,2 @@ +#lang scheme/base +(provide make-hash hash-set! hash-ref hash-map) diff --git a/collects/games/chat-noir/info.ss b/collects/games/chat-noir/info.ss new file mode 100644 index 0000000000..720ac5cac6 --- /dev/null +++ b/collects/games/chat-noir/info.ss @@ -0,0 +1,5 @@ +#lang setup/infotab + +(define game "chat-noir-unit.ss") +(define game-set "Puzzle Games") +(define compile-omit-files '("chat-noir.ss")) \ No newline at end of file diff --git a/collects/games/scribblings/chat-noir.scrbl b/collects/games/scribblings/chat-noir.scrbl new file mode 100644 index 0000000000..062edfa45e --- /dev/null +++ b/collects/games/scribblings/chat-noir.scrbl @@ -0,0 +1,59 @@ +#lang scribble/doc +@(require "common.ss") +@(require scheme/runtime-path (for-syntax scheme/port scheme/base)) +@(define-runtime-path cn "../chat-noir/chat-noir.ss") + +@gametitle["Chat Noir" "chat-noir" "Puzzle Game"] + +This game is written in the +@link["http://www.htdp.org/"]{How to Design Programs} +Intermediate language. It is a model solution to the final project for +the introductory programming course at the University of Chicago in +the fall of 2008. See the source code: +@schemeblock[#,(tt (path->string (simplify-path cn)))] + +The goal of the game is to stop the cat from escaping the board. Each +turn you click on a circle, which prevents the cat from stepping on +that space, and the cat responds by taking a step. If the cat is +completely boxed in and thus unable reach the border, you win. If the +cat does reach the border, you lose. + +The game was inspired by this one the one at +@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game +Design} and has essentailly the same rules. + +@(define-syntax (m stx) + (syntax-case stx () + [(_) + (call-with-input-file (build-path (current-load-relative-directory) + 'up + "chat-noir" + "chat-noir.ss") + (lambda (port) + (port-count-lines! port) + #`(schemeblock + #,@ + (let loop () + (let ([p (peeking-input-port port)]) + (let ([l (read-line p)]) + (cond + [(eof-object? l) '()] + [(regexp-match #rx"^[ \t]*$" l) + (read-line port) + (loop)] + [(regexp-match #rx"^ *;+" l) + => + (lambda (m) + (let-values ([(line col pos) (port-next-location port)]) + (read-line port) + (let-values ([(line2 col2 pos2) (port-next-location port)]) + (cons (datum->syntax + #f + `(code:comment ,(regexp-replace* #rx" " l "\u00a0"))) + (list "chat-noir.ss" line col pos (- pos2 pos))) + (loop))))] + [else + (cons (read-syntax "chat-noir.ss" port) + (loop))])))))))])) + +@m[] \ No newline at end of file diff --git a/collects/games/scribblings/std-games.scrbl b/collects/games/scribblings/std-games.scrbl index 9750d425c1..e0a881e935 100644 --- a/collects/games/scribblings/std-games.scrbl +++ b/collects/games/scribblings/std-games.scrbl @@ -22,4 +22,5 @@ @include-section["jewel.scrbl"] @include-section["parcheesi.scrbl"] @include-section["checkers.scrbl"] +@include-section["chat-noir.scrbl"] @include-section["gcalc.scrbl"] From 191d6fbf48ab6182a37d3b25f28dd2a6d9ab00d0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 5 Oct 2008 21:39:14 +0000 Subject: [PATCH 45/50] set svn:* props svn: r11945 --- collects/games/chat-noir/chat-noir-unit.ss | 2 +- collects/games/chat-noir/chat-noir.ss | 2 +- collects/games/chat-noir/info.ss | 2 +- collects/games/scribblings/chat-noir.scrbl | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-unit.ss b/collects/games/chat-noir/chat-noir-unit.ss index 2e9e3cbe14..0e0accc536 100644 --- a/collects/games/chat-noir/chat-noir-unit.ss +++ b/collects/games/chat-noir/chat-noir-unit.ss @@ -18,4 +18,4 @@ '(lib "htdp-intermediate-lambda.ss" "lang")) (namespace-attach-module orig-namespace '(lib "world.ss" "htdp")) - (dynamic-require chat-noir #f))) \ No newline at end of file + (dynamic-require chat-noir #f))) diff --git a/collects/games/chat-noir/chat-noir.ss b/collects/games/chat-noir/chat-noir.ss index 3f186ef012..38fda78eba 100644 --- a/collects/games/chat-noir/chat-noir.ss +++ b/collects/games/chat-noir/chat-noir.ss @@ -1002,4 +1002,4 @@ figure out why there is an extra board (sometimes) 1 initial-world) (on-redraw world->image) - (on-mouse-event clack)))) \ No newline at end of file + (on-mouse-event clack)))) diff --git a/collects/games/chat-noir/info.ss b/collects/games/chat-noir/info.ss index 720ac5cac6..183f63112a 100644 --- a/collects/games/chat-noir/info.ss +++ b/collects/games/chat-noir/info.ss @@ -2,4 +2,4 @@ (define game "chat-noir-unit.ss") (define game-set "Puzzle Games") -(define compile-omit-files '("chat-noir.ss")) \ No newline at end of file +(define compile-omit-files '("chat-noir.ss")) diff --git a/collects/games/scribblings/chat-noir.scrbl b/collects/games/scribblings/chat-noir.scrbl index 062edfa45e..efb9404b40 100644 --- a/collects/games/scribblings/chat-noir.scrbl +++ b/collects/games/scribblings/chat-noir.scrbl @@ -56,4 +56,4 @@ Design} and has essentailly the same rules. (cons (read-syntax "chat-noir.ss" port) (loop))])))))))])) -@m[] \ No newline at end of file +@m[] From a01a8a962fec4853b90543b42b873ae6f4f7f9ff Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 5 Oct 2008 23:12:37 +0000 Subject: [PATCH 46/50] svn: r11946 --- collects/games/chat-noir/chat-noir-module.ss | 5 +++++ 1 file changed, 5 insertions(+) create mode 100644 collects/games/chat-noir/chat-noir-module.ss diff --git a/collects/games/chat-noir/chat-noir-module.ss b/collects/games/chat-noir/chat-noir-module.ss new file mode 100644 index 0000000000..b9b57bdd27 --- /dev/null +++ b/collects/games/chat-noir/chat-noir-module.ss @@ -0,0 +1,5 @@ +(module chat-noir-module lang/htdp-intermediate-lambda + (require (lib "world.ss" "htdp")) + (require "hash.ss") + (require (lib "include.ss" "scheme")) + (include "chat-noir.ss")) From d2d85b39b328507e0dd04d23545006b7e8f22bcb Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 6 Oct 2008 02:32:37 +0000 Subject: [PATCH 47/50] cleaned up chat noir svn: r11947 --- collects/games/chat-noir/chat-noir-unit.ss | 9 +- collects/games/chat-noir/chat-noir.ss | 162 +++++++++++---------- collects/games/scribblings/chat-noir.scrbl | 76 +++++----- 3 files changed, 125 insertions(+), 122 deletions(-) diff --git a/collects/games/chat-noir/chat-noir-unit.ss b/collects/games/chat-noir/chat-noir-unit.ss index 0e0accc536..5b16026954 100644 --- a/collects/games/chat-noir/chat-noir-unit.ss +++ b/collects/games/chat-noir/chat-noir-unit.ss @@ -4,18 +4,15 @@ (prefix-in x: lang/htdp-intermediate-lambda) (prefix-in x: htdp/world)) - (provide game@) (define orig-namespace (current-namespace)) -(define-runtime-path chat-noir "chat-noir.ss") +(define-runtime-path chat-noir "chat-noir-module.ss") (define-unit game@ (import) (export) (define ns (make-base-namespace)) (parameterize ([current-namespace ns]) - (namespace-attach-module orig-namespace - '(lib "htdp-intermediate-lambda.ss" "lang")) - (namespace-attach-module orig-namespace - '(lib "world.ss" "htdp")) + (namespace-attach-module orig-namespace '(lib "mred.ss" "mred")) + (namespace-attach-module orig-namespace '(lib "class.ss" "scheme")) (dynamic-require chat-noir #f))) diff --git a/collects/games/chat-noir/chat-noir.ss b/collects/games/chat-noir/chat-noir.ss index 38fda78eba..9f40276a1d 100644 --- a/collects/games/chat-noir/chat-noir.ss +++ b/collects/games/chat-noir/chat-noir.ss @@ -4,8 +4,6 @@ Hint: include the size of the board in your world structure This enables you to make test cases with different size boards, making some of the test cases much easier to manage. -figure out why there is an extra board (sometimes) - |# (define circle-radius 20) @@ -195,28 +193,6 @@ figure out why there is an extra board (sometimes) (check-expect (world-height 3) 116.208) - -; -; -; -; -; -; ;;;;;;;;;; -; ;;; ;;; -; ;;; ;;; -; ;;;;;; ;;;;; ;;; ;;; ; ;;;; ;;;;; ;;;;;; -; ;;; ;;;;;;; ;;; ;;; ;;; ;;;;;;;;; ;;;;;;; ;;; ;;; -; ;;; ;;;;;;;; ;;; ;;; ;;; ;; ;; ;;;;;;;; ;;; -; ;;; ;;;;;;;;;;;; ;;; ;;; ; ;; ;; ; ;;;;;;;;; -; ;;; ;;; ;; ;; ; ;;; ; ;; ;;;; -; ;;; ; ;;; ;;; ;;; ;;; ;;;;;;; ;;;;;;;; ;;;;; ;;; -; ;;; ; ;; ;;; ;;;; ;;;; ;; ;;; ;;;;;; ;;;; ;; -; ;;;; ;;;; ;; ;;;; ;;;;;; -; ;; -; ; -; - - ;; cell-center : cell -> number (define (cell-center-x p) (local [(define x (posn-x p)) @@ -446,6 +422,24 @@ figure out why there is an extra board (sometimes) (make-dist-cell (make-posn 4 4) 0) (make-dist-cell (make-posn 3 3) 1))) + +;; lookup-board : board posn -> cell-or-false +(define (lookup-board board p) + (cond + [(empty? board) (error 'lookup-board "did not find posn")] + [else + (cond + [(equal? (cell-p (first board)) p) + (first board)] + [else + (lookup-board (rest board) p)])])) + +(check-expect (lookup-board (list (make-cell (make-posn 2 2) false)) + (make-posn 2 2)) + (make-cell (make-posn 2 2) false)) +(check-error (lookup-board '() (make-posn 0 0)) + "lookup-board: did not find posn") + ;; add-to-table : posn number table -> table (define (add-to-table p n t) (cond @@ -839,20 +833,27 @@ figure out why there is an extra board (sometimes) (list (make-cell (make-posn 0 0) true) (make-cell (make-posn 0 1) false))) -; -; -; ;; -; ;; -; ;;;; ;;;; ;;;;; -; ;; ; ;; ;; -; ;; ;; ;; -; ;; ;;;;; ;; -; ;; ;; ;; ;; -; ;;; ; ;; ;; ;; -; ;;; ;;;;;; ;;; -; -; -; + +; +; +; +; +; +; ;;;; +; ;;; +; ;;; ; +; ;;;;;; ;;;; ;;;;;;;;;;; +; ;;; ;;;; ;;;;;;;;; ;;; ;; +; ;;; ;;;;;;;;;;;;;;; ;;; +; ;;; ;;;;;;; ;;; ;;; ;;;; +; ;;; ;; ;;;; ;;; ;;;;; +; ;;; ; ;;;;;;;;;; ;;; ;;;; +; ;;; ; ;;;;;;;;;;; ;;; ;; +; ;;;; ;;;;; ;;;;; +; +; +; + ;; cat : symbol -> image (define (cat mode) @@ -918,37 +919,45 @@ figure out why there is an extra board (sometimes) (define sad-cat (cat 'sad)) (define thinking-cat (cat 'thinking)) -; -; ;;; ;;; -; ;; ;; -; ;; ;; -; ;;;;; ;;;; ;;;; ;;; ;; ;;;;; -; ;; ;; ;; ;; ;; ;;;;; ;; ;; -; ;; ;; ;; ;; ;; ;; ;; ;; -; ;; ;; ;; ;; ;;;;; ;; ;; ;; -; ;; ;; ;; ;; ;; ;; ;; ;; ;; -; ;; ;; ;; ;; ;; ;; ;; ;; ;; -; ;;;;; ;;;; ;;;;;; ;;;; ;;;;;; -; -; -; -;; lookup-board : board posn -> cell-or-false -(define (lookup-board board p) - (cond - [(empty? board) (error 'lookup-board "did not find posn")] - [else - (cond - [(equal? (cell-p (first board)) p) - (first board)] - [else - (lookup-board (rest board) p)])])) - -(check-expect (lookup-board (list (make-cell (make-posn 2 2) false)) - (make-posn 2 2)) - (make-cell (make-posn 2 2) false)) -(check-error (lookup-board '() (make-posn 0 0)) - "lookup-board: did not find posn") +; +; +; +; +; +; ;;;; ;;;; ;;;; ;;;; ;;;;; +; ;;;;; ;;;;; ;;; ;;;;; ;;; +; ;;; ; ;;; +; ;;;;;; ;; ; ;;;;;;;;; ; ;;;; ;; ;;; +; ;;;;; ;;; ;;;; ;;;;; ;;; ;;;;;;; ;;;;;;;;; ;;; +; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;;;;;;;; ;;; +; ;;; ;;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; +; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; ;; ;;;; ;; +; ;;;; ;;; ;;; ;;;; ;;; ;;;; ;;;; ;;;;;;;;;; ;;; +; ;;;;;;;;;; ;;; ;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;; +; ;;;; ;;;;; ;;;;; +; ;;; +; +; +; +; +; +; +; +; ;;;;; ;; +; ;;;; ;;;; +; ;;; ;;; +; ;;; ;;; ;;;;; ;;;; ;; ; ;;;; ;;; ;;; +; ;;;;;;;; ;;;;;;; ;;;;;;;;;;;;;;; ;;;; ;;;;;;;; +; ;;;;;;;; ;;;;;;;; ;;;;;;;;;; ;;; ;;;;;;;;;;;;;; +; ;;; ;; ;; ; ;;; ;;; ;;; ;;;; ;;; ;;; +; ;;; ;; ; ;; ;; ;;;; ;;; ;; ;;;; +; ;;;;;;; ;;;;;;;; ;;;;;;;;;; ;;; ;;;;;;;; +; ;;;;;;; ;;;;;; ;;;;;;;;;;;;;;;;;; ;;;;;;;;; +; ;;;; ;;;;; +; +; +; ;; append-all : (listof (list X)) -> (listof X) (define (append-all ls) @@ -963,16 +972,12 @@ figure out why there is an extra board (sometimes) (local [(define board-size 11) (define initial-board - (foldl - (lambda (c l) - (cond - [(and (= 0 (posn-x (cell-p c))) - (or (= 0 (posn-y (cell-p c))) - (= (- board-size 1) - (posn-y (cell-p c))))) - l] - [else (cons c l)])) - '() + (filter + (lambda (c) + (not (and (= 0 (posn-x (cell-p c))) + (or (= 0 (posn-y (cell-p c))) + (= (- board-size 1) + (posn-y (cell-p c))))))) (append-all (build-list board-size @@ -994,6 +999,7 @@ figure out why there is an extra board (sometimes) (and + ;; illustrates the speedup for state-based dfs ;((lambda (x) true) (time (build-table initial-world))) ;((lambda (x) true) (time (build-table/fast initial-world))) diff --git a/collects/games/scribblings/chat-noir.scrbl b/collects/games/scribblings/chat-noir.scrbl index efb9404b40..15c4ce7e44 100644 --- a/collects/games/scribblings/chat-noir.scrbl +++ b/collects/games/scribblings/chat-noir.scrbl @@ -5,13 +5,6 @@ @gametitle["Chat Noir" "chat-noir" "Puzzle Game"] -This game is written in the -@link["http://www.htdp.org/"]{How to Design Programs} -Intermediate language. It is a model solution to the final project for -the introductory programming course at the University of Chicago in -the fall of 2008. See the source code: -@schemeblock[#,(tt (path->string (simplify-path cn)))] - The goal of the game is to stop the cat from escaping the board. Each turn you click on a circle, which prevents the cat from stepping on that space, and the cat responds by taking a step. If the cat is @@ -19,41 +12,48 @@ completely boxed in and thus unable reach the border, you win. If the cat does reach the border, you lose. The game was inspired by this one the one at -@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game -Design} and has essentailly the same rules. +@link["http://www.gamedesign.jp/flash/chatnoir/chatnoir.html"]{Game Design} +and has essentailly the same rules. + +This game is written in the +@link["http://www.htdp.org/"]{How to Design Programs} +Intermediate language. It is a model solution to the final project for +the introductory programming course at the University of Chicago in +the fall of 2008, as below. @(define-syntax (m stx) (syntax-case stx () [(_) (call-with-input-file (build-path (current-load-relative-directory) - 'up - "chat-noir" - "chat-noir.ss") - (lambda (port) - (port-count-lines! port) - #`(schemeblock - #,@ - (let loop () - (let ([p (peeking-input-port port)]) - (let ([l (read-line p)]) - (cond - [(eof-object? l) '()] - [(regexp-match #rx"^[ \t]*$" l) - (read-line port) - (loop)] - [(regexp-match #rx"^ *;+" l) - => - (lambda (m) - (let-values ([(line col pos) (port-next-location port)]) - (read-line port) - (let-values ([(line2 col2 pos2) (port-next-location port)]) - (cons (datum->syntax - #f - `(code:comment ,(regexp-replace* #rx" " l "\u00a0"))) - (list "chat-noir.ss" line col pos (- pos2 pos))) - (loop))))] - [else - (cons (read-syntax "chat-noir.ss" port) - (loop))])))))))])) + 'up + "chat-noir" + "chat-noir.ss") + (lambda (port) + (port-count-lines! port) + #`(schemeblock + #,@ + (let loop () + (let* ([p (peeking-input-port port)] + [l (read-line p)]) + (cond + [(eof-object? l) '()] + [(regexp-match #rx"^[ \t]*$" l) + (read-line port) + (loop)] + [(regexp-match #rx"^ *;+" l) + => + (lambda (m) + (let-values ([(line col pos) (port-next-location port)]) + (read-line port) + (let-values ([(line2 col2 pos2) (port-next-location port)]) + (cons (datum->syntax + #f + `(code:comment ,(regexp-replace* #rx" " l "\u00a0")) + (list "chat-noir.ss" line col pos (- pos2 pos))) + (loop)))))] + [else + (cons (read-syntax "chat-noir.ss" port) + (loop))]))))) + #:mode 'text)])) @m[] From c556fd74aa7843c2a4dd7a6d644a9226bcd28fd4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 6 Oct 2008 03:42:33 +0000 Subject: [PATCH 48/50] svn: r11948 --- collects/games/chat-noir/info.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/games/chat-noir/info.ss b/collects/games/chat-noir/info.ss index 183f63112a..3e6104bd42 100644 --- a/collects/games/chat-noir/info.ss +++ b/collects/games/chat-noir/info.ss @@ -3,3 +3,4 @@ (define game "chat-noir-unit.ss") (define game-set "Puzzle Games") (define compile-omit-files '("chat-noir.ss")) +(define name "Chat Noir") \ No newline at end of file From f205e32302d669c16b9a7fb23fd26489169ce6d2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 6 Oct 2008 04:52:21 +0000 Subject: [PATCH 49/50] clarify and give an example for PLTCOLLECTS svn: r11949 --- collects/scribblings/reference/collects.scrbl | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/collects.scrbl b/collects/scribblings/reference/collects.scrbl index db56dd2d7c..12425b23b1 100644 --- a/collects/scribblings/reference/collects.scrbl +++ b/collects/scribblings/reference/collects.scrbl @@ -87,7 +87,15 @@ Produces a list of paths as follows: defined, it is combined with the default list using @scheme[path-list-string->path-list]. If it is not defined, the default collection path list (as constructed by the first three - bullets above) is used directly.} + bullets above) is used directly. + + Note that under @|AllUnix|, paths are separated by @litchar{:}, and + under Windows by @litchar{;}. Also, + @scheme[path-list-string->path-list] splices the default paths at an + empty path, for example, with many Unix shells you can set + @envvar{PLTCOLLECTS} to @tt{":`pwd`"}, @tt{"`pwd`:"}, or + @tt{"`pwd`"} to specify search the current directory after, before, + or instead of the default paths respectively.} }} From dd20d88776d6f8c47f510e425766a5cd39c5fd38 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 6 Oct 2008 07:50:04 +0000 Subject: [PATCH 50/50] Welcome to a new PLT day. svn: r11950 --- collects/repos-time-stamp/stamp.ss | 2 +- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 21c2263581..de61f90848 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "5oct2008") +#lang scheme/base (provide stamp) (define stamp "6oct2008") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 5c7900ae7a..95ce4208bc 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@