From 8851f8f7276ca9ff048182f3826b857a3bee5917 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 12 Aug 2013 15:49:06 -0500 Subject: [PATCH] adjust 2htdp/image's add-curve and scene+curve so they accurately compute the bounding box using the new get-path-bounding-box method --- pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt | 58 +++++++++++-------- .../htdp-lib/2htdp/private/image-more.rkt | 41 +++++++------ pkgs/htdp-pkgs/htdp-lib/teachpack/HISTORY.txt | 9 +++ 3 files changed, 64 insertions(+), 44 deletions(-) diff --git a/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt b/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt index 3dcbaa13b1..b9ea22f010 100644 --- a/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt +++ b/pkgs/gui-pkgs/gui-lib/mrlib/image-core.rkt @@ -885,30 +885,35 @@ has been moved out). (send dc set-smoothing 'smoothed) (send dc draw-path path dx dy))] [(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 (mode-color->pen 'outline (curve-segment-color simple-shape))) - (send dc set-brush "black" 'transparent) - (send dc set-smoothing 'smoothed) - (send dc draw-path path dx dy))])) + (define path (curve-segment->path simple-shape)) + (send dc set-pen (mode-color->pen 'outline (curve-segment-color simple-shape))) + (send dc set-brush "black" 'transparent) + (send dc set-smoothing 'smoothed) + (send dc draw-path path dx dy)])) + +(define (curve-segment->path simple-shape) + (define start (curve-segment-start simple-shape)) + (define end (curve-segment-end simple-shape)) + (define sx (point-x start)) + (define sy (point-y start)) + (define ex (point-x end)) + (define ey (point-y end)) + (define sa (degrees->radians (curve-segment-s-angle simple-shape))) + (define ea (degrees->radians (curve-segment-e-angle simple-shape))) + + (define path (new dc-path%)) + (define d (sqrt (+ (sqr (- ey sy)) (sqr (- ex sx))))) + (define sp (* (curve-segment-s-pull simple-shape) d)) + (define 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) + path) (define (render-np-atomic-shape np-atomic-shape dc dx dy) (cond @@ -1350,7 +1355,10 @@ the mask bitmap and the original bitmap are all together in a single bytes! to-img bitmap->image image-snip->image - image-snip%) + image-snip% + + curve-segment->path + mode-color->pen) ;; method names (provide get-shape get-bb get-pinhole get-normalized? get-normalized-shape) 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 f1cd40fb4f..b0c1057e2a 100644 --- a/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt +++ b/pkgs/htdp-pkgs/htdp-lib/2htdp/private/image-more.rkt @@ -977,25 +977,28 @@ (send image get-pinhole)))) (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 - (send image get-pinhole)))) + (define cs (make-curve-segment (make-point x1 y1) angle1 pull1 + (make-point x2 y2) angle2 pull2 + color)) + (define path (curve-segment->path cs)) + (define rdc (new record-dc%)) + (send rdc set-pen (mode-color->pen 'outline color)) + (send rdc set-brush "black" 'transparent) + (send rdc set-smoothing 'smoothed) + (define-values (path-l path-t path-w path-h) (send rdc get-path-bounding-box path 'stroke)) + (define dx (abs (min 0 path-l))) + (define dy (abs (min 0 path-t))) + (define bottom (max (+ dy path-t path-h) (+ dy (get-bottom image)))) + (define right (max (+ dx path-l path-w) (+ dx (get-right image)))) + (define baseline (+ dy (get-baseline image))) + (make-image (make-translate + dx dy + (make-overlay + cs + (image-shape image))) + (make-bb right bottom baseline) + #f + (send image get-pinhole))) ;; this is just so that 'text' objects can be sized. (define text-sizing-bm (make-object bitmap-dc% (make-object bitmap% 1 1))) diff --git a/pkgs/htdp-pkgs/htdp-lib/teachpack/HISTORY.txt b/pkgs/htdp-pkgs/htdp-lib/teachpack/HISTORY.txt index 9517c645f0..fcefb90009 100644 --- a/pkgs/htdp-pkgs/htdp-lib/teachpack/HISTORY.txt +++ b/pkgs/htdp-pkgs/htdp-lib/teachpack/HISTORY.txt @@ -1,3 +1,12 @@ +------------------------------------------------------------------------ +Version 6.0 + +* 2htdp/image: changed scene+curve and add-curve to more accurately + compute the bounding box of the curve (previously the argument + points were used as the bounding box for the entire curve; now the + bounding box is calculated properly in the case that the curve goes + outside that rectangle) + ------------------------------------------------------------------------ Version 5.3.4 [Wed Apr 24 16:20:03 EDT 2013]