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