1#lang racket/base
2
3(provide define/chk
4         x-place?
5         y-place?
6         mode?
7         angle?
8         side-count?
9         image-color?
10         pen-style?
11         pen-cap?
12         pen-join?
13         real-valued-posn?
14         step-count?
15         check-mode/color-combination)
16
17(require htdp/error
18         racket/class
19         racket/contract
20         lang/posn
21         (except-in racket/draw
22                    make-pen make-color)
23         mrlib/image-core
24         (for-syntax racket/base
25                     racket/list))
26
27;
28;
29;
30;
31;
32;
33;                                              ;;                      ;;      ;;
34;                                              ;;                      ;;      ;;
35;    ;;;;   ;;;;;;;;;  ;;;;   ;;;;      ;;;;   ;;;;;;   ;;;;    ;;;;   ;; ;;;  ;;  ;; ;;;  ;;;;;;
36;   ;;  ;;  ;;;; ;;;; ;;;;;;  ;;;;     ;;;;;;  ;;;;;;  ;;  ;;  ;;;;;;  ;;;;;   ;;  ;;;;;;  ;;;;;;
37;  ;;;;;;;; ;;   ;;  ;;;  ;;; ;;      ;;;      ;;  ;; ;;;;;;;;;;;      ;;;;;   ;;  ;;  ;; ;;;  ;;
38;  ;;;      ;;   ;;  ;;;  ;;; ;;      ;;;      ;;  ;; ;;;     ;;;      ;;;;;   ;;  ;;  ;; ;;;  ;;
39;   ;;; ;;  ;;   ;;   ;;;;;;  ;;       ;;;;;;  ;;  ;;  ;;; ;;  ;;;;;;  ;;  ;;  ;;  ;;  ;;  ;;;;;;
40;    ;;;;   ;;   ;;    ;;;;   ;;        ;;;;   ;;  ;;   ;;;;    ;;;;   ;;  ;;; ;;  ;;  ;;   ;;;;;
41;                                                                                          ;; ;;;
42;                                                                                          ;;;;;
43;
44;
45
46
47(define-syntax define/chk
48  (λ (stx)
49    (define (adjust-case fn-name case-args bodies)
50      (syntax-case case-args ()
51        [(args ... . final-arg)
52         (identifier? #'final-arg)
53         (let ([len (length (syntax->list #'(args ...)))])
54           (with-syntax ([(i ...) (build-list len add1)])
55             #`((args ... . final-arg)
56                (let ([args (check/normalize '#,fn-name 'args args i)] ...
57                      [final-arg
58                       (for/list ([x (in-list final-arg)]
59                                  [j (in-naturals #,(+ len 1))])
60                         (check/normalize '#,fn-name 'final-arg x j))])
61                  #,@bodies))))]
62        [(args ...)
63         (with-syntax ([(i ...) (build-list (length (syntax->list #'(args ...))) add1)]
64                       [(arg-ids ...)
65                        (map (λ (arg)
66                               (syntax-case arg ()
67                                 [x
68                                  (identifier? #'x)
69                                  #'x]
70                                 [(x y)
71                                  (identifier? #'x)
72                                  #'x]
73                                 [_
74                                  (raise-syntax-error 'define/chk "unknown argument spec" stx arg)]))
75                             (syntax->list #'(args ...)))])
76           #`((args ...)
77              (let ([arg-ids (check/normalize '#,fn-name 'arg-ids arg-ids i)] ...)
78                #,@bodies)))]))
79    (syntax-case stx (case-lambda)
80      [(define/chk fn-name (case-lambda [in-args in-body ...] ...))
81       (with-syntax ([((args body) ...) (map (lambda (a b) (adjust-case #'fn-name a b))
82                                             (syntax->list #'(in-args ...))
83                                             (syntax->list #'((in-body ...) ...)))])
84         #'(define fn-name
85             (case-lambda
86               [args body] ...)))]
87      [(define/chk (fn-name . args) body ...)
88       (with-syntax ([(args body) (adjust-case #'fn-name #'args #'(body ...))])
89         (quasisyntax/loc stx (define (fn-name . args) body)))])))
90
91;; check/normalize : symbol symbol any number -> any
92;; based on the name of the argument, checks to see if the input
93;; is valid and, if so, transforms it to a specific kind of value
94;;   width, height -> number
95;;   mode -> 'outline 'solid
96;;   color -> (is-a?/c color<%>)
97(define (check/normalize fn-name argname arg i)
98  (case argname
99    [(x-place)
100     (check-arg fn-name
101                (x-place? arg)
102                'x-place
103                i
104                arg)
105     (let ([sym (if (string? arg)
106                    (string->symbol arg)
107                    arg)])
108       (if (eq? sym 'center)
109           'middle
110           sym))]
111    [(y-place)
112     (check-arg fn-name
113                (y-place? arg)
114                'y-place
115                i
116                arg)
117     (let ([sym (if (string? arg)
118                    (string->symbol arg)
119                    arg)])
120       (if (eq? sym 'center)
121           'middle
122           sym))]
123    [(image image1 image2 image3)
124     (check-arg fn-name
125                (image? arg)
126                'image
127                i
128                arg)
129     (to-img arg)]
130    [(images)
131     (check-arg fn-name (and (list? arg) (andmap image? arg)) 'image-list i arg)
132     (for/list ([i (in-list arg)])
133       (to-img i))]
134    [(mode)
135     (check-arg fn-name
136                (mode? arg)
137                'mode
138                i
139                arg)
140     (cond
141       [(or (equal? arg "solid")
142            (equal? arg 'solid))
143        255]
144       [(equal? arg "outline")
145        'outline]
146       [(and (integer? arg)
147             (not (exact? arg)))
148        (inexact->exact arg)]
149       [else arg])]
150    [(width height radius radius1 radius2 side-length side-length1 side-length2
151            side-a side-b side-c)
152     (check-arg fn-name
153                (and (real? arg)
154                     (not (negative? arg)))
155                'non\ negative\ real\ number
156                i arg)
157     arg]
158    [(point-count)
159     (check-arg fn-name
160                (and (integer? arg)
161                     (>= arg 2))
162                'integer\ greater\ than\ or\ equal\ to\ 2
163                i arg)
164     (inexact->exact arg)]
165    [(dx dy x y x1 y1 x2 y2 pull pull1 pull2)
166     (check-arg fn-name
167                (real? arg)
168                'real\ number
169                i arg)
170     arg]
171    [(factor x-factor y-factor non-zero-radius)
172     (check-arg fn-name
173                (and (real? arg)
174                     (positive? arg))
175                'positive\ real\ number
176                i arg)
177     arg]
178    [(side-count)
179     (check-arg fn-name
180                (side-count? arg)
181                'side-count
182                i arg)
183     (inexact->exact arg)]
184    [(step-count)
185     (check-arg fn-name
186                (step-count? arg)
187                'step-count
188                i arg)
189     (inexact->exact arg)]
190    [(angle angle1 angle2 angle-a angle-b angle-c)
191     (check-arg fn-name
192                (angle? arg)
193                'angle\ in\ degrees
194                i arg)
195     (angle->proper-range arg)]
196    [(angle-between-0-and-360)
197     (check-arg fn-name
198                (angle? arg)
199                'angle\ in\ degrees
200                i arg)
201     (check-arg fn-name
202                (<= 0 arg 360)
203                '|angle between 0 and 360|
204                i arg)
205     (check-arg fn-name
206                (not (= 0 arg))
207                '|angle that is not 0|
208                i arg)
209     (check-arg fn-name
210                (not (= 360 arg))
211                '|angle that is not 360|
212                i arg)
213     arg]
214    [(color-only)
215     (check-arg fn-name (image-color? arg) 'image-color i arg)
216     (cond
217       [(color? arg) arg]
218       [(string? arg) arg]
219       [(symbol? arg) (symbol->string arg)])]
220    [(color)
221     (check-arg fn-name (or (image-color? arg) (pen? arg)) 'image-color-or-pen i arg)
222     ;; return either a string, color, or a pen,
223     ;; (technically, the string case is redundant,
224     ;;  but since there may be saved files that have
225     ;;  strings in the color positions we leave them
226     ;;  here too; note that using a pen struct means
227     ;;  'smoothed mode, but a color (or string) means
228     ;;  'aligned mode, so that's not redundant).
229     (cond
230       [(color? arg) arg]
231       [(pen? arg) arg]
232       [(symbol? arg) (symbol->string arg)]
233       [(string? arg) arg])]
234    [(color-list)
235     (check-arg fn-name (and (list? arg) (andmap image-color? arg)) 'color-list i arg)
236     arg]
237    [(string)
238     (check-arg fn-name (string? arg) 'string i arg)
239     arg]
240    [(font-size)
241     (check-arg fn-name (and (integer? arg) (<= 1 arg 255)) 'font-size i arg)
242     (inexact->exact arg)]
243    [(face)
244     (check-arg fn-name (or (not arg) (string? arg)) 'face i arg)
245     arg]
246    [(family)
247     (let ([syms '(default decorative roman script swiss modern symbol system)])
248       (check-arg fn-name
249                  (or (memq arg syms)
250                      (and (string? arg)
251                           (memq (string->symbol arg) syms)))
252                  'family i arg))
253     (if (string? arg) (string->symbol arg) arg)]
254    [(style)
255     (let ([syms '(normal italic slant)])
256       (check-arg fn-name (or (memq arg syms)
257                              (and (string? arg)
258                                   (memq (string->symbol arg) syms)))
259                  'style i arg))
260     (if (string? arg) (string->symbol arg) arg)]
261    [(weight)
262     (let ([syms '(normal bold light)])
263       (check-arg fn-name (or (memq arg syms)
264                              (and (string? arg)
265                                   (memq (string->symbol arg) syms)))
266                  'weight i arg))
267     (if (string? arg) (string->symbol arg) arg)]
268    [(underline)
269     (and arg #t)]
270    [(posns)
271     (check-arg fn-name
272                (and (list? arg)
273                     (andmap posn? arg))
274                'list-of-posns
275                i arg)
276     (check-arg fn-name
277                (andmap real-valued-posn? arg)
278                'list-of-posns-with-real-valued-x-and-y-coordinates
279                i arg)
280     (check-arg fn-name
281                (>= (length arg) 3)
282                'list-of-at-least-three-posns
283                i arg)
284     arg]
285    [(posns-or-pulled-points)
286     (check-arg fn-name
287                (and (list? arg)
288                     (andmap (or/c posn? pulled-point?) arg))
289                'list-of-posns-or-pulled-points
290                i arg)
291     (check-arg fn-name
292                (andmap (or/c pulled-point? real-valued-posn?) arg)
293                'list-of-posns-with-real-valued-x-and-y-coordinates
294                i arg)
295     (check-arg fn-name
296                (>= (length arg) 3)
297                'list-of-at-least-three-posns-or-pulled-points
298                i arg)
299     arg]
300    [(zero-or-more-posns)
301     (check-arg fn-name
302                (and (list? arg)
303                     (andmap posn? arg))
304                'list-of-posns
305                i arg)
306     (check-arg fn-name
307                (andmap real-valued-posn? arg)
308                'list-of-posns-with-real-valued-x-and-y-coordinates
309                i arg)
310     arg]
311    [(int-0-255 int0-255-1 int0-255-2 int0-255-3 int0-255-4)
312     (check-arg fn-name (and (integer? arg) (<= 0 arg 255))
313                'integer\ between\ 0\ and\ 255 i arg)
314     (inexact->exact arg)]
315
316    [(pen-style)
317     (check-arg fn-name (pen-style? arg) 'pen-style i arg)
318     (if (string? arg)
319         (string->symbol arg)
320         arg)]
321    [(pen-cap)
322     (check-arg fn-name (pen-cap? arg) 'pen-cap i arg)
323     (if (string? arg)
324         (string->symbol arg)
325         arg)]
326    [(pen-join)
327     (check-arg fn-name (pen-join? arg) 'pen-join i arg)
328     (if (string? arg)
329         (string->symbol arg)
330         arg)]
331    [(filename)
332     (check-arg fn-name (path-string? arg) 'path-string i arg)
333     arg]
334    [else
335     (error 'check "the function ~a has an argument with an unknown name: ~s"
336            fn-name
337            argname)]))
338
339(define (y-place? arg)
340  (and (member arg '("top" top "bottom" bottom "middle" middle "center" center
341                           "baseline" baseline "pinhole" pinhole))
342       #t))
343(define (x-place? arg)
344  (and (member arg '("left" left "right" right "middle" middle
345                            "center" center "pinhole" pinhole))
346       #t))
347(define (mode? arg)
348  (or (and (member arg '(solid outline "solid" "outline")) #t)
349      (and (integer? arg)
350           (<= 0 arg 255))))
351(define (side-count? i)
352  (and (integer? i)
353       (3 . <= .  i)))
354(define (step-count? i)
355  (and (integer? i)
356       (1 . <= .  i)))
357(define (image-color? c)
358  (cond
359    [(color? c) #t]
360    [(symbol? c)
361     (and (string->color-object/f (symbol->string c)) #t)]
362    [(string? c)
363     (and (string->color-object/f c) #t)]
364    [else #f]))
365
366(define (pen-style? arg)
367  (and (member (if (string? arg) (string->symbol arg) arg)
368               '(solid dot long-dash short-dash dot-dash))
369       #t))
370(define (pen-cap? arg)
371  (and (member (if (string? arg) (string->symbol arg) arg)
372               '(round projecting butt))
373       #t))
374(define (pen-join? arg)
375  (and (member (if (string? arg) (string->symbol arg) arg)
376               '(round bevel miter))
377       #t))
378(define (real-valued-posn? arg)
379  (and (posn? arg)
380       (real? (posn-x arg))
381       (real? (posn-y arg))))
382
383
384;; checks the dependent part of the 'color' specification
385(define (check-mode/color-combination fn-name i mode color)
386  (cond
387    [(or (eq? mode 'solid)
388         (number? mode))
389     (check-arg fn-name (image-color? color) 'image-color i color)]
390    [(eq? mode 'outline)
391     (void)]))
392
393(define (angle? arg)
394  (and (real? arg)
395       (not (or (= arg +inf.0)
396                (= arg -inf.0)
397                (equal? arg +nan.0)))))
398