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

adjust drracket's value printer to specially treat 2htdp/image images.

Browse Source 
related to PR 11849
This commit is contained in:
Robby Findler 2011-04-14 09:39:43 -05:00
parent 1c60499923
commit 7b4e673081
3 changed files with 50 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
collects/drracket/private/language.rkt
View File

@ -10,6 +10,8 @@
;; (which do not do compilation)
(prefix-in el: errortrace/errortrace-lib)
(prefix-in image-core: mrlib/image-core)
mzlib/pconvert
racket/pretty
mzlib/struct
@ -402,6 +404,14 @@
[pretty-print-print-hook
(λ (value display? port)
(cond
[(image-core:image? value)
;; do this computation here so that any failures
;; during drawing happen under the user's custodian
(image-core:compute-image-cache value)
(write-special value port)
1]
[(is-a? value snip%)
(write-special value port)
1]

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

@ -84,6 +84,13 @@ has been moved out).
(define res (send img copy))
(send res set-use-bitmap-cache?! (and bitmap-cache? #t))
res)
(define (compute-image-cache img)
(unless (image? img)
(error 'compute-cached-bitmap "expected an image as the first argument, got ~e" img))
(when (is-a? img image<%>)
(send img compute-cached-bitmap))
(void))
;; a shape is either:
;;
@ -233,7 +240,10 @@ has been moved out).
(send bdc get-bitmap)
(send bdc set-bitmap #f))))
(define-local-member-name set-use-bitmap-cache?!)
(define-local-member-name
set-use-bitmap-cache?!
set-cached-bitmap
compute-cached-bitmap)
(define image%
(class* snip% (png-convertible<%> image<%>)
@ -320,17 +330,19 @@ has been moved out).
(calc-scroll-step)
(inexact->exact (ceiling (/ y scroll-step))))
(define/override (copy) (make-image shape bb normalized? pinhole))
(define/override (copy)
(define res (make-image shape bb normalized? pinhole))
(when cached-bitmap
(send res set-cached-bitmap cached-bitmap))
res)
(define cached-bitmap #f)
(define use-cached-bitmap? #t)
(define/public (set-use-bitmap-cache?! u-b-c?)
(set! use-cached-bitmap? u-b-c?)
(unless use-cached-bitmap?
(set! cached-bitmap #f)))
;; this method is only used by the 'copy' method
(define/public (set-cached-bitmap bm) (set! cached-bitmap bm))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(define/public (compute-cached-bitmap)
(when use-cached-bitmap?
(unless cached-bitmap
(set! cached-bitmap (make-bitmap (+ (inexact->exact (round (bb-right bb))) 1)
@ -338,7 +350,15 @@ has been moved out).
(define bdc (make-object bitmap-dc% cached-bitmap))
(send bdc erase)
(render-image this bdc 0 0)
(send bdc set-bitmap #f)))
(send bdc set-bitmap #f))))
(define/public (set-use-bitmap-cache?! u-b-c?)
(set! use-cached-bitmap? u-b-c?)
(unless use-cached-bitmap?
(set! cached-bitmap #f)))
(define/override (draw dc x y left top right bottom dx dy draw-caret)
(compute-cached-bitmap)
(let ([alpha (send dc get-alpha)])
(when (pair? draw-caret)
@ -1182,7 +1202,7 @@ the mask bitmap and the original bitmap are all together in a single bytes!
(provide make-image image-shape image-bb image-normalized? image%
un/cache-image
un/cache-image compute-image-cache
(struct-out bb)
(struct-out point)

12
collects/mrlib/scribblings/image-core.scrbl
View File

@ -1,5 +1,6 @@
#lang scribble/doc
@(require "common.ss")
@(require "common.ss"
(for-label mrlib/image-core))
@title{Image Core}
@ -26,4 +27,13 @@ up an image.
@defproc[(un/cache-image [image image?] [b any/c]) image?]{
Returns an image that either caches its drawing in the
snip @method[snip% draw] method or doesn't, depending on @racket[b].
}
@defproc[(compute-image-cache [image image?]) void?]{
When the image has a bitmap-cache (which it does by default,
although @racket[un/cache-image] can disable it), this function
fills in the bitmap, doing the work to draw image into the bitmap.
Ordinarily, the image's bitmap cache is computed the first time
the image is actually rendered.
}