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

added support to the 2htdp/image library for reading files when there is no GUI around.

Browse Source 
currently the support is limited to images that can only report their sizes and pinholes and where equal?
signals an error unless the arguments are eq?.
This commit is contained in:
Robby Findler 2010-10-26 15:25:57 -05:00
parent 68b06b42d9
commit a744958fd5
6 changed files with 209 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
collects/2htdp/tests/test-image.rkt
View File

@ -47,6 +47,8 @@
racket/class
racket/file
racket/gui/base
racket/port
wxme
rackunit
(prefix-in 1: htdp/image)
(only-in lang/htdp-advanced equal~?))
@ -1970,6 +1972,66 @@
=>
#rx"^beside/align")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; testing the wxme connection for 2htdp/image images
;;
(let ()
(define txt (new text%))
(define img1 (overlay (rectangle 100 20 'solid 'red)
(rectangle 20 100 'solid 'red)))
(define img2
(put-pinhole 50
20
(overlay (rectangle 100 20 'solid 'red)
(rectangle 20 100 'solid 'red))))
(send txt insert "(define img (list ")
(send txt insert img1)
(send txt insert " ")
(send txt insert img2)
(send txt insert "))")
(define sp (open-output-string))
(send txt save-port sp)
(test (port->string (wxme-port->text-port (open-input-string (get-output-string sp))))
=>
"(define img (list . .))"))
(let ()
(define txt (new text%))
(define img1 (overlay (rectangle 100 20 'solid 'red)
(rectangle 20 200 'solid 'red)))
(define img2
(put-pinhole 50
20
(overlay (rectangle 200 20 'solid 'red)
(rectangle 20 100 'solid 'red))))
(define img3 (text "Hello" 32 'black))
(send txt insert "(")
(send txt insert img1)
(send txt insert " ")
(send txt insert img2)
(send txt insert " ")
(send txt insert img3)
(send txt insert ")")
(define sp (open-output-string))
(send txt save-port sp)
(define washed (read (wxme-port->port (open-input-string (get-output-string sp)))))
(test (list? washed) => #t)
(test (map pinhole-x washed) => (list #f 50 #f))
(test (map pinhole-y washed) => (list #f 20 #f))
(test (image-width (car washed)) => 100)
(test (image-height (car washed)) => 200)
(test (image-baseline (car washed)) => 200)
(test (equal? (image-baseline (list-ref washed 2))
(image-height (list-ref washed 2)))
=>
#f))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

62
collects/mrlib/image-core-wxme.rkt Normal file
View File

@ -0,0 +1,62 @@
#lang racket/base
(require racket/class
wxme
"private/image-core-snipclass.rkt"
"private/regmk.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
(class* object% (snip-reader<%>)
(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))))

64
collects/mrlib/image-core.rkt
View File

@ -32,34 +32,13 @@ has been moved out).
racket/math
racket/contract
"private/image-core-bitmap.ss"
"image-core-wxme.ss"
"private/image-core-snipclass.rkt"
"private/regmk.rkt"
(prefix-in cis: "cache-image-snip.ss")
(for-syntax racket/base))
(define-for-syntax id-constructor-pairs '())
(define-for-syntax (add-id-constructor-pair a b)
(set! id-constructor-pairs (cons (list a b) id-constructor-pairs)))
(define-syntax (define-struct/reg-mk stx)
(syntax-case stx ()
[(_ id . rest)
(let ([build-name
(λ (fmt)
(datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))])
(add-id-constructor-pair (build-name "struct:~a")
(build-name "make-~a"))
#'(define-struct id . rest))]))
(define-syntax (define-id->constructor stx)
(syntax-case stx ()
[(_ fn)
#`(define (fn x)
(case x
#,@(map (λ (x)
(with-syntax ([(struct: maker) x])
#`[(struct:) maker]))
id-constructor-pairs)))]))
(define-struct/reg-mk point (x y) #:transparent)
;
@ -93,15 +72,11 @@ has been moved out).
(define (set-image-shape! p s) (send p set-shape s))
(define (set-image-normalized?! p n?) (send p set-normalized? n?))
(define (image? p)
(or (is-a? p image%)
(or (is-a? p image<%>)
(is-a? p image-snip%)
(is-a? p bitmap%)))
;; a bb is (bounding box)
;; (make-bb number number number)
(define-struct/reg-mk bb (right bottom baseline) #:transparent)
;; a shape is either:
;;
;; - (make-overlay shape shape)
@ -219,14 +194,10 @@ has been moved out).
; ;; ;
; ;;;;
(define-local-member-name
get-shape set-shape get-bb get-pinhole
get-normalized? set-normalized get-normalized-shape)
(define skip-image-equality-fast-path (make-parameter #f))
(define image%
(class* snip% (equal<%>)
(class* snip% (equal<%> image<%>)
(init-field shape bb normalized? pinhole)
(define/public (equal-to? that eq-recur)
(or (eq? this that)
@ -346,30 +317,13 @@ has been moved out).
(define image-snipclass%
(class snip-class%
(define/override (read f)
(let* ([bytes (send f get-unterminated-bytes)]
[str
(and bytes
(with-handlers ((exn:fail? (λ (x) #f)))
(bytes->string/utf-8 bytes)))]
[lst
(and str
(with-handlers ((exn:fail:read? (λ (x) #f)))
(parse
(racket/base:read
(open-input-string
str)))))])
(let ([lst (parse (fetch (send f get-unterminated-bytes)))])
(cond
[(not lst)
(make-image (make-ellipse 100 100 0 'solid "black")
(make-bb 100 100 100)
#f
#f)]
[(= 2 (length lst))
;; backwards compatibility for saved images that didn't have a pinhole
(make-image (list-ref lst 0)
(list-ref lst 1)
#f
#f)]
[else
(make-image (list-ref lst 0)
(list-ref lst 1)
@ -379,7 +333,8 @@ has been moved out).
(provide snip-class)
(define snip-class (new image-snipclass%))
(send snip-class set-classname (format "~s" '(lib "image-core.ss" "mrlib")))
(send snip-class set-classname (format "~s" (list '(lib "image-core.ss" "mrlib")
'(lib "image-core-wxme.rkt" "mrlib"))))
(send snip-class set-version 1)
(send (get-the-snip-class-list) add snip-class)
@ -406,9 +361,6 @@ has been moved out).
(k #f)))]))]
[else sexp]))))
(define-id->constructor id->constructor)
(define (normalized-shape? s)
(cond
[(overlay? s)

36
collects/mrlib/private/image-core-snipclass.rkt Normal file
View File

@ -0,0 +1,36 @@
#lang racket/base
(require racket/class)
(provide fetch image<%>
get-shape set-shape get-bb get-pinhole
get-normalized? set-normalized get-normalized-shape)
(define-local-member-name
get-shape set-shape get-bb get-pinhole
get-normalized? set-normalized get-normalized-shape)
(define image<%>
(interface ()
get-shape set-shape get-bb get-pinhole
get-normalized? get-normalized-shape))
(define (fetch bytes)
(let* ([str
(and bytes
(with-handlers ((exn:fail? (λ (x) #f)))
(bytes->string/utf-8 bytes)))]
[lst (and str
(with-handlers ((exn:fail:read? (λ (x) #f)))
(racket/base:read
(open-input-string
str))))])
(cond
[(and (list? lst)
(= 2 (length lst)))
;; backwards compatibility for saved images that didn't have a pinhole
(list (list-ref lst 0)
(list-ref lst 1)
#f)]
[else
lst])))
(define racket/base:read read)

37
collects/mrlib/private/regmk.rkt Normal file
View File

@ -0,0 +1,37 @@
#lang racket
(provide define-struct/reg-mk
id->constructor
(struct-out point)
(struct-out bb))
(define-for-syntax id-constructor-pairs '())
(define-for-syntax (add-id-constructor-pair a b)
(set! id-constructor-pairs (cons (list a b) id-constructor-pairs)))
(define-syntax (define-struct/reg-mk stx)
(syntax-case stx ()
[(_ id . rest)
(let ([build-name
(λ (fmt)
(datum->syntax #'id (string->symbol (format fmt (syntax->datum #'id)))))])
(add-id-constructor-pair (build-name "struct:~a")
(build-name "make-~a"))
#'(define-struct id . rest))]))
(define-syntax (define-id->constructor stx)
(syntax-case stx ()
[(_ fn)
#`(define (fn x)
(case x
#,@(map (λ (x)
(with-syntax ([(struct: maker) x])
#`[(struct:) maker]))
id-constructor-pairs)))]))
(define-id->constructor id->constructor)
(define-struct/reg-mk point (x y) #:transparent)
;; a bb is (bounding box)
;; (make-bb number number number)
(define-struct/reg-mk bb (right bottom baseline) #:transparent)

4
collects/wxme/private/compat.rkt
View File

@ -39,6 +39,10 @@
"(lib \"cache-image-snip.ss\" \"mrlib\")"
'(lib "cache-image.ss" "wxme"))
(register-lib-mapping!
"(lib \"image-core.ss\" \"mrlib\")"
'(lib "image-core-wxme.rkt" "wxme"))
(register-lib-mapping!
"test-case-box%"
'(lib "test-case.ss" "wxme"))))