From 6dff582220eab18c57209e010cfd90b71b795847 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Sat, 22 Sep 2007 13:48:22 +0000
Subject: [PATCH] experiment with alpha setting in dc<%>, plus some slideshow
 experiments and other minor changes

svn: r7399

original commit: b9a0d860c07a1c58c46a60fdb1ce0541eca225d2
---
 collects/mred/lang/main.ss       |  6 ++++++
 collects/mred/lang/reader.ss     |  4 ++++
 collects/mred/private/kernel.ss  |  2 ++
 collects/mzscheme/lang/reader.ss | 25 ++-----------------------
 collects/tests/mred/draw.ss      | 18 ++++++++++++++++--
 5 files changed, 30 insertions(+), 25 deletions(-)
 create mode 100644 collects/mred/lang/main.ss
 create mode 100644 collects/mred/lang/reader.ss

diff --git a/collects/mred/lang/main.ss b/collects/mred/lang/main.ss
new file mode 100644
index 00000000..cb188c81
--- /dev/null
+++ b/collects/mred/lang/main.ss
@@ -0,0 +1,6 @@
+(module main mzscheme
+  (require (lib "class.ss")
+           (lib "mred.ss" "mred"))
+  (provide (all-from mzscheme)
+           (all-from (lib "class.ss"))
+           (all-from (lib "mred.ss" "mred"))))
diff --git a/collects/mred/lang/reader.ss b/collects/mred/lang/reader.ss
new file mode 100644
index 00000000..b68e74b5
--- /dev/null
+++ b/collects/mred/lang/reader.ss
@@ -0,0 +1,4 @@
+(module reader mzscheme
+  (require (lib "module-reader.ss" "syntax"))
+
+  (provide-module-reader (lib "main.ss" "mred" "lang")))
diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss
index 23a2e19d..28926eb3 100644
--- a/collects/mred/private/kernel.ss
+++ b/collects/mred/private/kernel.ss
@@ -373,6 +373,8 @@
     on-event
     on-paint)
   (define-private-class dc% dc<%> object% #f
+    get-alpha
+    set-alpha
     glyph-exists?
     end-page
     end-doc
diff --git a/collects/mzscheme/lang/reader.ss b/collects/mzscheme/lang/reader.ss
index ea0df3a4..d68946ec 100644
--- a/collects/mzscheme/lang/reader.ss
+++ b/collects/mzscheme/lang/reader.ss
@@ -1,26 +1,5 @@
 (module reader mzscheme
-  (provide (rename *read read)
-           (rename *read-syntax read-syntax))
+  (require (lib "module-reader.ss" "syntax"))
 
-  (define (*read in)
-    (wrap in read))
+  (provide-module-reader mzscheme))
 
-  (define (*read-syntax src in)
-    (wrap in (lambda (in)
-               (read-syntax src in))))
-
-  (define (wrap port read)
-    (let ([body
-           (let loop ([a null])
-             (let ([v (read port)])
-               (if (eof-object? v)
-                   (reverse a)
-                   (loop (cons v a)))))])
-      (let* ([p-name (object-name port)]
-             [name (if (path? p-name)
-                       (let-values ([(base name dir?) (split-path p-name)])
-                         (string->symbol (path->string (path-replace-suffix name #""))))
-                       'page)]
-             [id 'doc])
-        `(module ,name mzscheme
-           . ,body)))))
diff --git a/collects/tests/mred/draw.ss b/collects/tests/mred/draw.ss
index 733c3f6e..fd2e9342 100644
--- a/collects/tests/mred/draw.ss
+++ b/collects/tests/mred/draw.ss
@@ -204,6 +204,8 @@
        [hp2 hp]
        [hp2.5 hp0]
        [hp3 hp]
+       [hp4 (new horizontal-panel% [parent vp]
+                 [stretchable-height #f])]
        [bb (make-object bitmap% (sys-path "bb.gif") 'gif)]
        [return (let* ([bm (make-object bitmap% (sys-path "return.xbm") 'xbm)]
 		      [dc (make-object bitmap-dc% bm)])
@@ -220,7 +222,8 @@
        [smoothing 'unsmoothed]
        [save-filename #f]
        [save-file-format #f]
-       [clip 'none])
+       [clip 'none]
+       [current-alpha 1.0])
   (send hp0 stretchable-height #f)
   (send hp stretchable-height #f)
   (send hp2.5 stretchable-height #f)
@@ -936,9 +939,13 @@
 				      mem-dc)
 				    (get-dc)))])
 		    (when dc
+                      (send dc clear)
+
 		      (send dc start-doc "Draw Test")
 		      (send dc start-page)
 
+                      (send dc set-alpha current-alpha)
+
 		      (if clip-pre-scale?
 			  (begin
 			    (send dc set-scale 1 1)
@@ -1205,7 +1212,14 @@
 			     (set! clock-start #f)
 			     (set! clock-end #f)
 			     (send canvas refresh))))])
-      (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t)))))
+      (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t)))
+      (make-object slider% "Alpha" 0 10 hp4
+                   (lambda (s e)
+                     (let ([a (/ (send s get-value) 10.0)])
+                       (unless (= a current-alpha)
+                         (set! current-alpha a)
+                         (send canvas refresh))))
+                   10 '(horizontal plain))))
 
   (send f show #t))