From 911123bf94d8ad20053a0825caf827910db6e397 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 7 Jan 2010 01:56:46 +0000 Subject: [PATCH] added add-curve svn: r17523 --- collects/2htdp/image.ss | 1 + collects/2htdp/private/image-more.ss | 39 ++++++++++++ collects/2htdp/private/img-err.ss | 4 +- collects/2htdp/tests/test-image.ss | 34 ++++++++++ collects/mrlib/image-core.ss | 59 +++++++++++++++++- .../teachpack/2htdp/scribblings/image-toc.ss | 44 ++++++++++++- .../teachpack/2htdp/scribblings/image.scrbl | 36 +++++++++++ .../2htdp/scribblings/img/12472655f6c.png | Bin 0 -> 1424 bytes .../2htdp/scribblings/img/13121248a3c.png | Bin 0 -> 2024 bytes .../2htdp/scribblings/img/df251e846.png | Bin 0 -> 1488 bytes 10 files changed, 211 insertions(+), 6 deletions(-) create mode 100644 collects/teachpack/2htdp/scribblings/img/12472655f6c.png create mode 100644 collects/teachpack/2htdp/scribblings/img/13121248a3c.png create mode 100644 collects/teachpack/2htdp/scribblings/img/df251e846.png 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 0000000000000000000000000000000000000000..5ad6d4bcaee10e6239f310fbaec40b5542ad6929 GIT binary patch literal 1424 zcmb7E`#;kQ82%26kjlyBG@q;`mD_d{Cp&DKJIgI?B+YaxIhus5nM-F|I7mwwQ4*5~ zX)?|XSwtlzj5EwF4z{@*l1tOhpU~&?yzl$V`@{3RpXYf~y**vFsqapkNJ`FrFkB%kU)dv&A3F2W5o5}bkFL%5^bhpw#U>@}x&;u-N7?Nz?+{3nVGWQFz_2I^85&>rnYvh@+G7vEXGKtWlLMb{3!OB z>er5X8|tydQ&pMNl8iZK53Np;X$mUiwi3|n-m^?^uA}czd?&>R??}8^Rv{_y1M@H1x-!O zSFNqpk@05F$fzTBcILa(GjHDP6AI_VOK7#Pl)rz!P>9Fj+OF!Vs#q1&8EYjwnCa$qPTE5eHZ~o{U~!j6HGo0V%J}QdsmaMN zD=WgjzPhdFlx34Efq{X(Pol%aC10eXe8vp}PoaZ#UPWOcF*NkwwhYMW$s0Q=g_+Jp zOkxfREw4*F7O`nhz(Nt;hf-by|&&N-nvhLk`6HmD{GSD?JIM@^R zg3ssschf*3IqPL`N_sj~zF||Tl(^;nw-y$hFtfZC$R!aaN$Q>iLQ{g`oKr%Lnw*s) z9*@W2aH6837W(Q?Iq~tE@}NTR=$IHM=f!a&P@)HKNWS{tR9TtHpi?C{fdD-04SR9w z5*Di|gW(Fh8+t}boEP-PW~Mn{lH#?+LZ6B+>4_yh*iB1qmIskiFYz6b_(XWW?3 z(T;3ivAr$0Df(9R50JLfdr-3?T1UR#!8d z&l+Lkr4osmnOXbqmV-|6t%Z%iLpIy#iC{>>H#%e zuCS-a$jE5KV)0kU^+gJQZkWF>jNw=V2gsZ9cxPv43I!>Hp`k;<)>ei)dqyI86*Qq* zysiYKwT>-QJlx$c>w!iXiuG@6F>!G`duVeI{Xk!bBYbF0S3 z&(@zNA@oVZ4XJFPiwbIPX=#y2!o9q!ezmfC76lT%Y{-|6mdZBe9cqhX>Y3UwwZ$j;ij#QR|Xdv#R; z5M1r=2xDT659eZ2Q&S~iMk*YbC)?WC*k}rl8fdY7JGzyiRD~|_oNziC3QDBT z<2yP!Iy*a21zr{`MT9Li1qdvHwN0?FYmt4Ojl12ov@L@ f+k$TI>e|%6?_nq8{Z_+Od|JTG$P)t^)S!_hl0%|!isB+I zgi>p$rNP!%Nlwg}Gc8RdvzRX@MK_n`+y8?Q{;Qqc=S+JZc)Y&toQwOn`)s?(@oA#!?v0;apN1;%Hf`WpAg1B6+mzS5L zqa&S8r_pF8lgVH(7>&l>-rm;M*4Eb6&d$!2m6i3esZ{Fu^XD@&Glz$VU%q@Plgaw~ z`;A7U(P*5Wo_2P2rqk(kI(_fny+J`ir%s&$fU8%p%H?v)IR2WtW5F@9F;o(tGP=KF_ zXN$$+=H_OJM1rXPjM>>)fj|%!7sugn$ktdu(jX#l^)++rz_SWMqV} z{q^ftH#awHU^_dzZQHi#^?Jg#PN(zs_O{0M_4V!U?p|72B5b#}w+93SSYrnU2DY`e z;Ut)~2L=Y%Y&L_zAZ;HwaNyOeS7hv!m6ev3mLo@wkb|jI>cN8t6$%9z8vvS`nvNbl zO3n@q4ejdcnx38}X}7erL_|c8`<2JX$6MS!;MtRtlbxNNk&%%^VJejx7Z+DoS4Z9k zfCmpABqb#gwRt>VM@PrR#DrD0TrLj}52w@VgzS`*lzaE?SxmEFn@pyLhK6Iuj-kWb zw{Q3L^?myEskJr$l$Dj8IdcZxK7IPMOeR}gTwDjctE+2%exA$aqQDdi<>bke6%`dI z$w+kx`qUE=5;PhO&i&*60;T6cp-=_~2Y2q=X)#l))$ZTFAH_xOc`Pg}NTt$?7cb(c zMMg$q7}nL*g)$}p+Pne4(a~{aWCZ`#qEINp!^06>0=*ui(O6Ygb?)3ba|wQae$LL$ zN~IEUKp<2DOQq7()KnUc_Q$i?+1W)!Md+guv-NttQmOpo66@*d>Eq*5UthmbHULN@ z5|K#sdx3f7$`y%3vb?;!f%eCbAGKPoP$*n`(8I$cEG(?Lx|+~Xglz!0apOi_Uf$ZN z=jP@X7Z?Bd@ngg7zP`TR-d;YRzxvYM-90KQ>h9gUM8_dx13*DRL2hpD>eO>`a&Fza zH9tT9m+YRNp25MvgoFe)H@E2MXqik#Vh}*@GyM|z`T5n=)oQi+&Ye3r71xH?I-O3h z*9(QhUAuOX8v(58?S1?9ZDC=7^rXq#E-o&?!NJ|#-LbK;q-~PdJS!`!q@+ZxR+pBR zHa0dQHWJstX0zFeiHRHzXLfdWe0-e8uJ zCr&673UmAZqN1Yg?CcG(ZEbBYUAk0UTx>3(zP{ea#|Ni-O5To*jU5;m=JR>9H_U+p!ndRl>$;rv)>IcF$o6Qah33>eZG0JclhN)DlpF2rw?X-GAfp&@h|0II92larIJ zwT~Y^UQ<&;2nK+fni_#XV6h>IXHzJY#Kgph4<8b>$H&LDT5WW6Gy zs0{#exja5Tp1d6s6GLtz1^|tXjWIDX_>W`p&hdD>XV0FIv&YBBKYjY-@9$5>W-^&B zE-vrizb9t{z>60z4jno~#`g2`d-LWEX&3-B8V!Co@?UB1-o2aXlJZMTOib9@+dDZq z5w=}jT}MYpt+4^%^XJbvolvv3v$He)lNOY~f3RuRo|~IHTG&MD4WMts~W5U9|<-&yvJv}||-n~mnNkO>)3cnEPL?ThE)hd-rr_*5=hGE#$)D)A+WU*LmHrvvOfk3dfC9w|n zYG4>vTU(3&)g=`F)&DDQ+MD)&!M0JUR4pwne;*DF4gDWrG5+**m$sDv0000?!v3MxMIqoF#s1XIqh%ry2yqVzJDO(9qD_ ztatu-nS` zI=;B9%y9mcr6oK5)MV$C_083p8&D+F)tI}v`Ep=ZS1oGJqj%~>1)v)QLj^r>2LJ%G z%}HztuO2z9ov&qJBS?0n&qdmd355hae(IAGQs=Xr(M#DMQ9sIHFw&eS`20-q`(xd9 z2|XSjFwL8W5Fda4yTkF?YN{XzVyf*uJWMWyXyS+_UW`C8xub^wRhu6C!>KKG>XS2s zbXFHf^7RhtByTKn?pqGVHh&-%b7F?5t-XA|wdr2<`<%+*cw_f$4e$cu4yXZd#QhcB zScbUV(As*CG;k12KHwSMSi(=tSrPWo-L48T-159O1GqO-4GFESt7A~iA1|RauB?6J z$RuM7tT|!X!NDN}03e|0cVw1aF7NDgZ9fNb`)IiUj*gB-Hy+}y4|(Ojo}@x)rKPv# z@aYR6Omh!Ay%DEP>JJc*=VhdFuKI4aZN;!N0-^P-kbT^{GZ>5~3*9|gS6iDH6Qf2# zsfqz*eOE3S1Vr$CPsyc&pC%^(k$%MErOeqsA65sHd$I(osjTztdo_Ga7;Q|9!#C$6eTxs$Jg7~&^Cr8J}6!U9KS+>OktjLZ_U!(~lIET@Z%W&iQ4aq#o zmBm6alb@)irG@Xx-skqQElrjfAD^|gY4^?yR2yEU&%CU|vVhL410?kE-x~0F)6-kcG9;mo;7I!V z`d3_)(eqLBA?MC5T!>R}5M4dU;99lVBEbmZn++Bqb$11;!Kz97&$- z4g&i@Q#WgHf_OPS-A;O2`dlhrUS`$Q1bq)1^5S*#k`fX)vlmMTV@2=;!aPbNAteRO zn7bETbHkXX`2@(w$iP&OOs5fc>b&1mp%;~H(B^B(;T9H>MJG7ZV*LWPL?YRPETPjK zOV12t(7O3lXj4~Lu4J^nsHn)Nz*r`e`KBU&ReuH03~Yf1MMYh?+oagoSOP)FWBQ?& zw#^n%8V68~_4SMWg=Sp3TN057*?Zl{$mk#yRWYp6;JNDOhlIUZ`bHH#1)*51a^vk4 z6*KE|+?kmfW9104FWWl>CLTL2ZUS-&X=5oeZkH_C=@u3i%H^R@sLaevmq!?8uspjf zpxix2zJ_v%3=a=io?iL3c>LEdGAp?Gk-Nm?WOORF`TpUKs!IO~p5981K AApigX literal 0 HcmV?d00001