diff --git a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt index 3440192cd4..eba5e7992b 100644 --- a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt @@ -63,7 +63,8 @@ [parent bp]) min-width 100) (send f show #t))) -;; the obfuscation in the width and height defaults is so that error checking happens in the right order +;; the obfuscation in the width and height defaults +;; is so that error checking happens in the right order (define/chk (save-image image filename [width (if (image? image) (image-width image) 0)] @@ -160,24 +161,26 @@ (define/chk (overlay/align x-place y-place image image2 . image3) (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole)) - (check-dependencies 'overlay/align - (and (send image get-pinhole) - (send image2 get-pinhole) - (andmap (λ (x) (send x get-pinhole)) - image3)) - "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes" - 'pinhole "pinhole")) + (check-dependencies + 'overlay/align + (and (send image get-pinhole) + (send image2 get-pinhole) + (andmap (λ (x) (send x get-pinhole)) + image3)) + "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes" + 'pinhole "pinhole")) (overlay/internal x-place y-place image (cons image2 image3) #t)) (define/chk (underlay/align x-place y-place image image2 . image3) (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole)) - (check-dependencies 'underlay/align - (and (send image get-pinhole) - (send image2 get-pinhole) - (andmap (λ (x) (send x get-pinhole)) - image3)) - "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes" - 'pinhole "pinhole")) + (check-dependencies + 'underlay/align + (and (send image get-pinhole) + (send image2 get-pinhole) + (andmap (λ (x) (send x get-pinhole)) + image3)) + "when x-place or y-place is ~e or ~e, then all of the arguments must have pinholes" + 'pinhole "pinhole")) (let ([imgs (reverse (list* image image2 image3))]) (overlay/internal x-place y-place (car imgs) (cdr imgs) #f))) @@ -422,10 +425,11 @@ (place-image/internal image1 x1 y1 image2 'middle 'middle)) (define/chk (place-image/align image1 x1 y1 x-place y-place image2) (when (or (eq? x-place 'pinhole) (eq? y-place 'pinhole)) - (check-dependencies 'place-image/align - (send image1 get-pinhole) - "when x-place or y-place is ~e or ~e, the the first image argument must have a pinhole" - 'pinhole "pinhole")) + (check-dependencies + 'place-image/align + (send image1 get-pinhole) + "when x-place or y-place is ~e or ~e, the the first image argument must have a pinhole" + 'pinhole "pinhole")) (place-image/internal image1 x1 y1 image2 x-place y-place)) (define/chk (place-images images zero-or-more-posns image2) (check-place-images-dependency 'place-images images zero-or-more-posns) @@ -683,13 +687,13 @@ (text->font atomic-shape))]) (rotated-rectangular-bounding-box w h (text-angle atomic-shape)))] [(flip? atomic-shape) - (let* ([bitmap (flip-shape atomic-shape)] - [bb (ibitmap-raw-bitmap bitmap)]) - (let-values ([(l t r b) - (rotated-rectangular-bounding-box (* (send bb get-width) (ibitmap-x-scale bitmap)) - (* (send bb get-height) (ibitmap-y-scale bitmap)) - (ibitmap-angle bitmap))]) - (values l t r b)))] + (define bitmap (flip-shape atomic-shape)) + (define bb (ibitmap-raw-bitmap bitmap)) + (define-values (l t r b) + (rotated-rectangular-bounding-box (* (send bb get-width) (ibitmap-x-scale bitmap)) + (* (send bb get-height) (ibitmap-y-scale bitmap)) + (ibitmap-angle bitmap))) + (values l t r b)] [else (eprintf "using bad bounding box for ~s\n" atomic-shape) (values 0 0 100 100)])) @@ -1347,7 +1351,9 @@ (current-directory)))] [else (raise-syntax-error 'bitmap - "expected the argument to specify a local path (via a string) or a module path (e.g. `icons/b-run.png')" + (string-append + "expected the argument to specify a local path (via a string)" + " or a module path (e.g. `icons/b-run.png')") stx)])]) #`(bitmap/proc '#,path/lst))])) @@ -1401,10 +1407,13 @@ (bytes-ref bytes i)))])) (define/chk (color-list->bitmap color-list width height) - (check-dependencies 'color-list->bitmap - (= (* width height) (length color-list)) - "the length of the color list to match the product of the width and the height, but the list has ~a elements and the width and height are ~a and ~a respectively" - (length color-list) width height) + (check-dependencies + 'color-list->bitmap + (= (* width height) (length color-list)) + (string-append + "the length of the color list to match the product of the width and the height," + " but the list has ~a elements and the width and height are ~a and ~a respectively") + (length color-list) width height) (cond [(or (zero? width) (zero? height)) (rectangle width height "solid" "black")] @@ -1444,7 +1453,8 @@ (define/chk (pinhole-x image) (let ([ph (send image get-pinhole)]) (and ph (point-x ph)))) (define/chk (pinhole-y image) (let ([ph (send image get-pinhole)]) (and ph (point-y ph)))) -(define/chk (put-pinhole x1 y1 image) (make-image (image-shape image) (image-bb image) (image-normalized? image) (make-point x1 y1))) +(define/chk (put-pinhole x1 y1 image) + (make-image (image-shape image) (image-bb image) (image-normalized? image) (make-point x1 y1))) (define/chk (center-pinhole image) (let ([bb (send image get-bb)]) (make-image (image-shape image) @@ -1452,7 +1462,8 @@ (image-normalized? image) (make-point (/ (bb-right bb) 2) (/ (bb-baseline bb) 2))))) -(define/chk (clear-pinhole image) (make-image (image-shape image) (image-bb image) (image-normalized? image) #f)) +(define/chk (clear-pinhole image) + (make-image (image-shape image) (image-bb image) (image-normalized? image) #f)) (define build-color/color (let ([orig-make-color make-color])