From c73bb99cf688801d9e24eded21102ba2f60f40ea Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 15 Nov 2008 02:49:54 +0000 Subject: [PATCH 01/12] fix struct type immutable-field handling and checking of prop:procedure values (PR 9914 and more) svn: r12454 --- .../scribblings/reference/procedures.scrbl | 8 ++- collects/tests/mzscheme/struct.ss | 50 +++++++++++++++ src/mzscheme/src/schpriv.h | 2 +- src/mzscheme/src/struct.c | 63 ++++++++++++------- 4 files changed, 99 insertions(+), 24 deletions(-) diff --git a/collects/scribblings/reference/procedures.scrbl b/collects/scribblings/reference/procedures.scrbl index 51554a1fd6..75a4f93b97 100644 --- a/collects/scribblings/reference/procedures.scrbl +++ b/collects/scribblings/reference/procedures.scrbl @@ -240,7 +240,7 @@ instances can be applied as procedures. In particular, when an application expression, a procedure is extracted from the instance and used to complete the procedure call. -If the @scheme[prop:procedure] property value is an integer, it +If the @scheme[prop:procedure] property value is an exact non-negative integer, it designates a field within the structure that should contain a procedure. The integer must be between @scheme[0] (inclusive) and the number of non-automatic fields in the structure type (exclusive, not @@ -317,7 +317,11 @@ is disallowed). (fish-weight wanda) (for-each wanda '(1 2 3)) (fish-weight wanda) -]} +] + +If the value supplied for the @scheme[prop:procedure] property is not +an exact non-negative integer or a procedure, the +@exnraise[exn:fail:contract].} @defproc[(procedure-struct-type? [type struct-type?]) boolean?]{ diff --git a/collects/tests/mzscheme/struct.ss b/collects/tests/mzscheme/struct.ss index dd2b96d6a8..57154481e1 100644 --- a/collects/tests/mzscheme/struct.ss +++ b/collects/tests/mzscheme/struct.ss @@ -927,4 +927,54 @@ ;; ---------------------------------------- +(let () + (define-struct foo (a [b #:mutable]) #:transparent) + (define-struct (bar foo) (f g) + #:transparent + #:property + prop:procedure + (struct-field-index f)) + (test '(1) (make-bar 1 2 list 4) 1) + (test '(foo 2 0 (0)) call-with-values + (lambda () (struct-type-info struct:foo)) + (lambda (name cnt auto-cnt acc mut imm super skipped?) + (list name cnt auto-cnt imm))) + (test '(bar 2 0 (0 1)) call-with-values + (lambda () (struct-type-info struct:bar)) + (lambda (name cnt auto-cnt acc mut imm super skipped?) + (list name cnt auto-cnt imm)))) + +(let () + (define-struct foo (a [b #:mutable] [z #:auto]) #:transparent) + (define-struct (bar foo) (f g) + #:transparent + #:property + prop:procedure + (struct-field-index f)) + (test '#&1 (make-bar 1 2 box 4) 1) + (test '(foo 2 1 (0)) call-with-values + (lambda () (struct-type-info struct:foo)) + (lambda (name cnt auto-cnt acc mut imm super skipped?) + (list name cnt auto-cnt imm))) + (test '(bar 2 0 (0 1)) call-with-values + (lambda () (struct-type-info struct:bar)) + (lambda (name cnt auto-cnt acc mut imm super skipped?) + (list name cnt auto-cnt imm)))) + +(let () + (define-struct foo (a [b #:mutable] [z #:auto]) #:transparent) + (define (try v) + (define-struct (bar foo) ([f #:mutable] g [q #:auto]) + #:property + prop:procedure + v) + 10) + (err/rt-test (try 0)) + (err/rt-test (try 2)) + (err/rt-test (try -1)) + (err/rt-test (try 'x)) + (test 10 try 1)) + +;; ---------------------------------------- + (report-errs) diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 6e0dd3fb47..1846ad86b3 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -576,7 +576,7 @@ typedef struct Scheme_Struct_Type { int num_props; /* < 0 => props is really a hash table */ Scheme_Object *proc_attr; /* int (position) or proc, only for proc_struct */ - char *immutables; + char *immutables; /* for immediate slots, only (not parent) */ Scheme_Object *guard; diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index ab0d92ec59..6434106e2b 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -865,28 +865,46 @@ static Scheme_Object *guard_property(Scheme_Object *prop, Scheme_Object *v, Sche if (SCHEME_INTP(v)) pos = SCHEME_INT_VAL(v); - else + else if (SCHEME_BIGPOS(v)) pos = t->num_slots; /* too big */ + else + pos = -1; /* negative bignum */ - if (pos >= t->num_islots) { - scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", v); - return NULL; - } - - if (t->name_pos > 0) { + if (pos >= 0) { Scheme_Struct_Type *parent_type; - parent_type = t->parent_types[t->name_pos - 1]; - pos += parent_type->num_slots; - v = scheme_make_integer(pos); - } + if (t->name_pos > 0) + parent_type = t->parent_types[t->name_pos - 1]; + else + parent_type = NULL; + + if (pos >= (t->num_islots - (parent_type ? parent_type->num_islots : 0))) { + scheme_arg_mismatch("make-struct-type", "index for procedure >= initialized-field count: ", v); + return NULL; + } + + if (parent_type) { + /* proc_attr needs to be in terms of the whole field array */ + pos += parent_type->num_slots; + v = scheme_make_integer(pos); + } + } else + v = scheme_false; /* complain below */ + } + + if (SCHEME_INTP(v) || SCHEME_PROCP(v)) { + /* ok */ + } else { + scheme_arg_mismatch("make-struct-type", + "prop:procedure value is not a procedure or exact non-negative integer: ", + orig_v); } t->proc_attr = v; if (SCHEME_INTP(v)) { long pos; - pos = SCHEME_INT_VAL(v); + pos = SCHEME_INT_VAL(orig_v); if (!t->immutables || !t->immutables[pos]) { scheme_arg_mismatch("make-struct-type", "field is not specified as immutable for a prop:procedure index: ", @@ -1676,7 +1694,7 @@ static void get_struct_type_info(int argc, Scheme_Object *argv[], Scheme_Object ims = scheme_null; if (stype->immutables) { int i; - for (i = stype->num_islots; i--; ) { + for (i = stype->num_islots - (parent ? parent->num_islots : 0); i--; ) { if (stype->immutables[i]) ims = scheme_make_pair(scheme_make_integer(i), ims); } @@ -2856,19 +2874,20 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base || (proc_attr && SCHEME_INTP(proc_attr))) { Scheme_Object *l, *a; char *ims; - int n, p; + int n, ni, p; n = struct_type->num_slots; - if (parent_type) + ni = struct_type->num_islots; + if (parent_type) { n -= parent_type->num_slots; + ni -= parent_type->num_islots; + } ims = (char *)scheme_malloc_atomic(n); memset(ims, 0, n); if (proc_attr && SCHEME_INTP(proc_attr)) { p = SCHEME_INT_VAL(proc_attr); - if (parent_type) - p += parent_type->num_slots; - if (p < struct_type->num_slots) + if (p < ni) ims[p] = 1; } @@ -2877,12 +2896,14 @@ static Scheme_Object *_make_struct_type(Scheme_Object *basesym, const char *base if (SCHEME_INTP(a)) p = SCHEME_INT_VAL(a); else - p = struct_type->num_slots; /* too big */ + p = n; /* too big */ - if (p >= struct_type->num_islots) { + if (p >= n) { scheme_raise_exn(MZEXN_FAIL_CONTRACT, "make-struct-type: index %V for immutable field >= initialized-field count %d in list: %V", - a, struct_type->num_islots, immutable_pos_list); + a, + ni, + immutable_pos_list); return NULL; } From 1d353330265cfa1c1e38b8c1b7fe77ef98b19606 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 15 Nov 2008 08:50:16 +0000 Subject: [PATCH 02/12] Welcome to a new PLT day. svn: r12455 --- 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 37859d3cfd..908da5f1ba 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "14nov2008") +#lang scheme/base (provide stamp) (define stamp "15nov2008") From c0fb0086e9b85982eaa5045325514697a5f0f18c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 15 Nov 2008 13:42:11 +0000 Subject: [PATCH 03/12] =?UTF-8?q?fix=20R6RS=20boolean=3D=3F=20and=20symbol?= =?UTF-8?q?=3D=3F?= svn: r12456 --- collects/rnrs/base-6.ss | 20 ++++++++++++++++++-- collects/tests/r6rs/base.sls | 4 ++++ 2 files changed, 22 insertions(+), 2 deletions(-) diff --git a/collects/rnrs/base-6.ss b/collects/rnrs/base-6.ss index 7868e58930..4084ec3a06 100644 --- a/collects/rnrs/base-6.ss +++ b/collects/rnrs/base-6.ss @@ -76,7 +76,7 @@ [r6rs:string->number string->number]) ;; 11.8 - not boolean? boolean=? + not boolean? (rename-out [r6rs:boolean=? boolean=?]) ;; 11.9 (rename-out [r5rs:pair? pair?] @@ -123,7 +123,7 @@ [r5rs:for-each for-each]) ;; 11.10 - symbol? symbol=? + symbol? (rename-out [r6rs:symbol=? symbol=?]) string->symbol symbol->string ;; 11.11 @@ -349,6 +349,22 @@ (and (regexp-match? rx:number s) (string->number (regexp-replace* #rx"[|][0-9]+" s ""))))) +(define r6rs:symbol=? + (case-lambda + [(a b) (symbol=? a b)] + [(a b . rest) (and (symbol=? a b) + (andmap (lambda (s) + (symbol=? a s)) + rest))])) + +(define r6rs:boolean=? + (case-lambda + [(a b) (boolean=? a b)] + [(a b . rest) (and (boolean=? a b) + (andmap (lambda (s) + (boolean=? a s)) + rest))])) + (define-syntax-rule (make-mapper what for for-each in-val val-length val->list list->result) (case-lambda [(proc val) (list->result diff --git a/collects/tests/r6rs/base.sls b/collects/tests/r6rs/base.sls index f5fbb6fcc1..d39521ad9e 100644 --- a/collects/tests/r6rs/base.sls +++ b/collects/tests/r6rs/base.sls @@ -1005,6 +1005,8 @@ (test (boolean=? #t #t) #t) (test (boolean=? #t #f) #f) (test (boolean=? #f #t) #f) + (test (boolean=? #t #t #f) #f) + (test (boolean=? #t #t #t #t) #t) ;; 11.9 (test (pair? '(a . b)) #t) @@ -1126,6 +1128,8 @@ (test (symbol=? 'a 'a) #t) (test (symbol=? 'a 'A) #f) (test (symbol=? 'a 'b) #f) + (test (symbol=? 'a 'a 'b) #f) + (test (symbol=? 'a 'a 'a 'a) #t) (test (symbol->string 'flying-fish) "flying-fish") From 015503bde3d5bfb125231f8ef096419a741672fb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 15 Nov 2008 16:51:58 +0000 Subject: [PATCH 04/12] trigger GCs based on number of allocated bitmaps under Windows, not just their sizes svn: r12457 --- src/wxcommon/wxGC.cxx | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/src/wxcommon/wxGC.cxx b/src/wxcommon/wxGC.cxx index 31faa718c3..31f523775d 100644 --- a/src/wxcommon/wxGC.cxx +++ b/src/wxcommon/wxGC.cxx @@ -374,7 +374,11 @@ char *gc::gcGetName() { forces a GC more frequently than might otherwise happen as the total size of bitmaps grows. */ -static long total, accum = 1024 * 1024 * 5; +#define INIT_ACCUM_SIZE 1024 * 1024 * 5 +#define INIT_ACCUM_COUNT 1000 + +static long total, accum = INIT_ACCUM_SIZE; +static int total_count, accum_count = INIT_ACCUM_COUNT; void *GC_malloc_accounting_shadow(long a) { @@ -383,10 +387,24 @@ void *GC_malloc_accounting_shadow(long a) a = sizeof(long); total += a; accum -= a; + total_count += 1; + accum_count -= 1; if (accum <= 0) { GC_gcollect(); accum = total >> 1; + if (accum < INIT_ACCUM_SIZE) + accum = INIT_ACCUM_SIZE; } +#ifdef wx_msw + /* Under Windows, the number of bitmaps matters, even if + they're small. */ + if (accum_count <= 0) { + GC_gcollect(); + accum_count = total_count >> 1; + if (accum_count < INIT_ACCUM_COUNT) + accum_count = INIT_ACCUM_COUNT; + } +#endif p = (long *)GC_malloc_atomic(a); *p = a; return (void *)p; @@ -397,5 +415,7 @@ void GC_free_accounting_shadow(void *p) if (p) { total -= *(long *)p; accum += *(long *)p; + total_count -= 1; + accum_count += 1; } } From 69fdabf0a0cbb9c4e8ae72ce8788b5924da6ca88 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 15 Nov 2008 18:54:30 +0000 Subject: [PATCH 05/12] fix {s,u}int-list->bytevector (PR 9916) svn: r12459 --- collects/rnrs/bytevectors-6.ss | 7 ++++--- collects/tests/r6rs/bytevectors.sls | 15 +++++++++++++++ 2 files changed, 19 insertions(+), 3 deletions(-) diff --git a/collects/rnrs/bytevectors-6.ss b/collects/rnrs/bytevectors-6.ss index dc26a0e069..d3944e9380 100644 --- a/collects/rnrs/bytevectors-6.ss +++ b/collects/rnrs/bytevectors-6.ss @@ -311,16 +311,17 @@ (bytevector->int-list 'bytevector->sint-list bytevector-sint-ref bv endianness size)) (define (int-list->bytevector who signed? set l endianness size) - (unless (list? l) + (unless (mlist? l) (raise-type-error who "list" l)) (check-endian endianness) (unless (exact-positive-integer? size) (raise-type-error who "exact positive integer" size)) - (let* ([len (length l)] + (let* ([l (mlist->list l)] + [len (length l)] [bv (make-bytes (* size len))]) (for ([v (in-list l)] [k (in-naturals)]) - (set l k v endianness size)) + (set bv (* k size) v endianness size)) bv)) (define (uint-list->bytevector l endianness size) diff --git a/collects/tests/r6rs/bytevectors.sls b/collects/tests/r6rs/bytevectors.sls index f2b00a75a9..87fc507a1b 100644 --- a/collects/tests/r6rs/bytevectors.sls +++ b/collects/tests/r6rs/bytevectors.sls @@ -277,6 +277,21 @@ (test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) (bytevector->uint-list b 'little 2)) '(513 65283 513 513)) + (test (bytevector->u8-list + (uint-list->bytevector '(513 65283 513 513) 'little 2)) + '(1 2 3 255 1 2 1 2)) + (test (bytevector->u8-list + (uint-list->bytevector '(513 65283 513 513) 'big 2)) + '(2 1 255 3 2 1 2 1)) + (test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) + (bytevector->sint-list b 'little 2)) + '(513 -253 513 513)) + (test (let ((b (u8-list->bytevector '(2 1 255 3 2 1 2 1)))) + (bytevector->sint-list b 'big 2)) + '(513 -253 513 513)) + (test (bytevector->u8-list + (sint-list->bytevector '(513 -253 513 513) 'little 2)) + '(1 2 3 255 1 2 1 2)) (test (let ((b (u8-list->bytevector '(1 2 3 255 1 2 1 2)))) (bytevector->sint-list b 'little 2)) '(513 -253 513 513)) From 1e5caacddeb4205868a99f9433a78ab3cf552303 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 16 Nov 2008 08:50:11 +0000 Subject: [PATCH 06/12] Welcome to a new PLT day. svn: r12460 --- 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 908da5f1ba..a1bf00e010 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "15nov2008") +#lang scheme/base (provide stamp) (define stamp "16nov2008") From 4254ad8afa837c23055bfcfbfd3796573dbcab07 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 16 Nov 2008 17:27:41 +0000 Subject: [PATCH 07/12] add support for rotated cards in games/cards svn: r12461 --- collects/games/cards/card-class.ss | 134 +++++++++++++++++++++++------ collects/games/cards/cards.scrbl | 51 ++++++++--- collects/games/cards/classes.ss | 64 +++++++++----- collects/games/cards/make-cards.ss | 25 +----- 4 files changed, 196 insertions(+), 78 deletions(-) diff --git a/collects/games/cards/card-class.ss b/collects/games/cards/card-class.ss index 526642bd1f..1f9330efd1 100644 --- a/collects/games/cards/card-class.ss +++ b/collects/games/cards/card-class.ss @@ -2,9 +2,11 @@ (module card-class mzscheme (require mzlib/class mzlib/class100 + mzlib/shared (prefix mred: mred) "snipclass.ss" - "region.ss") + "region.ss" + (only scheme/base for in-range)) (provide card%) @@ -28,18 +30,43 @@ (thunk) (send dc set-clipping-region r)))) + (define (rotate-bm bm cw?) + (let ([w (send bm get-width)] + [h (send bm get-height)]) + (let ([bm2 (make-object mred:bitmap% h w)] + [s (make-bytes (* w h 4))] + [s2 (make-bytes (* h w 4))]) + (send bm get-argb-pixels 0 0 w h s) + (for ([i (in-range w)]) + (for ([j (in-range h)]) + (let ([src-pos (* (+ i (* j w)) 4)]) + (bytes-copy! s2 + (if cw? + (* (+ (- (- h j) 1) (* i h)) 4) + (* (+ j (* (- (- w i) 1) h)) 4)) + s src-pos (+ src-pos 4))))) + (let ([dc (make-object mred:bitmap-dc% bm2)]) + (send dc set-argb-pixels 0 0 h w s2) + (send dc set-bitmap #f)) + bm2))) + + (define orientations (shared ([o (list* 'n 'e 's 'w o)]) o)) + (define (find-head l s) + (if (eq? (car l) s) + l + (find-head (cdr l) s))) + (define card% - (class100 mred:snip% (-suit-id -value -width -height -front -back -semi-front -semi-back -mk-dim-front -mk-dim-back) + (class100 mred:snip% (-suit-id -value -width -height -front -back -mk-dim-front -mk-dim-back -rotated-bms) (inherit set-snipclass set-count get-admin) (private-field [suit-id -suit-id] [value -value] [width -width] [height -height] + [rotated 'n] [front -front] [back -back] - [semi-front -semi-front] - [semi-back -semi-back] [mk-dim-front -mk-dim-front] [mk-dim-back -mk-dim-back] [dim-front #f] @@ -51,13 +78,20 @@ [can-move? #t] [snap-back? #f] [stay-region #f] - [home-reg #f]) + [home-reg #f] + [rotated-bms -rotated-bms]) (private [refresh (lambda () (let ([a (get-admin)]) (when a (send a needs-update this 0 0 width height))))] + [refresh-size + (lambda () + (let ([a (get-admin)]) + (when a + (send a resized this #f))) + (refresh))] [check-dim (lambda () (when is-dim? @@ -65,7 +99,18 @@ (unless dim-back (set! dim-back (mk-dim-back))) (unless dim-front - (set! dim-front (mk-dim-front))))))]) + (set! dim-front (mk-dim-front))))))] + [get-rotated + (lambda (bm dir) + (if (eq? dir 'n) + bm + (or (hash-table-get rotated-bms (cons dir bm) #f) + (let ([rotated-bm (case dir + [(w) (rotate-bm bm #f)] + [(e) (rotate-bm bm #t)] + [(s) (rotate-bm (rotate-bm bm #t) #t)])]) + (hash-table-put! rotated-bms (cons dir bm) rotated-bm) + rotated-bm))))]) (public [face-down? (lambda () flipped?)] [flip @@ -84,6 +129,25 @@ (unless (eq? is-dim? (and v #t)) (set! is-dim? (and v #t)) (refresh))])] + [orientation (lambda () (case rotated + [(n) 0] + [(e) 270] + [(w) 90] + [(s) 180]))] + [rotate (lambda (mode) + (let ([delta (case mode + [(0 360) 0] + [(cw -90 270) 1] + [(ccw 90 -270) 3] + [(180 -180) 2] + [else (error 'rotate "bad mode: ~e" mode)])]) + (set! rotated (list-ref (find-head orientations rotated) delta)) + (if (odd? delta) + (let ([w width]) + (set! width height) + (set! height w) + (refresh-size)) + (refresh))))] [get-suit-id (lambda () suit-id)] [get-suit @@ -133,26 +197,44 @@ [draw (lambda (dc x y left top right bottom dx dy draw-caret) (check-dim) - (if semi-flipped? - (send dc draw-bitmap (if flipped? semi-back semi-front) (+ x (/ width 4)) y) - (with-card-region - dc x y width height - (lambda () - (send dc draw-bitmap - (if flipped? - (if is-dim? dim-back back) - (if is-dim? dim-front front)) - x y)))))] - [copy (lambda () (make-object card% suit-id value width height - front back semi-front semi-back - (lambda () - (unless dim-front - (set! dim-front (mk-dim-front))) - dim-front) - (lambda () - (unless dim-back - (set! dim-back (mk-dim-back))) - dim-back)))]) + (let ([do-draw + (lambda (x y) + (with-card-region + dc x y width height + (lambda () + (send dc draw-bitmap + (let ([bm (if flipped? + (if is-dim? dim-back back) + (if is-dim? dim-front front))]) + (get-rotated bm rotated)) + x y))))]) + (if semi-flipped? + (let-values ([(sx sy) (send dc get-scale)]) + (case rotated + [(n s) + (send dc set-scale (/ sx 2) sy) + (do-draw (+ (* 2 x) (/ width 2)) y) + (send dc set-scale sx sy)] + [(e w) + (send dc set-scale sx (/ sy 2)) + (do-draw x (+ (* 2 y) (/ height 2))) + (send dc set-scale sx sy)])) + (do-draw x y))))] + [copy (lambda () + (let ([rotated? (memq rotated '(e w))]) + (make-object card% suit-id value + (if rotated? height width) + (if rotated? width height ) + front back + (lambda () + (unless dim-front + (set! dim-front (mk-dim-front))) + dim-front) + (lambda () + (unless dim-back + (set! dim-back (mk-dim-back))) + dim-back) + rotated-bms)))]) (private-field [save-x (box 0)] [save-y (box 0)]) diff --git a/collects/games/cards/cards.scrbl b/collects/games/cards/cards.scrbl index 7eda556041..556a0a292f 100644 --- a/collects/games/cards/cards.scrbl +++ b/collects/games/cards/cards.scrbl @@ -17,8 +17,9 @@ module provides a toolbox for creating cards games.} table<%>]{ Returns a table. The table is named by @scheme[title], and it is -@scheme[w] cards wide and @scheme[h] cards high. The table is not -initially shown; @scheme[(send table show #t)] shows it.} +@scheme[w] cards wide and @scheme[h] cards high (assuming a standard +card of 71 by 96 pixels). The table is not initially shown; +@scheme[(send table show #t)] shows it.} @defproc[(make-deck) (listof card<%>)]{ @@ -37,7 +38,7 @@ Returns a single card given a bitmap for the front, an optional bitmap for the back, and arbitrary values for the card's suit and value (which are returned by the card's @method[card<%> get-value] and @method[card<%> get-suit-id] methods). All provided bitmaps should be -71 by 96 pixels.} +the same size.} @defproc[(shuffle-list [lst list?] [n exact-nonnegative-integer?]) list?]{ @@ -171,8 +172,9 @@ Create an instance with @scheme[make-table]. void?]{ Adds @scheme[cards] to fill the region @scheme[r], fanning them out - bottom-right to top-left. The region @scheme[r] does not have to be - added to the table.} + bottom-right to top-left, assuming that all cards in @scheme[cards] + have the same width and height. The region @scheme[r] does not have + to be added to the table.} @defmethod[(remove-card [card (is-a?/c card<%>)]) void?]{ @@ -227,6 +229,19 @@ Removes @scheme[card] from the table.} Like @method[table<%> flip-cards], but only for @scheme[card] or elements of @scheme[cards] that are currently face down/up.} +@defmethod*[([(rotate-card [card (is-a?/c card<%>)] + [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) + void?] + [(rotate-cards [cards (listof (is-a?/c card<%>))] + [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) + void?])]{ + + Rotates @scheme[card] or all @scheme[cards] (at once, currently + without animation, but animation may be added in the future). + The center of each card is kept in place, except that the card is + moved as necessary to keep it on the table. See @xmethod[card<%> + rotate] for information on @scheme[mode].} + @defmethod*[([(card-to-front [card (is-a?/c card<%>)]) void?] [(card-to-back [card (is-a?/c card<%>)]) void?])]{ @@ -384,13 +399,13 @@ Create instances with @scheme[make-deck] or @scheme[make-card]. @defmethod[(card-width) exact-nonnegative-integer?]{ - Returns the width of the card in pixels. All cards have the same - width.} + Returns the width of the card in pixels. If the card is rotated 90 or + 270 degrees, the result is the card's original height.} @defmethod[(card-height) exact-nonnegative-integer?]{ - Returns the height of the card in pixels. All cards have the same - height.} + Returns the height of the card in pixels. If the card is rotated 90 or + 270 degrees, the result is the card's original width.} @defmethod[(flip) void?]{ @@ -409,6 +424,22 @@ Create instances with @scheme[make-deck] or @scheme[make-card]. Returns @scheme[#t] if the card is currently face down.} +@defmethod[(rotate [mode (or/c 'cw 'ccw 0 90 -90 180 -180 270 -270 360)]) void?]{ + + Rotates the card. Unlike using the @xmethod[table<%> rotate-card] method, + the card's top-left position is kept in place. + + If @scheme[mode] is @scheme['cw], the card is + rotated clockwise; if @scheme[mode] is @scheme['ccw], the card is + rotated counter-clockwise; if @scheme[mode] is one of the allowed + numbers, the card is rotated the corresponding amount in degrees + counter-clockwise.} + +@defmethod[(orientation) (or/c 0 90 180 270)]{ + + Returns the orientation of the card, where @scheme[0] corresponds to + its initial state, @scheme[90] is rotated 90 degrees counter-clockwise, and so on.} + @defmethod[(get-suit-id) any/c]{ Normally returns @scheme[1], @scheme[2], @scheme[3], or @scheme[4] @@ -476,7 +507,7 @@ Create instances with @scheme[make-deck] or @scheme[make-card]. @defmethod*[([(dim) boolean?] [(dim [can? any/c]) void?])]{ - Gets/sets a hilite on the card, whichis rendered by drawing it dimmer + Gets/sets a hilite on the card, which is rendered by drawing it dimmer than normal.} @defmethod[(copy) (is-a?/c card<%>)]{ diff --git a/collects/games/cards/classes.ss b/collects/games/cards/classes.ss index 7c8444d0e6..7016f4bd53 100644 --- a/collects/games/cards/classes.ss +++ b/collects/games/cards/classes.ss @@ -519,6 +519,27 @@ (flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))) (flip-step (lambda () (for-each (lambda (c) (send c flip)) cards))) (flip-step (lambda () (for-each (lambda (c) (send c semi-flip)) cards))))))] + [rotate-card + (lambda (card mode) (rotate-cards (list card) mode))] + [rotate-cards + (lambda (cards mode) + (begin-card-sequence) + (let ([tw (table-width)] + [th (table-height)]) + (map (lambda (c) + (let ([w (send c card-width)] + [h (send c card-height)]) + (send c rotate mode) + (let ([w2 (send c card-width)] + [h2 (send c card-height)] + [x (box 0)] + [y (box 0)]) + (send pb get-snip-location c x y) + (send pb move-to c + (min (max 0 (+ (unbox x) (/ (- w w2) 2))) (- tw w2)) + (min (max 0 (+ (unbox y) (/ (- h h2) 2))) (- th h2)))))) + cards) + (end-card-sequence)))] [card-face-up (lambda (card) (cards-face-up (list card)))] @@ -695,27 +716,28 @@ (send pb only-front-selected)))] [position-cards-in-region (lambda (cards r set) - (let-values ([(x y w h) (send pb get-region-box r)] - [(len) (sub1 (length cards))] - [(cw ch) (values (send back get-width) - (send back get-height))]) - (let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))] - [pw (pretty cw)] - [ph (pretty ch)]) - (let-values ([(x w) (if (> w pw) - (values (+ x (/ (- w pw) 2)) pw) - (values x w))] - [(y h) (if (> h ph) - (values (+ y (/ (- h ph) 2)) ph) - (values y h))]) - (position-cards cards x y - (lambda (p) - (if (zero? len) - (values (/ (- w cw) 2) - (/ (- h ch) 2)) - (values (* (- len p) (/ (- w cw) len)) - (* (- len p) (/ (- h ch) len))))) - set)))))]) + (unless (null? cards) + (let-values ([(x y w h) (send pb get-region-box r)] + [(len) (sub1 (length cards))] + [(cw ch) (values (send (car cards) get-width) + (send (car cards) get-height))]) + (let* ([pretty (lambda (cw) (+ (* (add1 len) cw) (* len PRETTY-CARD-SEP-AMOUNT)))] + [pw (pretty cw)] + [ph (pretty ch)]) + (let-values ([(x w) (if (> w pw) + (values (+ x (/ (- w pw) 2)) pw) + (values x w))] + [(y h) (if (> h ph) + (values (+ y (/ (- h ph) 2)) ph) + (values y h))]) + (position-cards cards x y + (lambda (p) + (if (zero? len) + (values (/ (- w cw) 2) + (/ (- h ch) 2)) + (values (* (- len p) (/ (- w cw) len)) + (* (- len p) (/ (- h ch) len))))) + set))))))]) (super-new [label title] [style '(metal no-resize-border)]) (begin (define c (make-object mred:editor-canvas% this #f '(no-vscroll no-hscroll))) diff --git a/collects/games/cards/make-cards.ss b/collects/games/cards/make-cards.ss index 9317e79039..38da0dcbd4 100644 --- a/collects/games/cards/make-cards.ss +++ b/collects/games/cards/make-cards.ss @@ -9,15 +9,6 @@ (define (get-bitmap file) (make-object mred:bitmap% file)) - (define (make-semi bm-in w h) - (let* ([bm (make-object mred:bitmap% (floor (/ w 2)) h)] - [mdc (make-object mred:bitmap-dc%)]) - (send mdc set-bitmap bm) - (send mdc set-scale 0.5 1) - (send mdc draw-bitmap bm-in 0 0) - (send mdc set-bitmap #f) - bm)) - (define (make-dim bm-in) (let ([w (send bm-in get-width)] [h (send bm-in get-height)]) @@ -46,11 +37,6 @@ (define back (get-bitmap (here "card-back.png"))) - (define semi-back - (let ([w (send back get-width)] - [h (send back get-height)]) - (make-semi back w h))) - (define dim-back (make-dim back)) @@ -74,9 +60,9 @@ value w h front back - (make-semi front w h) semi-back (lambda () (make-dim front)) - (lambda () dim-back)) + (lambda () dim-back) + (make-hash-table 'equal)) (vloop (sub1 value)))))))))) (define (make-card front-bm back-bm suit-id value) @@ -87,12 +73,9 @@ value w h front-bm (or back-bm back) - (make-semi front-bm w h) - (if back-bm - (make-semi back-bm w h) - semi-back) (lambda () (make-dim front-bm)) (lambda () (if back-bm (make-dim back) - dim-back)))))) + dim-back)) + (make-hash-table 'equal))))) From 4e8d06087330681c32618799e6ab1e55b143dea2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 16 Nov 2008 19:37:47 +0000 Subject: [PATCH 08/12] update version numbers for the v4.1.3 release svn: r12463 --- 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 4dab675642..809edc18dd 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.2.5" +#define MZSCHEME_VERSION "4.1.3.1" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 -#define MZSCHEME_VERSION_Z 2 -#define MZSCHEME_VERSION_W 5 +#define MZSCHEME_VERSION_Z 3 +#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 dfd62c1e926d512f40c8b047130849a76905c99f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 17 Nov 2008 01:13:43 +0000 Subject: [PATCH 09/12] removed redundant double-quotes from error messages svn: r12465 --- collects/handin-server/checker.ss | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss index b6acefa943..a80d3ff831 100644 --- a/collects/handin-server/checker.ss +++ b/collects/handin-server/checker.ss @@ -78,7 +78,7 @@ (let ([line (bytes->string/utf-8 line)]) (unless (or (< (string-length line) len) (< (string-width line) len)) - (error* "~a \"~a\" in \"~a\" is longer than ~a characters" + (error* "~a \"~a\" in ~a is longer than ~a characters" (if n (format "Line #~a" n) "The line") (regexp-replace #rx"^[ \t]*(.*?)[ \t]*$" line "\\1") (currently-processed-file-name) @@ -148,7 +148,8 @@ (define current-processed-file ; set when processing multi-file submissions (make-parameter #f)) (define (currently-processed-file-name) - (or (current-processed-file) "your code")) + (let ([c (current-processed-file)]) + (if c (format "\"~a\"" c) "your code"))) (define (input->process->output maxwidth textualize? untabify? bad-re) (let loop ([n 1]) @@ -164,7 +165,7 @@ [line (if (and untabify? (regexp-match? #rx"\t" line)) (untabify line) line)]) (when (and bad-re (regexp-match? bad-re line)) - (error* "You cannot use \"~a\" in \"~a\"!~a" + (error* "You cannot use \"~a\" in ~a!~a" (if (regexp? bad-re) (object-name bad-re) bad-re) (currently-processed-file-name) (if textualize? "" (format " (line ~a)" n)))) From b07b874e2eff8d9258249f21c08818cc57872b42 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 17 Nov 2008 01:25:46 +0000 Subject: [PATCH 10/12] scheme/load in guide svn: r12466 --- collects/scribblings/guide/guide.scrbl | 6 + collects/scribblings/guide/modules.scrbl | 9 +- collects/scribblings/guide/namespaces.scrbl | 132 ++++++++++++++++++++ collects/scribblings/guide/welcome.scrbl | 4 +- 4 files changed, 143 insertions(+), 8 deletions(-) diff --git a/collects/scribblings/guide/guide.scrbl b/collects/scribblings/guide/guide.scrbl index 06f277bf85..8cb705429f 100644 --- a/collects/scribblings/guide/guide.scrbl +++ b/collects/scribblings/guide/guide.scrbl @@ -92,6 +92,12 @@ downloadable packages contributed by PLT Scheme users. #:date "2004" #:url "http://www.cs.utah.edu/plt/publications/oopsla04-gff.pdf") + (bib-entry #:key "Flatt02" + #:author "Matthew Flatt" + #:title "Composable and Compilable Macros: You Want it When?" + #:location "International Conference on Functional Programming" + #:date "2002") + (bib-entry #:key "Flatt06" #:author "Matthew Flatt, Robert Bruce Findler, and Matthias Felleisen" #:title "Scheme with Classes, Mixins, and Traits (invited tutorial)" diff --git a/collects/scribblings/guide/modules.scrbl b/collects/scribblings/guide/modules.scrbl index 7b3677d0d7..f5212c8893 100644 --- a/collects/scribblings/guide/modules.scrbl +++ b/collects/scribblings/guide/modules.scrbl @@ -5,12 +5,9 @@ @title[#:tag "modules" #:style 'toc]{Modules} -Scheme definitions and expressions are normally written inside of a -module. Although a @tech{REPL} evaluates definitions and expressions outside -of a module for exploration and debugging purposes, and although -@scheme[load] can evaluate definitions and expressions from a file as -if they appeared in a @tech{REPL} interaction, code that is meant to last for -more than a few seconds belongs in a module. + +Modules let you organize Scheme code into multiple files and reusable +libraries. @local-table-of-contents[] diff --git a/collects/scribblings/guide/namespaces.scrbl b/collects/scribblings/guide/namespaces.scrbl index a391966ecf..2e8e23c84a 100644 --- a/collects/scribblings/guide/namespaces.scrbl +++ b/collects/scribblings/guide/namespaces.scrbl @@ -385,3 +385,135 @@ example, since the enclosing module requires instance of @schememodname[scheme/class]. Moreover, that instance is the same as the one imported into the module, so the class datatype is shared. + +@; ---------------------------------------------------------------------- + +@section[#:tag "load"]{Scripting Evaluation and Using @scheme[load]} + +Historically, Scheme and Lisp systems did not offer module +systems. Instead, large programs were built by essentially scripting +the @tech{REPL} to evaluate program fragments in a particular order. +While @tech{REPL} scripting turns out to be a bad way to structure +programs and libraries, it is still sometimes a useful capability. + +@margin-note{Describing a program via @scheme[load] interacts +especially badly with macro-defined language extensions +@cite["Flatt02"].} + +The @scheme[load] function runs a @tech{REPL} script by +@scheme[read]ing S-expressions from a file, one by one, and passing +them to @scheme[eval]. If a file @filepath{place.scm} contains + +@schemeblock[ +(define city "Salt Lake City") +(define state "Utah") +(printf "~a, ~a\n" city state) +] + +then it can be loaded in a @tech{REPL}: + +@interaction[ +(eval:alts (load "place.scm") (begin (define city "Salt Lake City") + (printf "~a, Utah\n" city))) +city +] + +Since @scheme[load] uses @scheme[eval], however, a module like the +following generally will not work---for the same reasons described in +@secref["namespaces"]: + +@schememod[ +scheme + +(define there "Utopia") + +(load "here.scm") +] + +The current namespace for evaluating the content of +@filepath{here.scm} is likely to be empty; in any case, you cannot get +@scheme[there] from @filepath{here.scm}. Also, any definitions in +@filepath{here.scm} will not become visible for use within the module; +after all, the @scheme[load] happens dynamically, while references to +identifiers within the module are resolved lexically, and therefore +statically. + +Unlike @scheme[eval], @scheme[load] does not accept a namespace +argument. To supply a namespace to @scheme[load], set the +@scheme[current-namespace] parameter. The following example evaluates +the expressions in @filepath{here.scm} using the bindings of the +@schememodname[scheme/base] module: + +@schememod[ +scheme + +(parameterize ([current-namespace (make-base-namespace)]) + (load "here.scm")) +] + +You can even use @scheme[namespace-anchor->namespace] to make the +bindings of the enclosing module accessible for dynamic evaluation. In +the following example, when @filepath{here.scm} is @scheme[load]ed, it +can refer to @scheme[there] as well as the bindings of +@schememodname[scheme]: + +@schememod[ +scheme + +(define there "Utopia") + +(define-namespace-anchor a) +(parameterize ([current-namespace (namespace-anchor->namespace a)]) + (load "here.scm")) +] + +Still, if @filepath{here.scm} defines any identifiers, the definitions +cannot be directly (i.e., statically) referenced by in the enclosing +module. + +The @schememodname[scheme/load] module language is different from +@schememodname[scheme] or @schememodname[scheme/base]. A module using +@schememodname[scheme/load] treats all of its content as dynamic, +passing each form in the module body to @scheme[eval] (using a +namespace that is initialized with @schememodname[scheme]). As a +result, uses of @scheme[eval] and @scheme[load] in the module body see +the same dynamic namespace as immediate body forms. For example, if +@filepath{here.scm} contains + +@schemeblock[ +(define here "Morporkia") +(define (go!) (set! here there)) +] + +then running + +@schememod[ +scheme/load + +(define there "Utopia") + +(load "here.scm") + +(go!) +(printf "~a\n" here) +] + +prints ``Utopia''. + +Drawbacks of using @schememodname[scheme/load] include reduced +error checking, tool support, and performance. For example, with the +program + +@schememod[ +scheme/load + +(define good 5) +(printf "running\n") +good +bad +] + +DrScheme's @onscreen{Check Syntax} tool cannot tell that the second +@scheme[good] is a reference to the first, and the unbound reference +to @scheme[bad] is reported only at run time instead of rejected +syntactically. diff --git a/collects/scribblings/guide/welcome.scrbl b/collects/scribblings/guide/welcome.scrbl index dde5dfa79e..ca68a82a1c 100644 --- a/collects/scribblings/guide/welcome.scrbl +++ b/collects/scribblings/guide/welcome.scrbl @@ -198,11 +198,11 @@ tempted to put just (substring str 0 5)) ] -into @filepath{piece.ss} and run @exec{mzscheme} with +into @filepath{piece.scm} and run @exec{mzscheme} with @interaction[ #:eval piece-eval -(eval:alts (load "piece.ss") (void)) +(eval:alts (load "piece.scm") (void)) (piece "howdy universe") ] From e4da627da938cba9b4b0fe4503da47033ad6de8d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 17 Nov 2008 08:50:12 +0000 Subject: [PATCH 11/12] Welcome to a new PLT day. svn: r12468 --- 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 a1bf00e010..62f0e8c300 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "16nov2008") +#lang scheme/base (provide stamp) (define stamp "17nov2008") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 360fadb38c..f26316da27 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Mon, 17 Nov 2008 14:32:15 +0000 Subject: [PATCH 12/12] change 'list' contract to (listof any) svn: r12469 --- collects/lang/private/beginner-funs.ss | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/lang/private/beginner-funs.ss b/collects/lang/private/beginner-funs.ss index e82123d6c1..83562ce7e0 100644 --- a/collects/lang/private/beginner-funs.ss +++ b/collects/lang/private/beginner-funs.ss @@ -278,18 +278,18 @@ ((beginner-append append) ((listof any) (listof any) (listof any) ... -> (listof any)) "to create a single list from several, by juxtaposition of the items") - (length (list -> number) + (length ((listof any) -> number) "to compute the number of items on a list") - (memq (any list -> (union false list)) + (memq (any (listof any) -> (union false list)) "to determine whether some value is on some list" " (comparing values with eq?)") - (memv (any list -> (union false list)) + (memv (any (listof any) -> (union false list)) "to determine whether some value is on the list" " (comparing values with eqv?)") - ((beginner-member member) (any list -> boolean) + ((beginner-member member) (any (listof any)-> boolean) "to determine whether some value is on the list" " (comparing values with equal?)") - (reverse (list -> list) + (reverse ((listof any) -> list) "to create a reversed version of a list") (assq (X (listof (cons X Y)) -> (union false (cons X Y))) "to determine whether some item is the first item of a pair"