From 8fb8f561c48ad7660b049a318511a929c39e4c06 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 4 Apr 2014 16:43:37 -0500 Subject: [PATCH] adjust 2htdp/image so that they work properly as wxme-mode snips Before, they would create a crippled version in that mode, but that is no longer necessary (it may never have been necessary, but it certainly hasn't been necessary in a while) --- .../gui-lib/mrlib/image-core-wxme.rkt | 58 ++----------------- pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt | 33 ++++++----- 2 files changed, 23 insertions(+), 68 deletions(-) diff --git a/pkgs/gui-pkgs/gui-lib/mrlib/image-core-wxme.rkt b/pkgs/gui-pkgs/gui-lib/mrlib/image-core-wxme.rkt index 88906d33bc..b2ce8655fa 100644 --- a/pkgs/gui-pkgs/gui-lib/mrlib/image-core-wxme.rkt +++ b/pkgs/gui-pkgs/gui-lib/mrlib/image-core-wxme.rkt @@ -2,61 +2,13 @@ (require racket/class wxme "private/image-core-snipclass.rkt" - "private/regmk.rkt") + "image-core.rkt") (provide reader image<%>) -(define guiless-image% - (class* object% (equal<%> image<%>) - (init-field pinhole bb) - (define/public (equal-to? that eq-recur) - (cond - [(eq? this that) #t] - [else (error 'image% "cannot do equality comparison without gui libraries")])) - (define/public (equal-hash-code-of y) 42) - (define/public (equal-secondary-hash-code-of y) 3) - - (define/public (get-shape) - (error 'image% "cannot get-shape without gui libraries")) - (define/public (set-shape s) - (error 'image% "cannot get-shape without gui libraries")) - (define/public (get-bb) bb) - (define/public (get-pinhole) pinhole) - (define/public (get-normalized?) #f) - (define/public (set-normalized? n?) (void)) - - (define/public (get-normalized-shape) - (error 'image% "cannot get-normalized-shape without gui libraries")) - - (super-new))) - (define reader - (new + (new (class* object% (snip-reader<%>) - (define/public (read-header vers stream) - (void)) + (define/public (read-header vers stream) (void)) (define/public (read-snip text? cvers stream) - (let* ([lst (fetch (send stream read-raw-bytes '2htdp/image))]) - (if text? - #"." - (let ([marshalled-img (list-ref lst 0)] - [marshalled-bb (list-ref lst 1)] - [marshalled-pinhole (list-ref lst 2)]) - (new guiless-image% - [bb (if (and (vector? marshalled-bb) - (= 4 (vector-length marshalled-bb)) - (eq? (vector-ref marshalled-bb 0) 'struct:bb) - (number? (vector-ref marshalled-bb 1)) - (number? (vector-ref marshalled-bb 2)) - (number? (vector-ref marshalled-bb 3))) - (apply make-bb (cdr (vector->list marshalled-bb))) - (make-bb 100 100 100))] - [pinhole - (if (and (vector? marshalled-pinhole) - (= 3 (vector-length marshalled-pinhole)) - (eq? (vector-ref marshalled-pinhole 0) 'struct:point) - (number? (vector-ref marshalled-pinhole 1)) - (number? (vector-ref marshalled-pinhole 2))) - (make-point (vector-ref marshalled-pinhole 1) - (vector-ref marshalled-pinhole 2)) - #f)]))))) - (super-new)))) + (snipclass-bytes->image (send stream read-raw-bytes '2htdp/image))) + (super-new)))) diff --git a/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt b/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt index dc0cc748d9..fc1175348d 100644 --- a/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt +++ b/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt @@ -37,7 +37,6 @@ has been moved out). racket/math racket/contract "private/image-core-bitmap.rkt" - "image-core-wxme.rkt" "private/image-core-snipclass.rkt" "private/regmk.rkt" racket/snip @@ -440,21 +439,23 @@ has been moved out). (define racket/base:read read) (define image-snipclass% (class snip-class% - (define/override (read f) - (let ([lst (parse (fetch (send f get-unterminated-bytes)))]) - (cond - [(not lst) - (make-image (make-translate 50 50 (make-ellipse 100 100 0 'solid "black")) - (make-bb 100 100 100) - #f - #f)] - [else - (make-image (list-ref lst 0) - (list-ref lst 1) - #f - (list-ref lst 2))]))) + (define/override (read f) (snipclass-bytes->image (send f get-unterminated-bytes))) (super-new))) +(define (snipclass-bytes->image bytes) + (define lst (parse (fetch bytes))) + (cond + [(not lst) + (make-image (make-translate 50 50 (make-ellipse 100 100 0 'solid "black")) + (make-bb 100 100 100) + #f + #f)] + [else + (make-image (list-ref lst 0) + (list-ref lst 1) + #f + (list-ref lst 2))])) + (provide snip-class) (define snip-class (new image-snipclass%)) (send snip-class set-classname (format "~s" (list '(lib "image-core.ss" "mrlib") @@ -1372,7 +1373,9 @@ the mask bitmap and the original bitmap are all together in a single bytes! image-snip% curve-segment->path - mode-color->pen) + mode-color->pen + + snipclass-bytes->image) ;; method names (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape)