From 6266fe8b11b778985ce83f2f999e995ba39c569d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 28 Feb 2008 17:47:19 +0000 Subject: [PATCH] added regular-polygon and changed language to scheme/base svn: r8823 --- collects/htdp/image.ss | 1607 +++++++++++++------------ collects/teachpack/htdp/image.ss | 1 + collects/tests/mzscheme/htdp-image.ss | 15 + 3 files changed, 844 insertions(+), 779 deletions(-) diff --git a/collects/htdp/image.ss b/collects/htdp/image.ss index a101404e91..fb9b3ed31d 100644 --- a/collects/htdp/image.ss +++ b/collects/htdp/image.ss @@ -5,657 +5,706 @@ plt/collects/tests/mzscheme/image-test.ss |# -(module image mzscheme +#lang scheme/base - (require mred - mzlib/class - (lib "cache-image-snip.ss" "mrlib") - mzlib/math - (lib "posn.ss" "lang") - (lib "imageeq.ss" "lang" "private") - "error.ss") - - (provide image-width - image-height - overlay - overlay/xy - - pinhole-x - pinhole-y - move-pinhole - put-pinhole - - rectangle - circle - ellipse - triangle - line - star - add-line - text - - shrink - shrink-tl - shrink-tr - shrink-bl - shrink-br - - image-inside? - find-image - - image->color-list - color-list->image - - image->alpha-color-list - alpha-color-list->image - - image-color? - make-color - color-red - color-green - color-blue - color? - make-alpha-color - alpha-color-alpha - alpha-color-red - alpha-color-green - alpha-color-blue - alpha-color?) +(require mred + mzlib/class + (lib "cache-image-snip.ss" "mrlib") + mzlib/math + (lib "posn.ss" "lang") + (lib "imageeq.ss" "lang" "private") + "error.ss") - ;; ---------------------------------------- - - (define (color-list? l) - (and (list? l) (andmap image-color? l))) - (define (alpha-color-list? l) - (and (list? l) (andmap alpha-color? l))) +(provide image-width + image-height + overlay + overlay/xy + + pinhole-x + pinhole-y + move-pinhole + put-pinhole + + rectangle + circle + ellipse + triangle + line + star + add-line + text + regular-polygon + + shrink + shrink-tl + shrink-tr + shrink-bl + shrink-br + + image-inside? + find-image + + image->color-list + color-list->image + + image->alpha-color-list + alpha-color-list->image + + image-color? + make-color + color-red + color-green + color-blue + color? + make-alpha-color + alpha-color-alpha + alpha-color-red + alpha-color-green + alpha-color-blue + alpha-color?) - (define-struct color (red green blue) (make-inspector)) - (define-struct alpha-color (alpha red green blue) (make-inspector)) +;; ---------------------------------------- - ;; ---------------------------------------- +(define (color-list? l) + (and (list? l) (andmap image-color? l))) +(define (alpha-color-list? l) + (and (list? l) (andmap alpha-color? l))) - (define (check name p? v desc arg-posn) (check-arg name (p? v) desc arg-posn v)) +(define-struct color (red green blue) #:inspector (make-inspector)) +(define-struct alpha-color (alpha red green blue) #:inspector (make-inspector)) - (define (check-coordinate name val arg-posn) (check name finite-real? val "finite real number" arg-posn)) - (define (check-integer-coordinate name val arg-posn) (check name nii? val "integer" arg-posn)) - (define (check-size name val arg-posn) (check name pos-number? val "positive number" arg-posn)) - (define (check-posi-size name val arg-posn) (check name pos-integer? val "positive integer" arg-posn)) - (define (check-size/0 name val arg-posn) (check name nn-number? val "non-negative number" arg-posn)) - (define (check-image name val arg-posn) (check name image? val "image" arg-posn)) - (define (check-image-color name val arg-posn) - (let ([simple-check (λ (x) (or (string? x) (symbol? x) (color? x)))]) - (check name simple-check val "image-color" arg-posn) - (unless (image-color? val) - (error name "~e is not a valid color name" val)))) - (define (check-mode name val arg-posn) (check name mode? val mode-str arg-posn)) - - (define (pos-number? i) (and (number? i) (positive? i))) - (define (pos-integer? i) (and (number? i) (positive? i) (integer? i))) - (define (nn-number? i) (and (number? i) (or (zero? i) (positive? i)))) - (define (nii? x) (and (integer? x) (not (= x +inf.0)) (not (= x -inf.0)))) - (define (finite-real? x) (and (real? x) (not (= x +inf.0)) (not (= x -inf.0)))) - - (define (check-sizes who w h) - (unless (and (< 0 w 10000) (< 0 h 10000)) - (error (format "cannot make ~a x ~a image" w h)))) - - (define (mode? x) - (member x '(solid "solid" outline "outline"))) - - (define mode-str "'solid \"solid\" 'outline or \"outline\"") - - (define (mode->brush-symbol m) - (cond - [(member m '(solid "solid")) - 'solid] - [(member m '(outline "outline")) - 'transparent])) - - (define (mode->pen-symbol m) - (cond - [(member m '(solid "solid")) 'transparent] - [(member m '(outline "outline")) 'solid])) - - (define (make-color% c) - (cond - [(string? c) (send the-color-database find-color c)] - [(symbol? c) (send the-color-database find-color (symbol->string c))] - [(color? c) (make-object color% - (color-red c) - (color-green c) - (color-blue c))] - [else #f])) - - (define (image-color? c) - (cond - [(color? c) #t] - [(string? c) (and (send the-color-database find-color c) #t)] - [(symbol? c) (and (send the-color-database find-color (symbol->string c)) #t)] - [else #f])) - - (define (image-width a) - (check-image 'image-width a "first") - (let-values ([(w h) (snip-size a)]) - (inexact->exact (ceiling w)))) +;; ---------------------------------------- - (define (image-height a) - (check-image 'image-height a "first") - (let-values ([(w h) (snip-size a)]) - (inexact->exact (ceiling h)))) - - (define (pinhole-x a) - (check-image 'pinhole-x a "first") - (let-values ([(x y) (send (coerce-to-cache-image-snip a) get-pinhole)]) - x)) - - (define (pinhole-y a) - (check-image 'pinhole-y a "first") - (let-values ([(x y) (send (coerce-to-cache-image-snip a) get-pinhole)]) - y)) - - (define (move-pinhole raw-i dx dy) - (check-image 'move-pinhole raw-i "first") - (check-coordinate 'move-pinhole dx "second") - (check-coordinate 'move-pinhole dy "third") - (let ([i (coerce-to-cache-image-snip raw-i)]) - (let-values ([(px py) (send i get-pinhole)] - [(w h) (send i get-size)]) +(define (check name p? v desc arg-posn) (check-arg name (p? v) desc arg-posn v)) + +(define (check-coordinate name val arg-posn) (check name finite-real? val "finite real number" arg-posn)) +(define (check-integer-coordinate name val arg-posn) (check name nii? val "integer" arg-posn)) +(define (check-size name val arg-posn) (check name pos-number? val "positive number" arg-posn)) +(define (check-posi-size name val arg-posn) (check name pos-integer? val "positive integer" arg-posn)) +(define (check-size/0 name val arg-posn) (check name nn-number? val "non-negative number" arg-posn)) +(define (check-image name val arg-posn) (check name image? val "image" arg-posn)) +(define (check-image-color name val arg-posn) + (let ([simple-check (λ (x) (or (string? x) (symbol? x) (color? x)))]) + (check name simple-check val "image-color" arg-posn) + (unless (image-color? val) + (error name "~e is not a valid color name" val)))) +(define (check-mode name val arg-posn) (check name mode? val mode-str arg-posn)) + +(define (pos-number? i) (and (number? i) (positive? i))) +(define (pos-integer? i) (and (number? i) (positive? i) (integer? i))) +(define (nn-number? i) (and (number? i) (or (zero? i) (positive? i)))) +(define (nii? x) (and (integer? x) (not (= x +inf.0)) (not (= x -inf.0)))) +(define (finite-real? x) (and (real? x) (not (= x +inf.0)) (not (= x -inf.0)))) + +(define (check-sizes who w h) + (unless (and (< 0 w 10000) (< 0 h 10000)) + (error (format "cannot make ~a x ~a image" w h)))) + +(define (mode? x) + (member x '(solid "solid" outline "outline"))) + +(define mode-str "'solid \"solid\" 'outline or \"outline\"") + +(define (mode->brush-symbol m) + (cond + [(member m '(solid "solid")) + 'solid] + [(member m '(outline "outline")) + 'transparent])) + +(define (mode->pen-symbol m) + (cond + [(member m '(solid "solid")) 'transparent] + [(member m '(outline "outline")) 'solid])) + +(define (make-color% c) + (cond + [(string? c) (send the-color-database find-color c)] + [(symbol? c) (send the-color-database find-color (symbol->string c))] + [(color? c) (make-object color% + (color-red c) + (color-green c) + (color-blue c))] + [else #f])) + +(define (image-color? c) + (cond + [(color? c) #t] + [(string? c) (and (send the-color-database find-color c) #t)] + [(symbol? c) (and (send the-color-database find-color (symbol->string c)) #t)] + [else #f])) + +(define (image-width a) + (check-image 'image-width a "first") + (let-values ([(w h) (snip-size a)]) + (inexact->exact (ceiling w)))) + +(define (image-height a) + (check-image 'image-height a "first") + (let-values ([(w h) (snip-size a)]) + (inexact->exact (ceiling h)))) + +(define (pinhole-x a) + (check-image 'pinhole-x a "first") + (let-values ([(x y) (send (coerce-to-cache-image-snip a) get-pinhole)]) + x)) + +(define (pinhole-y a) + (check-image 'pinhole-y a "first") + (let-values ([(x y) (send (coerce-to-cache-image-snip a) get-pinhole)]) + y)) + +(define (move-pinhole raw-i dx dy) + (check-image 'move-pinhole raw-i "first") + (check-coordinate 'move-pinhole dx "second") + (check-coordinate 'move-pinhole dy "third") + (let ([i (coerce-to-cache-image-snip raw-i)]) + (let-values ([(px py) (send i get-pinhole)] + [(w h) (send i get-size)]) + (new cache-image-snip% + (dc-proc (send i get-dc-proc)) + (argb-proc (send i get-argb-proc)) + (width w) + (height h) + (argb (send i get-argb/no-compute)) + (px (+ px dx)) + (py (+ py dy)))))) + +(define (put-pinhole raw-i px py) + (check-image 'put-pinhole raw-i "first") + (check-coordinate 'put-pinhole px "second") + (check-coordinate 'put-pinhole py "third") + (let ([i (coerce-to-cache-image-snip raw-i)]) + (let-values ([(w h) (send i get-size)]) + (new cache-image-snip% + (dc-proc (send i get-dc-proc)) + (argb-proc (send i get-argb-proc)) + (width w) + (height h) + (argb (send i get-argb/no-compute)) + (px (floor px)) + (py (floor py)))))) + +(define (overlay a b . cs) + (check-image 'overlay a "first") + (check-image 'overlay b "second") + (let loop ([cs cs] + [i 3]) + (unless (null? cs) + (check-image 'overlay (car cs) (number->ord i)))) + (let ([all-imgs (reverse (list* a b cs))]) + (let loop ([imgs (cdr all-imgs)] + [acc (car all-imgs)]) + (cond + [(null? imgs) acc] + [else (loop (cdr imgs) + (real-overlay/xy 'overlay (car imgs) 0 0 acc))])))) + +(define (overlay/xy a dx dy b) + (check-image 'overlay/xy a "first") + (check-coordinate 'overlay/xy dx "second") + (check-coordinate 'overlay/xy dy "third") + (check-image 'overlay/xy b "fourth") + (real-overlay/xy 'overlay/xy + a + (floor (if (exact? dx) dx (inexact->exact dx))) + (floor (if (exact? dy) dy (inexact->exact dy))) + b)) + +(define (real-overlay/xy name raw-a raw-delta-x raw-delta-y raw-b) + (let ([a (coerce-to-cache-image-snip raw-a)] + [b (coerce-to-cache-image-snip raw-b)]) + (let-values ([(a-w a-h) (snip-size a)] + [(b-w b-h) (snip-size b)] + [(a-px a-py) (send a get-pinhole)] + [(b-px b-py) (send b get-pinhole)]) + (let* ([delta-x (+ raw-delta-x a-px (- b-px))] + [delta-y (+ raw-delta-y a-py (- b-py))] + [left (min 0 delta-x)] + [top (min 0 delta-y)] + [right (max (+ delta-x b-w) a-w)] + [bottom (max (+ delta-y b-h) a-h)] + [new-w (inexact->exact (ceiling (- right left)))] + [new-h (inexact->exact (ceiling (- bottom top)))] + [a-dx (inexact->exact (round (- left)))] + [a-dy (inexact->exact (round (- top)))] + [b-dx (inexact->exact (round (- delta-x left)))] + [b-dy (inexact->exact (round (- delta-y top)))] + [new-px (- a-px left)] + [new-py (- a-py top)] + [combine (lambda (a-f b-f) + (lambda (dc dx dy) + (a-f dc (+ dx a-dx) (+ dy a-dy)) + (b-f dc (+ dx b-dx) (+ dy b-dy))))]) + (check-sizes name new-w new-h) (new cache-image-snip% - (dc-proc (send i get-dc-proc)) - (argb-proc (send i get-argb-proc)) - (width w) - (height h) - (argb (send i get-argb/no-compute)) - (px (+ px dx)) - (py (+ py dy)))))) - - (define (put-pinhole raw-i px py) - (check-image 'put-pinhole raw-i "first") - (check-coordinate 'put-pinhole px "second") - (check-coordinate 'put-pinhole py "third") - (let ([i (coerce-to-cache-image-snip raw-i)]) - (let-values ([(w h) (send i get-size)]) + [dc-proc (combine (send a get-dc-proc) + (send b get-dc-proc))] + [argb-proc (combine (send a get-argb-proc) + (send b get-argb-proc))] + [width new-w] + [height new-h] + [px new-px] + [py new-py]))))) +;; ------------------------------------------------------------ + +(define (shrink raw-img in-left in-up in-right in-down) + (check-image 'shrink raw-img "first") + (check-size/0 'shrink in-left "second") + (check-size/0 'shrink in-up "third") + (check-size/0 'shrink in-right "fourth") + (check-size/0 'shrink in-down "fifth") + (let ([left (inexact->exact (floor in-left))] + [up (inexact->exact (floor in-up))] + [right (inexact->exact (floor in-right))] + [down (inexact->exact (floor in-down))] + [img (coerce-to-cache-image-snip raw-img)]) + (let-values ([(i-px i-py) (send img get-pinhole)] + [(i-width i-height) (send img get-size)]) + (let* ([dc-proc (send img get-dc-proc)] + [argb-proc (send img get-argb-proc)] + [delta-w (- i-px left)] + [delta-h (- i-py up)] + [width (+ left right 1)] + [height (+ up down 1)]) (new cache-image-snip% - (dc-proc (send i get-dc-proc)) - (argb-proc (send i get-argb-proc)) - (width w) - (height h) - (argb (send i get-argb/no-compute)) - (px (floor px)) - (py (floor py)))))) - - (define (overlay a b . cs) - (check-image 'overlay a "first") - (check-image 'overlay b "second") - (let loop ([cs cs] - [i 3]) - (unless (null? cs) - (check-image 'overlay (car cs) (number->ord i)))) - (let ([all-imgs (reverse (list* a b cs))]) - (let loop ([imgs (cdr all-imgs)] - [acc (car all-imgs)]) - (cond - [(null? imgs) acc] - [else (loop (cdr imgs) - (real-overlay/xy 'overlay (car imgs) 0 0 acc))])))) + [px left] + [py up] + [dc-proc (lambda (dc dx dy) + (let ([clip (send dc get-clipping-region)] + [rgn (make-object region% dc)]) + (send rgn set-rectangle dx dy width height) + (when clip + (send rgn intersect clip)) + (send dc set-clipping-region rgn) + (dc-proc dc (- dx delta-w) (- dy delta-h)) + (send dc set-clipping-region clip)))] + [argb-proc (lambda (argb dx dy) (argb-proc argb (- dx delta-w) (- dy delta-h)))] + [width width] + [height height]))))) - (define (overlay/xy a dx dy b) - (check-image 'overlay/xy a "first") - (check-coordinate 'overlay/xy dx "second") - (check-coordinate 'overlay/xy dy "third") - (check-image 'overlay/xy b "fourth") - (real-overlay/xy 'overlay/xy - a - (floor (if (exact? dx) dx (inexact->exact dx))) - (floor (if (exact? dy) dy (inexact->exact dy))) - b)) +(define (shrink-tl raw-img in-x in-y) + (check-image 'shrink-tl raw-img "first") + (check-size 'shrink-tl in-x "second") + (check-size 'shrink-tl in-y "third") + (let ([x (inexact->exact (floor in-x))] + [y (inexact->exact (floor in-y))]) + (put-pinhole (shrink (put-pinhole raw-img 0 0) 0 0 (- x 1) (- y 1)) (/ x 2) (/ y 2)))) - (define (real-overlay/xy name raw-a raw-delta-x raw-delta-y raw-b) - (let ([a (coerce-to-cache-image-snip raw-a)] - [b (coerce-to-cache-image-snip raw-b)]) - (let-values ([(a-w a-h) (snip-size a)] - [(b-w b-h) (snip-size b)] - [(a-px a-py) (send a get-pinhole)] - [(b-px b-py) (send b get-pinhole)]) - (let* ([delta-x (+ raw-delta-x a-px (- b-px))] - [delta-y (+ raw-delta-y a-py (- b-py))] - [left (min 0 delta-x)] - [top (min 0 delta-y)] - [right (max (+ delta-x b-w) a-w)] - [bottom (max (+ delta-y b-h) a-h)] - [new-w (inexact->exact (ceiling (- right left)))] - [new-h (inexact->exact (ceiling (- bottom top)))] - [a-dx (inexact->exact (round (- left)))] - [a-dy (inexact->exact (round (- top)))] - [b-dx (inexact->exact (round (- delta-x left)))] - [b-dy (inexact->exact (round (- delta-y top)))] - [new-px (- a-px left)] - [new-py (- a-py top)] - [combine (lambda (a-f b-f) - (lambda (dc dx dy) - (a-f dc (+ dx a-dx) (+ dy a-dy)) - (b-f dc (+ dx b-dx) (+ dy b-dy))))]) - (check-sizes name new-w new-h) - (new cache-image-snip% - [dc-proc (combine (send a get-dc-proc) - (send b get-dc-proc))] - [argb-proc (combine (send a get-argb-proc) - (send b get-argb-proc))] - [width new-w] - [height new-h] - [px new-px] - [py new-py]))))) - ;; ------------------------------------------------------------ - - (define (shrink raw-img in-left in-up in-right in-down) - (check-image 'shrink raw-img "first") - (check-size/0 'shrink in-left "second") - (check-size/0 'shrink in-up "third") - (check-size/0 'shrink in-right "fourth") - (check-size/0 'shrink in-down "fifth") - (let ([left (inexact->exact (floor in-left))] - [up (inexact->exact (floor in-up))] - [right (inexact->exact (floor in-right))] - [down (inexact->exact (floor in-down))] - [img (coerce-to-cache-image-snip raw-img)]) - (let-values ([(i-px i-py) (send img get-pinhole)] - [(i-width i-height) (send img get-size)]) - (let* ([dc-proc (send img get-dc-proc)] - [argb-proc (send img get-argb-proc)] - [delta-w (- i-px left)] - [delta-h (- i-py up)] - [width (+ left right 1)] - [height (+ up down 1)]) - (new cache-image-snip% - [px left] - [py up] - [dc-proc (lambda (dc dx dy) - (let ([clip (send dc get-clipping-region)] - [rgn (make-object region% dc)]) - (send rgn set-rectangle dx dy width height) - (when clip - (send rgn intersect clip)) - (send dc set-clipping-region rgn) - (dc-proc dc (- dx delta-w) (- dy delta-h)) - (send dc set-clipping-region clip)))] - [argb-proc (lambda (argb dx dy) (argb-proc argb (- dx delta-w) (- dy delta-h)))] - [width width] - [height height]))))) - - (define (shrink-tl raw-img in-x in-y) - (check-image 'shrink-tl raw-img "first") - (check-size 'shrink-tl in-x "second") - (check-size 'shrink-tl in-y "third") - (let ([x (inexact->exact (floor in-x))] - [y (inexact->exact (floor in-y))]) - (put-pinhole (shrink (put-pinhole raw-img 0 0) 0 0 (- x 1) (- y 1)) (/ x 2) (/ y 2)))) - - (define (shrink-tr raw-img in-x in-y) - (check-image 'shrink-tr raw-img "first") - (check-size 'shrink-tr in-x "second") - (check-size 'shrink-tr in-y "third") - (let ([x (inexact->exact (floor in-x))] - [y (inexact->exact (floor in-y))]) - (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) 0) (- x 1) 0 0 (- y 1)) - (/ x 2) - (/ y 2)))) - - (define (shrink-bl raw-img in-x in-y) - (check-image 'shrink-bl raw-img "first") - (check-size 'shrink-bl in-x "second") - (check-size 'shrink-bl in-y "third") - (let ([x (inexact->exact (floor in-x))] - [y (inexact->exact (floor in-y))]) +(define (shrink-tr raw-img in-x in-y) + (check-image 'shrink-tr raw-img "first") + (check-size 'shrink-tr in-x "second") + (check-size 'shrink-tr in-y "third") + (let ([x (inexact->exact (floor in-x))] + [y (inexact->exact (floor in-y))]) + (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) 0) (- x 1) 0 0 (- y 1)) + (/ x 2) + (/ y 2)))) + +(define (shrink-bl raw-img in-x in-y) + (check-image 'shrink-bl raw-img "first") + (check-size 'shrink-bl in-x "second") + (check-size 'shrink-bl in-y "third") + (let ([x (inexact->exact (floor in-x))] + [y (inexact->exact (floor in-y))]) (put-pinhole (shrink (put-pinhole raw-img 0 (- (image-height raw-img) 1)) 0 (- y 1) (- x 1) 0) (/ x 2) (/ y 2)))) - - (define (shrink-br raw-img in-x in-y) - (check-image 'shrink-br raw-img "first") - (check-size 'shrink-br in-x "second") - (check-size 'shrink-br in-y "third") - (let ([x (inexact->exact (floor in-x))] - [y (inexact->exact (floor in-y))]) - (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) (- (image-height raw-img) 1)) - (- x 1) - (- y 1) - 0 - 0) - (/ x 2) - (/ y 2)))) + +(define (shrink-br raw-img in-x in-y) + (check-image 'shrink-br raw-img "first") + (check-size 'shrink-br in-x "second") + (check-size 'shrink-br in-y "third") + (let ([x (inexact->exact (floor in-x))] + [y (inexact->exact (floor in-y))]) + (put-pinhole (shrink (put-pinhole raw-img (- (image-width raw-img) 1) (- (image-height raw-img) 1)) + (- x 1) + (- y 1) + 0 + 0) + (/ x 2) + (/ y 2)))) - ;; ------------------------------------------------------------ +;; ------------------------------------------------------------ - (define (line in-x in-y color) - (check-coordinate 'line in-x "first") - (check-coordinate 'line in-y "second") - (check-image-color 'line color "third") - (let* ([x (floor (inexact->exact in-x))] - [y (floor (inexact->exact in-y))] - [w (+ (abs x) 1)] - [h (+ (abs y) 1)] - [px (abs (min x 0))] - [py (abs (min y 0))]) - (check-sizes 'line w h) - (let* ([do-draw - (λ (dc dx dy) - (send dc draw-line (+ px dx) (+ py dy) (+ dx px x) (+ dy py y)))] - [draw-proc (make-color-wrapper color 'transparent 'solid do-draw)] - [mask-proc (make-color-wrapper 'black 'transparent 'solid do-draw)]) - (make-simple-cache-image-snip w h px py draw-proc mask-proc)))) - - ;; test what happens when the line moves out of the box. - (define (add-line raw-i pre-x1 pre-y1 pre-x2 pre-y2 color-in) - (check-image 'add-line raw-i "first") - (check-coordinate 'add-line pre-x1 "second") - (check-coordinate 'add-line pre-y1 "third") - (check-coordinate 'add-line pre-x2 "fourth") - (check-coordinate 'add-line pre-y2 "fifth") - (check-image-color 'add-line color-in "sixth") - (let ([i (coerce-to-cache-image-snip raw-i)]) - (let-values ([(px py) (send i get-pinhole)] - [(iw ih) (send i get-size)] - [(x1 y1 x2 y2) - (if (<= pre-x1 pre-x2) - (values pre-x1 pre-y1 pre-x2 pre-y2) - (values pre-x2 pre-y2 pre-x1 pre-y1))]) - (let* ([line-w (abs (- x2 x1))] - [line-h (abs (- y2 y1))] - [build-snip - (λ (do-draw py-offset) - (let* ([draw-proc - (make-color-wrapper color-in 'transparent 'solid do-draw)] - [mask-proc - (make-color-wrapper 'black 'transparent 'solid do-draw)] - [line - (make-simple-cache-image-snip (+ line-w 1) (+ line-h 1) px py draw-proc mask-proc)]) - (real-overlay/xy 'add-line i (+ px x1) (+ py py-offset) line)))]) - (if (y1 . <= . y2) - (build-snip (λ (dc dx dy) - (send dc draw-line - dx - dy - (+ dx (- x2 x1)) - (+ dy (- y2 y1)))) - y1) - (build-snip (λ (dc dx dy) - (send dc draw-line - dx - (+ dy line-h) - (+ dx line-w) - dy)) - y2)))))) +(define (line in-x in-y color) + (check-coordinate 'line in-x "first") + (check-coordinate 'line in-y "second") + (check-image-color 'line color "third") + (let* ([x (floor (inexact->exact in-x))] + [y (floor (inexact->exact in-y))] + [w (+ (abs x) 1)] + [h (+ (abs y) 1)] + [px (abs (min x 0))] + [py (abs (min y 0))]) + (check-sizes 'line w h) + (let* ([do-draw + (λ (dc dx dy) + (send dc draw-line (+ px dx) (+ py dy) (+ dx px x) (+ dy py y)))] + [draw-proc (make-color-wrapper color 'transparent 'solid do-draw)] + [mask-proc (make-color-wrapper 'black 'transparent 'solid do-draw)]) + (make-simple-cache-image-snip w h px py draw-proc mask-proc)))) - (define (text str size color-in) - (check 'text (lambda (x) (and (string? x) (not (equal? "" x)))) str "non-empty string" "first") - (check 'text (lambda (x) (and (integer? x) (<= 1 x 255))) size "integer between 1 and 255" "second") - (check-image-color 'text color-in "third") - (let ([color (make-color% color-in)]) - (let-values ([(tw th) (get-text-size size str)]) - (let ([draw-proc - (lambda (txt-color mode dc dx dy) - (let ([old-mode (send dc get-text-mode)] - [old-fore (send dc get-text-foreground)] - [old-font (send dc get-font)]) - (send dc set-text-mode mode) - (send dc set-text-foreground txt-color) - (send dc set-font (get-font size)) - (send dc draw-text str dx dy) - (send dc set-text-mode old-mode) - (send dc set-text-foreground old-fore) - (send dc set-font old-font)))]) - (new cache-image-snip% - [dc-proc (lambda (dc dx dy) (draw-proc color 'transparent dc dx dy))] - [argb-proc - (lambda (argb dx dy) - (let ([bm-color - (build-bitmap - (lambda (dc) - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) - (send dc draw-rectangle 0 0 tw th)) - tw - th)] - [bm-mask - (build-bitmap - (lambda (dc) - (draw-proc - (send the-color-database find-color "black") - 'solid dc 0 0)) - tw - th)]) - (overlay-bitmap argb dx dy bm-color bm-mask)))] - [width tw] - [height th] - [px 0] - [py 0]))))) +;; test what happens when the line moves out of the box. +(define (add-line raw-i pre-x1 pre-y1 pre-x2 pre-y2 color-in) + (check-image 'add-line raw-i "first") + (check-coordinate 'add-line pre-x1 "second") + (check-coordinate 'add-line pre-y1 "third") + (check-coordinate 'add-line pre-x2 "fourth") + (check-coordinate 'add-line pre-y2 "fifth") + (check-image-color 'add-line color-in "sixth") + (let ([i (coerce-to-cache-image-snip raw-i)]) + (let-values ([(px py) (send i get-pinhole)] + [(iw ih) (send i get-size)] + [(x1 y1 x2 y2) + (if (<= pre-x1 pre-x2) + (values pre-x1 pre-y1 pre-x2 pre-y2) + (values pre-x2 pre-y2 pre-x1 pre-y1))]) + (let* ([line-w (abs (- x2 x1))] + [line-h (abs (- y2 y1))] + [build-snip + (λ (do-draw py-offset) + (let* ([draw-proc + (make-color-wrapper color-in 'transparent 'solid do-draw)] + [mask-proc + (make-color-wrapper 'black 'transparent 'solid do-draw)] + [line + (make-simple-cache-image-snip (+ line-w 1) (+ line-h 1) px py draw-proc mask-proc)]) + (real-overlay/xy 'add-line i (+ px x1) (+ py py-offset) line)))]) + (if (y1 . <= . y2) + (build-snip (λ (dc dx dy) + (send dc draw-line + dx + dy + (+ dx (- x2 x1)) + (+ dy (- y2 y1)))) + y1) + (build-snip (λ (dc dx dy) + (send dc draw-line + dx + (+ dy line-h) + (+ dx line-w) + dy)) + y2)))))) - (define cached-bdc-for-text-size (make-thread-cell #f)) - (define (get-text-size size string) - (unless (thread-cell-ref cached-bdc-for-text-size) - (let* ([bm (make-object bitmap% 1 1)] - [dc (make-object bitmap-dc% bm)]) - (thread-cell-set! cached-bdc-for-text-size dc))) - (let ([dc (thread-cell-ref cached-bdc-for-text-size)]) - (let-values ([(w h _1 _2) (send dc get-text-extent string (get-font size))]) - (values (inexact->exact (ceiling w)) - (inexact->exact (ceiling h)))))) - - (define (get-font size) - (send the-font-list find-or-create-font size - 'default 'normal 'normal #f - (case (system-type) - [(macosx) 'partly-smoothed] - [else 'smoothed]))) +(define (text str size color-in) + (check 'text (lambda (x) (and (string? x) (not (equal? "" x)))) str "non-empty string" "first") + (check 'text (lambda (x) (and (integer? x) (<= 1 x 255))) size "integer between 1 and 255" "second") + (check-image-color 'text color-in "third") + (let ([color (make-color% color-in)]) + (let-values ([(tw th) (get-text-size size str)]) + (let ([draw-proc + (lambda (txt-color mode dc dx dy) + (let ([old-mode (send dc get-text-mode)] + [old-fore (send dc get-text-foreground)] + [old-font (send dc get-font)]) + (send dc set-text-mode mode) + (send dc set-text-foreground txt-color) + (send dc set-font (get-font size)) + (send dc draw-text str dx dy) + (send dc set-text-mode old-mode) + (send dc set-text-foreground old-fore) + (send dc set-font old-font)))]) + (new cache-image-snip% + [dc-proc (lambda (dc dx dy) (draw-proc color 'transparent dc dx dy))] + [argb-proc + (lambda (argb dx dy) + (let ([bm-color + (build-bitmap + (lambda (dc) + (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send dc set-brush (send the-brush-list find-or-create-brush color 'solid)) + (send dc draw-rectangle 0 0 tw th)) + tw + th)] + [bm-mask + (build-bitmap + (lambda (dc) + (draw-proc + (send the-color-database find-color "black") + 'solid dc 0 0)) + tw + th)]) + (overlay-bitmap argb dx dy bm-color bm-mask)))] + [width tw] + [height th] + [px 0] + [py 0]))))) - (define (a-rect/circ who do-draw w h color brush pen) - (check-sizes who w h) - (let* ([dc-proc (make-color-wrapper color brush pen do-draw)] - [mask-proc (make-color-wrapper 'black brush pen do-draw)]) - (make-simple-cache-image-snip w h (floor (/ w 2)) (floor (/ h 2)) dc-proc mask-proc))) - - (define (rectangle in-w in-h mode color) - (check-size 'rectangle in-w "first") - (check-size 'rectangle in-h "second") - (check-mode 'rectangle mode "third") - (check-image-color 'rectangle color "fourth") - (let ([w (inexact->exact (floor in-w))] - [h (inexact->exact (floor in-h))]) - (a-rect/circ 'rectangle - (lambda (dc dx dy) (send dc draw-rectangle dx dy w h)) - w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) - - (define (ellipse in-w in-h mode color) - (check-size 'ellipse in-w "first") - (check-size 'ellipse in-h "second") - (check-mode 'ellipse mode "third") - (check-image-color 'ellipse color "fourth") - (let ([w (inexact->exact (floor in-w))] - [h (inexact->exact (floor in-h))]) - (a-rect/circ 'ellipse - (lambda (dc dx dy) (send dc draw-ellipse dx dy w h)) - w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) - - (define (circle in-r mode color) - (check-size 'circle in-r "first") - (check-mode 'circle mode "second") - (check-image-color 'circle color "third") - (let ([r (inexact->exact (floor in-r))]) - (a-rect/circ 'circle - (lambda (dc dx dy) (send dc draw-ellipse dx dy (* 2 r) (* 2 r))) - (* 2 r) (* 2 r) color (mode->brush-symbol mode) (mode->pen-symbol mode)))) - - (define (triangle in-size mode color) - (check 'triangle - (lambda (x) (and (real? x) (< 2 x 10000))) - in-size - "positive real number bigger than 2" - "first") - (check-mode 'triangle mode "second") - (check-image-color 'triangle color "third") - (let* ([size (floor (inexact->exact in-size))] - [right (- size 1)] - [bottom (inexact->exact (ceiling (* size (sin (* 2/3 pi)))))] - [points (list (make-object point% 0 bottom) - (make-object point% right bottom) - (make-object point% (/ size 2) 0))] - [draw (make-color-wrapper - color (mode->brush-symbol mode) 'solid - (lambda (dc dx dy) - (send dc draw-polygon points dx dy)))] - [mask-draw (make-color-wrapper - 'black (mode->brush-symbol mode) 'solid - (lambda (dc dx dy) - (send dc draw-polygon points dx dy)))] - [w size] - [h (+ bottom 1)]) - (make-simple-cache-image-snip w h (floor (/ w 2)) (floor (/ h 2)) draw mask-draw))) - - (define (star points in-inner-radius in-outer-radius mode color) - (check 'star - (lambda (x) (and (real? x) (< 3 x 10000))) - points - "positive real number bigger than or equal to 4" - "first") - (check-size 'star in-inner-radius "second") - (check-size 'star in-outer-radius "second") - (check-mode 'star mode "fourth") - (check-image-color 'star color "fifth") - (let* ([inner-radius (inexact->exact (floor in-inner-radius))] - [outer-radius (inexact->exact (floor in-outer-radius))] - [points (star-points inner-radius outer-radius points)] - [radial-offset - (if (<= inner-radius outer-radius) - 0 - (- inner-radius outer-radius))] - [draw - (make-color-wrapper - color (mode->brush-symbol mode) 'solid - (λ (dc dx dy) - (send dc draw-polygon points - (+ dx radial-offset) - (+ dy radial-offset))))] - [mask-draw - (make-color-wrapper - 'black (mode->brush-symbol mode) 'solid - (λ (dc dx dy) - (send dc draw-polygon points - (+ dx radial-offset) - (+ dy radial-offset))))] - [size-determining-radius (+ (max inner-radius outer-radius) 1)]) - (make-simple-cache-image-snip - (* size-determining-radius 2) - (* size-determining-radius 2) - size-determining-radius - size-determining-radius - draw - mask-draw))) - - (define (star-points small-rad large-rad points) - (let ([roff (floor (/ large-rad 2))]) - (let loop ([i points]) - (cond - [(zero? i) '()] - [else - (let* ([this-p (- i 1)] - [theta1 (* 2 pi (/ this-p points))] - [theta2 (* 2 pi (/ (- this-p 1/2) points))]) - (let-values ([(x1 y1) (find-xy small-rad theta1)] - [(x2 y2) (find-xy large-rad theta2)]) - (let ([p1 (make-object point% - (+ large-rad x1) - (+ large-rad y1))] - [p2 (make-object point% - (+ large-rad x2) - (+ large-rad y2))]) - (list* p1 p2 (loop (- i 1))))))])))) - - (define (find-xy radius theta) - (values (* radius (cos theta)) - (* radius (sin theta)))) - - (define (make-simple-cache-image-snip w h px py dc-proc mask-proc) - (let ([w (inexact->exact (ceiling w))] - [h (inexact->exact (ceiling h))]) - (let ([argb-proc - (lambda (argb-vector dx dy) - (let ([c-bm (build-bitmap (lambda (dc) (dc-proc dc 0 0)) w h)] - [m-bm (build-bitmap (lambda (dc) (mask-proc dc 0 0)) w h)]) - (overlay-bitmap argb-vector dx dy c-bm m-bm)))]) - (new cache-image-snip% - [dc-proc dc-proc] - [argb-proc argb-proc] - [width w] - [height h] - [px px] - [py py])))) - - (define (make-color-wrapper color-in brush pen rest) - (let ([color (make-color% color-in)]) - (lambda (dc dx dy) - (let ([old-brush (send dc get-brush)] - [old-pen (send dc get-pen)]) - (send dc set-brush (send the-brush-list find-or-create-brush color brush)) - (send dc set-pen (send the-pen-list find-or-create-pen color 1 pen)) - (rest dc dx dy) - (send dc set-pen old-pen) - (send dc set-brush old-brush))))) - - - ;; ------------------------------------------------------------ +(define cached-bdc-for-text-size (make-thread-cell #f)) +(define (get-text-size size string) + (unless (thread-cell-ref cached-bdc-for-text-size) + (let* ([bm (make-object bitmap% 1 1)] + [dc (make-object bitmap-dc% bm)]) + (thread-cell-set! cached-bdc-for-text-size dc))) + (let ([dc (thread-cell-ref cached-bdc-for-text-size)]) + (let-values ([(w h _1 _2) (send dc get-text-extent string (get-font size))]) + (values (inexact->exact (ceiling w)) + (inexact->exact (ceiling h)))))) - (define (image-inside? i a) - (and (locate-image 'image-inside? - (coerce-to-cache-image-snip i) - (coerce-to-cache-image-snip a)) - #t)) +(define (get-font size) + (send the-font-list find-or-create-font size + 'default 'normal 'normal #f + (case (system-type) + [(macosx) 'partly-smoothed] + [else 'smoothed]))) + +(define (a-rect/circ who do-draw w h color brush pen) + (check-sizes who w h) + (let* ([dc-proc (make-color-wrapper color brush pen do-draw)] + [mask-proc (make-color-wrapper 'black brush pen do-draw)]) + (make-simple-cache-image-snip w h (floor (/ w 2)) (floor (/ h 2)) dc-proc mask-proc))) + +(define (rectangle in-w in-h mode color) + (check-size 'rectangle in-w "first") + (check-size 'rectangle in-h "second") + (check-mode 'rectangle mode "third") + (check-image-color 'rectangle color "fourth") + (let ([w (inexact->exact (floor in-w))] + [h (inexact->exact (floor in-h))]) + (a-rect/circ 'rectangle + (lambda (dc dx dy) (send dc draw-rectangle dx dy w h)) + w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) + +(define (ellipse in-w in-h mode color) + (check-size 'ellipse in-w "first") + (check-size 'ellipse in-h "second") + (check-mode 'ellipse mode "third") + (check-image-color 'ellipse color "fourth") + (let ([w (inexact->exact (floor in-w))] + [h (inexact->exact (floor in-h))]) + (a-rect/circ 'ellipse + (lambda (dc dx dy) (send dc draw-ellipse dx dy w h)) + w h color (mode->brush-symbol mode) (mode->pen-symbol mode)))) + +(define (circle in-r mode color) + (check-size 'circle in-r "first") + (check-mode 'circle mode "second") + (check-image-color 'circle color "third") + (let ([r (inexact->exact (floor in-r))]) + (a-rect/circ 'circle + (lambda (dc dx dy) (send dc draw-ellipse dx dy (* 2 r) (* 2 r))) + (* 2 r) (* 2 r) color (mode->brush-symbol mode) (mode->pen-symbol mode)))) + +(define (triangle in-size mode color) + (check 'triangle + (lambda (x) (and (real? x) (< 2 x 10000))) + in-size + "positive real number bigger than 2" + "first") + (check-mode 'triangle mode "second") + (check-image-color 'triangle color "third") + (let* ([size (floor (inexact->exact in-size))] + [right (- size 1)] + [bottom (inexact->exact (ceiling (* size (sin (* 2/3 pi)))))] + [points (list (make-object point% 0 bottom) + (make-object point% right bottom) + (make-object point% (/ size 2) 0))] + [draw (make-color-wrapper + color (mode->brush-symbol mode) 'solid + (lambda (dc dx dy) + (send dc draw-polygon points dx dy)))] + [mask-draw (make-color-wrapper + 'black (mode->brush-symbol mode) 'solid + (lambda (dc dx dy) + (send dc draw-polygon points dx dy)))] + [w size] + [h (+ bottom 1)]) + (make-simple-cache-image-snip w h (floor (/ w 2)) (floor (/ h 2)) draw mask-draw))) + + +(define (regular-polygon sides in-radius mode color [angle 0]) + (check 'regular-polygon + (λ (x) (and (integer? x) (<= 4 sides 10000))) + sides + "positive integer bigger than or equal to 4" + "first") + (check-size 'star in-radius "second") + (check-mode 'regular-polygon mode "third") + (check-image-color 'regular-polygon color "fourth") + (check 'regular-polygon real? angle "real number" "fifth") + (let* ([radius (inexact->exact (floor in-radius))] + [points (regular-polygon-points radius sides angle)] + [draw + (make-color-wrapper + color (mode->brush-symbol mode) 'solid + (λ (dc dx dy) + (send dc draw-polygon points dx dy)))] + [mask-draw + (make-color-wrapper + 'black (mode->brush-symbol mode) 'solid + (λ (dc dx dy) + (send dc draw-polygon points dx dy)))]) + (make-simple-cache-image-snip + (* radius 2) + (* radius 2) + radius + radius + draw + mask-draw))) + +(define (regular-polygon-points in-radius points delta-angle) + (let ([radius (- in-radius 1)]) + (let loop ([n points]) + (cond + [(zero? n) null] + [else + (let ([angle (+ delta-angle (* 2 pi n (/ 1 points)))]) + (cons (make-object point% + (+ radius (* radius (cos angle))) + (+ radius (* radius (sin angle)))) + (loop (- n 1))))])))) - (define (find-image i a) - (or (locate-image 'find-image - (coerce-to-cache-image-snip i) - (coerce-to-cache-image-snip a)) - (error 'find-image - "the second image does not appear within the first image"))) - - (define (locate-image who i a) - (check-image who i "first") - (check-image who a "second") - (let-values ([(iw ih) (snip-size i)] - [(ipx ipy) (send i get-pinhole)] - [(aw ah) (snip-size a)] - [(apx apy) (send a get-pinhole)]) - (and (iw . >= . aw) - (ih . >= . ah) - (let ([i-argb-vector (argb-vector (send i get-argb))] - [a-argb-vector (argb-vector (send a get-argb))]) - (let ([al (let loop ([offset 0]) - (cond - [(= offset (* ah aw 4)) null] - [else (cons (subvector a-argb-vector offset (+ offset (* 4 aw))) - (loop (+ offset (* 4 aw))))]))]) - (let yloop ([dy 0]) - (and (dy . <= . (- ih ah)) - (let xloop ([dx 0]) - (if (dx . <= . (- iw aw)) - (if (let loop ([al al][dd 0]) - (or (null? al) - (and (first-in-second? - i-argb-vector - (car al) - (* 4 (+ (* (+ dy dd) iw) dx))) - (loop (cdr al) (add1 dd))))) - (make-posn (+ dx (- apx ipx)) (+ dy (- apy ipy))) - (xloop (add1 dx))) - (yloop (add1 dy))))))))))) - - (define (subvector orig i j) - (let ([v (make-vector (- j i) #f)]) - (let loop ([x i]) - (when (< x j) - (vector-set! v (- x i) (vector-ref orig x)) - (loop (+ x 1)))) - v)) +(define (star points in-inner-radius in-outer-radius mode color) + (check 'star + (lambda (x) (and (integer? x) (<= 3 x 10000))) + points + "positive integer bigger than or equal to 3" + "first") + (check-size 'star in-inner-radius "second") + (check-size 'star in-outer-radius "third") + (check-mode 'star mode "fourth") + (check-image-color 'star color "fifth") + (let* ([inner-radius (inexact->exact (floor in-inner-radius))] + [outer-radius (inexact->exact (floor in-outer-radius))] + [points (star-points inner-radius outer-radius points)] + [radial-offset + (if (<= inner-radius outer-radius) + 0 + (- inner-radius outer-radius))] + [draw + (make-color-wrapper + color (mode->brush-symbol mode) 'solid + (λ (dc dx dy) + (send dc draw-polygon points + (+ dx radial-offset) + (+ dy radial-offset))))] + [mask-draw + (make-color-wrapper + 'black (mode->brush-symbol mode) 'solid + (λ (dc dx dy) + (send dc draw-polygon points + (+ dx radial-offset) + (+ dy radial-offset))))] + + ;; we want the radius to be this max -- if it draws outside + ;; this radius, we should change the drawing. + [size-determining-radius (max inner-radius outer-radius)]) + (make-simple-cache-image-snip + (* size-determining-radius 2) + (* size-determining-radius 2) + size-determining-radius + size-determining-radius + draw + mask-draw))) + +(define (star-points in-small-rad in-large-rad points) + (let* ([small-rad (- in-small-rad 1)] + [large-rad (- in-large-rad 1)] + [roff (floor (/ large-rad 2))]) + (let loop ([i points]) + (cond + [(zero? i) '()] + [else + (let* ([this-p (- i 1)] + [theta1 (* 2 pi (/ this-p points))] + [theta2 (* 2 pi (/ (- this-p 1/2) points))]) + (let-values ([(x1 y1) (find-xy small-rad theta1)] + [(x2 y2) (find-xy large-rad theta2)]) + (let ([p1 (make-object point% + (+ large-rad x1) + (+ large-rad y1))] + [p2 (make-object point% + (+ large-rad x2) + (+ large-rad y2))]) + (list* p1 p2 (loop (- i 1))))))])))) + +(define (find-xy radius theta) + (values (* radius (cos theta)) + (* radius (sin theta)))) + +(define (make-simple-cache-image-snip w h px py dc-proc mask-proc) + (let ([w (inexact->exact (ceiling w))] + [h (inexact->exact (ceiling h))]) + (let ([argb-proc + (lambda (argb-vector dx dy) + (let ([c-bm (build-bitmap (lambda (dc) (dc-proc dc 0 0)) w h)] + [m-bm (build-bitmap (lambda (dc) (mask-proc dc 0 0)) w h)]) + (overlay-bitmap argb-vector dx dy c-bm m-bm)))]) + (new cache-image-snip% + [dc-proc dc-proc] + [argb-proc argb-proc] + [width w] + [height h] + [px px] + [py py])))) + +(define (make-color-wrapper color-in brush pen rest) + (let ([color (make-color% color-in)]) + (lambda (dc dx dy) + (let ([old-brush (send dc get-brush)] + [old-pen (send dc get-pen)]) + (send dc set-brush (send the-brush-list find-or-create-brush color brush)) + (send dc set-pen (send the-pen-list find-or-create-pen color 1 pen)) + (rest dc dx dy) + (send dc set-pen old-pen) + (send dc set-brush old-brush))))) + + +;; ------------------------------------------------------------ + +(define (image-inside? i a) + (and (locate-image 'image-inside? + (coerce-to-cache-image-snip i) + (coerce-to-cache-image-snip a)) + #t)) + +(define (find-image i a) + (or (locate-image 'find-image + (coerce-to-cache-image-snip i) + (coerce-to-cache-image-snip a)) + (error 'find-image + "the second image does not appear within the first image"))) + +(define (locate-image who i a) + (check-image who i "first") + (check-image who a "second") + (let-values ([(iw ih) (snip-size i)] + [(ipx ipy) (send i get-pinhole)] + [(aw ah) (snip-size a)] + [(apx apy) (send a get-pinhole)]) + (and (iw . >= . aw) + (ih . >= . ah) + (let ([i-argb-vector (argb-vector (send i get-argb))] + [a-argb-vector (argb-vector (send a get-argb))]) + (let ([al (let loop ([offset 0]) + (cond + [(= offset (* ah aw 4)) null] + [else (cons (subvector a-argb-vector offset (+ offset (* 4 aw))) + (loop (+ offset (* 4 aw))))]))]) + (let yloop ([dy 0]) + (and (dy . <= . (- ih ah)) + (let xloop ([dx 0]) + (if (dx . <= . (- iw aw)) + (if (let loop ([al al][dd 0]) + (or (null? al) + (and (first-in-second? + i-argb-vector + (car al) + (* 4 (+ (* (+ dy dd) iw) dx))) + (loop (cdr al) (add1 dd))))) + (make-posn (+ dx (- apx ipx)) (+ dy (- apy ipy))) + (xloop (add1 dx))) + (yloop (add1 dy))))))))))) + +(define (subvector orig i j) + (let ([v (make-vector (- j i) #f)]) + (let loop ([x i]) + (when (< x j) + (vector-set! v (- x i) (vector-ref orig x)) + (loop (+ x 1)))) + v)) #| (initial inequalities thanks to Matthew (thanks!!)) @@ -796,157 +845,157 @@ converting from the computer's coordinates, we get: (+ m2 b2 (* m2 b2 -1/255))) |# - - ;; in the above, m3 & b3 come from iv - ;; and m2 & b2 come from av - (define (first-in-second? iv av xd) - (let loop ([i (vector-length av)]) - (or (zero? i) - (let ([a (- i 4)] - [r (- i 3)] - [g (- i 2)] - [b (- i 1)]) - (let* ([m2 (vector-ref av a)] - [m3 (vector-ref iv (+ xd a))] - [test - (lambda (b2 b3) - (<= (+ b2 (* m2 b2 -1/255)) - (+ m3 b3 (* m3 b3 -1/255)) - (+ m2 b2 (* m2 b2 -1/255))))]) - (and (<= 0 m3 m2) - (test (vector-ref av r) (vector-ref iv (+ xd r))) - (test (vector-ref av g) (vector-ref iv (+ xd g))) - (test (vector-ref av b) (vector-ref iv (+ xd b))) - (loop (- i 4)))))))) - ;; ---------------------------------------- +;; in the above, m3 & b3 come from iv +;; and m2 & b2 come from av +(define (first-in-second? iv av xd) + (let loop ([i (vector-length av)]) + (or (zero? i) + (let ([a (- i 4)] + [r (- i 3)] + [g (- i 2)] + [b (- i 1)]) + (let* ([m2 (vector-ref av a)] + [m3 (vector-ref iv (+ xd a))] + [test + (lambda (b2 b3) + (<= (+ b2 (* m2 b2 -1/255)) + (+ m3 b3 (* m3 b3 -1/255)) + (+ m2 b2 (* m2 b2 -1/255))))]) + (and (<= 0 m3 m2) + (test (vector-ref av r) (vector-ref iv (+ xd r))) + (test (vector-ref av g) (vector-ref iv (+ xd g))) + (test (vector-ref av b) (vector-ref iv (+ xd b))) + (loop (- i 4)))))))) - (define (image->color-list i-raw) - (check-image 'image->color-list i-raw "first") - (let* ([cis (coerce-to-cache-image-snip i-raw)] - [i (send cis get-bitmap)] - [iw (send i get-width)] - [ih (send i get-height)] - [new-bitmap (make-object bitmap% iw ih)] - [bdc (make-object bitmap-dc% new-bitmap)]) - (send bdc clear) - (send bdc draw-bitmap i 0 0 'solid - (send the-color-database find-color "black") - (send i get-loaded-mask)) - (let ([is (make-bytes (* 4 iw ih))] - [cols (make-vector (* iw ih))]) - (send bdc get-argb-pixels 0 0 iw ih is) - (let yloop ([y 0][pos 0]) - (unless (= y ih) - (let xloop ([x 0][pos pos]) - (if (= x iw) - (yloop (add1 y) pos) - (begin - (vector-set! cols (+ x (* y iw)) - (make-color (bytes-ref is (+ 1 pos)) - (bytes-ref is (+ 2 pos)) - (bytes-ref is (+ 3 pos)))) - (xloop (add1 x) (+ pos 4))))))) - (send bdc set-bitmap #f) - (vector->list cols)))) - - (define (image->alpha-color-list i) - (check-image 'image->alpha-color-list i "first") - (let* ([argb (cond - [(is-a? i image-snip%) - (send (coerce-to-cache-image-snip i) get-argb)] - [(is-a? i cache-image-snip%) (send i get-argb)])] - [v (argb-vector argb)]) - (let loop ([i (vector-length v)] - [a null]) - (cond - [(zero? i) a] - [else (loop (- i 4) - (cons (make-alpha-color - (vector-ref v (- i 4)) - (vector-ref v (- i 3)) - (vector-ref v (- i 2)) - (vector-ref v (- i 1))) - a))])))) +;; ---------------------------------------- - (define (color-list->image cl in-w in-h px py) - (check 'color-list->image color-list? cl "list-of-colors" "first") - (check-posi-size 'color-list->image in-w "second") - (check-posi-size 'color-list->image in-h "third") - (check-coordinate 'color-list->image px "fourth") - (check-coordinate 'color-list->image py "fifth") - (let ([w (inexact->exact in-w)] - [h (inexact->exact in-h)]) - (unless (and (< 0 w 10000) (< 0 h 10000)) - (error 'color-list->image "cannot make ~a x ~a image" w h)) - (unless (= (* w h) (length cl)) - (error 'color-list->image - "given width times given height is ~a, but the given color list has ~a items" - (* w h) - (length cl))) - (let* ([bm (make-object bitmap% w h)] - [mask-bm (make-object bitmap% w h)] - [dc (make-object bitmap-dc% bm)] - [mask-dc (make-object bitmap-dc% mask-bm)]) - (unless (send bm ok?) - (error (format "cannot make ~a x ~a image" w h))) - (let ([is (make-bytes (* 4 w h) 0)] - [mask-is (make-bytes (* 4 w h) 0)] - [cols (list->vector (map (λ (x) - (or (make-color% x) - (error 'color-list->image "color ~e is unknown" x))) - cl))]) - (let yloop ([y 0][pos 0]) - (unless (= y h) - (let xloop ([x 0][pos pos]) - (if (= x w) - (yloop (add1 y) pos) - (let* ([col (vector-ref cols (+ x (* y w)))] - [r (pk (send col red))] - [g (pk (send col green))] - [b (pk (send col blue))]) - (bytes-set! is (+ 1 pos) r) - (bytes-set! is (+ 2 pos) g) - (bytes-set! is (+ 3 pos) b) - (when (= 255 r g b) - (bytes-set! mask-is (+ 1 pos) 255) - (bytes-set! mask-is (+ 2 pos) 255) - (bytes-set! mask-is (+ 3 pos) 255)) - (xloop (add1 x) (+ pos 4))))))) - (send dc set-argb-pixels 0 0 w h is) - (send mask-dc set-argb-pixels 0 0 w h mask-is)) - (send dc set-bitmap #f) - (send mask-dc set-bitmap #f) - (bitmaps->cache-image-snip bm mask-bm px py)))) - - (define (pk col) (min 255 (max 0 col))) - - (define (alpha-color-list->image cl in-w in-h px py) - (check 'alpha-color-list->image alpha-color-list? cl "list-of-alpha-colors" "first") - (check-posi-size 'alpha-color-list->image in-w "second") - (check-posi-size 'alpha-color-list->image in-h "third") - (check-coordinate 'alpha-color-list->image px "fourth") - (check-coordinate 'alpha-color-list->image py "fifth") - (let ([w (inexact->exact in-w)] - [h (inexact->exact in-h)]) - (unless (and (< 0 w 10000) (< 0 h 10000)) - (error 'alpha-color-list->image format "cannot make ~a x ~a image" w h)) - (unless (= (* w h) (length cl)) - (error 'alpha-color-list->image - "given width times given height is ~a, but the given color list has ~a items" - (* w h) (length cl))) - (let ([index-list (alpha-colors->ent-list cl)]) - (argb->cache-image-snip (make-argb (list->vector index-list) w) px py)))) - - ;; alpha-colors->ent-list : (listof alpha-color) -> (listof number) - (define (alpha-colors->ent-list cl) - (let loop ([cl cl]) +(define (image->color-list i-raw) + (check-image 'image->color-list i-raw "first") + (let* ([cis (coerce-to-cache-image-snip i-raw)] + [i (send cis get-bitmap)] + [iw (send i get-width)] + [ih (send i get-height)] + [new-bitmap (make-object bitmap% iw ih)] + [bdc (make-object bitmap-dc% new-bitmap)]) + (send bdc clear) + (send bdc draw-bitmap i 0 0 'solid + (send the-color-database find-color "black") + (send i get-loaded-mask)) + (let ([is (make-bytes (* 4 iw ih))] + [cols (make-vector (* iw ih))]) + (send bdc get-argb-pixels 0 0 iw ih is) + (let yloop ([y 0][pos 0]) + (unless (= y ih) + (let xloop ([x 0][pos pos]) + (if (= x iw) + (yloop (add1 y) pos) + (begin + (vector-set! cols (+ x (* y iw)) + (make-color (bytes-ref is (+ 1 pos)) + (bytes-ref is (+ 2 pos)) + (bytes-ref is (+ 3 pos)))) + (xloop (add1 x) (+ pos 4))))))) + (send bdc set-bitmap #f) + (vector->list cols)))) + +(define (image->alpha-color-list i) + (check-image 'image->alpha-color-list i "first") + (let* ([argb (cond + [(is-a? i image-snip%) + (send (coerce-to-cache-image-snip i) get-argb)] + [(is-a? i cache-image-snip%) (send i get-argb)])] + [v (argb-vector argb)]) + (let loop ([i (vector-length v)] + [a null]) (cond - [(null? cl) null] - [else - (let ([ac (car cl)]) - (list* (alpha-color-alpha ac) - (alpha-color-red ac) - (alpha-color-green ac) - (alpha-color-blue ac) - (loop (cdr cl))))])))) + [(zero? i) a] + [else (loop (- i 4) + (cons (make-alpha-color + (vector-ref v (- i 4)) + (vector-ref v (- i 3)) + (vector-ref v (- i 2)) + (vector-ref v (- i 1))) + a))])))) + +(define (color-list->image cl in-w in-h px py) + (check 'color-list->image color-list? cl "list-of-colors" "first") + (check-posi-size 'color-list->image in-w "second") + (check-posi-size 'color-list->image in-h "third") + (check-coordinate 'color-list->image px "fourth") + (check-coordinate 'color-list->image py "fifth") + (let ([w (inexact->exact in-w)] + [h (inexact->exact in-h)]) + (unless (and (< 0 w 10000) (< 0 h 10000)) + (error 'color-list->image "cannot make ~a x ~a image" w h)) + (unless (= (* w h) (length cl)) + (error 'color-list->image + "given width times given height is ~a, but the given color list has ~a items" + (* w h) + (length cl))) + (let* ([bm (make-object bitmap% w h)] + [mask-bm (make-object bitmap% w h)] + [dc (make-object bitmap-dc% bm)] + [mask-dc (make-object bitmap-dc% mask-bm)]) + (unless (send bm ok?) + (error (format "cannot make ~a x ~a image" w h))) + (let ([is (make-bytes (* 4 w h) 0)] + [mask-is (make-bytes (* 4 w h) 0)] + [cols (list->vector (map (λ (x) + (or (make-color% x) + (error 'color-list->image "color ~e is unknown" x))) + cl))]) + (let yloop ([y 0][pos 0]) + (unless (= y h) + (let xloop ([x 0][pos pos]) + (if (= x w) + (yloop (add1 y) pos) + (let* ([col (vector-ref cols (+ x (* y w)))] + [r (pk (send col red))] + [g (pk (send col green))] + [b (pk (send col blue))]) + (bytes-set! is (+ 1 pos) r) + (bytes-set! is (+ 2 pos) g) + (bytes-set! is (+ 3 pos) b) + (when (= 255 r g b) + (bytes-set! mask-is (+ 1 pos) 255) + (bytes-set! mask-is (+ 2 pos) 255) + (bytes-set! mask-is (+ 3 pos) 255)) + (xloop (add1 x) (+ pos 4))))))) + (send dc set-argb-pixels 0 0 w h is) + (send mask-dc set-argb-pixels 0 0 w h mask-is)) + (send dc set-bitmap #f) + (send mask-dc set-bitmap #f) + (bitmaps->cache-image-snip bm mask-bm px py)))) + +(define (pk col) (min 255 (max 0 col))) + +(define (alpha-color-list->image cl in-w in-h px py) + (check 'alpha-color-list->image alpha-color-list? cl "list-of-alpha-colors" "first") + (check-posi-size 'alpha-color-list->image in-w "second") + (check-posi-size 'alpha-color-list->image in-h "third") + (check-coordinate 'alpha-color-list->image px "fourth") + (check-coordinate 'alpha-color-list->image py "fifth") + (let ([w (inexact->exact in-w)] + [h (inexact->exact in-h)]) + (unless (and (< 0 w 10000) (< 0 h 10000)) + (error 'alpha-color-list->image format "cannot make ~a x ~a image" w h)) + (unless (= (* w h) (length cl)) + (error 'alpha-color-list->image + "given width times given height is ~a, but the given color list has ~a items" + (* w h) (length cl))) + (let ([index-list (alpha-colors->ent-list cl)]) + (argb->cache-image-snip (make-argb (list->vector index-list) w) px py)))) + +;; alpha-colors->ent-list : (listof alpha-color) -> (listof number) +(define (alpha-colors->ent-list cl) + (let loop ([cl cl]) + (cond + [(null? cl) null] + [else + (let ([ac (car cl)]) + (list* (alpha-color-alpha ac) + (alpha-color-red ac) + (alpha-color-green ac) + (alpha-color-blue ac) + (loop (cdr cl))))]))) diff --git a/collects/teachpack/htdp/image.ss b/collects/teachpack/htdp/image.ss index 03bd2a7da7..8decb4874a 100644 --- a/collects/teachpack/htdp/image.ss +++ b/collects/teachpack/htdp/image.ss @@ -25,6 +25,7 @@ triangle line star + regular-polygon add-line text diff --git a/collects/tests/mzscheme/htdp-image.ss b/collects/tests/mzscheme/htdp-image.ss index 16eca06fff..47c198558f 100644 --- a/collects/tests/mzscheme/htdp-image.ss +++ b/collects/tests/mzscheme/htdp-image.ss @@ -559,6 +559,20 @@ (length (filter (λ (x) (equal? (make-color 255 0 0) x)) (image->color-list (star 4 5 10 'solid 'red)))))) +;; make sure star is relatively white +(test #t + 'regular-polygon1 + (>= 100 + (length (filter (λ (x) (equal? (make-color 255 0 0) x)) + (image->color-list (regular-polygon 4 10 'outline 'red)))))) + +;; make solid star is relatively colored +(test #t + 'regular-polygon2 + (<= 100 + (length (filter (λ (x) (equal? (make-color 255 0 0) x)) + (image->color-list (regular-polygon 4 10 'solid 'red)))))) + (test #t 'add-line1 (image=? (overlay (p00 (rectangle 5 4 'solid 'black)) @@ -790,6 +804,7 @@ (check-on-bitmap 'solid-star (star 4 10 20 'solid 'red)) (check-on-bitmap 'solid-star/reverse-args (star 4 20 10 'solid 'red)) (check-on-bitmap 'outline-star (star 4 10 20 'outline 'red)) +(check-on-bitmap 'regular-polygon (regular-polygon 4 10 'outline 'red)) (check-on-bitmap 'line (line 10 7 'red)) ; (check-on-bitmap 'text (text "XX" 12 'red)) ;; this test fails for reasons I can't control ... -robby (check-on-bitmap 'overlay1 (overlay (p00 (rectangle 1 4 'solid 'blue))