added finer control over pens

svn: r17670

collects/2htdp/image.ss

@@ -103,19 +103,10 @@ and they all have good sample contracts. (It is amazing what we can do with kids
          image-color?
          (rename-out [build-color make-color])
          color-red color-blue color-green color? color
+         
+         (rename-out [build-pen make-pen])
+         pen-color pen-width pen-style pen-cap pen-join
+
          image-width
          image-height
          image-baseline)
-
-(define build-color
-  (let ([orig-make-color make-color])
-    (let ([make-color 
-           (λ (a b c)
-             (check-arg 'make-color (and (integer? a) (<= 0 a 255)) 
-                        'integer\ between\ 0\ and\ 255 1 a)
-             (check-arg 'make-color (and (integer? b) (<= 0 b 255)) 
-                        'integer\ between\ 0\ and\ 255 2 b)
-             (check-arg 'make-color (and (integer? c) (<= 0 c 255)) 
-                        'integer\ between\ 0\ and\ 255 3 c)
-             (make-color a b c))])
-      make-color)))

collects/2htdp/private/image-more.ss

@@ -59,12 +59,12 @@
 (define (save-image pre-image filename)
   (let* ([image (to-img pre-image)]
          [bm (make-object bitmap% 
-               (inexact->exact (ceiling (+ 1 (get-right image)))) 
-               (inexact->exact (ceiling (+ 1 (get-bottom image)))))]
+               (inexact->exact (ceiling (+ 2 (get-right image)))) 
+               (inexact->exact (ceiling (+ 2 (get-bottom image)))))]
          [bdc (make-object bitmap-dc% bm)])
     (send bdc set-smoothing 'aligned)
     (send bdc clear)
-    (render-image image bdc 0 0)
+    (render-image image bdc 1 1)
     (send bdc set-bitmap #f)
     (send bm save-file filename 'png)))
 
@@ -632,34 +632,23 @@
       [else
        (loop (- x upper-bound))])))
 
-;; stamp : I I -> I
-;; treats the first I as if it were a mask and uses that mask to
-;; mask out parts of the first I (the mask is solid; no alpha stuff
-;; here, even if dim were used).
-;; only accepts solid black Is
-
-;; see-thru : I number -> I
-;; applies an alpha value to the I, making it translucent
-
-
-;; -- as in the current I library, but they don't actually create
-;; bitmaps, but instead just records that are rendered right as they are
-;; about to be drawn
-
-;;       rectangle
 
 (define/chk (polygon posns mode color)
+  (check-mode/color-combination 'polygon 3 mode color)
   (make-a-polygon (map (λ (p) (make-point (posn-x p) (posn-y p))) posns)
                   mode
                   color))
 
 (define/chk (rectangle width height mode color)
+  (check-mode/color-combination 'rectangle 4 mode color)
   (make-a-polygon (rectangle-points width height) mode color))
 
 (define/chk (square side-length mode color)
+  (check-mode/color-combination 'square 3 mode color)
   (make-a-polygon (rectangle-points side-length side-length) mode color))
 
 (define/chk (rhombus side-length angle mode color)
+  (check-mode/color-combination 'rhombus 3 mode color)
   (let* ([left-corner (make-polar side-length (+ (* pi 1/2) (/ (degrees->radians angle) 2)))]
          [right-corner (make-polar side-length (- (* pi 1/2) (/ (degrees->radians angle) 2)))]
          [bottom-corner (+ left-corner right-corner)])
@@ -763,6 +752,7 @@
                   #f))))
 
 (define/chk (isosceles-triangle side-length angle mode color)
+  (check-mode/color-combination 'isosceles-triangle 4 mode color)
   (let ([left-corner (make-polar side-length (+ (* pi 1/2) (/ (degrees->radians angle) 2)))]
         [right-corner (make-polar side-length (- (* pi 1/2) (/ (degrees->radians angle) 2)))])
     (make-a-polygon (list (make-point 0 0)
@@ -772,6 +762,7 @@
                     color)))
 
 (define/chk (right-triangle side-length1 side-length2 mode color)
+  (check-mode/color-combination 'right-triangle 4 mode color)
   (make-a-polygon (list (make-point 0 (- side-length2))
                         (make-point 0 0)
                         (make-point side-length1 0))
@@ -779,12 +770,15 @@
                   color))
 
 (define/chk (triangle side-length mode color)
+  (check-mode/color-combination 'triangle 3 mode color)
   (make-polygon/star side-length 3 mode color values))
 
 (define/chk (regular-polygon side-length side-count mode color)
+  (check-mode/color-combination 'regular-polygon 4 mode color)
   (make-polygon/star side-length side-count mode color values))
 
 (define/chk (star-polygon side-length side-count step-count mode color)
+  (check-mode/color-combination 'star-polygon 5 mode color)
   (check-arg 'star-polygon
              (step-count . < . side-count)
              (format "number that is smaller than the side-count (~a)" side-count)
@@ -798,6 +792,7 @@
   (make-polygon/star side-length side-count mode color (λ (l) (swizzle l step-count))))
 
 (define/chk (star side-length mode color)
+  (check-mode/color-combination 'star 3 mode color)
   (make-polygon/star side-length 5 mode color (λ (l) (swizzle l 2))))
 
 (define (make-polygon/star side-length side-count mode color adjust)
@@ -844,6 +839,7 @@
                         (+ i 1)))])))
 
 (define/chk (ellipse width height mode color)
+  (check-mode/color-combination 'ellipse 4 mode color)
   (make-image (make-translate (/ width 2) (/ height 2)
                               (make-ellipse width height 
                                             0
@@ -853,6 +849,7 @@
               #f))
 
 (define/chk (circle radius mode color)
+  (check-mode/color-combination 'circle 3 mode color)
   (let ([w/h (* 2 radius)])
     (make-image (make-translate radius radius (make-ellipse w/h w/h 0 mode color))
                 (make-bb w/h w/h w/h)
@@ -904,6 +901,19 @@
                      (current-directory)))])])
        #`(make-object image-snip% (make-object bitmap% #,path 'unknown/mask)))]))
 
+
+(define build-color
+  (let ([orig-make-color make-color])
+    (define/chk (make-color int0-255-1 int0-255-2 int0-255-3) 
+      (orig-make-color int0-255-1 int0-255-2 int0-255-3))
+    make-color))
+
+(define build-pen
+  (let ([orig-make-pen make-pen])
+    (define/chk (make-pen color real-0-255 pen-style pen-cap pen-join)
+      (orig-make-pen color real-0-255 pen-style pen-cap pen-join))
+    make-pen))
+
 (provide overlay
          overlay/align
          overlay/xy
@@ -962,7 +972,10 @@
          
          swizzle
          
-         rotate-xy)
+         rotate-xy
+         
+         build-color
+         build-pen)
 
 (provide/contract
  [np-atomic-bb (-> np-atomic-shape? (values real? real? real? real?))]

collects/2htdp/private/img-err.ss

@@ -9,7 +9,8 @@
          side-count?
          image-color?
          image-snip->image
-         bitmap->image)
+         bitmap->image
+         check-mode/color-combination)
 
 (require htdp/error
          scheme/class
@@ -147,20 +148,25 @@
          (+ arg 360)
          arg)]
     [(color)
-     (check-arg fn-name (image-color? arg) 'color i arg)
-     ;; return either a string or a color object;
-     ;; since there may be saved files that have 
-     ;; strings in the color positions we leave them
-     ;; here too.
-     (if (color? arg)
-         arg
-         (let* ([color-str
-                 (if (symbol? arg)
-                     (symbol->string arg)
-                     arg)])
-           (if (send the-color-database find-color color-str)
-               color-str
-               "black")))]
+     (check-arg fn-name (or (image-color? arg) (pen? arg)) 'image-color-or-pen i arg)
+     ;; return either a string, color, or a pen,
+     ;; (technically, the string case is redundant,
+     ;;  but since there may be saved files that have 
+     ;;  strings in the color positions we leave them
+     ;;  here too; note that using a pen struct means
+     ;;  'smoothed mode, but a color (or string) means
+     ;;  'aligned mode, so that's not redundant).
+     (cond
+       [(color? arg) arg]
+       [(pen? arg) arg]
+       [else
+        (let* ([color-str
+                (if (symbol? arg)
+                    (symbol->string arg)
+                    arg)])
+          (if (send the-color-database find-color color-str)
+              color-str
+              "black"))])]
     [(string)
      (check-arg fn-name (string? arg) 'string i arg)
      arg]
@@ -192,6 +198,30 @@
                 'list-of-at-least-three-posns
                 i arg)
      arg]
+    [(int0-255-1 int0-255-2 int0-255-3)
+     (check-arg fn-name (and (integer? arg) (<= 0 arg 255)) 
+                'integer\ between\ 0\ and\ 255 i arg)
+     arg]
+    [(real-0-255)
+     (check-arg fn-name (and (integer? arg) (<= 0 arg 255)) 
+                'real\ number\ between\ 0\ and\ 255 i arg)
+     arg]
+    
+    [(pen-style)
+     (check-arg fn-name (pen-style? arg) 'pen-style i arg)
+     (if (string? arg)
+         (string->symbol arg)
+         arg)]
+    [(pen-cap)
+     (check-arg fn-name (pen-cap? arg) 'pen-cap i arg)
+     (if (string? arg)
+         (string->symbol arg)
+         arg)]
+    [(pen-join)
+     (check-arg fn-name (pen-join? arg) 'pen-join i arg)
+     (if (string? arg)
+         (string->symbol arg)
+         arg)]
     [else
      (error 'check "the function ~a has an argument with an unknown name: ~s"
             fn-name
@@ -213,6 +243,15 @@
   (and (integer? i)
        (1 . <= .  i)))
 (define (image-color? c) (or (symbol? c) (string? c) (color? c)))
+(define (pen-style? arg) 
+  (member (if (string? arg) (string->symbol arg) arg)
+          '(solid dot long-dash short-dash dot-dash)))
+(define (pen-cap? arg)
+  (member (if (string? arg) (string->symbol arg) arg)
+          '(round projecting butt)))
+(define (pen-join? arg)
+  (member (if (string? arg) (string->symbol arg) arg)
+          '(round bevel miter)))
 
 (define (to-img arg)
   (cond
@@ -233,3 +272,12 @@
                                 (make-bitmap bm mask-bm 0 1 1 #f #f))
                 (make-bb w h h)
                 #f)))
+
+
+;; checks the dependent part of the 'color' specification
+(define (check-mode/color-combination fn-name i mode color)
+  (cond
+    [(eq? mode 'solid)
+     (check-arg fn-name (image-color? color) 'image-color i color)]
+    [(eq? mode 'outline)
+     (void)]))

collects/2htdp/tests/test-image.ss

@@ -2,10 +2,8 @@
 #|
 ;; snippet of code for experimentation
 #lang scheme/gui
-(require 2htdp/private/image-more
-         mrlib/image-core
-         mrlib/private/image-core-bitmap
-         2htdp/private/img-err
+(require 2htdp/image
+         lang/posn
          (only-in lang/htdp-advanced equal~?))
 
 (define images
@@ -19,8 +17,25 @@
 (send f show #t)
 |#
 
-(require "../../mrlib/image-core.ss"
-         "../private/image-more.ss"
+(require "../image.ss"
+         (only-in "../../mrlib/image-core.ss" 
+                  image%
+                  make-image
+                  image-shape
+                  image-bb
+                  image-normalized?
+                  skip-image-equality-fast-path
+                  make-overlay
+                  make-translate
+                  make-bb
+                  normalize-shape
+                  make-ellipse
+                  make-polygon
+                  make-point
+                  make-crop )
+         (only-in "../private/image-more.ss" 
+                  bring-between
+                  swizzle)
          "../private/img-err.ss"
          "../../mrlib/private/image-core-bitmap.ss"
          lang/posn
@@ -41,6 +56,18 @@
            (parameterize ([skip-image-equality-fast-path #t])
              #,(quasisyntax/loc stx (check-equal? a b)))))]))
 
+(define-syntax (test/exn stx)
+  (syntax-case stx ()
+    [(test/exn a => b)
+     (with-syntax ([check-equal? (datum->syntax #'here 'check-equal? stx)])
+       #`(let ([reg b])
+           (unless (regexp? reg)
+             (error 'test/exn "expected a regular expression, got ~e" reg))
+           ;(printf "running line ~a\n" #,(syntax-line stx))
+           #,(quasisyntax/loc stx (check-regexp-match 
+                                   reg
+                                   (with-handlers ((exn:fail? exn-message)) a "NO EXN!")))))]))
+
 ;; test case: (beside (text "a"...) (text "b" ...)) vs (text "ab")
 
 ;(show-image (frame (rotate 30 (ellipse 200 400 'solid 'purple))))
@@ -195,6 +222,34 @@
       =>
       (rectangle 10 10 "solid" "plum"))
 
+(test (polygon (list (make-posn 0 0)
+                     (make-posn 0 10)
+                     (make-posn 10 10)
+                     (make-posn 10 0))
+               "solid" "plum")
+      =>
+      (polygon (list (make-posn 0 0)
+                     (make-posn 0 10)
+                     (make-posn 10 10)
+                     (make-posn 10 0)
+                     (make-posn 0 0))
+               "solid" "plum"))
+
+(test (polygon (list (make-posn 0 0)
+                     (make-posn 0 10)
+                     (make-posn 10 10)
+                     (make-posn 10 0))
+               "outline"
+               (make-pen "plum" 8 "solid" "round" "round"))
+      =>
+      (polygon (list (make-posn 0 0)
+                     (make-posn 0 10)
+                     (make-posn 10 10)
+                     (make-posn 10 0)
+                     (make-posn 0 0))
+               "outline"
+               (make-pen "plum" 8 "solid" "round" "round")))
+
 ;; make sure equality isn't equating everything
 (test (equal? (rectangle 10 10 'solid 'blue)
               (rectangle 10 10 'solid 'red))
@@ -233,47 +288,6 @@
       =>
       #t)
 
-
-(let ([size 10])
-  (test (add-line
-         (add-line
-          (add-line
-           (add-line
-            (rectangle size size 'solid 'white)
-            0 0 0 size 'black)
-           0 size size size 'black)
-          size size size 0 'black)
-         size 0 0 0 'black)
-        =>
-        (overlay (rectangle size size 'outline 'black)
-                 (rectangle size size 'solid 'white)))
-  
-  (test (add-line
-         (add-line
-          (add-line
-           (add-line
-            (rectangle size size 'solid 'white)
-            0 0 size 0 'black)
-           size 0 size size 'black)
-          size size 0 size 'black)
-         0 size 0 0 'black)
-        =>
-        (overlay (rectangle size size 'outline 'black)
-                 (rectangle size size 'solid 'white)))
-  
-  (test (add-line
-         (add-line
-          (add-line
-           (add-line
-            (rectangle size size 'solid 'white)
-            0 0 size 0 'black)
-           0 0 0 size 'black)
-          0 size size size 'black)
-         size 0 size size 'black)
-        =>
-        (overlay (rectangle size size 'outline 'black)
-                 (rectangle size size 'solid 'white))))
-
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  testing overlays
@@ -1304,3 +1318,143 @@
       (underlay/xy (rectangle 40 40 'solid 'orange)
                    2 7
                    (circle 4 'solid 'black)))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; pen arguments
+;;
+
+;; just make sure no errors.
+(test (image? (polygon (list (make-posn 0 0)
+                             (make-posn 100 100)
+                             (make-posn 100 0)
+                             (make-posn 0 100))
+                       "outline"
+                       (make-pen "darkslategray" 6 "solid" "round" "round")))
+      =>
+      #t)
+
+(test (image? (line 10 
+                    10 
+                    (make-pen "darkslategray" 6 "solid" "round" "round")))
+      =>
+      #t)
+
+(test (scale 2
+             (polygon (list (make-posn 0 0)
+                            (make-posn 100 0)
+                            (make-posn 100 100))
+                      "outline"
+                      (make-pen "black" 6 "solid" "round" "round")))
+      =>
+      (polygon (list (make-posn 0 0)
+                     (make-posn 200 0)
+                     (make-posn 200 200))
+               "outline"
+               (make-pen "black" 12 "solid" "round" "round")))
+
+(test (scale 2
+             (ellipse 30 40 "outline"
+                      (make-pen "black" 2 "solid" "round" "round")))
+      =>
+      (ellipse 60 80 "outline"
+               (make-pen "black" 4 "solid" "round" "round")))
+
+(test (scale 2
+             (polygon (list (make-posn 0 0)
+                            (make-posn 100 0)
+                            (make-posn 100 100))
+                      "outline"
+                      (make-pen "black" 0 "solid" "round" "round")))
+      =>
+      (polygon (list (make-posn 0 0)
+                     (make-posn 200 0)
+                     (make-posn 200 200))
+               "outline"
+               (make-pen "black" 0 "solid" "round" "round")))
+
+(test (scale 2
+             (add-line
+              (rectangle 100 100 'solid 'black)
+              20 20 80 80
+              (make-pen "black" 6 "solid" "round" "round")))
+      =>
+      (add-line
+       (rectangle 200 200 'solid 'black)
+       40 40 160 160
+       (make-pen "black" 12 "solid" "round" "round")))
+
+(test (scale 2
+             (add-curve
+              (rectangle 100 100 'solid 'black)
+              20 20 0 1/2
+              80 80 0 1/2
+              (make-pen "black" 6 "solid" "round" "round")))
+      =>
+      (add-curve
+       (rectangle 200 200 'solid 'black)
+       40 40 0 1/2
+       160 160 0 1/2
+       (make-pen "black" 12 "solid" "round" "round")))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  test that the extra mode check is there
+;;
+
+(test/exn (rectangle 10 10 "solid" (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^rectangle: expected <image-color>")
+
+(test/exn (rectangle 10 10 'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^rectangle: expected <image-color>")
+
+(test/exn (circle 10 'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^circle: expected <image-color>")
+
+(test/exn (ellipse 10 10 'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^ellipse: expected <image-color>")
+
+(test/exn (triangle 10 'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^triangle: expected <image-color>")
+
+(test/exn (right-triangle 10 12 'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^right-triangle: expected <image-color>")
+
+(test/exn (isosceles-triangle 10 120 'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^isosceles-triangle: expected <image-color>")
+
+(test/exn (square 10 'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^square: expected <image-color>")
+
+(test/exn (rhombus 40 45 'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^rhombus: expected <image-color>")
+
+(test/exn (regular-polygon 40 6 'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^regular-polygon: expected <image-color>")
+
+(test/exn (star 40 'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^star: expected <image-color>")
+
+(test/exn (star-polygon 40 7 3 'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^star-polygon: expected <image-color>")
+
+(test/exn (polygon (list (make-posn 0 0) (make-posn 100 0) (make-posn 100 100))
+                   'solid (make-pen "black" 12 "solid" "round" "round"))
+          =>
+          #rx"^polygon: expected <image-color>")
+
+

collects/mrlib/image-core.ss

@@ -174,6 +174,18 @@ has been moved out).
 
 ;; a mode is either 'solid or 'outline (indicating a pen width for outline mode)
 
+;; a pen is
+;;  - (make-pen color?  ;; <- the struct, not a string
+;;              (<=/c 0 255)
+;;              (or/c 'solid 'dot 'long-dash 'short-dash 'dot-dash)
+;;              (or/c 'round 'projecting 'butt)
+;;              (or/c 'round 'bevel 'miter))
+(define-struct/reg-mk pen (color width style cap join) #:transparent)
+
+;; an color is
+;;  - (make-color (<=/c 0 255) (<=/c 0 255) (<=/c 0 255))
+;;  - string
+(define-struct/reg-mk color (red green blue) #:transparent)
 
 ;                                                   
 ;                                                   
@@ -409,7 +421,7 @@ has been moved out).
                (add-crops 
                 (make-polygon (map scale-point (polygon-points shape))
                               (polygon-mode shape)
-                              (polygon-color shape)))])
+                              (scale-color (polygon-color shape) x-scale y-scale)))])
          (if bottom
              (make-overlay bottom (f this-one))
              (f this-one)))]
@@ -418,7 +430,7 @@ has been moved out).
               (add-crops
                (make-line-segment (scale-point (line-segment-start shape))
                                   (scale-point (line-segment-end shape))
-                                  (line-segment-color shape)))])
+                                  (scale-color (line-segment-color shape) x-scale y-scale)))])
          (if bottom
              (make-overlay bottom (f this-one))
              (f this-one)))]
@@ -434,7 +446,7 @@ has been moved out).
                                    (scale-point (curve-segment-end shape))
                                    (curve-segment-e-angle shape)
                                    (curve-segment-e-pull shape)
-                                   (curve-segment-color shape)))])
+                                   (scale-color (curve-segment-color shape) x-scale y-scale)))])
          (if bottom
              (make-overlay bottom (f this-one))
              (f this-one)))]
@@ -474,7 +486,7 @@ has been moved out).
                    (* y-scale (ellipse-height shape))
                    (ellipse-angle shape)
                    (ellipse-mode shape)
-                   (ellipse-color shape))]
+                   (scale-color (ellipse-color shape) x-scale y-scale))]
     [(text? shape)
      ;; should probably do something different here so that
      ;; the y-scale is always greater than 1
@@ -497,6 +509,15 @@ has been moved out).
                   (* y-scale (bitmap-y-scale shape))
                   #f #f)]))
 
+(define (scale-color color x-scale y-scale)
+  (cond
+    [(pen? color)
+     (make-pen (pen-color color)
+               (* (pen-width color) (/ (+ x-scale y-scale) 2))
+               (pen-style color)
+               (pen-cap color)
+               (pen-join color))]
+    [else color]))
 
 ;                                                                
 ;                                                                
@@ -556,29 +577,13 @@ has been moved out).
 (define (render-simple-shape simple-shape dc dx dy)
   (cond
     [(polygon? simple-shape)
-     (send dc set-pen (mode-color->pen (polygon-mode simple-shape)
-                                       (polygon-color simple-shape)))
-     (send dc set-brush (mode-color->brush (polygon-mode simple-shape)
-                                           (polygon-color simple-shape)))
-     (send dc set-smoothing (mode->smoothing (polygon-mode simple-shape)))
-     (cond
-       [(eq? (polygon-mode simple-shape) 'outline)
-        (let ([connect
-               (λ (p1 p2)
-                 (let ([path (new dc-path%)])
-                   (send path move-to (point-x p1) (point-y p1))
-                   (send path line-to (point-x p2) (point-y p2))
-                   (send dc draw-path path dx dy)))])
-          (let loop ([points (polygon-points simple-shape)])
-            (cond
-              [(null? (cdr points))
-               (connect (car points) (car (polygon-points simple-shape)))]
-              [else
-               (connect (car points) (cadr points))
-               (loop (cdr points))])))]
-       [else
-        (let ([path (polygon-points->path (polygon-points simple-shape))])
-          (send dc draw-path path dx dy 'winding))])]
+     (let ([mode (polygon-mode simple-shape)]
+           [color (polygon-color simple-shape)]
+           [path (polygon-points->path (polygon-points simple-shape))])
+       (send dc set-pen (mode-color->pen mode color))
+       (send dc set-brush (mode-color->brush mode color))
+       (send dc set-smoothing (mode-color->smoothing mode color))
+       (send dc draw-path path dx dy 'winding))]
     [(line-segment? simple-shape)
      (let* ([start (line-segment-start simple-shape)]
             [end (line-segment-end simple-shape)]
@@ -589,9 +594,9 @@ has been moved out).
             [ey (point-y end)])
        (send path move-to sx sy)
        (send path line-to ex ey)
-       (send dc set-pen (line-segment-color simple-shape) 1 'solid)
+       (send dc set-pen (mode-color->pen 'outline (line-segment-color simple-shape)))
        (send dc set-brush "black" 'transparent)
-       (send dc set-smoothing 'aligned)
+       (send dc set-smoothing 'smoothed)
        (send dc draw-path path dx dy))]
     [(curve-segment? simple-shape)
      (let* ([path (new dc-path%)]
@@ -614,9 +619,9 @@ has been moved out).
              (+ ey (* ep (sin ea)))
              ex
              ey)
-       (send dc set-pen (curve-segment-color simple-shape) 1 'solid)
+       (send dc set-pen (mode-color->pen 'outline (curve-segment-color simple-shape)))
        (send dc set-brush "black" 'transparent)
-       (send dc set-smoothing 'aligned)
+       (send dc set-smoothing 'smoothed)
        (send dc draw-path path dx dy))]
     [else
      (let ([dx (+ dx (translate-dx simple-shape))]
@@ -627,14 +632,16 @@ has been moved out).
           (let* ([path (new dc-path%)]
                  [ew (ellipse-width atomic-shape)]
                  [eh (ellipse-height atomic-shape)]
-                 [θ (degrees->radians (ellipse-angle atomic-shape))])
+                 [θ (degrees->radians (ellipse-angle atomic-shape))]
+                 [color (ellipse-color atomic-shape)]
+                 [mode (ellipse-mode atomic-shape)])
             (let-values ([(rotated-width rotated-height) (ellipse-rotated-size ew eh θ)])
               (send path ellipse 0 0 ew eh)
               (send path translate (- (/ ew 2)) (- (/ eh 2)))
               (send path rotate θ)
-              (send dc set-pen (mode-color->pen (ellipse-mode atomic-shape) (ellipse-color atomic-shape)))
-              (send dc set-brush (mode-color->brush (ellipse-mode atomic-shape) (ellipse-color atomic-shape)))
-              (send dc set-smoothing (mode->smoothing (ellipse-mode atomic-shape)))
+              (send dc set-pen (mode-color->pen mode color))
+              (send dc set-brush (mode-color->brush mode color))
+              (send dc set-smoothing (mode-color->smoothing mode color))
               (send dc draw-path path dx dy)))]
          [(bitmap? atomic-shape)
           (let ([bm (get-rendered-bitmap atomic-shape)]) 
@@ -669,7 +676,8 @@ has been moved out).
               (round (point-x (car points)))
               (round (point-y (car points))))
         (loop (cdr points))))
-    (send path line-to (round (point-x (car points))) (round (point-y (car points))))
+    (send path close)
+    ;(send path line-to (round (point-x (car points))) (round (point-y (car points))))
     path))
 
 (define (points->bb-path points)
@@ -819,24 +827,30 @@ the mask bitmap and the original bitmap are all together in a single bytes!
 (define (degrees->radians θ)
   (* θ 2 pi (/ 360)))
 
-(define (mode->smoothing mode)
-  (case mode
-    [(outline) 'aligned]
-    [(solid) 'smoothed]))
+(define (mode-color->smoothing mode color)
+  (cond
+    [(and (eq? mode 'outline)
+          (not (pen? color)))
+     'aligned]
+    [else 'smoothed]))
 
 (define (mode-color->pen mode color)
   (case mode
     [(outline) 
-     (send the-pen-list find-or-create-pen (get-color-arg color) 1 'solid)]
+     (cond
+       [(pen? color)
+        (pen->pen-obj/cache color)]
+       [else
+        (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid)])]
     [(solid)
      (send the-pen-list find-or-create-pen "black" 1 'transparent)]))
 
 (define (mode-color->brush mode color)
-  (send the-brush-list find-or-create-brush 
-        (get-color-arg color) 
-        (case mode
-          [(outline) 'transparent]
-          [(solid) 'solid])))
+  (case mode
+    [(outline)
+     (send the-brush-list find-or-create-brush "black" 'transparent)]
+    [(solid)
+     (send the-brush-list find-or-create-brush (get-color-arg color) 'solid)]))
 
 (define (get-color-arg color)
   (if (string? color) 
@@ -846,8 +860,34 @@ the mask bitmap and the original bitmap are all together in a single bytes!
         (color-green color)
         (color-blue color))))
 
-(define-struct/reg-mk color (red green blue) #:transparent)
 
+(define pen-ht (make-hash))
+
+(define (pen->pen-obj/cache pen)
+  (cond
+    [(and (equal? 'round (pen-join pen))
+          (equal? 'round (pen-cap pen)))
+     (send the-pen-list find-or-create-pen 
+           (pen-color pen)
+           (pen-width pen)
+           (pen-style pen))]
+    [else
+     (let* ([wb/f (hash-ref pen-ht pen #f)]
+            [pen-obj/f (and (weak-box? wb/f) (weak-box-value wb/f))])
+       (or pen-obj/f
+           (let ([pen-obj (pen->pen-obj pen)])
+             (hash-set! pen-ht pen (make-weak-box pen-obj))
+             pen-obj)))]))
+
+(define (pen->pen-obj pen)
+  (let ([ans (make-object pen% 
+               (pen-color pen)
+               (pen-width pen)
+               (pen-style pen))])
+    (send ans set-cap (pen-cap pen))
+    (send ans set-join (pen-join pen))
+    ans))
+       
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 
@@ -868,7 +908,8 @@ the mask bitmap and the original bitmap are all together in a single bytes!
          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-pen pen? pen-color pen-width pen-style pen-cap pen-join
+         
          make-bitmap bitmap? bitmap-raw-bitmap bitmap-raw-mask bitmap-angle bitmap-x-scale bitmap-y-scale 
          bitmap-rendered-bitmap bitmap-rendered-mask
 

collects/teachpack/2htdp/scribblings/image-gen.ss

@@ -3,9 +3,9 @@
 ;; Run this file is generate the images in the img/ directory, 
 ;; picked up by image-examples from image.scrbl
 
-(require 2htdp/private/image-more
+(require 2htdp/image
          lang/posn
-         mrlib/image-core)
+         (only-in 2htdp/private/image-more save-image))
 
 (define-namespace-anchor anchor)
 (define ns (namespace-anchor->namespace anchor))

collects/teachpack/2htdp/scribblings/image-toc.ss

@@ -141,20 +141,20 @@
       "white")
     'image
     "353ed4578.png")
+   (list
+    '(scene+line
+      (rectangle 100 100 "solid" "darkolivegreen")
+      25
+      25
+      100
+      100
+      (make-pen "goldenrod" 30 "solid" "round" "round"))
+    'image
+    "d629961aee.png")
    (list
     '(scene+line (rectangle 40 40 "solid" "gray") -10 50 50 -10 "maroon")
     'image
     "1f5944ec1ed.png")
-   (list
-    '(scene+line
-      (ellipse 80 60 "outline" "darkolivegreen")
-      (+ 40 (* 40 (cos (* pi 1/4))))
-      (+ 30 (* 30 (sin (* pi 1/4))))
-      (+ 40 (* 40 (cos (* pi 5/4))))
-      (+ 30 (* 30 (sin (* pi 5/4))))
-      "darkolivegreen")
-    'image
-    "2353974cf1b.png")
    (list
     '(scene+line (ellipse 40 40 "outline" "maroon") 0 40 40 0 "maroon")
     'image
@@ -491,7 +491,7 @@
        90
        180
        1/2
-       "white")
+       (make-pen "white" 4 "solid" "round" "round"))
       20
       10
       0
@@ -500,9 +500,9 @@
       90
       0
       1/2
-      "white")
+      (make-pen "white" 4 "solid" "round" "round"))
     'image
-    "2751bdfe579.png")
+    "21b080bdda8.png")
    (list
     '(add-curve
       (rectangle 100 100 "solid" "black")
@@ -531,20 +531,20 @@
       "white")
     'image
     "2a1f3988f.png")
+   (list
+    '(add-line
+      (rectangle 100 100 "solid" "darkolivegreen")
+      25
+      25
+      75
+      75
+      (make-pen "goldenrod" 30 "solid" "round" "round"))
+    'image
+    "7bbcc7cbaa.png")
    (list
     '(add-line (rectangle 40 40 "solid" "gray") -10 50 50 -10 "maroon")
     'image
     "12b0447b10c.png")
-   (list
-    '(add-line
-      (ellipse 80 60 "outline" "darkolivegreen")
-      (+ 40 (* 40 (cos (* pi 1/4))))
-      (+ 30 (* 30 (sin (* pi 1/4))))
-      (+ 40 (* 40 (cos (* pi 5/4))))
-      (+ 30 (* 30 (sin (* pi 5/4))))
-      "darkolivegreen")
-    'image
-    "17ca1cb72eb.png")
    (list
     '(add-line (ellipse 40 40 "outline" "maroon") 0 40 40 0 "maroon")
     'image
@@ -552,6 +552,32 @@
    (list '(line 30 -20 "red") 'image "12948ac080d.png")
    (list '(line -30 20 "red") 'image "69aaaa680d.png")
    (list '(line 30 30 "black") 'image "8e1ebaaf82.png")
+   (list
+    '(underlay
+      (rectangle 90 80 "solid" "mediumseagreen")
+      (polygon
+       (list
+        (make-posn 0 0)
+        (make-posn 50 0)
+        (make-posn 0 50)
+        (make-posn 50 50))
+       "outline"
+       (make-pen "darkslategray" 10 "solid" "projecting" "miter")))
+    'image
+    "29b31e5fe3a.png")
+   (list
+    '(underlay
+      (rectangle 80 80 "solid" "mediumseagreen")
+      (polygon
+       (list
+        (make-posn 0 0)
+        (make-posn 50 0)
+        (make-posn 0 50)
+        (make-posn 50 50))
+       "outline"
+       (make-pen "darkslategray" 10 "solid" "round" "round")))
+    'image
+    "1aaa434b462.png")
    (list
     '(polygon
       (list

collects/teachpack/2htdp/scribblings/image.scrbl

@@ -22,38 +22,56 @@ Existing images can be rotated, scaled, and overlaid on top of each other.
 
 @section{Basic Images}
 
-@defproc[(circle [radius (and/c real? (not/c negative?))]
-                 [mode mode?]
-                 [color image-color?])
-         image?]{
+@defproc*[([(circle [radius (and/c real? (not/c negative?))]
+                    [mode mode?]
+                    [color image-color?])
+            image?]
+           [(circle [radius (and/c real? (not/c negative?))]
+                    [mode 'outline]
+                    [color pen?])
+            image?])]{
   Constructs a circle with the given radius, height, mode, and color.
   
+   If the @scheme[mode] is @scheme['outline], then the @scheme[color]
+  can be a @scheme[pen?] struct or an @scheme[image-color?], but if the @scheme[mode]
+  is @scheme['solid], then the @scheme[color] must be an
+  @scheme[image-color?].
+
   @image-examples[(circle 30 "outline" "red")
                   (circle 20 "solid" "blue")]
-  
+
 }
 
 @defproc[(ellipse [width (and/c real? (not/c negative?))]
                   [height (and/c real? (not/c negative?))]
                   [mode mode?] 
-                  [color image-color?]) image?]{
+                  [color (or/c image-color? pen?)])
+         image?]{
   Constructs an ellipsis with the given width, height, mode, and color.
+
+  If the @scheme[mode] is @scheme['outline], then the @scheme[color]
+  can be a @scheme[pen?] struct or an @scheme[image-color?], but if the @scheme[mode]
+  is @scheme['solid], then the @scheme[color] must be an
+  @scheme[image-color?].
   
   @image-examples[(ellipse 40 20 "outline" "black")
-                  (ellipse 20 40 "solid" "blue")]
-  
+                  (ellipse 20 40 "solid" "blue")] 
 }
 
 @defproc[(triangle [side-length (and/c real? (not/c negative?))] 
                    [mode mode?]
-                   [color image-color?])
+                   [color (if (or (equal? mode 'outline)
+                                  (equal? mode "outline"))
+                              (or/c image-color? pen?)
+                              image-color?)])
          image?]{
-  Constructs a upward-pointing equilateral triangle. 
+   Constructs a upward-pointing equilateral triangle. 
   The @scheme[side-length] argument 
   determines the 
   length of the side of the triangle.
 
 @image-examples[(triangle 40 "solid" "tan")]
+
 }
 
 @defproc[(right-triangle [side-length1 (and/c real? (not/c negative?))]
@@ -171,7 +189,8 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                                  (make-posn -10 20)
                                  (make-posn 60 0)
                                  (make-posn -10 -20))
-                           "solid" "burlywood")
+                           "solid" 
+                           "burlywood")
                   (polygon (list (make-posn 0 0)
                                  (make-posn 0 40)
                                  (make-posn 20 40)
@@ -180,7 +199,27 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
                                  (make-posn 40 20)
                                  (make-posn 20 20)
                                  (make-posn 20 0))
-                           "solid" "plum")]
+                           "solid" 
+                           "plum")
+                  (underlay
+                   (rectangle 80 80 "solid" "mediumseagreen")
+                   (polygon
+                    (list (make-posn 0 0)
+                          (make-posn 50 0)
+                          (make-posn 0 50)
+                          (make-posn 50 50))
+                    "outline"
+                    (make-pen "darkslategray" 10 "solid" "round" "round")))
+                  
+                  (underlay
+                   (rectangle 90 80 "solid" "mediumseagreen")
+                   (polygon 
+                    (list (make-posn 0 0)
+                          (make-posn 50 0)
+                          (make-posn 0 50)
+                          (make-posn 50 50))
+                    "outline"
+                    (make-pen "darkslategray" 10 "solid" "projecting" "miter")))]
 }
 
 @defproc[(line [x1 real?] [y1 real?] [color image-color?]) image?]{
@@ -205,14 +244,12 @@ other. The top and bottom pair of angles is @scheme[angle] and the left and righ
   
   @image-examples[(add-line (ellipse 40 40 "outline" "maroon")
                             0 40 40 0 "maroon")
-                  (add-line (ellipse 80 60 "outline" "darkolivegreen")
-                            (+ 40 (* 40 (cos (* pi 1/4))))
-                            (+ 30 (* 30 (sin (* pi 1/4))))
-                            (+ 40 (* 40 (cos (* pi 5/4))))
-                            (+ 30 (* 30 (sin (* pi 5/4))))
-                            "darkolivegreen")
                   (add-line (rectangle 40 40 "solid" "gray")
-                            -10 50 50 -10 "maroon")]
+                            -10 50 50 -10 "maroon")
+                 (add-line
+                   (rectangle 100 100 "solid" "darkolivegreen")
+                   25 25 75 75 
+                   (make-pen "goldenrod" 30 "solid" "round" "round"))]
 }
 
 @defproc[(add-curve [image image?] 
@@ -237,28 +274,28 @@ Unlike @scheme[scene+curve], if the line passes outside of @scheme[image], the i
   gets larger to accomodate the curve.
 
 
-@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")
-                        
-                (add-curve (rectangle 100 100 "solid" "black")
-                           -20 -20 0 1 
-                           120 120 0 1
-                           "red")]
+  @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
+                    (make-pen "white" 4 "solid" "round" "round"))
+                   20 10 0 1/2
+                   20 90 0 1/2
+                   (make-pen "white" 4 "solid" "round" "round"))
+                  
+                  (add-curve (rectangle 100 100 "solid" "black")
+                             -20 -20 0 1 
+                             120 120 0 1
+                             "red")]
 }
 
 @defproc[(text [string string?] [font-size (and/c integer? (<=/c 1 255))] [color image-color?])
@@ -585,14 +622,12 @@ and universes using @scheme[2htdp/universe].
   
   @image-examples[(scene+line (ellipse 40 40 "outline" "maroon")
                               0 40 40 0 "maroon")
-                  (scene+line (ellipse 80 60 "outline" "darkolivegreen")
-                              (+ 40 (* 40 (cos (* pi 1/4))))
-                              (+ 30 (* 30 (sin (* pi 1/4))))
-                              (+ 40 (* 40 (cos (* pi 5/4))))
-                              (+ 30 (* 30 (sin (* pi 5/4))))
-                              "darkolivegreen")
                   (scene+line (rectangle 40 40 "solid" "gray")
-                              -10 50 50 -10 "maroon")]
+                              -10 50 50 -10 "maroon")
+                  (scene+line
+                   (rectangle 100 100 "solid" "darkolivegreen")
+                   25 25 100 100 
+                   (make-pen "goldenrod" 30 "solid" "round" "round"))]
 }
 
 @defproc[(scene+curve [scene image?] 
@@ -833,6 +868,49 @@ The baseline of an image is the place where the bottoms any letters line up, not
   greater than or equal to @scheme[3].
 }
 
+@defstruct[pen ([color image-color?]
+                [width (and/c real? (<=/c 0 255))]
+                [style pen-style?]
+                [cap pen-cap?]
+                [join pen-join?])]{
+  The @scheme[pen] struct specifies how the drawing library draws lines. 
+      
+      
+      A good default for @scheme[style] is @scheme["solid"], and
+      good default values for the @scheme[cap] and @scheme[join] fields
+      are @scheme["round"].
+      
+      Using @scheme[0] as a width is special; it means to always draw the 
+      smallest possible, but visible, pen. This means that the pen will always
+      be one pixel in size, no matter how the image is scaled.
+}
+
+@defproc[(pen-style? [x any/c]) boolean?]{
+  Determines if @scheme[x] is a valid pen style.
+  It can be one of
+  @scheme["solid"], @scheme['solid], 
+  @scheme["dot"], @scheme['dot], 
+  @scheme["long-dash"], @scheme['long-dash], 
+  @scheme["short-dash"], @scheme['short-dash], 
+  @scheme["dot-dash"], or @scheme['dot-dash].
+}
+
+@defproc[(pen-cap? [x any/c]) boolean?]{
+  Determines if @scheme[x] is a valid pen cap.
+  It can be one of
+  @scheme["round"], @scheme['round], 
+  @scheme["projecting"], @scheme['projecting], 
+  @scheme["butt"], or @scheme['butt].
+}
+
+@defproc[(pen-join? [x any/c]) boolean?]{
+  Determines if @scheme[x] is a valid pen join.
+  It can be one of
+  @scheme["round"], @scheme['round], 
+  @scheme["bevel"], @scheme['bevel], 
+  @scheme["miter"], or @scheme['miter].
+}
+
 @section{Equality Testing of Images}
 
 Two images are equal if they draw exactly the same way, at their current size