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

added a pinhole property to images

Browse Source
This commit is contained in:
Robby Findler 2010-09-05 12:12:25 -05:00
parent f440332768
commit 5e01ac5537
2 changed files with 27 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1767,7 +1767,7 @@
(/ (sqrt max-s) h)
img))))
#;
;#;
(time
(let ([fn (make-temporary-file "test-image~a")])
(redex-check
@ -1783,10 +1783,12 @@
(error 'test-image.rkt
"saving and loading this image fails:\n ~s"
(term image)))
(unless (< cpu 2000)
(unless (< cpu 4000)
(error 'test-image.rkt
"saving and loading this image takes too longer than 2 seconds:\n ~s"
(term image))))
"saving and loading this image takes too longer than 4 seconds:\n ~s"
(term image)))
(display #\.) (flush-output)
)
#:attempts 1000)))
;;This expression was found by the above. Its problematic because it has a negative width.

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

@ -91,7 +91,7 @@ has been moved out).
;; (make-image shape bb boolean)
;; NOTE: the shape field is mutated when normalized, as
;; is the normalized? field.
(define (make-image shape bb normalized?) (new image% [shape shape] [bb bb] [normalized? normalized?]))
(define (make-image shape bb normalized? [pinhole #f]) (new image% [shape shape] [bb bb] [normalized? normalized?] [pinhole pinhole]))
(define (image-shape p) (send p get-shape))
(define (image-bb p) (send p get-bb))
(define (image-normalized? p) (send p get-normalized?))
@ -231,7 +231,7 @@ has been moved out).
(define image%
(class* snip% (equal<%>)
(init-field shape bb normalized?)
(init-field shape bb normalized? pinhole)
(define/public (equal-to? that eq-recur)
(or (eq? this that)
(let ([that
@ -314,7 +314,7 @@ has been moved out).
(calc-scroll-step)
(inexact->exact (ceiling (/ y scroll-step))))
(define/override (copy) (make-image shape bb normalized?))
(define/override (copy) (make-image shape bb normalized? pinhole))
(define/override (draw dc x y left top right bottom dx dy draw-caret?)
(let ([smoothing (send dc get-smoothing)])
(render-image this dc x y)))
@ -331,7 +331,7 @@ has been moved out).
(set-box/f! rspace 0)))
(define/override (write f)
(let ([bytes (string->bytes/utf-8 (format "~s" (list shape bb)))])
(let ([bytes (string->bytes/utf-8 (format "~s" (list shape bb pinhole)))])
(send f put (bytes-length bytes) bytes)))
(super-new)
@ -360,13 +360,22 @@ has been moved out).
(racket/base:read
(open-input-string
str)))))])
(if lst
(make-image (list-ref lst 0)
(list-ref lst 1)
#f)
(make-image (make-ellipse 100 100 0 'solid "black")
(make-bb 100 100 100)
#f))))
(cond
[(not lst)
(make-image (make-ellipse 100 100 0 'solid "black")
(make-bb 100 100 100)
#f
#f)]
[(= 2 (length lst))
(make-image (list-ref lst 0)
(list-ref lst 1)
#f
#f)]
[else
(make-image (list-ref lst 0)
(list-ref lst 1)
#f
(list-ref lst 2))])))
(super-new)))
(provide snip-class)