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

added a pinhole property to images

Browse Source 
original commit: 5e01ac55373d2987410da7d95f26f42535cfae3b
This commit is contained in:
Robby Findler 2010-09-05 12:12:25 -05:00
parent 9937aefd11
commit ad9a2a8721
1 changed files with 20 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

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