made scaling work with pinholes
This commit is contained in:
parent
986b36d761
commit
e3b51e8cf4
|
@ -104,11 +104,15 @@
|
||||||
(scale-internal x-factor y-factor image))
|
(scale-internal x-factor y-factor image))
|
||||||
|
|
||||||
(define (scale-internal x-factor y-factor image)
|
(define (scale-internal x-factor y-factor image)
|
||||||
|
(let ([ph (send image get-pinhole)])
|
||||||
(make-image (make-scale x-factor y-factor (image-shape image))
|
(make-image (make-scale x-factor y-factor (image-shape image))
|
||||||
(make-bb (* x-factor (get-right image))
|
(make-bb (* x-factor (get-right image))
|
||||||
(* y-factor (get-bottom image))
|
(* y-factor (get-bottom image))
|
||||||
(* y-factor (get-baseline image)))
|
(* y-factor (get-baseline image)))
|
||||||
#f))
|
#f
|
||||||
|
(and ph
|
||||||
|
(make-point (* x-factor (point-x ph))
|
||||||
|
(* y-factor (point-y ph)))))))
|
||||||
|
|
||||||
;; overlay : image image image ... -> image
|
;; overlay : image image image ... -> image
|
||||||
;; places images on top of each other with their upper left corners aligned.
|
;; places images on top of each other with their upper left corners aligned.
|
||||||
|
|
|
@ -1594,6 +1594,13 @@
|
||||||
(test (pinhole-x (clear-pinhole (rectangle 10 24 'solid 'blue))) => #f)
|
(test (pinhole-x (clear-pinhole (rectangle 10 24 'solid 'blue))) => #f)
|
||||||
(test (pinhole-y (clear-pinhole (rectangle 10 24 'solid 'blue))) => #f)
|
(test (pinhole-y (clear-pinhole (rectangle 10 24 'solid 'blue))) => #f)
|
||||||
|
|
||||||
|
(test (pinhole-x (scale 11 (center-pinhole (rectangle 10 24 'solid 'blue))))
|
||||||
|
=>
|
||||||
|
55)
|
||||||
|
(test (pinhole-y (scale 11 (center-pinhole (rectangle 10 24 'solid 'blue))))
|
||||||
|
=>
|
||||||
|
132)
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;;
|
;;
|
||||||
;; test errors.
|
;; test errors.
|
||||||
|
|
|
@ -1,10 +1,5 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
;; changed:
|
|
||||||
;; - simple-shape
|
|
||||||
;; - np-atomic-shape
|
|
||||||
;; - atomic-shape
|
|
||||||
|
|
||||||
#|
|
#|
|
||||||
|
|
||||||
This library is the part of the 2htdp/image
|
This library is the part of the 2htdp/image
|
||||||
|
|
Loading…
Reference in New Issue
Block a user