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)))