diff --git a/collects/2htdp/image.ss b/collects/2htdp/image.ss index 60e3ecc8c9..022b1f160c 100644 --- a/collects/2htdp/image.ss +++ b/collects/2htdp/image.ss @@ -87,6 +87,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids right-triangle line add-line + add-curve text text/font bitmap diff --git a/collects/2htdp/private/image-more.ss b/collects/2htdp/private/image-more.ss index 239c018cce..c293956cf8 100644 --- a/collects/2htdp/private/image-more.ss +++ b/collects/2htdp/private/image-more.ss @@ -368,6 +368,16 @@ (rotate-point (line-segment-end simple-shape) θ) (line-segment-color simple-shape))] + [(curve-segment? simple-shape) + (make-curve-segment (rotate-point (curve-segment-start simple-shape) + θ) + (bring-between (+ (curve-segment-s-angle simple-shape) θ) 360) + (curve-segment-s-pull simple-shape) + (rotate-point (curve-segment-end simple-shape) + θ) + (bring-between (+ (curve-segment-e-angle simple-shape) θ) 360) + (curve-segment-e-pull simple-shape) + (curve-segment-color simple-shape))] [(polygon? simple-shape) (make-polygon (rotate-points θ (polygon-points simple-shape)) (polygon-mode simple-shape) @@ -427,6 +437,15 @@ (min y1 y2) (+ (max x1 x2) 1) (+ (max y1 y2) 1)))] + [(curve-segment? simple-shape) + (let ([x1 (point-x (curve-segment-start simple-shape))] + [y1 (point-y (curve-segment-start simple-shape))] + [x2 (point-x (curve-segment-end simple-shape))] + [y2 (point-y (curve-segment-end simple-shape))]) + (make-ltrb (min x1 x2) + (min y1 y2) + (+ (max x1 x2) 1) + (+ (max y1 y2) 1)))] [(polygon? simple-shape) (points->ltrb (polygon-points simple-shape))] [else @@ -686,6 +705,25 @@ (make-bb right bottom baseline) #f))) +(define/chk (add-curve image x1 y1 angle1 pull1 x2 y2 angle2 pull2 color) + (let* ([dx (abs (min 0 x1 x2))] + [dy (abs (min 0 y1 y2))] + [bottom (max (+ y1 dy) + (+ y2 dy) + (+ dy (get-bottom image)))] + [right (max (+ x1 dx) + (+ x2 dx) + (+ dx (get-right image)))] + [baseline (+ dy (get-baseline image))]) + (make-image (make-translate + dx dy + (make-overlay + (make-curve-segment (make-point x1 y1) angle1 pull1 + (make-point x2 y2) angle2 pull2 + color) + (image-shape image))) + (make-bb right bottom baseline) + #f))) ;; this is just so that 'text' objects can be sized. (define text-sizing-bm (make-object bitmap-dc% (make-object bitmap% 1 1))) @@ -906,6 +944,7 @@ line add-line + add-curve text text/font diff --git a/collects/2htdp/private/img-err.ss b/collects/2htdp/private/img-err.ss index 9da99c2df6..a7862d4710 100644 --- a/collects/2htdp/private/img-err.ss +++ b/collects/2htdp/private/img-err.ss @@ -120,7 +120,7 @@ 'non-negative-real-number i arg) arg] - [(dx dy x1 y1 x2 y2 factor x-factor y-factor) + [(dx dy x1 y1 x2 y2 factor x-factor y-factor pull1 pull2) (check-arg fn-name (real? arg) 'real\ number @@ -138,7 +138,7 @@ 'step-count i arg) arg] - [(angle) + [(angle angle1 angle2) (check-arg fn-name (angle? arg) 'angle\ in\ degrees diff --git a/collects/2htdp/tests/test-image.ss b/collects/2htdp/tests/test-image.ss index 3a61231002..8ea3236c13 100644 --- a/collects/2htdp/tests/test-image.ss +++ b/collects/2htdp/tests/test-image.ss @@ -920,6 +920,40 @@ (check-equal? (image-baseline (add-line txt 0 -10 100 100 'red)) (+ bl 10))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; curves +;; + +(test (add-curve (rectangle 100 20 'solid 'black) + 10 10 0 1/4 + 90 10 0 1/4 + 'white) + => + (add-line (rectangle 100 20 'solid 'black) + 10 10 + 90 10 + 'white)) + +(test (scale 2 + (add-curve + (rectangle 100 100 'solid 'black) + 20 20 0 1/3 80 80 0 1/3 'white)) + => + (add-curve + (rectangle 200 200 'solid 'black) + 40 40 0 1/3 160 160 0 1/3 'white)) + +(test (rotate + 90 + (add-curve + (rectangle 100 100 'solid 'black) + 20 20 0 1/3 80 80 0 1/3 'white)) + => + (add-curve + (rectangle 100 100 'solid 'black) + 20 80 90 1/3 80 20 90 1/3 'white)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; bitmap tests diff --git a/collects/mrlib/image-core.ss b/collects/mrlib/image-core.ss index 4ca2a2f140..615d8296f2 100644 --- a/collects/mrlib/image-core.ss +++ b/collects/mrlib/image-core.ss @@ -122,6 +122,7 @@ has been moved out). ;; an atomic-shape is either: ;; - polygon ;; - line-segment +;; - curve-segment ;; - np-atomic-shape ;; a np-atomic-shape is: @@ -159,6 +160,12 @@ has been moved out). (rec (line-segment-color a) (line-segment-color b)))) (λ (x y) 42) (λ (x y) 3))) + +;; a curve-segment is +;; +;; - (make-curve-segment point real real point real real color) +(define-struct/reg-mk curve-segment (start s-angle s-pull end e-angle e-pull color) #:transparent #:omit-define-syntaxes) + ;; a normalized-shape (subtype of shape) is either ;; - (make-overlay normalized-shape cropped-simple-shape) ;; - cropped-simple-shape @@ -171,6 +178,7 @@ has been moved out). ;; - (make-translate dx dy np-atomic-shape)) ;; - polygon ;; - line-segment +;; - curve-segment ;; an angle is a number between 0 and 360 (degrees) @@ -457,6 +465,22 @@ has been moved out). (if bottom (make-overlay bottom (f this-one)) (f this-one)))] + [(curve-segment? shape) + ;; the pull is multiplied by the distance + ;; between the two points when it is drawn, + ;; so we don't need to scale it here + (let ([this-one + (add-crops + (make-curve-segment (scale-point (curve-segment-start shape)) + (curve-segment-s-angle shape) + (curve-segment-s-pull shape) + (scale-point (curve-segment-end shape)) + (curve-segment-e-angle shape) + (curve-segment-e-pull shape) + (curve-segment-color shape)))]) + (if bottom + (make-overlay bottom (f this-one)) + (f this-one)))] [(np-atomic-shape? shape) (let ([this-one (add-crops @@ -471,11 +495,13 @@ has been moved out). (or (and (translate? shape) (np-atomic-shape? (translate-shape shape))) (polygon? shape) - (line-segment? shape))) + (line-segment? shape) + (curve-segment? shape))) (define (atomic-shape? shape) (or (polygon? shape) (line-segment? shape) + (curve-segment? shape) (np-atomic-shape? shape))) (define (np-atomic-shape? shape) @@ -576,14 +602,37 @@ has been moved out). (polygon-color simple-shape))) (send dc draw-path path dx dy 'winding))] [(line-segment? simple-shape) - (let ([path (new dc-path%)] - [start (line-segment-start simple-shape)] + (let ([start (line-segment-start simple-shape)] [end (line-segment-end simple-shape)]) (send dc set-pen (line-segment-color simple-shape) 1 'solid) (send dc set-brush "black" 'transparent) (send dc draw-line (+ dx (point-x start)) (+ dy (point-y start)) (+ dx (point-x end)) (+ dy (point-y end))))] + [(curve-segment? simple-shape) + (let* ([path (new dc-path%)] + [start (curve-segment-start simple-shape)] + [end (curve-segment-end simple-shape)] + [sx (point-x start)] + [sy (point-y start)] + [ex (point-x end)] + [ey (point-y end)] + [sa (degrees->radians (curve-segment-s-angle simple-shape))] + [ea (degrees->radians (curve-segment-e-angle simple-shape))] + [d (sqrt (+ (sqr (- ey sy)) (sqr (- ex sx))))] + [sp (* (curve-segment-s-pull simple-shape) d)] + [ep (* (curve-segment-e-pull simple-shape) d)]) + (send path move-to sx sy) + (send path curve-to + (+ sx (* sp (cos sa))) + (- sy (* sp (sin sa))) + (- ex (* ep (cos ea))) + (+ ey (* ep (sin ea))) + ex + ey) + (send dc set-pen (curve-segment-color simple-shape) 1 'solid) + (send dc set-brush "black" 'transparent) + (send dc draw-path path dx dy))] [else (let ([dx (+ dx (translate-dx simple-shape))] [dy (+ dy (translate-dy simple-shape))] @@ -797,6 +846,10 @@ the mask bitmap and the original bitmap are all together in a single bytes! text-angle text-size text-face text-family text-style text-weight text-underline make-polygon polygon? polygon-points polygon-mode polygon-color make-line-segment line-segment? line-segment-start line-segment-end line-segment-color + make-curve-segment curve-segment? + curve-segment-start curve-segment-s-angle curve-segment-s-pull + curve-segment-end curve-segment-e-angle curve-segment-e-pull + curve-segment-color make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale bitmap-rendered-bitmap bitmap-rendered-mask diff --git a/collects/teachpack/2htdp/scribblings/image-toc.ss b/collects/teachpack/2htdp/scribblings/image-toc.ss index 927740c886..c1204b96a1 100644 --- a/collects/teachpack/2htdp/scribblings/image-toc.ss +++ b/collects/teachpack/2htdp/scribblings/image-toc.ss @@ -9,7 +9,7 @@ (list '(image-height (rectangle 100 100 "solid" "black")) 'val 100) (list '(image-baseline (rectangle 100 100 "solid" "black")) 'val 100) (list '(image-height (text "Hello" 24 "black")) 'val 41) - (list '(image-baseline (text "Hello" 24 "black")) 'val 31.0) + (list '(image-baseline (text "Hello" 24 "black")) 'val 31) (list '(image-height (overlay (circle 20 "solid" "orange") (circle 30 "solid" "purple"))) @@ -382,6 +382,48 @@ "169f2ceb45c.png") (list '(text "Goodbye" 36 "indigo") 'image "169990a635e.png") (list '(text "Hello" 24 "olive") 'image "1bbeedc0d6.png") + (list + '(add-curve + (add-curve + (rectangle 40 100 'solid 'black) + 20 + 10 + 180 + 1/2 + 20 + 90 + 180 + 1/2 + 'white) + 20 + 10 + 0 + 1/2 + 20 + 90 + 0 + 1/2 + 'white) + 'image + "13121248a3c.png") + (list + '(add-curve (rectangle 100 100 'solid 'black) 20 20 0 1 80 80 0 1 'white) + 'image + "df251e846.png") + (list + '(add-curve + (rectangle 100 100 'solid 'black) + 20 + 20 + 0 + 1/3 + 80 + 80 + 0 + 1/3 + 'white) + 'image + "12472655f6c.png") (list '(add-line (ellipse 80 60 "outline" "darkolivegreen") diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index a75fc63668..cef95fc9d7 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -211,6 +211,42 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ "darkolivegreen")] } +@defproc[(add-curve [image image?] + [x1 real?] [y1 real?] [angle1 angle?] [pull1 real?] + [x2 real?] [y2 real?] [angle2 angle?] [pull2 real?] + [color image-color?]) + image?]{ + +Adds a curve to @scheme[image], starting at the point +(@scheme[x1],@scheme[y1]), and ending at the point +(@scheme[x2],@scheme[y2]). + +The @scheme[angle1] and @scheme[angle2] arguments specify the +angle that the curve has as it leaves the initial point and +as it reaches the final point, respectively. + +The @scheme[pull1] and @scheme[pull2] arguments control how +long the curve tries to stay with that angle. Larger numbers +mean that the curve stays with the angle longer. + +@image-examples[(add-curve (rectangle 100 100 'solid 'black) + 20 20 0 1/3 + 80 80 0 1/3 + 'white) + (add-curve (rectangle 100 100 'solid 'black) + 20 20 0 1 + 80 80 0 1 + 'white) + (add-curve + (add-curve + (rectangle 40 100 'solid 'black) + 20 10 180 1/2 + 20 90 180 1/2 + 'white) + 20 10 0 1/2 + 20 90 0 1/2 + 'white)] +} @defproc[(text [string string?] [font-size (and/c integer? (<=/c 1 255))] [color image-color?]) image?]{ diff --git a/collects/teachpack/2htdp/scribblings/img/12472655f6c.png b/collects/teachpack/2htdp/scribblings/img/12472655f6c.png new file mode 100644 index 0000000000..5ad6d4bcae Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/12472655f6c.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/13121248a3c.png b/collects/teachpack/2htdp/scribblings/img/13121248a3c.png new file mode 100644 index 0000000000..9087167af9 Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/13121248a3c.png differ diff --git a/collects/teachpack/2htdp/scribblings/img/df251e846.png b/collects/teachpack/2htdp/scribblings/img/df251e846.png new file mode 100644 index 0000000000..3f5fd97dc2 Binary files /dev/null and b/collects/teachpack/2htdp/scribblings/img/df251e846.png differ