From 8c3eb7dcb4a43948e062dfa674bfec59c1790980 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 2 Mar 2013 08:05:36 -0700
Subject: [PATCH] slideshow/pict: add `#:alpha' argument to `pin-line'

---
 collects/scribblings/slideshow/picts.scrbl |  5 +++-
 collects/slideshow/pict.rkt                | 27 ++++++++++++++--------
 2 files changed, 22 insertions(+), 10 deletions(-)

diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl
index edef45e6c5..55a41c13e0 100644
--- a/collects/scribblings/slideshow/picts.scrbl
+++ b/collects/scribblings/slideshow/picts.scrbl
@@ -393,6 +393,7 @@ argument for consistency with the other functions.}
                       [#:end-pull end-pull real? 1/4]
                       [#:line-width line-width (or/c #f real?) #f]
                       [#:color color (or/c #f string? (is-a?/c color%)) #f]
+                      [#:alpha alpha (real-in 0.0 1.0)]
                       [#:style style (one-of/c 'transparent 'solid 'xor 'hilite 
                                                'dot 'long-dash 'short-dash 'dot-dash 
                                                'xor-dot 'xor-long-dash 'xor-short-dash 
@@ -411,6 +412,7 @@ argument for consistency with the other functions.}
                       [#:end-pull end-pull real? 1/4]
                       [#:line-width line-width (or/c #f real?) #f]
                       [#:color color (or/c #f string? (is-a?/c color%)) #f]
+                      [#:alpha alpha (real-in 0.0 1.0)]
                       [#:style style (one-of/c 'transparent 'solid 'xor 'hilite 
                                                'dot 'long-dash 'short-dash 'dot-dash 
                                                'xor-dot 'xor-long-dash 'xor-short-dash 
@@ -431,6 +433,7 @@ argument for consistency with the other functions.}
                       [#:end-pull end-pull real? 1/4]
                       [#:line-width line-width (or/c #f real?) #f]
                       [#:color color (or/c #f string? (is-a?/c color%)) #f]
+                      [#:alpha alpha (real-in 0.0 1.0)]
                       [#:style style (one-of/c 'transparent 'solid 'xor 'hilite 
                                                'dot 'long-dash 'short-dash 'dot-dash 
                                                'xor-dot 'xor-long-dash 'xor-short-dash 
@@ -466,7 +469,7 @@ defaults produce a straight line):
 
 ]
 
-The @racket[line-width], @racket[color], and @racket[style] arguments
+The @racket[line-width], @racket[color], @racket[alpha], and @racket[style] arguments
 apply to the added line.
 
 When the @racket[hide-arrowhead?] argument is a true value, then space
diff --git a/collects/slideshow/pict.rkt b/collects/slideshow/pict.rkt
index 934c147e4d..98eb6d9330 100644
--- a/collects/slideshow/pict.rkt
+++ b/collects/slideshow/pict.rkt
@@ -49,6 +49,7 @@
                     #:start-angle [sa #f] #:end-angle [ea #f]
                     #:start-pull [sp #f] #:end-pull [ep #f]
                     #:color [col #f]
+                    #:alpha [alpha 1.0]
                     #:line-width [lw #f]
                     #:under? [under? #f]
                     #:solid? [solid? #t]
@@ -58,10 +59,10 @@
                                          src src-find 
                                          dest dest-find
                                          #:style style))
-                    p lw col under?)
+                    p lw col alpha under?)
         (pin-curve* #f #f p src src-find dest dest-find
                     sa ea sp ep 0 col lw under? #t
-                    style)))
+                    style alpha)))
 
   (define (pin-arrow-line sz p 
                           src src-find
@@ -69,6 +70,7 @@
                           #:start-angle [sa #f] #:end-angle [ea #f]
                           #:start-pull [sp #f] #:end-pull [ep #f]
                           #:color [col #f]
+                          #:alpha [alpha 1.0]
                           #:line-width [lw #f]
                           #:under? [under? #f]
                           #:solid? [solid? #t]
@@ -81,10 +83,10 @@
                                                #f #f #f solid?
                                                #:hide-arrowhead? hide-arrowhead?
                                                #:style style))
-                    p lw col under?)
+                    p lw col alpha under?)
         (pin-curve* #f (not hide-arrowhead?) p src src-find dest dest-find
                     sa ea sp ep sz col lw under? solid?
-                    style)))
+                    style alpha)))
   
     (define (pin-arrows-line sz p 
                              src src-find
@@ -92,6 +94,7 @@
                              #:start-angle [sa #f] #:end-angle [ea #f]
                              #:start-pull [sp #f] #:end-pull [ep #f]
                              #:color [col #f]
+                             #:alpha [alpha 1.0]
                              #:line-width [lw #f]
                              #:under? [under? #f]
                              #:solid? [solid? #t]
@@ -104,11 +107,11 @@
                                                   #f #f #f solid?
                                                   #:hide-arrowhead? hide-arrowhead?
                                                   #:style style))
-                      p lw col under?)
+                      p lw col alpha under?)
           (pin-curve* (not hide-arrowhead?) (not hide-arrowhead?)
                       p src src-find dest dest-find
                       sa ea sp ep sz col lw under? solid? 
-                      style)))
+                      style alpha)))
     
   (define (pin-curve* start-arrow? end-arrow? p 
                       src src-find
@@ -116,7 +119,7 @@
                       sa ea sp ep
                       sz col lw
                       under? solid?
-                      style)
+                      style alpha)
     (let-values ([(sx0 sy0) (src-find p src)]
                  [(dx0 dy0) (dest-find p dest)])
       (let* ([sa (or sa
@@ -169,6 +172,9 @@
                     [p (if col
                            (colorize p col)
                            p)]
+                    [p (if (= alpha 1.0)
+                           p
+                           (cellophane p alpha))]
                     [p (if lw
                            (linewidth lw p)
                            p)]
@@ -180,13 +186,16 @@
            sx sy sx0 sy0)))))
 
 
-  (define (finish-pin l p lw col under?)
+  (define (finish-pin l p lw col alpha under?)
     (let* ([l (if lw
                   (linewidth lw l)
                   l)]
            [l (if col
                   (colorize l col)
-                  l)])
+                  l)]
+           [l (if (= alpha 1.0)
+                  l
+                  (cellophane l alpha))])
       (if under?
           (cc-superimpose l p)
           (cc-superimpose p l))))