From b025b527df735e67bd7c25f574c6d29bfc2f5867 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Thu, 4 Oct 2007 06:24:43 +0000
Subject: [PATCH] allow pin-over to accept pict-finding paths, etc.

svn: r7430
---
 collects/slideshow/viewer.ss            | 15 ++++++----
 collects/texpict/private/common-unit.ss |  4 ++-
 collects/texpict/utils.ss               | 39 ++++++++++++++-----------
 3 files changed, 35 insertions(+), 23 deletions(-)

diff --git a/collects/slideshow/viewer.ss b/collects/slideshow/viewer.ss
index f4f635d653..e2959f7110 100644
--- a/collects/slideshow/viewer.ss
+++ b/collects/slideshow/viewer.ss
@@ -319,7 +319,7 @@
 		    [y (send background-f get-y)])
 		(send background-f move (+ x dx) (+ y dy)))))
 	  
-	  (define/private (prev)
+	  (define/public (prev)
 	    (stop-transition)
 	    (set! current-page 
                   (let loop ([pos (max (sub1 current-page) 0)])
@@ -504,9 +504,11 @@
       (send (new (class editor-canvas% 
 		   (define/override (on-event e)
 		     (super on-event e)
-		     (when (and click-to-advance?
-				(send e button-up?))
-		       (send f next)))
+		     (when click-to-advance?
+                       (when (send e button-up? 'left)
+                         (send f next))
+                       (when (send e button-up? 'right)
+                         (send f prev))))
 		   (super-new))
 		 [parent c-frame] 
 		 [editor commentary] 
@@ -638,9 +640,12 @@
 		(set! clicking #f)
 		(when hit?
 		  ((click-region-thunk c))))]
-	     [(send e button-up?)
+	     [(send e button-up? 'left)
 	      (when click-to-advance?
 		(send (get-top-level-window) next))]
+	     [(send e button-up? 'right)
+	      (when click-to-advance?
+		(send (get-top-level-window) prev))]
 	     [else 
 	      (when (and clicking clicking-hit?)
 		(invert-clicking! #f))
diff --git a/collects/texpict/private/common-unit.ss b/collects/texpict/private/common-unit.ss
index 24d3be69bc..ed285c4c58 100644
--- a/collects/texpict/private/common-unit.ss
+++ b/collects/texpict/private/common-unit.ss
@@ -811,7 +811,9 @@
 		      (cond
 		       [(and (number? dx) (number? dy))
 			(values dx (- (pict-height base) dy))]
-		       [(and (pict? dx) (procedure? dy)
+		       [(and (or (pict? dx) 
+                                 (and (list? dx) (andmap pict? dx)))
+                             (procedure? dy)
 			     (procedure-arity-includes? dy 2))
 			(if flip?
 			    (let-values ([(dx dy) (dy base dx)])
diff --git a/collects/texpict/utils.ss b/collects/texpict/utils.ss
index 1dfcb72d5b..2b05571f6e 100644
--- a/collects/texpict/utils.ss
+++ b/collects/texpict/utils.ss
@@ -931,26 +931,31 @@
   (define cellophane
     (case-lambda
      [(p alpha-factor)
-      (let ([drawer (make-pict-drawer p)])
-	(let ([new
-	       (dc
-		(lambda (dc x y)
-                  (unless (zero? alpha-factor)
+      (cond
+       [(= 1.0 alpha-factor)
+        (inset p 0)]
+       [(zero? alpha-factor)
+        (ghost p)]
+       [else
+        (let ([drawer (make-pict-drawer p)])
+          (let ([new
+                 (dc
+                  (lambda (dc x y)
                     (let ([a (send dc get-alpha)])
                       (send dc set-alpha (* a alpha-factor))
                       (drawer dc x y)
-                      (send dc set-alpha a))))
-		(pict-width p)
-		(pict-height p)
-		(pict-ascent p)
-		(pict-descent p))])
-	  (make-pict (pict-draw new)
-		     (pict-width new)
-		     (pict-height new)
-		     (pict-ascent new)
-		     (pict-descent new)
-		     (list (make-child p 0 0 1 1))
-		     #f)))]))
+                      (send dc set-alpha a)))
+                  (pict-width p)
+                  (pict-height p)
+                  (pict-ascent p)
+                  (pict-descent p))])
+            (make-pict (pict-draw new)
+                       (pict-width new)
+                       (pict-height new)
+                       (pict-ascent new)
+                       (pict-descent new)
+                       (list (make-child p 0 0 1 1))
+                       #f)))])]))
 
   (define inset/clip
     (case-lambda