Remove dynamic checks from racket/draw.
Now that this code has contracts, these checks are redundant. The contracts are at least as precise as the checks are.
This commit is contained in:
parent
c758f65a0b
commit
94a837fcc8
|
@ -112,57 +112,44 @@
|
|||
(and bm
|
||||
(send bm get-bitmap-gl-context))))
|
||||
|
||||
(def/public (set-bitmap [(make-or-false bitmap%) v])
|
||||
(define/public (set-bitmap v)
|
||||
(internal-set-bitmap v))
|
||||
|
||||
(def/public (get-bitmap)
|
||||
(internal-get-bitmap))
|
||||
|
||||
(def/public (set-pixel [real? x][real? y][color% c])
|
||||
(define/public (set-pixel x y c)
|
||||
(let ([s (bytes 255 (color-red c) (color-green c) (color-blue c))])
|
||||
(set-argb-pixels x y 1 1 s)))
|
||||
|
||||
(def/public (get-pixel [real? x][real? y][color% c])
|
||||
(define/public (get-pixel x y c)
|
||||
(let-values ([(w h) (get-size)])
|
||||
(let ([b (make-bytes 4)])
|
||||
(get-argb-pixels x y 1 1 b)
|
||||
(send c set (bytes-ref b 1) (bytes-ref b 2) (bytes-ref b 3))
|
||||
(and (<= 0 x w) (<= 0 y h)))))
|
||||
|
||||
(def/public (set-argb-pixels [exact-nonnegative-integer? x]
|
||||
[exact-nonnegative-integer? y]
|
||||
[exact-nonnegative-integer? w]
|
||||
[exact-nonnegative-integer? h]
|
||||
[bytes? bstr]
|
||||
[any? [set-alpha? #f]]
|
||||
[any? [pre-mult? #f]])
|
||||
(define/public (set-argb-pixels x y w h bstr
|
||||
[set-alpha? #f]
|
||||
[pre-mult? #f])
|
||||
(let ([bm (internal-get-bitmap)])
|
||||
(when bm
|
||||
(send bm set-argb-pixels x y w h bstr set-alpha? pre-mult?))))
|
||||
|
||||
(def/public (get-argb-pixels [exact-nonnegative-integer? x]
|
||||
[exact-nonnegative-integer? y]
|
||||
[exact-nonnegative-integer? w]
|
||||
[exact-nonnegative-integer? h]
|
||||
[bytes? bstr]
|
||||
[any? [get-alpha? #f]]
|
||||
[any? [pre-mult? #f]])
|
||||
(define/public (get-argb-pixels x y w h bstr
|
||||
[get-alpha? #f]
|
||||
[pre-mult? #f])
|
||||
(let ([bm (internal-get-bitmap)])
|
||||
(when bm
|
||||
(send bm get-argb-pixels x y w h bstr get-alpha? pre-mult?))))
|
||||
|
||||
(def/public (draw-bitmap-section-smooth [bitmap% src]
|
||||
[real? dest-x]
|
||||
[real? dest-y]
|
||||
[nonnegative-real? dest-w]
|
||||
[nonnegative-real? dest-h]
|
||||
[real? src-x]
|
||||
[real? src-y]
|
||||
[nonnegative-real? src-w]
|
||||
[nonnegative-real? src-h]
|
||||
[(symbol-in solid opaque xor) [style 'solid]]
|
||||
[(make-or-false color%) [color black]]
|
||||
[(make-or-false bitmap%) [mask #f]])
|
||||
(define/public (draw-bitmap-section-smooth src dest-x dest-y
|
||||
dest-w dest-h
|
||||
src-x src-y
|
||||
src-w src-h
|
||||
[style 'solid]
|
||||
[color black]
|
||||
[mask #f])
|
||||
(let ([sx (if (zero? src-w) 1.0 (/ dest-w src-w))]
|
||||
[sy (if (zero? src-h) 1.0 (/ dest-h src-h))])
|
||||
(let ([t (get-transformation)]
|
||||
|
|
|
@ -286,10 +286,10 @@
|
|||
(define/public (get-bitmap-gl-context)
|
||||
#f)
|
||||
|
||||
(def/public (load-file [(make-alts path-string? input-port?) in]
|
||||
[bitmap-file-kind-symbol? [kind 'unknown]]
|
||||
[(make-or-false color%) [bg #f]]
|
||||
[any? [complain-on-failure? #f]])
|
||||
(define/public (load-file in
|
||||
[kind 'unknown]
|
||||
[bg #f]
|
||||
[complain-on-failure? #f])
|
||||
(check-alternate 'load-file)
|
||||
(release-bitmap-storage)
|
||||
(set!-values (s b&w?) (do-load-bitmap in kind bg complain-on-failure?))
|
||||
|
@ -502,9 +502,7 @@
|
|||
(proc bm)
|
||||
(send bm release-bitmap-storage)))
|
||||
|
||||
(def/public (save-file [(make-alts path-string? output-port?) out]
|
||||
[bitmap-save-kind-symbol? [kind 'unknown]]
|
||||
[quality-integer? [quality 75]])
|
||||
(define/public (save-file out [kind 'unknown] [quality 75])
|
||||
(and (ok?)
|
||||
(begin
|
||||
(if alt?
|
||||
|
@ -625,13 +623,9 @@
|
|||
|
||||
(define/public (get-handle) s)
|
||||
|
||||
(def/public (get-argb-pixels [exact-nonnegative-integer? x]
|
||||
[exact-nonnegative-integer? y]
|
||||
[exact-nonnegative-integer? w]
|
||||
[exact-nonnegative-integer? h]
|
||||
[bytes? bstr]
|
||||
[any? [get-alpha? #f]]
|
||||
[any? [pre-mult? #f]])
|
||||
(define/public (get-argb-pixels x y w h bstr
|
||||
[get-alpha? #f]
|
||||
[pre-mult? #f])
|
||||
(unless ((bytes-length bstr) . >= . (* w h 4))
|
||||
(raise-mismatch-error (method-name 'bitmap% 'get-argb-pixels)
|
||||
"byte string is too short: "
|
||||
|
@ -701,13 +695,9 @@
|
|||
(let ([p (+ (* 4 i) row)])
|
||||
(bytes-set! bstr p 255)))))]))
|
||||
|
||||
(def/public (set-argb-pixels [exact-nonnegative-integer? x]
|
||||
[exact-nonnegative-integer? y]
|
||||
[exact-nonnegative-integer? w]
|
||||
[exact-nonnegative-integer? h]
|
||||
[bytes? bstr]
|
||||
[any? [set-alpha? #f]]
|
||||
[any? [pre-mult? #f]])
|
||||
(define/public (set-argb-pixels x y w h bstr
|
||||
[set-alpha? #f]
|
||||
[pre-mult? #f])
|
||||
(unless ((bytes-length bstr) . >= . (* w h 4))
|
||||
(raise-mismatch-error (method-name 'bitmap% 'set-argb-pixels)
|
||||
"byte string is too short: "
|
||||
|
|
|
@ -118,8 +118,7 @@
|
|||
(define/public (get-transformation) transformation)
|
||||
|
||||
(def/public (get-stipple) stipple)
|
||||
(def/public (set-stipple [(make-or-false bitmap%) s]
|
||||
[(make-or-false transformation-vector?) [t #f]])
|
||||
(define/public (set-stipple s [t #f])
|
||||
(check-immutable 'set-stipple)
|
||||
(set! stipple s)
|
||||
(set! transformation (and s t)))
|
||||
|
|
|
@ -55,7 +55,7 @@
|
|||
(def/public (blue) b)
|
||||
(def/public (alpha) a)
|
||||
|
||||
(def/public (set [byte? rr] [byte? rg] [byte? rb] [(real-in 0 1) [ra 1.0]])
|
||||
(define/public (set rr rg rb [ra 1.0])
|
||||
(if immutable?
|
||||
(error (method-name 'color% 'set) "object is immutable")
|
||||
(begin
|
||||
|
@ -68,7 +68,7 @@
|
|||
(def/public (is-immutable?) immutable?)
|
||||
(def/public (set-immutable) (set! immutable? #t))
|
||||
|
||||
(def/public (copy-from [color% c])
|
||||
(define/public (copy-from c)
|
||||
(if immutable?
|
||||
(error (method-name 'color% 'copy-from) "object is immutable")
|
||||
(begin (set (color-red c) (color-green c) (color-blue c) (color-alpha c))
|
||||
|
|
|
@ -109,7 +109,7 @@
|
|||
(cairo_close_path cr))
|
||||
(do-points cr open-points align-x align-y))
|
||||
|
||||
(def/public (append [dc-path% path])
|
||||
(define/public (append path)
|
||||
(flatten-closed!)
|
||||
(flatten-open!)
|
||||
(set! closed-points (s:append closed-points (send path get-closed-points)))
|
||||
|
@ -175,7 +175,7 @@
|
|||
(max b (vector-ref p 1) (vector-ref p 3)))]))])
|
||||
(values l t (- r l) (- b t))))))
|
||||
|
||||
(def/public (move-to [real? x] [real? y])
|
||||
(define/public (move-to x y)
|
||||
(when (or (pair? open-points)
|
||||
(pair? rev-open-points))
|
||||
(close))
|
||||
|
@ -184,7 +184,7 @@
|
|||
(define/private (do-move-to x y)
|
||||
(set! rev-open-points (list (cons (exact->inexact x) (exact->inexact y)))))
|
||||
|
||||
(def/public (line-to [real? x] [real? y])
|
||||
(define/public (line-to x y)
|
||||
(unless (or (pair? open-points)
|
||||
(pair? rev-open-points))
|
||||
(error (method-name 'dc-path% 'line-to) "path not yet open"))
|
||||
|
@ -193,9 +193,7 @@
|
|||
(define/private (do-line-to x y)
|
||||
(set! rev-open-points (cons (cons (exact->inexact x) (exact->inexact y)) rev-open-points)))
|
||||
|
||||
(def/public (lines [(make-alts (make-list point%) list-of-pair-of-real?) pts]
|
||||
[real? [x 0.0]]
|
||||
[real? [y 0.0]])
|
||||
(define/public (lines pts [x 0.0] [y 0.0])
|
||||
(unless (or (pair? open-points)
|
||||
(pair? rev-open-points))
|
||||
(error (method-name 'dc-path% 'lines) "path not yet open"))
|
||||
|
@ -204,7 +202,7 @@
|
|||
(do-line-to (+ x (car p)) (+ y (cdr p)))
|
||||
(do-line-to (+ x (point-x p)) (+ y (point-y p))))))
|
||||
|
||||
(def/public (curve-to [real? x1] [real? y1] [real? x2] [real? y2] [real? x3] [real? y3])
|
||||
(define/public (curve-to x1 y1 x2 y2 x3 y3)
|
||||
(unless (or (pair? open-points)
|
||||
(pair? rev-open-points))
|
||||
(error (method-name 'dc-path% 'curve-to) "path not yet open"))
|
||||
|
@ -219,9 +217,7 @@
|
|||
(exact->inexact y2))
|
||||
rev-open-points)))
|
||||
|
||||
(def/public (arc [real? x] [real? y]
|
||||
[real? w] [real? h]
|
||||
[real? start] [real? end] [any? [ccw? #t]])
|
||||
(define/public (arc x y w h start end [ccw? #t])
|
||||
(do-arc x y w h start end ccw?))
|
||||
|
||||
(define/private (do-arc x y w h start end ccw?)
|
||||
|
@ -306,13 +302,12 @@
|
|||
(vector-ref v 4) (vector-ref v 5)
|
||||
(vector-ref v 6) (vector-ref v 7)))))))))
|
||||
|
||||
(def/public (ellipse [real? x] [real? y]
|
||||
[nonnegative-real? w] [nonnegative-real? h])
|
||||
(define/public (ellipse x y w h)
|
||||
(when (open?) (close))
|
||||
(do-arc x y w h 0 2pi #f)
|
||||
(close))
|
||||
|
||||
(def/public (text-outline [font% font] [string? str] [real? x] [real? y] [any? [combine? #f]])
|
||||
(define/public (text-outline font str x y [combine? #f])
|
||||
(when (open?) (close))
|
||||
(let ([p (text-to-path font str x y combine?)])
|
||||
(for ([a (in-list p)])
|
||||
|
@ -325,7 +320,7 @@
|
|||
[(close) (close)])))
|
||||
(close))
|
||||
|
||||
(def/public (scale [real? x][real? y])
|
||||
(define/public (scale x y)
|
||||
(unless (and (= x 1.0) (= y 1.0))
|
||||
(flatten-open!)
|
||||
(flatten-closed!)
|
||||
|
@ -343,7 +338,7 @@
|
|||
(* (vector-ref p 2) x)
|
||||
(* (vector-ref p 3) y)))))
|
||||
|
||||
(def/public (translate [real? x][real? y])
|
||||
(define/public (translate x y)
|
||||
(unless (and (zero? x) (zero? y))
|
||||
(flatten-open!)
|
||||
(flatten-closed!)
|
||||
|
@ -361,7 +356,7 @@
|
|||
(+ (vector-ref p 2) x)
|
||||
(+ (vector-ref p 3) y)))))
|
||||
|
||||
(def/public (rotate [real? th])
|
||||
(define/public (rotate th)
|
||||
(flatten-open!)
|
||||
(flatten-closed!)
|
||||
(set! open-points (rotate-points open-points th))
|
||||
|
@ -383,7 +378,7 @@
|
|||
[cx (make-polar (magnitude cx) (+ (angle cx) (- th)))])
|
||||
(values (real-part cx) (imag-part cx))))
|
||||
|
||||
(def/public (transform [matrix-vector? m])
|
||||
(define/public (transform m)
|
||||
(flatten-open!)
|
||||
(flatten-closed!)
|
||||
(set! open-points (transform-points open-points m))
|
||||
|
@ -406,7 +401,7 @@
|
|||
(* y (vector-ref m 3))
|
||||
(vector-ref m 5))))
|
||||
|
||||
(def/public (rectangle [real? x] [real? y] [real? w] [real? h])
|
||||
(define/public (rectangle x y w h)
|
||||
(when (open?) (close))
|
||||
(move-to x y)
|
||||
(line-to (+ x w) y)
|
||||
|
@ -414,8 +409,7 @@
|
|||
(line-to x (+ y h))
|
||||
(close))
|
||||
|
||||
(def/public (rounded-rectangle [real? x] [real? y] [real? w] [real? h]
|
||||
[real? [radius -0.25]])
|
||||
(define/public (rounded-rectangle x y w h [radius -0.25])
|
||||
(when (open?) (close))
|
||||
(let ([dx (min (/ w 2)
|
||||
(if (negative? radius)
|
||||
|
|
|
@ -201,8 +201,7 @@
|
|||
(def/public (get-font-id) id)
|
||||
(def/public (get-font-key) key)
|
||||
|
||||
(def/public (screen-glyph-exists? [char? c]
|
||||
[any? [for-label? #f]])
|
||||
(define/public (screen-glyph-exists? c [for-label? #f])
|
||||
(has-screen-glyph? c this (get-pango) for-label?))
|
||||
|
||||
(init-rest args)
|
||||
|
|
|
@ -17,20 +17,20 @@
|
|||
|
||||
(define stencil-size 0)
|
||||
(define/public (get-stencil-size) stencil-size)
|
||||
(def/public (set-stencil-size [(integer-in 0 256) s])
|
||||
(define/public (set-stencil-size s)
|
||||
(set! stencil-size s))
|
||||
|
||||
(define accum-size 0)
|
||||
(define/public (get-accum-size) accum-size)
|
||||
(def/public (set-accum-size [(integer-in 0 256) s])
|
||||
(define/public (set-accum-size s)
|
||||
(set! accum-size s))
|
||||
|
||||
(define depth-size 1)
|
||||
(define/public (get-depth-size) depth-size)
|
||||
(def/public (set-depth-size [(integer-in 0 256) s])
|
||||
(define/public (set-depth-size s)
|
||||
(set! depth-size s))
|
||||
|
||||
(define multisample-size 0)
|
||||
(define/public (get-multisample-size) multisample-size)
|
||||
(def/public (set-multisample-size [(integer-in 0 256) s])
|
||||
(define/public (set-multisample-size s)
|
||||
(set! multisample-size s)))
|
||||
|
|
|
@ -125,7 +125,7 @@
|
|||
|
||||
(define stipple #f)
|
||||
(def/public (get-stipple) stipple)
|
||||
(def/public (set-stipple [(make-or-false bitmap%) s])
|
||||
(define/public (set-stipple s)
|
||||
(check-immutable 'set-stipple)
|
||||
(set! stipple s)))
|
||||
|
||||
|
|
|
@ -11,8 +11,8 @@
|
|||
[y 0.0])
|
||||
(define/public (get-x) x)
|
||||
(define/public (get-y) y)
|
||||
(def/public (set-x [real? v]) (set! x (exact->inexact v)))
|
||||
(def/public (set-y [real? v]) (set! y (exact->inexact v)))
|
||||
(define/public (set-x v) (set! x (exact->inexact v)))
|
||||
(define/public (set-y v) (set! y (exact->inexact v)))
|
||||
(super-new)))
|
||||
|
||||
(define point-x (class-field-accessor point% x))
|
||||
|
|
|
@ -188,8 +188,7 @@
|
|||
[temp-cr (cairo_destroy cr)]
|
||||
[else (set! temp-cr cr)]))))))
|
||||
|
||||
(def/public (in-region? [real? x]
|
||||
[real? y])
|
||||
(define/public (in-region? x y)
|
||||
(with-temp-cr
|
||||
(lambda (cr)
|
||||
(let-values ([(x y)
|
||||
|
@ -206,12 +205,7 @@
|
|||
(values x y))])
|
||||
(install-region cr #t values values (lambda (cr v) (and v (cairo_in_fill cr x y))))))))
|
||||
|
||||
(def/public (set-arc [real? x]
|
||||
[real? y]
|
||||
[nonnegative-real? width]
|
||||
[nonnegative-real? height]
|
||||
[real? start-radians]
|
||||
[real? end-radians])
|
||||
(define/public (set-arc x y width height start-radians end-radians)
|
||||
(modifying 'set-arc)
|
||||
(let ([p (new dc-path%)])
|
||||
(send p move-to (+ x (/ width 2)) (+ y (/ height 2)))
|
||||
|
@ -220,20 +214,16 @@
|
|||
(when matrix (send p transform matrix))
|
||||
(set! paths (list (cons p 'any)))))
|
||||
|
||||
(def/public (set-ellipse [real? x]
|
||||
[real? y]
|
||||
[nonnegative-real? width]
|
||||
[nonnegative-real? height])
|
||||
(define/public (set-ellipse x y width height)
|
||||
(modifying 'set-ellipse)
|
||||
(let ([p (new dc-path%)])
|
||||
(send p ellipse x y width height)
|
||||
(when matrix (send p transform matrix))
|
||||
(set! paths (list (cons p 'any)))))
|
||||
|
||||
(def/public (set-path [dc-path% path]
|
||||
[real? [x 0.0]]
|
||||
[real? [y 0.0]]
|
||||
[(symbol-in odd-even winding) [fill-style 'odd-even]])
|
||||
(define/public (set-path path
|
||||
[x 0.0] [y 0.0]
|
||||
[fill-style 'odd-even])
|
||||
(modifying 'set-path)
|
||||
(let ([p (new dc-path%)])
|
||||
(send p append path)
|
||||
|
@ -241,10 +231,9 @@
|
|||
(when matrix (send p transform matrix))
|
||||
(set! paths (list (cons p fill-style)))))
|
||||
|
||||
(def/public (set-polygon [(make-alts (make-list point%) list-of-pair-of-real?) pts]
|
||||
[real? [x 0.0]]
|
||||
[real? [y 0.0]]
|
||||
[(symbol-in odd-even winding) [fill-style 'odd-even]])
|
||||
(define/public (set-polygon pts
|
||||
[x 0.0] [y 0.0]
|
||||
[fill-style 'odd-even])
|
||||
(modifying 'set-polygon)
|
||||
(if (null? pts)
|
||||
(set! paths null)
|
||||
|
@ -261,21 +250,14 @@
|
|||
(when matrix (send p transform matrix))
|
||||
(set! paths (list (cons p fill-style))))))
|
||||
|
||||
(def/public (set-rectangle [real? x]
|
||||
[real? y]
|
||||
[nonnegative-real? width]
|
||||
[nonnegative-real? height])
|
||||
(define/public (set-rectangle x y width height)
|
||||
(modifying 'set-rectangle)
|
||||
(let ([p (new dc-path%)])
|
||||
(send p rectangle x y width height)
|
||||
(when matrix (send p transform matrix))
|
||||
(set! paths (list (cons p 'any)))))
|
||||
|
||||
(def/public (set-rounded-rectangle [real? x]
|
||||
[real? y]
|
||||
[nonnegative-real? width]
|
||||
[nonnegative-real? height]
|
||||
[real? [radius -0.25]])
|
||||
(define/public (set-rounded-rectangle x y width height [radius -0.25])
|
||||
(modifying 'set-rounded-rectangle)
|
||||
(let ([p (new dc-path%)])
|
||||
(send p rounded-rectangle x y width height radius)
|
||||
|
@ -288,12 +270,12 @@
|
|||
"different built-in dc for given region: "
|
||||
r)))
|
||||
|
||||
(def/public (intersect [region% r])
|
||||
(define/public (intersect r)
|
||||
(check-compatible r 'union)
|
||||
(modifying 'intersect)
|
||||
(set! paths (append paths (send r get-paths))))
|
||||
|
||||
(def/public (subtract [region% r])
|
||||
(define/public (subtract r)
|
||||
(check-compatible r 'subtract)
|
||||
(unless (null? paths)
|
||||
(let ([add-paths (send r get-paths)])
|
||||
|
@ -302,10 +284,10 @@
|
|||
(do-union 'subtract r (lambda (p) (rev-paths p)))
|
||||
(set! paths (append paths p)))))))
|
||||
|
||||
(def/public (union [region% r])
|
||||
(define/public (union r)
|
||||
(do-union 'union r values))
|
||||
|
||||
(def/public (xor [region% r])
|
||||
(define/public (xor r)
|
||||
(do-union 'xor r (lambda (p) (rev-paths p))))
|
||||
|
||||
(define/private rev-paths
|
||||
|
|
Loading…
Reference in New Issue
Block a user