suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

adjust 'dc' so that the ascent and descent arguments are independently

Browse Source 
optional and add a contract that calls the 'draw' argument to make
sure it restores the dc state.

The call to the 'draw' function happens right when 'dc' is called and
it tests the property that 'draw' doesn't abuse the state only that
one time and only with x=0 and y=0. This seems likely to catch common
errors, however, since the mismanagement of the state is unlikely to
be related to the values of 'x' and 'y' and also unlikely to depend on
the timing of the the call (i.e., if it happens at all, it probably
always happens).

Another way we could enforce this contract would be to wrap the `draw'
argument so that each time it is called, we grab the state of the dc
and compare it to afterwards.  The current strategy is less expensive
and also catches errors earlier (in the case of slidehow specifically,
we'll get the errors during the startup of the presentation instead of
when we try to render a slide (in the middle of the presentation,
typically)).

This change slows down calls to 'dc'. For example, this program:

 #lang racket/gui
(require pict)

(define brush (send the-brush-list find-or-create-brush "black" 'solid))
(define (circ w h)
  (dc (λ (dc dx dy)
        (define orig-pen (send dc get-pen))
        (define orig-brush (send dc get-brush))
        (send dc set-pen "black" 1 'transparent)
        (send dc set-brush brush)
        (send dc draw-ellipse dx dy w h)
        (send dc set-pen orig-pen)
        (send dc set-brush orig-brush))
      w h))

(void
 (time
  (for/fold ([b (blank)]) ([i (in-range 10000)])
    (vc-append (circ (random 1000)
                     (random 1000))
               b))))

goes from
  cpu time: 16 real time: 17 gc time: 0
to
  cpu time: 2166 real time: 2172 gc time: 224
on my machine.

Still, that cost, when measured in a per-call-to-dc way is
only .21 msecs, which seems reasonable given the pain of
tracking down the kinds of bugs that this contract
helps detect.
This commit is contained in:
Robby Findler 2014-07-14 23:01:47 -05:00
parent add04001cd
commit 1b3fd890ad
4 changed files with 114 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

51
pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl
View File

@ -130,29 +130,23 @@ A @racket[child] structure is normally not created directly with
@section{Basic Pict Constructors}
@defproc*[([(dc [draw ((is-a?/c dc<%>) real? real? . -> . any)]
[w real?]
[h real?])
pict?]
[(dc [draw ((is-a?/c dc<%>) real? real? . -> . any)]
[w real?]
[h real?]
[a real?]
[d real?])
pict?])]{
@defproc[(dc [draw (-> (is-a?/c dc<%>) real? real? any)]
[w real?]
[h real?]
[a real? h]
[d real? 0])
pict?]{
Creates an arbitrary self-rendering pict. The arguments to the
rendering procedure will be a drawing context and top-left location for
drawing.
The @racket[w] and @racket[h] arguments determine the width and height
of the resulting pict's @tech{bounding box}. In the three-argument case, the
descent is @math{0} and the ascent is @racket[h] for the bounding
box; in the five-argument case, @racket[a] and @racket[d] are used
as the bounding box's ascent and descent.
The @racket[w], @racket[h], @racket[a], and @racket[d] arguments
determine the width, height, ascent, and descent of the
of the resulting pict's @tech{bounding box} respectively.
When the rendering procedure is called, the current pen and brush will
be solid and in the pict's color (and linewidth), and the scale and
be @racket['solid] and in the pict's color and @racket[linewidth], and the scale and
offset of the drawing context will be set. The text mode will be transparent, but
the font and text colors are not guaranteed to be anything in
particular.
@ -174,9 +168,30 @@ particular.
(send dc draw-path path dx dy)
(send dc set-brush old-brush)
(send dc set-pen old-pen))
50 50)
]}
50 50)]
The @racket[draw] is called during the dynamic extent of
the call to @racket[dc] as part of the contract checking.
Specifically, the pre-condition portion of the contract
for @racket[dc] concocts a @racket[dc<%>] object with a
random initial state, calls the @racket[draw] argument
with that @racket[dc<%>] and then checks to make sure that
@racket[draw] the state of the @racket[dc<%>] object
is the same as it was before @racket[draw] was called.
@examples[#:eval
ss-eval
(dc (λ (dc dx dy)
(send dc set-brush "red" 'solid)
(send dc set-pen "black" 1 'transparent)
(send dc draw-ellipse dx dy 50 50))
50 50)]
@history[#:changed "1.3" @list{The @racket[draw] argument is
now called by the @racket[#:pre]
condition of @racket[dc].}]
}
@defproc*[([(blank [size real? 0]) pict?]
[(blank [w real?] [h real?]) pict?]

2
pkgs/pict-pkgs/pict-lib/info.rkt
View File

@ -12,4 +12,4 @@
(define pkg-authors '(mflatt robby))
(define version "1.2")
(define version "1.3")

78
pkgs/pict-pkgs/pict-lib/pict/main.rkt
View File

@ -4,6 +4,9 @@
racket/class
racket/draw
racket/bool)
(define a-number 0)
(provide
(except-out (all-from-out "private/main.rkt")
pict->bitmap
@ -19,8 +22,22 @@
hb-append
htl-append
hbl-append
cellophane)
cellophane
dc)
(contract-out
[dc (->i ([draw (-> (is-a?/c dc<%>) real? real? any)]
[w real?]
[h real?])
([d (or/c #f real?)]
[a (or/c #f real?)])
#:pre (draw)
(let ()
(define bdc (new bitmap-dc% [bitmap (make-bitmap 1 1)]))
(randomize-state bdc)
(define old-state (get-dc-state bdc))
(draw bdc 0 0)
(equal? (get-dc-state bdc) old-state))
[p pict?])]
[cellophane (-> pict? (real-in 0 1) pict?)]
[vl-append *-append/c]
[vc-append *-append/c]
@ -66,6 +83,65 @@
[result pict?])]
[disk (->* ((and/c rational? (not/c negative?))) (#:draw-border? any/c) pict?)]))
;; randomizes some portions of the state of the given dc;
;; doesn't pick random values for things that the 'dc'
;; function promises not to change (e.g. the pen/brush style).
(define (randomize-state dc)
(send dc set-origin (random-real) (random-real))
(send dc set-pen (random-color) (random 255) 'solid)
(send dc set-brush (random-color) 'solid)
(send dc set-alpha (random))
(send dc set-text-background (random-color))
(send dc set-text-foreground (random-color))
(send dc set-text-mode 'transparent)
(send dc set-font (send the-font-list find-or-create-font
(+ 1 (random 254))
(pick-one 'default 'decorative 'roman 'script
'swiss 'modern 'symbol 'system)
(pick-one 'normal 'italic 'slant)
(pick-one 'normal 'bold 'light)))
;; set-transformation is relatively expensive
;; at the moment, so we don't randomize it
#;
(send dc set-transformation
(vector (vector (random-real) (random-real) (random-real)
(random-real) (random-real) (random-real))
(random-real) (random-real) (random-real) (random-real) (random-real))))
(define (random-real) (+ (random 1000) (random)))
(define (random-color) (make-object color% (random 255) (random 255) (random 255)))
(define (pick-one . args) (list-ref args (random (length args))))
(define (get-dc-state dc)
(vector (pen->vec (send dc get-pen))
(brush->vec (send dc get-brush))
(send dc get-alpha)
(font->vec (send dc get-font))
(let-values ([(ox oy) (send dc get-origin)])
(cons ox oy))
(color->vec (send dc get-text-background))
(send dc get-text-mode)
(send dc get-transformation)
(color->vec (send dc get-text-foreground))))
(define (pen->vec pen)
(vector (color->vec (send pen get-color))
(send pen get-width)
(send pen get-style)))
(define (brush->vec brush)
(vector (color->vec (send brush get-color))
(send brush get-style)))
(define (font->vec font)
(vector (send font get-point-size)
(send font get-family)
(send font get-style)
(send font get-weight)))
(define (color->vec c)
(vector (send c red) (send c green) (send c blue)))
(define *-append/c
(->i ([r/p (or/c real? pict?)])
#:rest [more (listof pict?)]

9
pkgs/pict-pkgs/pict-lib/texpict/private/mrpict-extra.rkt
View File

@ -88,12 +88,9 @@
x))
x)))
(define dc
(case-lambda
[(f w h a d)
(make-pict `(prog ,f ,h) w h a d null #f #f)]
[(f w h)
(dc f w h h 0)]))
(define (dc f w h [a h] [d 0])
(make-pict `(prog ,f ,h) w h a d null #f #f))
(define prog-picture dc)
(define current-expected-text-scale (make-parameter (list 1 1)))