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

Rackety: bring down below 102 columns

Browse Source
This commit is contained in:
Robby Findler 2014-06-22 19:04:01 -05:00
parent 1271c11781
commit 43c1ddbf5f
1 changed files with 44 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt
View File

@ -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])