added support for special-case drawing of individual edges to the graph library and support to be able to use that to redex

svn: r13226

collects/drscheme/private/debug.ss

@@ -1115,6 +1115,8 @@ profile todo:
                         (send src lock #f))))))
                sorted)
               
+              (printf "sorted ~s\n" sorted)
+              
               ;; clear out old annotations (and thaw colorers)
               (when internal-clear-test-coverage-display
                 (internal-clear-test-coverage-display)

collects/mrlib/graph.ss

@@ -231,7 +231,8 @@
     (mixin ((class->interface pasteboard%)) (graph-pasteboard<%>)
       (inherit find-first-snip find-next-selected-snip)
       
-      (init-field [edge-label-font #f])
+      (init-field [edge-label-font #f]
+                  [edge-labels? #t])
       
       (define draw-arrow-heads? #t)
       (inherit refresh get-admin)
@@ -535,12 +536,12 @@
                           [(b45x b45y) (values s5x s4y)]
                           [(b56x b56y) (values s5x s6y)])
               
-              (update-polygon s4x s4y sx s4y)
+              (update-arrowhead-polygon s4x s4y sx s4y)
               (send dc draw-spline (+ dx s1x) (+ dy s1y) (+ dx b12x) (+ dy b12y) (+ dx s2x) (+ dy s2y))
               (send dc draw-spline (+ dx s2x) (+ dy s2y) (+ dx b23x) (+ dy b23y) (+ dx s3x) (+ dy s3y))
               (send dc draw-line (+ dx s3x) (+ dy s3y) (+ dx s6x) (+ dy s6y))
               
-              (when (link-label the-link)
+              (when (and edge-labels? (link-label the-link))
                 (let* ((textlen (get-text-length (link-label the-link)))
                        (linelen (- s6x s3x))
                        (offset (* 1/2 (- linelen textlen))))
@@ -606,19 +607,8 @@
                            ;; the snips overlap, draw nothing
                            (void)]
                           [else
-                           (send dc draw-line
+                           (draw-single-edge dc dx dy from to from-x from-y to-x to-y arrow-point-ok?)
-                                 (+ dx from-x) (+ dy from-y) 
+                           (when (and edge-labels? (link-label from-link))
-                                 (+ dx to-x) (+ dy to-y))
-                           (update-polygon from-x from-y to-x to-y)
-                           (when (and draw-arrow-heads?
-                                      (arrow-point-ok? (send point1 get-x) (send point1 get-y))
-                                      (arrow-point-ok? (send point2 get-x) (send point2 get-y))
-                                      (arrow-point-ok? (send point3 get-x) (send point3 get-y))
-                                      (arrow-point-ok? (send point4 get-x) (send point4 get-y)))
-                             ;; the arrowhead is not overlapping the snips, so draw it
-                             ;; (this is only an approximate test, but probably good enough)
-                             (send dc draw-polygon points dx dy))
-                           (when (named-link? from-link)
                              (let-values ([(text-len h d v) (send dc get-text-extent (link-label from-link))])
                                (let* ([arrow-end-x (send point3 get-x)]
                                       [arrow-end-y (send point3 get-y)]
@@ -628,15 +618,14 @@
                                                  (- (* 1/2 vec)
                                                     (make-polar (/ text-len 2) (angle vec))))])
                                  (when (> (sqrt (+ (sqr (- arrow-end-x from-x))
-                                                   (sqr (- arrow-end-y from-y))))
+                                                        (sqr (- arrow-end-y from-y))))
-                                          text-len)
+                                               text-len)
                                    (send dc draw-text (link-label from-link)
                                          (+ dx (real-part middle))
                                          (+ dy (imag-part middle))
                                          #f
                                          0
                                          (- (angle vec)))))))]))))))))
-          (define (named-link? l) (link-label l))
           
           (define (set-pen/brush from-link dark-lines?)
             (send dc set-brush 
@@ -678,6 +667,20 @@
             (send dc set-text-foreground old-fg)
             (send dc set-brush old-brush))))
       
+      (define/public (draw-single-edge dc dx dy from to from-x from-y to-x to-y arrow-point-ok?)
+        (send dc draw-line
+              (+ dx from-x) (+ dy from-y) 
+              (+ dx to-x) (+ dy to-y))
+        (update-arrowhead-polygon from-x from-y to-x to-y point1 point2 point3 point4)
+        (when (and draw-arrow-heads?
+                   (arrow-point-ok? (send point1 get-x) (send point1 get-y))
+                   (arrow-point-ok? (send point2 get-x) (send point2 get-y))
+                   (arrow-point-ok? (send point3 get-x) (send point3 get-y))
+                   (arrow-point-ok? (send point4 get-x) (send point4 get-y)))
+          ;; the arrowhead is not overlapping the snips, so draw it
+          ;; (this is only an approximate test, but probably good enough)
+          (send dc draw-polygon points dx dy)))
+      
       ;; for-each-to-redraw : number number number number (link snip -> void)
       (define/private (for-each-to-redraw left top right bottom f)
         (let ()
@@ -727,11 +730,11 @@
        [point4 (make-object point% 0 0)]
        [points (list point1 point2 point3 point4)])
       
-      ;; update-polygon : number^4 -> void
+      ;; update-arrowhead-polygon : number^4 -> void
       ;; updates points1, 2, and 3 with the arrow head's
       ;; points. Use a turtle-like movement to find the points.
       ;; point3 is the point where the line should end.
-      (define/private (update-polygon from-x from-y to-x to-y)
+      (define/public (update-arrowhead-polygon from-x from-y to-x to-y point1 point2 point3 point4)
         (define (move tx ty ta d) (values (+ tx (* d (cos ta)))
                                           (+ ty (* d (sin ta)))
                                           ta))

collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl

@@ -60,5 +60,51 @@ different nodes.
   is @scheme[#t].
 }
 
+@defmethod[(draw-single-edge [dc (is-a?/c dc<%>)]
+			     [dx real?]
+			     [dy real?]
+			     [from (is-a?/c graph-snip<%>)]
+			     [to (is-a?/c graph-snip<%>)]
+			     [from-x real?]
+			     [from-y real?]
+			     [to-x real?]
+			     [to-y real?]
+			     [arrow-point-ok? (-> real? real? boolean?)]) void?]{
+
+This method is called to draw each edge in the graph, except
+for the edges that connect a node to itself.
+
+The @scheme[dc], @scheme[dx], and @scheme[dy] arguments are
+the same as in @method[editor<%> on-paint]. 
+
+The
+@scheme[from-x], @scheme[from-y], @scheme[to-x], and
+@scheme[to-y] arguments specify points on the source and
+destination snip's bounding box where a straight line
+between the centers of the snip would intersect.
+
+The @scheme[arrow-point-ok?] function returns @scheme[#t]
+when the point specified by its arguments is inside the the
+smallest rectangle that covers both the source and
+destination snips, but is outside of both of the rectangles
+that surround the source and destination snips themselves.
+
+This default implementation uses @scheme[update-polygon] to compute
+the arrowheads and otherwise draws a straight line between the two
+points and then the arrowheads, unless the arrowhead points
+are not ok according to @scheme[arrow-point-ok?], in which case
+it just draws the line.
+}
+
+@defmethod[(update-arrowhead-polygon [from-x real?] [from-y real?] [to-x real?] [to-y real?] 
+                                     [point1 (is-a?/c point%)]
+                                     [point2 (is-a?/c point%)]
+                                     [point3 (is-a?/c point%)]
+                                     [point4 (is-a?/c point%)]) void?]{
+
+Updates the arguments @scheme[point1], @scheme[point2], @scheme[point3], @scheme[point4] with the coordinates
+of an arrowhead for a line that connects (@scheme[from-x],@scheme[from-y]) to (@scheme[to-x],@scheme[to-y]).
+}
+
 }
 

collects/mrlib/scribblings/graph/graph-pasteboard-mixin.scrbl

@@ -3,7 +3,11 @@
 
 @defmixin/title[graph-pasteboard-mixin (pasteboard%) (graph-pasteboard<%>)]{
 
-@defconstructor/auto-super[([edge-label-font (or/c #f (is-a?/c font%)) #f])]{
+@defconstructor/auto-super[([edge-labels? boolean? #t]
+                            [edge-label-font (or/c #f (is-a?/c font%)) #f])]{
+
+If @scheme[edge-labels?] is @scheme[#f], no edge labels are
+drawn. Otherwise, they are.
 
 If @scheme[edge-label-font] is supplied, it is used when drawing the
 labels on the edges. Otherwise, the font is not set before drawing

collects/redex/gui.ss

@@ -9,6 +9,7 @@
          "private/matcher.ss"
          "private/reduction-semantics.ss"
          "private/size-snip.ss"
+         mrlib/graph
          scheme/contract
          scheme/class
          scheme/gui/base)
@@ -37,7 +38,9 @@
                #:scheme-colors? boolean?
                #:layout (-> any/c any/c)
                #:edge-label-font (or/c #f (is-a?/c font%))
-               #:filter (-> any/c (or/c #f string?) any/c))
+               #:edge-labels? boolean?
+               #:filter (-> any/c (or/c #f string?) any/c)
+               #:graph-pasteboard-mixin (make-mixin-contract graph-pasteboard<%>))
               any)]
  [traces/ps (->* (reduction-relation?
                   any/c
@@ -50,7 +53,9 @@
                   #:colors (listof any/c)
                   #:layout (-> any/c any/c)
                   #:edge-label-font (or/c #f (is-a?/c font%))
-                  #:filter (-> any/c (or/c #f string?) any/c))
+                  #:edge-labels? boolean?
+                  #:filter (-> any/c (or/c #f string?) any/c)
+                  #:graph-pasteboard-mixin (make-mixin-contract graph-pasteboard<%>))
                  any)]
  
  [term-node? (-> any/c boolean?)]

collects/redex/private/traces.ss

@@ -133,6 +133,8 @@
                    #:colors [colors '()]
                    #:layout [layout void]
                    #:edge-label-font [edge-label-font #f]
+                   #:edge-labels? [edge-labels? #t]
+                   #:graph-pasteboard-mixin [extra-graph-pasteboard-mixin values]
                    #:filter [term-filter (lambda (x y) #t)])
   (let-values ([(graph-pb canvas)
                 (traces reductions pre-exprs
@@ -144,6 +146,8 @@
                         #:colors colors
                         #:layout layout
                         #:edge-label-font edge-label-font
+                        #:edge-labels? edge-labels?
+                        #:graph-pasteboard-mixin extra-graph-pasteboard-mixin
                         #:filter term-filter)])
     (print-to-ps graph-pb canvas filename)))
 
@@ -232,12 +236,14 @@
                 #:scheme-colors? [scheme-colors? #t]
                 #:layout [layout void]
                 #:edge-label-font [edge-label-font #f]
+                #:edge-labels? [edge-labels? #t]
                 #:filter [term-filter (lambda (x y) #t)]
+                #:graph-pasteboard-mixin [extra-graph-pasteboard-mixin values]
                 #:no-show-frame? [no-show-frame? #f])
   (define exprs (if multiple? pre-exprs (list pre-exprs)))
   (define main-eventspace (current-eventspace))
   (define saved-parameterization (current-parameterization))
-  (define graph-pb (new graph-pasteboard% [layout layout] [edge-label-font edge-label-font]))
+  (define graph-pb (new (extra-graph-pasteboard-mixin graph-pasteboard%) [layout layout] [edge-label-font edge-label-font] [edge-labels? edge-labels?]))
   (define user-char-width (initial-char-width))
   (define f (instantiate red-sem-frame% ()
               (label "PLT Redex Reduction Graph")

collects/redex/redex.scrbl

@@ -4,11 +4,12 @@
           scribble/eval
           (for-syntax scheme/base)
           (for-label scheme/base
-	  	     scheme/gui
+                     scheme/gui
                      scheme/pretty
                      scheme/contract
-		     (only-in slideshow/pict pict? text dc-for-text-size)
+		     mrlib/graph
-		     redex))
+                     (only-in slideshow/pict pict? text dc-for-text-size)
+                     redex))
 
 @(define-syntax (defpattech stx)
    (syntax-case stx ()
@@ -378,7 +379,7 @@ stands for repetition unless otherwise indicated):
          (in-hole term term)
          hole
          #t #f
-	 string]
+         string]
    [term-sequence 
      term
      ,@scheme-expression
@@ -1156,10 +1157,12 @@ exploring reduction sequences.
                            (and/c (listof (or/c string? (is-a?/c color%)))
                                   (lambda (x) (member (length x) '(2 3 4 6))))))]
 
-	         [#:scheme-colors? scheme-colors? boolean? #t]
+                 [#:scheme-colors? scheme-colors? boolean? #t]
                  [#:filter term-filter (-> any/c (or/c #f string?) any/c) (lambda (x y) #t)]
                  [#:layout layout (-> (listof term-node?) void) void]
-                 [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f])
+                 [#:edge-labels? edge-label-font boolean? #t]
+                 [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f]
+                 [#:graph-pasteboard-mixin graph-pasteboard-mixin (make-mixin-contract graph-pasteboard<%>) values])
          void?]{
 
 This function opens a new window and inserts each expression
@@ -1228,10 +1231,23 @@ after new terms are inserted in response to the user clicking on the
 reduce button, and after the initial set of terms is inserted.
 See also @scheme[term-node-set-position!].
 
+If @scheme[edge-labels?] is @scheme[#t] (the default), then edge labels
+are drawn; otherwise not.
+
 The @scheme[edge-label-font] argument is used as the font on the edge
-labels. If nothign is suppled, the @scheme[dc<%>] object's default
+labels. If @scheme[#f] is suppled, the @scheme[dc<%>] object's default
 font is used.
 
+The traces library an instance of the @schememodname[mrlib/graph]
+library's @scheme[graph-pasteboard<%>] interface to layout
+the graphs.  Sometimes, overriding one of its methods can
+help give finer-grained control over the layout, so the
+@scheme[graph-pasteboard-mixin] is applied to the class
+before it is instantiated. Also note that all of the snips
+inserted into the editor by this library have a
+@tt{get-term-node} method which returns the snip's
+@scheme[term-node].
+
 }
 
 @defproc[(traces/ps [reductions reduction-relation?] 
@@ -1249,7 +1265,9 @@ font is used.
                     [#:colors colors (listof (list string string)) '()]
                     [#:filter term-filter (-> any/c (or/c #f string?) any/c) (lambda (x y) #t)]
                     [#:layout layout (-> (listof term-node?) void) void]
-                    [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f])
+                    [#:edge-labels? edge-label-font boolean? #t]
+                    [#:edge-label-font edge-label-font (or/c #f (is-a?/c font%)) #f]
+                    [#:graph-pasteboard-mixin graph-pasteboard-mixin (make-mixin-contract graph-pasteboard<%>) values])
          void?]{
 
 The arguments behave just like the function @scheme[traces], but

doc/release-notes/redex/HISTORY.txt

@@ -3,6 +3,9 @@ v4.1.4
   - initial-char-width now accepts functions to give finer grained
     control of the initial widths of the terms.
 
+ - traces & traces/ps: added the ability to specify a mixin
+   to be mixed into the graph pasteboard
+
 v4.1.3
 
   * added redex-check, a tool for automatically generating test cases