From 50cd17833f4db7dea33038f87ffd8870a25d91ed Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Wed, 4 Jun 2008 21:36:13 +0000
Subject: [PATCH] abstracted out edge drawing so it can be overriden

svn: r10136
---
 collects/mrlib/graph.ss                       | 64 ++++++++++---------
 .../graph/graph-pasteboard-intf.scrbl         | 19 +++++-
 2 files changed, 51 insertions(+), 32 deletions(-)

diff --git a/collects/mrlib/graph.ss b/collects/mrlib/graph.ss
index 2ed73337c4..83b692a938 100644
--- a/collects/mrlib/graph.ss
+++ b/collects/mrlib/graph.ss
@@ -222,7 +222,8 @@
       on-mouse-over-snips
       set-arrowhead-params
       get-arrowhead-params
-      set-draw-arrow-heads?))
+      set-draw-arrow-heads?
+      draw-edges))
   
   (define-struct rect (left top right bottom))
   
@@ -482,6 +483,11 @@
                         (max b (rect-bottom rect))))]))]))
       
       (define/override (on-paint before? dc left top right bottom dx dy draw-caret)
+        (when before?
+          (draw-edges dc left top right bottom dx dy))
+        (super on-paint before? dc left top right bottom dx dy draw-caret))
+      
+      (define/public (draw-edges dc left top right bottom dx dy)
         (let ()
           ;; draw-connection : link snip boolean boolean -> void
           ;; sets the drawing context (pen and brush)
@@ -637,37 +643,33 @@
                       (link-dark-text from-link)
                       (link-light-text from-link))))
           
-          ;;; body of on-paint
-          (when before?
-            (let ([old-pen (send dc get-pen)]
-                  [old-brush (send dc get-brush)]
-                  [old-fg (send dc get-text-foreground)]
-                  [os (send dc get-smoothing)])
-              (send dc set-smoothing 'aligned)
-              
-              (let ([pairs '()])
-                (for-each-to-redraw 
-                 left top right bottom 
-                 (lambda (from-link to)
-                   (let ([from (link-snip from-link)])
-                     (cond
-                       [(or (memq from currently-overs)
-                            (memq to currently-overs))
-                        (set! pairs (cons (cons from-link to) pairs))]
-                       [else
-                        (draw-connection from-link to #f)]))))
-                (for-each (lambda (pr)
-                            (draw-connection (car pr) (cdr pr) #t))
-                          pairs))
-              
-              (send dc set-smoothing os)
-              (send dc set-pen old-pen)
-              (send dc set-text-foreground old-fg)
-              (send dc set-brush old-brush)))
-          
-          (super on-paint before? dc left top right bottom dx dy draw-caret)))
+          (let ([old-pen (send dc get-pen)]
+                [old-brush (send dc get-brush)]
+                [old-fg (send dc get-text-foreground)]
+                [os (send dc get-smoothing)])
+            (send dc set-smoothing 'aligned)
+            
+            (let ([pairs '()])
+              (for-each-to-redraw 
+               left top right bottom 
+               (lambda (from-link to)
+                 (let ([from (link-snip from-link)])
+                   (cond
+                     [(or (memq from currently-overs)
+                          (memq to currently-overs))
+                      (set! pairs (cons (cons from-link to) pairs))]
+                     [else
+                      (draw-connection from-link to #f)]))))
+              (for-each (lambda (pr)
+                          (draw-connection (car pr) (cdr pr) #t))
+                        pairs))
+            
+            (send dc set-smoothing os)
+            (send dc set-pen old-pen)
+            (send dc set-text-foreground old-fg)
+            (send dc set-brush old-brush))))
       
-        ;; for-each-to-redraw : number number number number (link snip -> void)
+      ;; for-each-to-redraw : number number number number (link snip -> void)
       (define/private (for-each-to-redraw left top right bottom f)
         (let ()
           ;;  : link snip boolean boolean -> void
diff --git a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl
index 71ead5d6e9..6b8b051765 100644
--- a/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl
+++ b/collects/mrlib/scribblings/graph/graph-pasteboard-intf.scrbl
@@ -43,5 +43,22 @@ drawn on the edges between nodes.
 This setting does not affect self-links---only links between two
 different nodes.
 
-}}
+}
+
+@defmethod[(draw-edges [dc (is-a?/c dc<%>)]
+[left real?]
+[top real?]
+[right real?]
+[bottom real?]
+[dx real?]
+[dy real?]) void?]{
+  This is called by the @method[editor<%> on-paint] callback of a
+  graph pasteboard, and is expected to draw the edges between the
+  snips. The argments are a subset of those passed to
+  @method[editor<%> on-paint] and it is only called when the
+  @scheme[before?] argument to   @method[editor<%> on-paint] 
+  is @scheme[#t].
+}
+
+}