deeglaze · July 20, 2019 14:11 · spdegabrielle · Jul 20, 2019
diff --git a/standard-cat.rkt b/standard-cat.rkt
 #lang racket

 (require pict/color)
 (provide
 (contract-out
  [cat-silhouette
   (->i ([width positive?] [height positive?])
        (#:left-ear-extent [left-ear-extent (>=/c 0)]
         #:left-ear-arc [left-ear-arc (real-in 0 (* 2 pi))]
         #:left-ear-angle [left-ear-angle (real-in 0 (* 2 pi))]
         #:right-ear-extent [right-ear-extent (>=/c 0)]
         #:right-ear-arc [right-ear-arc (real-in 0 (* 2 pi))]
         #:right-ear-angle [right-ear-angle (real-in 0 (* 2 pi))]
         #:color [color (or/c color/c #f)]
         #:border-color [border-color (or/c #f color/c)]
         #:border-width [border-width (or/c #f (real-in 0 255))])
        #:pre/desc (left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
        (ear-positioning-errors left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
        (values [_ pict?]
                [_ (-> (or/c (cons/c real? real?) (is-a?/c point%))
                       (cons/c real? real?))]))]

 [standard-cat/transform
  (->i ([width positive?] [height positive?])
       (#:left-ear-extent [left-ear-extent (>=/c 0)]
        #:left-ear-arc [left-ear-arc (real-in 0 (* 2 pi))]
        #:left-ear-angle [left-ear-angle (real-in 0 (* 2 pi))]
        #:right-ear-extent [right-ear-extent (>=/c 0)]
        #:right-ear-arc [right-ear-arc (real-in 0 (* 2 pi))]
        #:right-ear-angle [right-ear-angle (real-in 0 (* 2 pi))]
        #:fur-color [fur-color (or/c #f color/c)]
        #:fur-border-color [fur-border-color (or/c #f color/c)]
        #:lip-color [lip-color (or/c #f color/c)]
        #:lip-border-color [lip-border-color color/c]
        #:lip-border-width [lip-border-width (or/c #f (real-in 0 255))]
        #:eye-color [eye-color (or/c #f color/c)]
        #:nose-color [nose-color (or/c #f color/c)]
        #:nose [nose pict?]
        #:happy? [happy? any/c]
        #:eyes [eyes (or/c #f pict?)]
        #:left-eye [left-eye (eyes) (if eyes (or/c #f pict?) pict?)]
        #:right-eye [right-eye (eyes) (if eyes (or/c #f pict?) pict?)]
        #:whisker-length [whisker-length positive?]
        #:whisker-droop [whisker-droop real?]
        ;; #f to hide whiskers
        #:whisker-width [whisker-width (or/c #f (real-in 0 255))]
        #:whisker-color [whisker-color color/c]
        #:whisker-inset? [whisker-inset? any/c]
        ;; #f for no border
        #:border-width [border-width (or/c #f (real-in 0 255))])
       #:pre/desc (left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
       (ear-positioning-errors left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
       (values [_ pict?]
               [_ (-> (or/c (cons/c real? real?) (is-a?/c point%))
                      (cons/c real? real?))]))]

  [standard-cat
  (->i ([width positive?] [height positive?])
       (#:left-ear-extent [left-ear-extent (>=/c 0)]
        #:left-ear-arc [left-ear-arc (real-in 0 (* 2 pi))]
        #:left-ear-angle [left-ear-angle (real-in 0 (* 2 pi))]
        #:right-ear-extent [right-ear-extent (>=/c 0)]
        #:right-ear-arc [right-ear-arc (real-in 0 (* 2 pi))]
        #:right-ear-angle [right-ear-angle (real-in 0 (* 2 pi))]
        #:fur-color [fur-color (or/c #f color/c)]
        #:fur-border-color [fur-border-color (or/c #f color/c)]
        #:lip-color [lip-color (or/c #f color/c)]
        #:lip-border-color [lip-border-color color/c]
        #:lip-border-width [lip-border-width (or/c #f (real-in 0 255))]
        #:eye-color [eye-color (or/c #f color/c)]
        #:nose-color [nose-color (or/c #f color/c)]
        #:nose [nose pict?]
        #:happy? [happy? any/c]
        #:eyes [eyes (or/c #f pict?)]
        #:left-eye [left-eye (eyes) (if eyes (or/c #f pict?) pict?)]
        #:right-eye [right-eye (eyes) (if eyes (or/c #f pict?) pict?)]
        #:whisker-length [whisker-length positive?]
        #:whisker-droop [whisker-droop real?]
        ;; #f to hide whiskers
        #:whisker-width [whisker-width (or/c #f (real-in 0 255))]
        #:whisker-color [whisker-color color/c]
        #:whisker-inset? [whisker-inset? any/c]
        ;; #f for no border
        #:border-width [border-width (or/c #f (real-in 0 255))])
       #:pre/desc (left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
       (ear-positioning-errors left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
       [_ pict?])]

 [happy-eyes (->* (positive? positive?)
                  (#:boldness (real-in 0 1)
                   #:color (or/c #f color/c)
                   #:border-color color/c
                   #:border-width (or/c #f (real-in 0 255)))
                  pict?)]))
 (require pict racket/draw)

 ;; Not exported by pict/private/utils.rkt
 (define (draw-shape/border w h draw-fun
                           color [border-color #f] [border-width #f]
                           #:draw-border? [draw-border? #t]
                           #:transparent? [transparent? #f])
  (dc (λ (dc dx dy)
        (define old-brush (send dc get-brush))
        (define old-pen   (send dc get-pen))
        (send dc set-brush
              (send the-brush-list find-or-create-brush
                    (cond [transparent? "white"]
                          [color        color]
                          [else         (send old-pen get-color)])
                    (if transparent? 'transparent 'solid)))
        (if draw-border?
            (when (or border-color border-width)
              ;; otherwise, leave pen as is
              (send dc set-pen (send the-pen-list
                                     find-or-create-pen
                                     (or border-color
                                         (send old-pen get-color))
                                     (or border-width
                                         (send old-pen get-width))
                                     (send old-pen get-style))))
            (send dc set-pen "black" 1 'transparent))
        (draw-fun dc dx dy)
        (send dc set-brush old-brush)
        (send dc set-pen   old-pen))
      w h))

 ;; ellipse-point: positive? positive? real? [real? real?] -> (is/a point%)
 ;; Creates a point% representing the x,y coordinates on an ellipse that
 ;; fills the rectangle (0,0)-(width,height), then offsets the result by
 ;; (offset-x, offset-y).
 (define (ellipse-point width height θ [offset-x 0] [offset-y 0])
  (make-object point% (+ offset-x (* (/ width 2) (cos θ)))
    (+ offset-y (* (/ height 2) (sin θ)))))

 ;; circumscribed-triangle: real? real? -> pict?
 ;; Draws a triangle whose points lie on an ellipse filling the rectangle
 ;; (0,0)-(width,height). Each point is positioned by its angular position.
 ;; The triangle may be optionally filled with a #:color argument. If given
 ;; a positive #:border-width argument, the triangle will have a border of
 ;; color #:border-color.
 (define (circumscribed-triangle width height
                                #:angle0 [angle0 (/ pi 2)]
                                #:angle1 [angle1 (+ angle0 (* 2/3 pi))]
                                #:angle2 [angle2 (+ angle1 (* 2/3 pi))]
                                #:color [color #f]
                                #:border-color [border-color "black"]
                                #:border-width [border-width #f])
  (draw-shape/border width height
                     (λ (dc dx dy)
                       (define radius (/ (min width height) 2))
                       (send dc draw-polygon
                             (list (ellipse-point width height angle0 dx dy)
                                   (ellipse-point width height angle1 dx dy)
                                   (ellipse-point width height angle2 dx dy))
                             (/ width 2) (/ height 2)))
                     color border-color border-width
                     #:draw-border? (or border-color border-width)
                     #:transparent? (not color)))

 ;; equilateral-triangle: draws a circumscribed triangle with all points
 ;; equidistant from each other on the circle. The triangle can be optionally
 ;; rotated.
 (define (equilateral-triangle width height
                              #:angle [angle 0]
                              #:color [color #f]
                              #:border-color [border-color #f])
  (circumscribed-triangle width height
                          #:angle0 (+ (/ pi 2) angle)
                          #:angle1 (+ (/ pi 2) angle (* 2/3 pi))
                          #:angle2 (+ (/ pi 2) angle (* 4/3 pi))
                          #:color color #:border-color border-color
                          #:border-width (and border-color 1)))
 
 (define (polar r θ)
  (cons (* r (cos θ)) (* r (sin θ))))

 (define (default-ear-extent height) (/ height 4))
 (define default-ear-arc (* pi 1/4))
 (define (default-left-ear-angle left-ear-arc)
  (- (* 2/3 pi) (/ left-ear-arc 2)))
 (define (default-right-ear-angle right-ear-arc)
  (- (* 1/3 pi) (/ right-ear-arc 2)))

 (define (cat-silhouette width height
                        ;; How much farther than the circle does the ear extend?
                        #:left-ear-extent [left-ear-extent (default-ear-extent height)]
                        ;; How much of an arc does the ear sweep out?
                        #:left-ear-arc [left-ear-arc default-ear-arc]
                        ;; At what angle do we start drawing the ear?
                        #:left-ear-angle [left-ear-angle (default-left-ear-angle left-ear-arc)]
                        #:right-ear-extent [right-ear-extent (default-ear-extent height)]
                        #:right-ear-arc [right-ear-arc default-ear-arc]
                        #:right-ear-angle [right-ear-angle (default-right-ear-angle right-ear-arc)]
                        #:color [color "orange"]
                        #:border-color [border-color (make-object color% 200 80 100)]
                        #:border-width [border-width 1])
  (define x-radius (/ width 2))
  (define y-radius (/ height 2))
  
  (define left-ear-tip
    (polar (+ left-ear-extent x-radius) (+ left-ear-angle (/ left-ear-arc 2))))
  (define right-ear-tip
    (polar (+ right-ear-extent x-radius) (+ right-ear-angle (/ right-ear-arc 2))))
  
  ;; All calculations done in cat-face-center-is-(0,0) coordinates.
  (define left-protrusion
    (min (- x-radius) (car left-ear-tip) (car right-ear-tip)))
  (define right-protrusion
    (max x-radius (car right-ear-tip) (car left-ear-tip)))
  (define top-protrusion
    (max y-radius (cdr left-ear-tip) (cdr right-ear-tip)))
  (define bottom-protrusion
    (min (- y-radius) (cdr left-ear-tip) (cdr right-ear-tip)))
 
  ;; All protrusions affect what the overall coordinate space is.
  ;; If an ear extends past the leftmost or topmost extent of the base circle,
  ;; then all coordinates must be adjusted by the difference from the circle.
  ;; If an ear extends past the rightmost or bottommost extent of the circle,
  ;; that difference (plus the left/top difference) add to the width and
  ;; height of the image.
  ;; The left and top protrusions are what shift our coordinate space.
  ;; The right and bottom protrusions possibly add to the overall width
  ;; and height.
  (define adjust-left (+ (- (max 0 (+ left-protrusion x-radius)))
                         (or border-width 0)))
  (define adjust-top (max 0 (- (+ (or border-width 0) top-protrusion)
                               y-radius)))
 
  (define (from-cat-coords point)
    (match-define (cons x y)
      (cond [(pair? point) point]
            [else (cons (send point get-x) (send point get-y))]))
    (cons (+ x adjust-left x-radius) (- (+ y-radius adjust-top) y)))
 
  (define left-ear-end
    (from-cat-coords
     (ellipse-point width height (+ left-ear-angle left-ear-arc))))
  (define right-ear-end
    (from-cat-coords
     (ellipse-point width height (+ right-ear-angle right-ear-arc))))
 
  (define width*
    (+ adjust-left x-radius right-protrusion (or border-width 0)))
  (define height*
    (+ adjust-top y-radius (- bottom-protrusion) (or border-width 0)))
  (values
   (draw-shape/border width*
                      height*
                      (λ (dc dx dy)
                        (define cat-path (new dc-path%))
                        (send cat-path arc
                              adjust-left adjust-top
                              width height
                              (+ left-ear-angle left-ear-arc)
                              right-ear-angle)
                        (send cat-path lines
                              (list (from-cat-coords right-ear-tip)
                                    right-ear-end))
                        (send cat-path arc
                              adjust-left adjust-top
                              width height
                              (+ right-ear-angle right-ear-arc)
                              left-ear-angle)
                        (send cat-path lines
                              (list (from-cat-coords left-ear-tip)
                                    left-ear-end))
                        (send cat-path close)
                        (send dc draw-path cat-path dx dy))
                      color border-color border-width
                      #:draw-border? border-width
                      #:transparent? (not color))
   from-cat-coords))

 ;; ear-positioning-errors: 4 reals -> #f or Listof[String]
 ;; Checks for errors in a cat's ear positioning. Error messages are
 ;; returned as a list of strings (descriptions of the errors).
 (define (ear-positioning-errors in-left-ear-arc in-left-ear-angle
                                in-right-ear-arc in-right-ear-angle)
  (define left-ear-arc (if (unsupplied-arg? in-left-ear-arc)
                           default-ear-arc
                           in-left-ear-arc))
  (define left-ear-angle (if (unsupplied-arg? in-left-ear-angle)
                             (default-left-ear-angle left-ear-arc)
                             in-left-ear-angle))
  (define right-ear-arc (if (unsupplied-arg? in-right-ear-arc)
                            default-ear-arc
                            in-right-ear-arc))
  (define right-ear-angle (if (unsupplied-arg? in-right-ear-angle)
                              (default-right-ear-angle right-ear-arc)
                              in-right-ear-angle))
  
  (define messages
    (list
     (and (< left-ear-angle right-ear-angle)
          (list "Left ear is to the right of the right ear"))
     (and (> (+ left-ear-arc right-ear-arc) (* 2 pi))
          (list "Ear arcs cannot exceed 2pi"))
     (and (> (+ right-ear-angle right-ear-arc) left-ear-angle)
          (list "Right ear cannot overlap with left ear"))
     (and (> (+ left-ear-angle left-ear-arc) (+ (* 2 pi) right-ear-angle))
          (list "Left ear cannot overlap with right ear"))))
  (define errors (filter values messages))
  (or (null? errors) errors))

 (define (happy-eyes width height
                    #:boldness [boldness 0.2]
                    #:color [color "black"]
                    #:border-color [border-color "black"]
                    #:border-width [border-width #f])
  ;; More boldness = less height for the smaller ellipse.
  (define height-percent (- 1 boldness))
  (unless (< 0 boldness 1)
    (error 'happy-eyes "Boldness must be between 0 and 1 exclusive"))
  (draw-shape/border width height
                     (lambda (dc dx dy)
                       (define eye-path (new dc-path%))
                       (send eye-path arc 0 0 width height 0 pi)
                       (send eye-path arc 0 (* height boldness)
                             width (* height height-percent) pi 0 #f)
                       (send eye-path close)
                       (send dc draw-path eye-path dx dy))
                     color border-color border-width
                     #:draw-border? border-width
                     #:transparent? (not color)))
 
 (define (standard-cat/transform width height
                      #:left-ear-extent [left-ear-extent (default-ear-extent height)]
                      #:left-ear-arc [left-ear-arc default-ear-arc]
                      #:left-ear-angle [left-ear-angle (default-left-ear-angle left-ear-arc)]
                      #:right-ear-extent [right-ear-extent (default-ear-extent height)]
                      #:right-ear-arc [right-ear-arc default-ear-arc]
                      #:right-ear-angle [right-ear-angle (default-right-ear-angle right-ear-arc)]
                      #:fur-color [fur-color "orange"]
                      #:fur-border-color [fur-border-color (make-object color% 200 80 100)]
                      #:eye-color [eye-color "black"]
                      #:nose-color [nose-color "pink"]
                      #:nose [nose (equilateral-triangle (/ width 4) (/ height 4) #:angle pi #:color nose-color)]
                      #:lip-color [lip-color (make-object color% 240 140 0)]
                      #:lip-border-color [lip-border-color fur-border-color]
                      #:lip-border-width [lip-border-width 1]
                      #:happy? [happy? #f]
                      #:eyes [eyes
                              (if happy?
                                  (happy-eyes (/ width 6) (/ height 6) #:color eye-color)
                                  (filled-ellipse (/ width 6) (/ height 6) #:color eye-color))]
                      #:left-eye [left-eye #f]
                      #:right-eye [right-eye #f]
                      #:whisker-length [whisker-length (* 3/8 width)]
                      #:whisker-droop [whisker-droop (* 1/6 height)]
                      #:whisker-color [whisker-color (make-object color% 100 40 50)]
                      #:whisker-width [whisker-width 1]
                      #:whisker-inset? [whisker-inset? #t]
                      #:border-width [border-width 1])
  (define-values (face coord-fn)
    (cat-silhouette width height
                    #:left-ear-extent left-ear-extent
                    #:left-ear-arc left-ear-arc
                    #:left-ear-angle left-ear-angle
                    #:right-ear-extent right-ear-extent
                    #:right-ear-arc right-ear-arc
                    #:right-ear-angle right-ear-angle
                    #:color fur-color
                    #:border-color fur-border-color
                    #:border-width border-width))
  
  (match-define (cons pre-center-x center-y) (coord-fn (cons 0 0)))

  (define left-whisker-center-offset
    (* -3/4 (pict-width nose)))
  (define left-whisker-extent-from-center
    (+ (- whisker-length) left-whisker-center-offset))
  (define left-whisker-inset-amount
    (if whisker-inset?
        (max 0 (- (car (coord-fn (cons left-whisker-extent-from-center 0)))))
        0))

  (define right-whisker-center-offset
    (* 3/4 (pict-width nose)))
  (define right-whisker-extent-from-center
    (+ whisker-length right-whisker-center-offset))
  (define right-whisker-inset-amount
    (if whisker-inset?
        (max 0 (- (car (coord-fn (cons right-whisker-extent-from-center 0)))
                  (pict-width face)))
        0))
  
  ;; If we don't show the whiskers, we don't need to inset the face
  ;; in order to draw them past the extent of the cat silhouette.
  (define-values (center-x face*)
    (cond [(not whisker-width) (values pre-center-x face)]
          [else
           (define inset-face
             (inset face left-whisker-inset-amount 0
                    right-whisker-inset-amount 0))
           (values (+ pre-center-x left-whisker-inset-amount)
                   inset-face)]))
 
  (define face-and-nose
    (pin-over face*
              (- center-x (/ (pict-width nose) 2))
              (- center-y (/ (pict-height nose) 2))
              nose))
 
  (define lip
    (draw-shape/border (/ width 4) (/ height 4)
                       (λ (dc dx dy)
                         (send dc draw-arc dx dy (/ width 4) (/ height 4) pi 0))
                       lip-color lip-border-color lip-border-width
                       #:draw-border? lip-border-width
                       #:transparent? (not lip-color)))
 
  (define left-lip
    (pin-over face-and-nose
              (- center-x (pict-width lip))
              center-y
              lip))
 
  (define lips
    (pin-over left-lip center-x center-y lip))
 
  (define select-left-eye (or left-eye eyes))
  (define with-left-eye
    (pin-over lips
              (- center-x (pict-width select-left-eye) (/ (pict-width nose) 2))
              (- center-y (pict-height nose))
              select-left-eye))

  (define with-eyes
    (pin-over with-left-eye
              (+ center-x (/ (pict-width nose) 2))
              (- center-y (pict-height nose))
              (or right-eye eyes)))

  (cond
    [(not whisker-width) (values with-eyes coord-fn)]
    [else    
     (define left-whisker
       (draw-shape/border
        (/ width 2) (/ height 16)
        (λ (dc dx dy)
          (send dc draw-spline dx dy
                (- dx (* 5/8 whisker-length))
                (+ dy (* 1/16 height))
                (- dx whisker-length)
                (+ dy whisker-droop)))
        #f whisker-color whisker-width
        #:draw-border? whisker-width
        #:transparent? #f))

     (define right-whisker
       (draw-shape/border
        (/ width 2) (/ height 16)
        (λ (dc dx dy)
          (send dc draw-spline dx dy
                (+ dx (* 5/8 whisker-length))
                (+ dy (* 1/16 height))
                (+ dx whisker-length)
                (+ dy whisker-droop)))
        #f whisker-color whisker-width
        #:draw-border? whisker-width
        #:transparent? #f))

     (define with-whisker0
       (pin-over with-eyes
                 (- center-x (/ (pict-width nose) 2))
                 (+ center-y (/ (pict-height nose) 2))
                 left-whisker))

     (define with-whisker1
       (pin-over with-whisker0
                 (+ center-x left-whisker-center-offset)
                 (+ center-y (* 1/4 (pict-height nose)))
                 left-whisker))

     (define with-whisker2
       (pin-over with-whisker1
                 (+ center-x (/ (pict-width nose) 2))
                 (+ center-y (/ (pict-height nose) 2))
                 right-whisker))

     (values
      (pin-over with-whisker2
                (+ center-x right-whisker-center-offset)
                (+ center-y (* 1/4 (pict-height nose)))
                right-whisker)
      (λ (pair)
        (match-define (cons dx dy) (coord-fn pair))
        (cons (+ left-whisker-inset-amount dx) dy)))]))

 (define (standard-cat width height
                      #:left-ear-extent [left-ear-extent (default-ear-extent height)]
                      #:left-ear-arc [left-ear-arc default-ear-arc]
                      #:left-ear-angle [left-ear-angle (default-left-ear-angle left-ear-arc)]
                      #:right-ear-extent [right-ear-extent (default-ear-extent height)]
                      #:right-ear-arc [right-ear-arc default-ear-arc]
                      #:right-ear-angle [right-ear-angle (default-right-ear-angle right-ear-arc)]
                      #:fur-color [fur-color "orange"]
                      #:fur-border-color [fur-border-color (make-object color% 200 80 100)]
                      #:eye-color [eye-color "black"]
                      #:nose-color [nose-color "pink"]
                      #:nose [nose (equilateral-triangle (/ width 4) (/ height 4) #:angle pi #:color nose-color)]
                      #:lip-color [lip-color (make-object color% 240 140 0)]
                      #:lip-border-color [lip-border-color fur-border-color]
                      #:lip-border-width [lip-border-width 1]
                      #:happy? [happy? #f]
                      #:eyes [eyes
                              (if happy?
                                  (happy-eyes (/ width 6) (/ height 6) #:color eye-color)
                                  (filled-ellipse (/ width 6) (/ height 6) #:color eye-color))]
                      #:left-eye [left-eye #f]
                      #:right-eye [right-eye #f]
                      #:whisker-length [whisker-length (* 3/8 width)]
                      #:whisker-droop [whisker-droop (* 1/6 height)]
                      #:whisker-color [whisker-color (make-object color% 100 40 50)]
                      #:whisker-width [whisker-width 1]
                      #:whisker-inset? [whisker-inset? #t]
                      #:border-width [border-width 1])
  (define-values (cat _) (standard-cat/transform
                          width height
                          #:left-ear-extent left-ear-extent
                          #:left-ear-arc left-ear-arc
                          #:left-ear-angle left-ear-angle
                          #:right-ear-extent left-ear-extent
                          #:right-ear-arc right-ear-arc
                          #:right-ear-angle right-ear-angle
                          #:fur-color fur-color
                          #:fur-border-color fur-border-color
                          #:eye-color eye-color
                          #:nose-color nose-color
                          #:nose nose
                          #:lip-color lip-color
                          #:lip-border-color lip-border-color
                          #:happy? happy?
                          #:eyes eyes
                          #:left-eye left-eye
                          #:right-eye right-eye
                          #:whisker-length whisker-length
                          #:whisker-droop whisker-droop
                          #:whisker-color whisker-color
                          #:whisker-width whisker-width
                          #:whisker-inset? whisker-inset?
                          #:border-width border-width))
  cat)

 ;; Wink!
 (standard-cat 50 90 #:happy? #t #:left-eye (filled-ellipse (/ 50 6) (/ 90 6)))
	#lang racket

	(require pict/color)
	(provide
	(contract-out
	[cat-silhouette
	(->i ([width positive?] [height positive?])
	(#:left-ear-extent [left-ear-extent (>=/c 0)]
	#:left-ear-arc [left-ear-arc (real-in 0 (* 2 pi))]
	#:left-ear-angle [left-ear-angle (real-in 0 (* 2 pi))]
	#:right-ear-extent [right-ear-extent (>=/c 0)]
	#:right-ear-arc [right-ear-arc (real-in 0 (* 2 pi))]
	#:right-ear-angle [right-ear-angle (real-in 0 (* 2 pi))]
	#:color [color (or/c color/c #f)]
	#:border-color [border-color (or/c #f color/c)]
	#:border-width [border-width (or/c #f (real-in 0 255))])
	#:pre/desc (left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
	(ear-positioning-errors left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
	(values [_ pict?]
	[_ (-> (or/c (cons/c real? real?) (is-a?/c point%))
	(cons/c real? real?))]))]

	[standard-cat/transform
	(->i ([width positive?] [height positive?])
	(#:left-ear-extent [left-ear-extent (>=/c 0)]
	#:left-ear-arc [left-ear-arc (real-in 0 (* 2 pi))]
	#:left-ear-angle [left-ear-angle (real-in 0 (* 2 pi))]
	#:right-ear-extent [right-ear-extent (>=/c 0)]
	#:right-ear-arc [right-ear-arc (real-in 0 (* 2 pi))]
	#:right-ear-angle [right-ear-angle (real-in 0 (* 2 pi))]
	#:fur-color [fur-color (or/c #f color/c)]
	#:fur-border-color [fur-border-color (or/c #f color/c)]
	#:lip-color [lip-color (or/c #f color/c)]
	#:lip-border-color [lip-border-color color/c]
	#:lip-border-width [lip-border-width (or/c #f (real-in 0 255))]
	#:eye-color [eye-color (or/c #f color/c)]
	#:nose-color [nose-color (or/c #f color/c)]
	#:nose [nose pict?]
	#:happy? [happy? any/c]
	#:eyes [eyes (or/c #f pict?)]
	#:left-eye [left-eye (eyes) (if eyes (or/c #f pict?) pict?)]
	#:right-eye [right-eye (eyes) (if eyes (or/c #f pict?) pict?)]
	#:whisker-length [whisker-length positive?]
	#:whisker-droop [whisker-droop real?]
	;; #f to hide whiskers
	#:whisker-width [whisker-width (or/c #f (real-in 0 255))]
	#:whisker-color [whisker-color color/c]
	#:whisker-inset? [whisker-inset? any/c]
	;; #f for no border
	#:border-width [border-width (or/c #f (real-in 0 255))])
	#:pre/desc (left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
	(ear-positioning-errors left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
	(values [_ pict?]
	[_ (-> (or/c (cons/c real? real?) (is-a?/c point%))
	(cons/c real? real?))]))]

	[standard-cat
	(->i ([width positive?] [height positive?])
	(#:left-ear-extent [left-ear-extent (>=/c 0)]
	#:left-ear-arc [left-ear-arc (real-in 0 (* 2 pi))]
	#:left-ear-angle [left-ear-angle (real-in 0 (* 2 pi))]
	#:right-ear-extent [right-ear-extent (>=/c 0)]
	#:right-ear-arc [right-ear-arc (real-in 0 (* 2 pi))]
	#:right-ear-angle [right-ear-angle (real-in 0 (* 2 pi))]
	#:fur-color [fur-color (or/c #f color/c)]
	#:fur-border-color [fur-border-color (or/c #f color/c)]
	#:lip-color [lip-color (or/c #f color/c)]
	#:lip-border-color [lip-border-color color/c]
	#:lip-border-width [lip-border-width (or/c #f (real-in 0 255))]
	#:eye-color [eye-color (or/c #f color/c)]
	#:nose-color [nose-color (or/c #f color/c)]
	#:nose [nose pict?]
	#:happy? [happy? any/c]
	#:eyes [eyes (or/c #f pict?)]
	#:left-eye [left-eye (eyes) (if eyes (or/c #f pict?) pict?)]
	#:right-eye [right-eye (eyes) (if eyes (or/c #f pict?) pict?)]
	#:whisker-length [whisker-length positive?]
	#:whisker-droop [whisker-droop real?]
	;; #f to hide whiskers
	#:whisker-width [whisker-width (or/c #f (real-in 0 255))]
	#:whisker-color [whisker-color color/c]
	#:whisker-inset? [whisker-inset? any/c]
	;; #f for no border
	#:border-width [border-width (or/c #f (real-in 0 255))])
	#:pre/desc (left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
	(ear-positioning-errors left-ear-arc left-ear-angle right-ear-arc right-ear-angle)
	[_ pict?])]

	[happy-eyes (->* (positive? positive?)
	(#:boldness (real-in 0 1)
	#:color (or/c #f color/c)
	#:border-color color/c
	#:border-width (or/c #f (real-in 0 255)))
	pict?)]))
	(require pict racket/draw)

	;; Not exported by pict/private/utils.rkt
	(define (draw-shape/border w h draw-fun
	color [border-color #f] [border-width #f]
	#:draw-border? [draw-border? #t]
	#:transparent? [transparent? #f])
	(dc (λ (dc dx dy)
	(define old-brush (send dc get-brush))
	(define old-pen (send dc get-pen))
	(send dc set-brush
	(send the-brush-list find-or-create-brush
	(cond [transparent? "white"]
	[color color]
	[else (send old-pen get-color)])
	(if transparent? 'transparent 'solid)))
	(if draw-border?
	(when (or border-color border-width)
	;; otherwise, leave pen as is
	(send dc set-pen (send the-pen-list
	find-or-create-pen
	(or border-color
	(send old-pen get-color))
	(or border-width
	(send old-pen get-width))
	(send old-pen get-style))))
	(send dc set-pen "black" 1 'transparent))
	(draw-fun dc dx dy)
	(send dc set-brush old-brush)
	(send dc set-pen old-pen))
	w h))

	;; ellipse-point: positive? positive? real? [real? real?] -> (is/a point%)
	;; Creates a point% representing the x,y coordinates on an ellipse that
	;; fills the rectangle (0,0)-(width,height), then offsets the result by
	;; (offset-x, offset-y).
	(define (ellipse-point width height θ [offset-x 0] [offset-y 0])
	(make-object point% (+ offset-x (* (/ width 2) (cos θ)))
	(+ offset-y (* (/ height 2) (sin θ)))))

	;; circumscribed-triangle: real? real? -> pict?
	;; Draws a triangle whose points lie on an ellipse filling the rectangle
	;; (0,0)-(width,height). Each point is positioned by its angular position.
	;; The triangle may be optionally filled with a #:color argument. If given
	;; a positive #:border-width argument, the triangle will have a border of
	;; color #:border-color.
	(define (circumscribed-triangle width height
	#:angle0 [angle0 (/ pi 2)]
	#:angle1 [angle1 (+ angle0 (* 2/3 pi))]
	#:angle2 [angle2 (+ angle1 (* 2/3 pi))]
	#:color [color #f]
	#:border-color [border-color "black"]
	#:border-width [border-width #f])
	(draw-shape/border width height
	(λ (dc dx dy)
	(define radius (/ (min width height) 2))
	(send dc draw-polygon
	(list (ellipse-point width height angle0 dx dy)
	(ellipse-point width height angle1 dx dy)
	(ellipse-point width height angle2 dx dy))
	(/ width 2) (/ height 2)))
	color border-color border-width
	#:draw-border? (or border-color border-width)
	#:transparent? (not color)))

	;; equilateral-triangle: draws a circumscribed triangle with all points
	;; equidistant from each other on the circle. The triangle can be optionally
	;; rotated.
	(define (equilateral-triangle width height
	#:angle [angle 0]
	#:color [color #f]
	#:border-color [border-color #f])
	(circumscribed-triangle width height
	#:angle0 (+ (/ pi 2) angle)
	#:angle1 (+ (/ pi 2) angle (* 2/3 pi))
	#:angle2 (+ (/ pi 2) angle (* 4/3 pi))
	#:color color #:border-color border-color
	#:border-width (and border-color 1)))

	(define (polar r θ)
	(cons (* r (cos θ)) (* r (sin θ))))

	(define (default-ear-extent height) (/ height 4))
	(define default-ear-arc (* pi 1/4))
	(define (default-left-ear-angle left-ear-arc)
	(- (* 2/3 pi) (/ left-ear-arc 2)))
	(define (default-right-ear-angle right-ear-arc)
	(- (* 1/3 pi) (/ right-ear-arc 2)))

	(define (cat-silhouette width height
	;; How much farther than the circle does the ear extend?
	#:left-ear-extent [left-ear-extent (default-ear-extent height)]
	;; How much of an arc does the ear sweep out?
	#:left-ear-arc [left-ear-arc default-ear-arc]
	;; At what angle do we start drawing the ear?
	#:left-ear-angle [left-ear-angle (default-left-ear-angle left-ear-arc)]
	#:right-ear-extent [right-ear-extent (default-ear-extent height)]
	#:right-ear-arc [right-ear-arc default-ear-arc]
	#:right-ear-angle [right-ear-angle (default-right-ear-angle right-ear-arc)]
	#:color [color "orange"]
	#:border-color [border-color (make-object color% 200 80 100)]
	#:border-width [border-width 1])
	(define x-radius (/ width 2))
	(define y-radius (/ height 2))

	(define left-ear-tip
	(polar (+ left-ear-extent x-radius) (+ left-ear-angle (/ left-ear-arc 2))))
	(define right-ear-tip
	(polar (+ right-ear-extent x-radius) (+ right-ear-angle (/ right-ear-arc 2))))

	;; All calculations done in cat-face-center-is-(0,0) coordinates.
	(define left-protrusion
	(min (- x-radius) (car left-ear-tip) (car right-ear-tip)))
	(define right-protrusion
	(max x-radius (car right-ear-tip) (car left-ear-tip)))
	(define top-protrusion
	(max y-radius (cdr left-ear-tip) (cdr right-ear-tip)))
	(define bottom-protrusion
	(min (- y-radius) (cdr left-ear-tip) (cdr right-ear-tip)))

	;; All protrusions affect what the overall coordinate space is.
	;; If an ear extends past the leftmost or topmost extent of the base circle,
	;; then all coordinates must be adjusted by the difference from the circle.
	;; If an ear extends past the rightmost or bottommost extent of the circle,
	;; that difference (plus the left/top difference) add to the width and
	;; height of the image.
	;; The left and top protrusions are what shift our coordinate space.
	;; The right and bottom protrusions possibly add to the overall width
	;; and height.
	(define adjust-left (+ (- (max 0 (+ left-protrusion x-radius)))
	(or border-width 0)))
	(define adjust-top (max 0 (- (+ (or border-width 0) top-protrusion)
	y-radius)))

	(define (from-cat-coords point)
	(match-define (cons x y)
	(cond [(pair? point) point]
	[else (cons (send point get-x) (send point get-y))]))
	(cons (+ x adjust-left x-radius) (- (+ y-radius adjust-top) y)))

	(define left-ear-end
	(from-cat-coords
	(ellipse-point width height (+ left-ear-angle left-ear-arc))))
	(define right-ear-end
	(from-cat-coords
	(ellipse-point width height (+ right-ear-angle right-ear-arc))))

	(define width*
	(+ adjust-left x-radius right-protrusion (or border-width 0)))
	(define height*
	(+ adjust-top y-radius (- bottom-protrusion) (or border-width 0)))
	(values
	(draw-shape/border width*
	height*
	(λ (dc dx dy)
	(define cat-path (new dc-path%))
	(send cat-path arc
	adjust-left adjust-top
	width height
	(+ left-ear-angle left-ear-arc)
	right-ear-angle)
	(send cat-path lines
	(list (from-cat-coords right-ear-tip)
	right-ear-end))
	(send cat-path arc
	adjust-left adjust-top
	width height
	(+ right-ear-angle right-ear-arc)
	left-ear-angle)
	(send cat-path lines
	(list (from-cat-coords left-ear-tip)
	left-ear-end))
	(send cat-path close)
	(send dc draw-path cat-path dx dy))
	color border-color border-width
	#:draw-border? border-width
	#:transparent? (not color))
	from-cat-coords))

	;; ear-positioning-errors: 4 reals -> #f or Listof[String]
	;; Checks for errors in a cat's ear positioning. Error messages are
	;; returned as a list of strings (descriptions of the errors).
	(define (ear-positioning-errors in-left-ear-arc in-left-ear-angle
	in-right-ear-arc in-right-ear-angle)
	(define left-ear-arc (if (unsupplied-arg? in-left-ear-arc)
	default-ear-arc
	in-left-ear-arc))
	(define left-ear-angle (if (unsupplied-arg? in-left-ear-angle)
	(default-left-ear-angle left-ear-arc)
	in-left-ear-angle))
	(define right-ear-arc (if (unsupplied-arg? in-right-ear-arc)
	default-ear-arc
	in-right-ear-arc))
	(define right-ear-angle (if (unsupplied-arg? in-right-ear-angle)
	(default-right-ear-angle right-ear-arc)
	in-right-ear-angle))

	(define messages
	(list
	(and (< left-ear-angle right-ear-angle)
	(list "Left ear is to the right of the right ear"))
	(and (> (+ left-ear-arc right-ear-arc) (* 2 pi))
	(list "Ear arcs cannot exceed 2pi"))
	(and (> (+ right-ear-angle right-ear-arc) left-ear-angle)
	(list "Right ear cannot overlap with left ear"))
	(and (> (+ left-ear-angle left-ear-arc) (+ (* 2 pi) right-ear-angle))
	(list "Left ear cannot overlap with right ear"))))
	(define errors (filter values messages))
	(or (null? errors) errors))

	(define (happy-eyes width height
	#:boldness [boldness 0.2]
	#:color [color "black"]
	#:border-color [border-color "black"]
	#:border-width [border-width #f])
	;; More boldness = less height for the smaller ellipse.
	(define height-percent (- 1 boldness))
	(unless (< 0 boldness 1)
	(error 'happy-eyes "Boldness must be between 0 and 1 exclusive"))
	(draw-shape/border width height
	(lambda (dc dx dy)
	(define eye-path (new dc-path%))
	(send eye-path arc 0 0 width height 0 pi)
	(send eye-path arc 0 (* height boldness)
	width (* height height-percent) pi 0 #f)
	(send eye-path close)
	(send dc draw-path eye-path dx dy))
	color border-color border-width
	#:draw-border? border-width
	#:transparent? (not color)))

	(define (standard-cat/transform width height
	#:left-ear-extent [left-ear-extent (default-ear-extent height)]
	#:left-ear-arc [left-ear-arc default-ear-arc]
	#:left-ear-angle [left-ear-angle (default-left-ear-angle left-ear-arc)]
	#:right-ear-extent [right-ear-extent (default-ear-extent height)]
	#:right-ear-arc [right-ear-arc default-ear-arc]
	#:right-ear-angle [right-ear-angle (default-right-ear-angle right-ear-arc)]
	#:fur-color [fur-color "orange"]
	#:fur-border-color [fur-border-color (make-object color% 200 80 100)]
	#:eye-color [eye-color "black"]
	#:nose-color [nose-color "pink"]
	#:nose [nose (equilateral-triangle (/ width 4) (/ height 4) #:angle pi #:color nose-color)]
	#:lip-color [lip-color (make-object color% 240 140 0)]
	#:lip-border-color [lip-border-color fur-border-color]
	#:lip-border-width [lip-border-width 1]
	#:happy? [happy? #f]
	#:eyes [eyes
	(if happy?
	(happy-eyes (/ width 6) (/ height 6) #:color eye-color)
	(filled-ellipse (/ width 6) (/ height 6) #:color eye-color))]
	#:left-eye [left-eye #f]
	#:right-eye [right-eye #f]
	#:whisker-length [whisker-length (* 3/8 width)]
	#:whisker-droop [whisker-droop (* 1/6 height)]
	#:whisker-color [whisker-color (make-object color% 100 40 50)]
	#:whisker-width [whisker-width 1]
	#:whisker-inset? [whisker-inset? #t]
	#:border-width [border-width 1])
	(define-values (face coord-fn)
	(cat-silhouette width height
	#:left-ear-extent left-ear-extent
	#:left-ear-arc left-ear-arc
	#:left-ear-angle left-ear-angle
	#:right-ear-extent right-ear-extent
	#:right-ear-arc right-ear-arc
	#:right-ear-angle right-ear-angle
	#:color fur-color
	#:border-color fur-border-color
	#:border-width border-width))

	(match-define (cons pre-center-x center-y) (coord-fn (cons 0 0)))

	(define left-whisker-center-offset
	(* -3/4 (pict-width nose)))
	(define left-whisker-extent-from-center
	(+ (- whisker-length) left-whisker-center-offset))
	(define left-whisker-inset-amount
	(if whisker-inset?
	(max 0 (- (car (coord-fn (cons left-whisker-extent-from-center 0)))))
	0))

	(define right-whisker-center-offset
	(* 3/4 (pict-width nose)))
	(define right-whisker-extent-from-center
	(+ whisker-length right-whisker-center-offset))
	(define right-whisker-inset-amount
	(if whisker-inset?
	(max 0 (- (car (coord-fn (cons right-whisker-extent-from-center 0)))
	(pict-width face)))
	0))

	;; If we don't show the whiskers, we don't need to inset the face
	;; in order to draw them past the extent of the cat silhouette.
	(define-values (center-x face*)
	(cond [(not whisker-width) (values pre-center-x face)]
	[else
	(define inset-face
	(inset face left-whisker-inset-amount 0
	right-whisker-inset-amount 0))
	(values (+ pre-center-x left-whisker-inset-amount)
	inset-face)]))

	(define face-and-nose
	(pin-over face*
	(- center-x (/ (pict-width nose) 2))
	(- center-y (/ (pict-height nose) 2))
	nose))

	(define lip
	(draw-shape/border (/ width 4) (/ height 4)
	(λ (dc dx dy)
	(send dc draw-arc dx dy (/ width 4) (/ height 4) pi 0))
	lip-color lip-border-color lip-border-width
	#:draw-border? lip-border-width
	#:transparent? (not lip-color)))

	(define left-lip
	(pin-over face-and-nose
	(- center-x (pict-width lip))
	center-y
	lip))

	(define lips
	(pin-over left-lip center-x center-y lip))

	(define select-left-eye (or left-eye eyes))
	(define with-left-eye
	(pin-over lips
	(- center-x (pict-width select-left-eye) (/ (pict-width nose) 2))
	(- center-y (pict-height nose))
	select-left-eye))

	(define with-eyes
	(pin-over with-left-eye
	(+ center-x (/ (pict-width nose) 2))
	(- center-y (pict-height nose))
	(or right-eye eyes)))

	(cond
	[(not whisker-width) (values with-eyes coord-fn)]
	[else
	(define left-whisker
	(draw-shape/border
	(/ width 2) (/ height 16)
	(λ (dc dx dy)
	(send dc draw-spline dx dy
	(- dx (* 5/8 whisker-length))
	(+ dy (* 1/16 height))
	(- dx whisker-length)
	(+ dy whisker-droop)))
	#f whisker-color whisker-width
	#:draw-border? whisker-width
	#:transparent? #f))

	(define right-whisker
	(draw-shape/border
	(/ width 2) (/ height 16)
	(λ (dc dx dy)
	(send dc draw-spline dx dy
	(+ dx (* 5/8 whisker-length))
	(+ dy (* 1/16 height))
	(+ dx whisker-length)
	(+ dy whisker-droop)))
	#f whisker-color whisker-width
	#:draw-border? whisker-width
	#:transparent? #f))

	(define with-whisker0
	(pin-over with-eyes
	(- center-x (/ (pict-width nose) 2))
	(+ center-y (/ (pict-height nose) 2))
	left-whisker))

	(define with-whisker1
	(pin-over with-whisker0
	(+ center-x left-whisker-center-offset)
	(+ center-y (* 1/4 (pict-height nose)))
	left-whisker))

	(define with-whisker2
	(pin-over with-whisker1
	(+ center-x (/ (pict-width nose) 2))
	(+ center-y (/ (pict-height nose) 2))
	right-whisker))

	(values
	(pin-over with-whisker2
	(+ center-x right-whisker-center-offset)
	(+ center-y (* 1/4 (pict-height nose)))
	right-whisker)
	(λ (pair)
	(match-define (cons dx dy) (coord-fn pair))
	(cons (+ left-whisker-inset-amount dx) dy)))]))

	(define (standard-cat width height
	#:left-ear-extent [left-ear-extent (default-ear-extent height)]
	#:left-ear-arc [left-ear-arc default-ear-arc]
	#:left-ear-angle [left-ear-angle (default-left-ear-angle left-ear-arc)]
	#:right-ear-extent [right-ear-extent (default-ear-extent height)]
	#:right-ear-arc [right-ear-arc default-ear-arc]
	#:right-ear-angle [right-ear-angle (default-right-ear-angle right-ear-arc)]
	#:fur-color [fur-color "orange"]
	#:fur-border-color [fur-border-color (make-object color% 200 80 100)]
	#:eye-color [eye-color "black"]
	#:nose-color [nose-color "pink"]
	#:nose [nose (equilateral-triangle (/ width 4) (/ height 4) #:angle pi #:color nose-color)]
	#:lip-color [lip-color (make-object color% 240 140 0)]
	#:lip-border-color [lip-border-color fur-border-color]
	#:lip-border-width [lip-border-width 1]
	#:happy? [happy? #f]
	#:eyes [eyes
	(if happy?
	(happy-eyes (/ width 6) (/ height 6) #:color eye-color)
	(filled-ellipse (/ width 6) (/ height 6) #:color eye-color))]
	#:left-eye [left-eye #f]
	#:right-eye [right-eye #f]
	#:whisker-length [whisker-length (* 3/8 width)]
	#:whisker-droop [whisker-droop (* 1/6 height)]
	#:whisker-color [whisker-color (make-object color% 100 40 50)]
	#:whisker-width [whisker-width 1]
	#:whisker-inset? [whisker-inset? #t]
	#:border-width [border-width 1])
	(define-values (cat _) (standard-cat/transform
	width height
	#:left-ear-extent left-ear-extent
	#:left-ear-arc left-ear-arc
	#:left-ear-angle left-ear-angle
	#:right-ear-extent left-ear-extent
	#:right-ear-arc right-ear-arc
	#:right-ear-angle right-ear-angle
	#:fur-color fur-color
	#:fur-border-color fur-border-color
	#:eye-color eye-color
	#:nose-color nose-color
	#:nose nose
	#:lip-color lip-color
	#:lip-border-color lip-border-color
	#:happy? happy?
	#:eyes eyes
	#:left-eye left-eye
	#:right-eye right-eye
	#:whisker-length whisker-length
	#:whisker-droop whisker-droop
	#:whisker-color whisker-color
	#:whisker-width whisker-width
	#:whisker-inset? whisker-inset?
	#:border-width border-width))
	cat)

	;; Wink!
	(standard-cat 50 90 #:happy? #t #:left-eye (filled-ellipse (/ 50 6) (/ 90 6)))