0. #lang racket
1.  
2. (require pict racket/draw)
3.  
4. ;; Not exported by pict/private/utils.rkt
5. (define (draw-shape/border w h draw-fun
6.                              color [border-color #f] [border-width #f]
7.                              #:draw-border? [draw-border? #t]
8.                              #:transparent? [transparent? #f])
9.     (dc (λ (dc dx dy)
10.           (define old-brush (send dc get-brush))
11.           (define old-pen   (send dc get-pen))
12.           (send dc set-brush
13.                 (send the-brush-list find-or-create-brush
14.                       (cond [transparent? "white"]
15.                             [color        color]
16.                             [else         (send old-pen get-color)])
17.                       (if transparent? 'transparent 'solid)))
18.           (if draw-border?
19.               (when (or border-color border-width)
20.                 ;; otherwise, leave pen as is
21.                 (send dc set-pen (send the-pen-list
22.                                        find-or-create-pen
23.                                        (or border-color
24.                                            (send old-pen get-color))
25.                                        (or border-width
26.                                            (send old-pen get-width))
27.                                        (send old-pen get-style))))
28.               (send dc set-pen "black" 1 'transparent))
29.           (draw-fun dc dx dy)
30.           (send dc set-brush old-brush)
31.           (send dc set-pen   old-pen))
32.         w h))
33.  
34. (define (circumscribed-triangle width height
35.         #:angle0 [angle0 (/ pi 2)]
36.         #:angle1 [angle1 (+ angle0 (* 2/3 pi))]
37.         #:angle2 [angle2 (+ angle1 (* 2/3 pi))]
38.         #:color [color #f]
39.         #:border-color [border-color #f]
40.         #:border-width [border-width #f])
41.   (draw-shape/border width height
42.                      (λ (dc dx dy)
43.                        (define radius (/ (min width height) 2))
44.                        (send dc draw-polygon
45.                              (list (make-object point% (+ dx (* radius (cos angle0))) (- dy (* radius (sin angle0))))
46.                                    (make-object point% (+ dx (* radius (cos angle1))) (- dy (* radius (sin angle1))))
47.                                    (make-object point% (+ dx (* radius (cos angle2))) (- dy (* radius (sin angle2)))))
48.                              (/ width 2) (/ height 2)))
49.                      color border-color border-width
50.                      #:draw-border? (or border-color border-width)
51.                      #:transparent? #f))
52.  
53. (define (isoceles-triangle width height
54.                            #:angle [angle 0]
55.                            #:color [color #f]
56.                            #:border-color [border-color #f])
57.   (circumscribed-triangle width height
58.                           #:angle0 (+ (/ pi 2) angle)
59.                           #:angle1 (+ angle (* 4/3 pi))
60.                           #:angle2 (+ angle (* 5/3 pi))
61.                           #:color color #:border-color border-color
62.                           #:border-width (and border-color 1)))
63.  
64.  
65. (define (equilateral-triangle width height
66.                               #:angle [angle 0]
67.                               #:color [color #f]
68.                               #:border-color [border-color #f])
69.   (circumscribed-triangle width height
70.                           #:angle0 (+ (/ pi 2) angle)
71.                           #:angle1 (+ (/ pi 2) angle (* 2/3 pi))
72.                           #:angle2 (+ (/ pi 2) angle (* 4/3 pi))
73.                           #:color color #:border-color border-color
74.                           #:border-width (and border-color 1)))
75.  
76. (define (polar r θ)
77.   (cons (* r (cos θ)) (* r (sin θ))))
78.  
79. (define (cat-silhouette radius ;; radius of the cat face
80.                         ;; How much farther than the circle does the ear extend?
81.                         #:left-ear-extent [left-ear-extent (/ radius 2)]
82.                         ;; How much of an arc does the ear sweep out?
83.                         #:left-ear-arc [left-ear-arc (* pi 1/4)]
84.                         ;; At what angle do we start drawing the ear?
85.                         #:left-ear-angle [left-ear-angle (- (* 2/3 pi) (/ left-ear-arc 2))]
86.                         #:right-ear-extent [right-ear-extent (/ radius 2)]
87.                         #:right-ear-arc [right-ear-arc (* pi 1/4)]
88.                         #:right-ear-angle [right-ear-angle (- (* 1/3 pi) (/ right-ear-arc 2))]
89.                         #:color [color "orange"]
90.                         #:border-color [border-color (make-object color% 200 80 100)]
91.                         #:border-width [border-width 1])
92.   (when (> (+ left-ear-arc right-ear-arc) (* 2 pi))
93.     (error 'cat-silhouette "Ear arcs cannot exceed 2pi"))
94.   (when (> (+ right-ear-angle right-ear-arc) left-ear-angle)
95.     (error 'cat-silhouette "Right ear cannot overlap with left ear"))
96.   (when (> (+ left-ear-angle left-ear-arc) (+ (* 2 pi) right-ear-angle))
97.     (error 'cat-silhouette "Left ear cannot overlap with right ear"))
98.  
99.   (define left-ear-tip
100.     (polar (+ left-ear-extent radius) (+ left-ear-angle (/ left-ear-arc 2))))
101.   (define right-ear-tip
102.     (polar (+ right-ear-extent radius) (+ right-ear-angle (/ right-ear-arc 2))))
103.  
104.   ;; All calculations done in cat-face-center-is-(0,0) coordinates.
105.   (define left-protrusion
106.     (min (- radius) (car left-ear-tip) (car right-ear-tip)))
107.   (define right-protrusion
108.     (max radius (car right-ear-tip) (car left-ear-tip)))
109.   (define top-protrusion
110.     (max radius (cdr left-ear-tip) (cdr right-ear-tip)))
111.   (define bottom-protrusion
112.     (min (- radius) (cdr left-ear-tip) (cdr right-ear-tip)))
113.  
114.   ;; All protrusions affect what the overall coordinate space is.
115.   ;; If an ear extends past the leftmost or topmost extent of the base circle,
116.   ;; then all coordinates must be adjusted by the difference from the circle.
117.   ;; If an ear extends past the rightmost or bottommost extent of the circle,
118.   ;; that difference (plus the left/top difference) add to the width and
119.   ;; height of the image.
120.   ;; The left and top protrusions are what shift our coordinate space.
121.   ;; The right and bottom protrusions possibly add to the overall width
122.   ;; and height.
123.   (define adjust-left (+ (- (max 0 (+ left-protrusion radius)))
124.                          (or border-width 0)))
125.   (define adjust-top (max 0 (- (+ (or border-width 0) top-protrusion) radius)))
126.  
127.   (define (from-cat-coords point)
128.     (match-define (cons x y) point)
129.     (cons (+ x adjust-left radius) (- (+ radius adjust-top) y)))
130.  
131.   (define left-ear-end
132.     (from-cat-coords
133.     (polar radius (+ left-ear-angle left-ear-arc))))
134.   (define right-ear-end
135.     (from-cat-coords
136.      (polar radius (+ right-ear-angle right-ear-arc))))
137.  
138.   (define width
139.     (+ adjust-left radius right-protrusion (or border-width 0)))
140.   (define height
141.     (+ adjust-top radius (- bottom-protrusion) (or border-width 0)))
142.   (values
143.   (draw-shape/border width
144.                      height
145.                      (λ (dc dx dy)
146.                        (define diameter (* radius 2))
147.                        (define cat-path (new dc-path%))
148.                        (send cat-path arc
149.                              (+ adjust-left dx) (+ adjust-top dy)
150.                              diameter diameter
151.                              (+ left-ear-angle left-ear-arc)
152.                              right-ear-angle)
153.                        (send cat-path lines
154.                              (list (from-cat-coords right-ear-tip)
155.                                    right-ear-end))
156.                        (send cat-path arc
157.                              (+ adjust-left dx) (+ adjust-top dy)
158.                              diameter diameter
159.                              (+ right-ear-angle right-ear-arc)
160.                              left-ear-angle)
161.                        (send cat-path lines
162.                              (list (from-cat-coords left-ear-tip)
163.                                    left-ear-end))
164.                        (send cat-path close)
165.                        (send dc draw-path cat-path dx dy))
166.                      color border-color border-width
167.                      #:draw-border? border-width
168.                      #:transparent? #f)
169.   from-cat-coords))
170.  
171. (define (happy-eyes width height
172.                     #:boldness [boldness 0.2]
173.                     #:color [color "black"]
174.                     #:border-color [border-color "black"]
175.                     #:border-width [border-width #f])
176.   ;; More boldness = less height for the smaller ellipse.
177.   (define height-percent (- 1 boldness))
178.   (unless (< 0 boldness 1)
179.           (error 'happy-eyes "Boldness must be between 0 and 1 exclusive"))
180.   (draw-shape/border width height
181.     (lambda (dc dx dy)
182.       (define eye-path (new dc-path%))
183.       (send eye-path arc dx dy width height 0 pi)
184.       (send eye-path arc dx (+ dy (* height boldness))
185.             width (* height height-percent) pi 0 #f)
186.       (send eye-path close)
187.       (send dc draw-path eye-path dx dy))
188.       color border-color border-width
189.       #:draw-border? border-width
190.       #:transparent? #f))
191.  
192. (define (standard-cat radius
193.                       #:left-ear-extent [left-ear-extent (/ radius 2)]
194.                       #:left-ear-arc [left-ear-arc (* pi 1/4)]
195.                       #:left-ear-angle [left-ear-angle (- (* 2/3 pi) (/ left-ear-arc 2))]
196.                       #:right-ear-extent [right-ear-extent (/ radius 2)]
197.                       #:right-ear-arc [right-ear-arc (* pi 1/4)]
198.                       #:right-ear-angle [right-ear-angle (- (* 1/3 pi) (/ right-ear-arc 2))]
199.                       #:fur-color [fur-color "orange"]
200.                       #:fur-border-color [fur-border-color (make-object color% 200 80 100)]
201.                       #:eye-color [eye-color "black"]
202.                       #:nose-color [nose-color "pink"]
203.                       #:nose [nose (equilateral-triangle (/ radius 2) (/ radius 2) #:angle pi #:color nose-color)]
204.                       #:happy? [happy? #f]
205.                       #:eyes [eyes
206.                               (if happy?
207.                                   (happy-eyes (/ radius 3) (/ radius 3) #:color eye-color)
208.                                   (filled-ellipse (/ radius 3) (/ radius 3) #:color eye-color))]
209.                       #:left-eye [left-eye #f]
210.                       #:right-eye [right-eye #f]
211.                       #:border-width [border-width 1])
212.   (define radius2 (* 1/2 radius))
213.   (define-values (face coord-fn)
214.     (cat-silhouette radius
215.                     #:left-ear-extent left-ear-extent
216.                     #:left-ear-arc left-ear-arc
217.                     #:left-ear-angle left-ear-angle
218.                     #:right-ear-extent right-ear-extent
219.                     #:right-ear-arc right-ear-arc
220.                     #:right-ear-angle right-ear-angle
221.                     #:color fur-color
222.                     #:border-color fur-border-color
223.                     #:border-width border-width))
224.   (match-define (cons center-x center-y) (coord-fn (cons 0 0)))
225.  
226.   (define face-and-nose
227.   (pin-over face
228.             (- center-x (/ (pict-width nose) 2))
229.             (- center-y (/ (pict-height nose) 2))
230.             nose))
231.  
232.   (define lip
233.     (draw-shape/border radius2 radius2
234.                      (λ (dc dx dy)
235.                        (send dc draw-arc dx dy radius2 radius2 pi 0))
236.                      fur-color fur-border-color 1))
237.  
238.   (define left-lip
239.     (pin-over face-and-nose
240.               (- center-x (pict-width lip))
241.               center-y
242.               lip))
243.  
244.   (define lips
245.     (pin-over left-lip center-x center-y lip))
246.  
247.   (define select-left-eye (or left-eye eyes))
248.   (define with-left-eye
249.     (pin-over lips
250.               (- center-x (pict-width select-left-eye) (/ (pict-width nose) 2))
251.               (- center-y (pict-height nose))
252.               select-left-eye))
253.  
254.   (pin-over with-left-eye
255.             (+ center-x (/ (pict-width nose) 2))
256.             (- center-y (pict-height nose))
257.             (or right-eye eyes)))
258.  
259. (dc (lambda (dc dx dy)
260.       (define eye-path (new dc-path%))
261.       (send eye-path arc dx dy 50 100 0 pi)
262.       (send eye-path arc dx dy 50 50 pi 0 #f)
263.       (send eye-path close)
264.       (send dc draw-path dx dy 50 100))
265.      50 100)
266. (standard-cat 50)
267. (standard-cat 50 #:happy? #t)

=>

draw-path: contract violation

expected: (is-a?/c dc-path%)

given: 0

in: the 1st argument of

(->*m

((is-a?/c dc-path%))

(real? real? (or/c 'odd-even 'winding))

void?)

contract from: (class bitmap-dc%)

blaming: <pkgs>/pict-lib/pict/main.rkt

(assuming the contract is correct)