suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust 2htdp/image so that they work properly as wxme-mode snips

Browse Source 
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)
This commit is contained in:
Robby Findler 2014-04-04 16:43:37 -05:00
parent 34de786970
commit 8fb8f561c4
2 changed files with 23 additions and 68 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
pkgs/gui-pkgs/gui-lib/mrlib/image-core-wxme.rkt
View File

@ -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))))

33
pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt
View File

@ -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)