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.

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.

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)]
+@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?]
+             [a real? h]
-                [d real?])
+             [d real? 0])
-            pict?])]{
+         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
+The @racket[w], @racket[h], @racket[a], and @racket[d] arguments 
-of the resulting pict's @tech{bounding box}.  In the three-argument case, the
+determine the width, height, ascent, and descent of the
-descent is @math{0} and the ascent is @racket[h] for the bounding
+of the resulting pict's @tech{bounding box} respectively.
-box; in the five-argument case, @racket[a] and @racket[d] are used
-as the bounding box's ascent and descent.
 
 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?]

pkgs/pict-pkgs/pict-lib/info.rkt

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

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

pkgs/pict-pkgs/pict-lib/texpict/private/mrpict-extra.rkt

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