From 1b3fd890adb72530f354b8983a34b2b8e43754d8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 14 Jul 2014 23:01:47 -0500 Subject: [PATCH] adjust 'dc' so that the ascent and descent arguments are independently optional and add a contract that calls the 'draw' argument to make sure it restores the dc state. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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. --- .../pict-doc/pict/scribblings/pict.scrbl | 51 +++++++----- pkgs/pict-pkgs/pict-lib/info.rkt | 2 +- pkgs/pict-pkgs/pict-lib/pict/main.rkt | 78 ++++++++++++++++++- .../pict-lib/texpict/private/mrpict-extra.rkt | 9 +-- 4 files changed, 114 insertions(+), 26 deletions(-) diff --git a/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl b/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl index 0084e5d3c0..272affe725 100644 --- a/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl +++ b/pkgs/pict-pkgs/pict-doc/pict/scribblings/pict.scrbl @@ -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?] diff --git a/pkgs/pict-pkgs/pict-lib/info.rkt b/pkgs/pict-pkgs/pict-lib/info.rkt index 35f2c8847d..7f1575c3df 100644 --- a/pkgs/pict-pkgs/pict-lib/info.rkt +++ b/pkgs/pict-pkgs/pict-lib/info.rkt @@ -12,4 +12,4 @@ (define pkg-authors '(mflatt robby)) -(define version "1.2") +(define version "1.3") diff --git a/pkgs/pict-pkgs/pict-lib/pict/main.rkt b/pkgs/pict-pkgs/pict-lib/pict/main.rkt index 93055bf736..ef838db13e 100644 --- a/pkgs/pict-pkgs/pict-lib/pict/main.rkt +++ b/pkgs/pict-pkgs/pict-lib/pict/main.rkt @@ -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?)] diff --git a/pkgs/pict-pkgs/pict-lib/texpict/private/mrpict-extra.rkt b/pkgs/pict-pkgs/pict-lib/texpict/private/mrpict-extra.rkt index 92a7a91a58..01bd4f450f 100644 --- a/pkgs/pict-pkgs/pict-lib/texpict/private/mrpict-extra.rkt +++ b/pkgs/pict-pkgs/pict-lib/texpict/private/mrpict-extra.rkt @@ -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)))