experiment with alpha setting in dc<%>, plus some slideshow experiments and other minor changes

svn: r7399

collects/mred/lang/info.ss

@@ -0,0 +1,2 @@
+(module info (lib "infotab.ss" "setup")
+  (define name "MrEd #lang"))

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"))))

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")))

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

collects/mzscheme/lang/reader.ss

@@ -1,26 +1,5 @@
 (module reader mzscheme
-  (provide (rename *read read)
+  (require (lib "module-reader.ss" "syntax"))
-           (rename *read-syntax read-syntax))
 
-  (define (*read in)
+  (provide-module-reader mzscheme))
-    (wrap in read))
 
-  (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)))))

collects/net/doc.txt

@@ -52,7 +52,7 @@ For example, this url:
                                                  {6}
 
   1 = scheme, 2 = user, 3 = host, 4 = port,
-  5 = path,  6 = param (or last path segment),
+  5 = path (two elements),  6 = param (of second path element),
   7 = query, 8 = fragment
 
   The strings inside the fields user, path, query, and fragment are

collects/slideshow/core.ss

@@ -23,7 +23,8 @@
 				   page          ; int
 				   page-count    ; int
 				   inset         ; sinset
-				   transitions)) ; canvas% bitmap% -> 'went or delay-msecs
+				   transitions   ; canvas% bitmap% -> 'went or delay-msecs
+                                   timeout))     ; msecs
   (define/provide-struct just-a-comment (content)) ; content is list of strings and picts
   (define/provide-struct sinset (l t r b))
   (define/provide-struct click-region (left top right bottom thunk show-click?))
@@ -204,7 +205,7 @@
 	      (ht-append 2 p t))
 	    p))
 
-      (define (add-slide! pict title comment page-count inset)
+      (define (add-slide! pict title comment page-count inset timeout)
 	(viewer:add-talk-slide! 
 	 (make-sliderec (make-pict-drawer (add-commentary pict
 							  comment))
@@ -213,7 +214,8 @@
 			page-number
 			page-count
 			inset
-			null))
+			null
+                        timeout))
 	(set! page-number (+ page-number page-count)))
 
       (define (skip-slides n)
@@ -232,7 +234,7 @@
 	       (- (sinset-r sinset))
 	       (- (sinset-b sinset))))
 
-      (define (do-add-slide! content title comment page-count inset)
+      (define (do-add-slide! content title comment page-count inset timeout)
 	(add-slide!
 	 (ct-superimpose
 	  (apply-slide-inset inset full-page)
@@ -240,7 +242,8 @@
 	 title
 	 comment
 	 page-count
-	 inset))
+	 inset
+         timeout))
 
       (define default-slide-assembler
 	(lambda (s v-sep p)
@@ -254,7 +257,7 @@
 
       (define-struct name-only (title))
 
-      (define (one-slide/title/inset do-add-slide! use-assem? process v-sep skipped-pages s inset . x) 
+      (define (one-slide/title/inset do-add-slide! use-assem? process v-sep skipped-pages s inset timeout . x) 
 	(let-values ([(x c)
 		      (let loop ([x x][c #f][r null])
 			(cond
@@ -276,7 +279,8 @@
 	     (if (name-only? s) (name-only-title s) s)
 	     c
 	     (+ 1 skipped-pages)
-	     inset))))
+	     inset
+             timeout))))
 
       (define (slide-error nested string . args)
 	(apply error
@@ -287,7 +291,7 @@
 	       string
 	       args))
 
-      (define (do-slide/title/tall/inset do-add-slide! use-assem? skip-ok? process v-sep s inset . x)
+      (define (do-slide/title/tall/inset do-add-slide! use-assem? skip-ok? process v-sep s inset timeout . x)
 	;; Check slides:
 	(let loop ([l x][nested null])
 	  (or (null? l)
@@ -319,7 +323,7 @@
 	    (if skip-all?
 		(add1 skipped)
 		(begin
-		  (apply one-slide/title/inset do-add-slide! use-assem? process v-sep skipped s inset (reverse r))
+		  (apply one-slide/title/inset do-add-slide! use-assem? process v-sep skipped s inset timeout (reverse r))
 		  0))]
 	   [(memq (car l) '(nothing))
 	    (loop (cdr l) r comment skip-all? skipped)]
@@ -328,7 +332,7 @@
 	      (let ([skipped (if skip?
 				 (add1 skipped)
 				 (begin
-				   (apply one-slide/title/inset do-add-slide! use-assem? process v-sep skipped s inset (reverse r))
+				   (apply one-slide/title/inset do-add-slide! use-assem? process v-sep skipped s inset timeout (reverse r))
 				   0))])
 		(loop (cdr l) r comment skip-all? skipped)))]
 	   [(memq (car l) '(alts alts~)) 
@@ -349,7 +353,7 @@
 	(make-sinset l t r b))
 
       (define (slide/title/tall/inset/gap v-sep s inset . x)
-	(apply do-slide/title/tall/inset do-add-slide! #t #t values v-sep s inset x))
+	(apply do-slide/title/tall/inset do-add-slide! #t #t values v-sep s inset #f x))
 
       (define (slide/title/tall/inset s inset . x)
 	(apply slide/title/tall/inset/gap gap-size s inset x))
@@ -358,7 +362,7 @@
 	(apply slide/title/tall/inset (make-name-only s) inset x))
 
       (define (slide/title/tall/gap v-sep s . x)
-	(apply do-slide/title/tall/inset do-add-slide! #t #t values v-sep s zero-inset x))
+	(apply do-slide/title/tall/inset do-add-slide! #t #t values v-sep s zero-inset #f x))
 
       (define (slide/title/tall s . x)
 	(apply slide/title/tall/gap gap-size s x))
@@ -379,6 +383,9 @@
 	(apply slide/title/inset (make-name-only s) inset x))
 
       (define (slide/title/center/inset s inset . x)
+        (apply slide/title/center/inset/timeout s inset #f x))
+
+      (define (slide/title/center/inset/timeout s inset timeout . x)
 	(let ([max-width 0]
 	      [max-height 0]
 	      [combine (lambda (x)
@@ -388,13 +395,13 @@
 				 x)))])
 	  ;; Run through all the slides once to measure (don't actually create slides):
 	  (apply do-slide/title/tall/inset
-		 (lambda (content title comment page-count inset)
+		 (lambda (content title comment page-count inset timeout)
 		   (set! max-width (max max-width (pict-width content)))
 		   (set! max-height (max max-height (pict-height content))))
 		 #f
 		 #f
 		 (lambda (x) (list (combine x)))
-		 0 #f inset x)
+		 0 #f inset timeout x)
 	  (apply do-slide/title/tall/inset
 		 do-add-slide!
 		 #t
@@ -408,7 +415,7 @@
 		     (ct-superimpose
 		      (blank max-width max-height)
 		      (combine x)))))
-		 0 s inset x)))
+		 0 s inset timeout x)))
 
       (define (slide/name/center/inset s inset . x)
 	(apply slide/title/center/inset (make-name-only s) inset x))
@@ -425,6 +432,9 @@
       (define (slide/center . x) (apply slide/title/center #f x))
       (define (slide/center/inset inset . x) (apply slide/title/center/inset #f inset x))
 
+      (define (slide/center/timeout t . x)
+        (apply slide/title/center/inset/timeout #f zero-inset t x))
+
       (define most-recent-slide
 	(case-lambda
 	 [() (most-recent-slide 0)]
@@ -458,7 +468,8 @@
 	    page-number
 	    1
 	    (sliderec-inset s)
-	    null))
+	    null
+            (sliderec-timeout s)))
 	  (set! page-number (+ page-number 1))))
 
       (define (start-at-recent-slide)

collects/slideshow/sig.ss

@@ -49,6 +49,7 @@
      slide/name/inset
      slide/name/tall/inset
      slide/name/center/inset
+     slide/center/timeout
      
      most-recent-slide retract-most-recent-slide re-slide start-at-recent-slide
      scroll-transition pause-transition

collects/slideshow/slide.ss

@@ -100,7 +100,8 @@
 	   enable-click-advance!
 	   title-h get-title-h set-title-h! current-slide-assembler
 	   current-page-number-font current-page-number-color 
-	   set-page-numbers-visible! done-making-slides)
+	   set-page-numbers-visible! done-making-slides
+           slide/center/timeout)
   (provide/contract [clickback 
 		     ((pict? (lambda (x)
 			       (and (procedure? x)

collects/slideshow/viewer.ss

@@ -54,7 +54,8 @@
 		       0
 		       1
 		       zero-inset
-		       null))
+		       null
+                       #f))
 
       (define (talk-list-ref n)
 	(if (n . < . slide-count)
@@ -137,7 +138,8 @@
 						(sliderec-page (car (last-pair l)))
 						1 
 						zero-inset 
-						null)))))]
+						null
+                                                #f)))))]
 	 [else (let ([a (car l)]
 		     [b (cadr l)]
 		     [c (caddr l)]
@@ -174,7 +176,8 @@
 			(sliderec-page a)
 			(- (+ (sliderec-page d) (sliderec-page-count d)) (sliderec-page a))
 			zero-inset
-			null)
+			null
+                        (sliderec-timeout a))
 		       (make-quad (list-tail l 4))))]))
 
       ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -318,11 +321,30 @@
 	  
 	  (define/private (prev)
 	    (stop-transition)
-	    (set! current-page (max (sub1 current-page)
+	    (set! current-page 
-				    0))
+                  (let loop ([pos (max (sub1 current-page) 0)])
+                    (cond
+                     [(zero? pos) pos]
+                     [(sliderec-timeout (talk-list-ref pos)) (loop (sub1 pos))]
+                     [else pos])))
 	    (refresh-page))
 	  
 	  (define/public (next)
+	    (if (pair? current-transitions)
+		(stop-transition)
+                (if (sliderec-timeout (talk-list-ref current-page))
+                    ;; skip to a slide without a timeout:
+                    (change-slide
+                     (- (let loop ([pos (add1 current-page)])
+                          (cond
+                           [(= pos slide-count) (sub1 slide-count)]
+                           [(sliderec-timeout (talk-list-ref pos)) (loop (add1 pos))]
+                           [else pos]))
+                        current-page))
+                    ;; normal step:
+                    (change-slide 1))))
+
+          (define/public (next-one)
             (if (pair? current-transitions)
 		(stop-transition)
                 (change-slide 1)))
@@ -702,6 +724,19 @@
 	      (set! click-regions null)
 	      (set! clicking #f)
 	      (stop-transition/no-refresh)
+              (when (sliderec-timeout (talk-list-ref current-page))
+                (let ([key (gensym)])
+                  (set! current-timeout-key key)
+                  (new timer%
+                       [interval (inexact->exact
+                                  (floor 
+                                   (* (sliderec-timeout (talk-list-ref current-page))
+                                      1000)))]
+                       [just-once? #t]
+                       [notify-callback 
+                        (lambda ()
+                          (when (eq? current-timeout-key key)
+                            (send c-frame next-one)))])))
 	      (cond
 	       [config:use-offscreen?
 		(let-values ([(cw ch) (get-client-size)])
@@ -831,7 +866,9 @@
 	  (let-values ([(cw ch) (send dc get-size)])
 	    (paint-slide dc page 1 1 cw ch config:use-screen-w config:use-screen-h #t))]
 	 [(dc page extra-scale-x extra-scale-y cw ch usw ush to-main?)
-	  (let* ([slide (talk-list-ref page)]
+	  (let* ([slide (if (sliderec? page)
+                            page
+                            (talk-list-ref page))]
 		 [ins (sliderec-inset slide)]
 		 [cw (if to-main?
 			 (+ cw (sinset-l ins) (sinset-r ins))
@@ -960,6 +997,7 @@
 
       (define current-transitions null)
       (define current-transitions-key #f)
+      (define current-timeout-key #f)
 
       (define (do-transitions transes offscreen)
 	(let ([key (cons 1 2)])
@@ -995,7 +1033,8 @@
       
       (define (stop-transition/no-refresh)
 	(set! current-transitions null)
-	(set! current-transitions-key #f))
+	(set! current-transitions-key #f)
+        (set! current-timeout-key #f))
       
       (define (get-page-from-user)
 	(unless (zero? slide-count)

collects/syntax/module-reader.ss

@@ -0,0 +1,33 @@
+(module module-reader mzscheme
+  (provide provide-module-reader)
+
+  (define-syntax provide-module-reader
+    (syntax-rules ()
+      [(_ lib)
+       (begin
+         (provide (rename *read read)
+                  (rename *read-syntax read-syntax))
+         
+         (define (*read in)
+           (wrap 'lib in read))
+         
+         (define (*read-syntax src in)
+           (wrap 'lib in (lambda (in)
+                           (read-syntax src in)))))]))
+
+  (define (wrap lib 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 ,lib
+           . ,body)))))
+

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))
 

collects/tests/mzscheme/contmark.ss

@@ -649,4 +649,38 @@
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
+(module m-wcm_ mzscheme
+  (provide m-wcm-go)
+  (define (m-wcm-go test)
+    (let ([v #f])
+
+      (test
+       (with-continuation-mark
+           'x 'y
+         (with-continuation-mark
+             'x2 'y
+             (let/cc k
+           (with-continuation-mark
+               'x3 'y
+           (with-continuation-mark
+               'x4 'y
+           (with-continuation-mark
+               'x5 'y
+               (with-continuation-mark
+                   'x 'y3
+                 (list
+                  ((let/cc k2
+                     (set! v k2)
+                     (lambda () '(y3)))))))))))))
+       
+      (v (lambda () 
+           (set! v void)
+           (continuation-mark-set->list
+            (current-continuation-marks)
+            'x))))))
+(require m-wcm_)
+(m-wcm-go (lambda (a) (test '((y3)) values a)))
+
+;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (report-errs)

collects/texpict/utils.ss

@@ -56,6 +56,8 @@
 	   scale
 	   scale/improve-new-text
            
+           cellophane
+
 	   inset/clip
            clip
 
@@ -926,6 +928,29 @@
 		     #f)))]
      [(p factor) (scale p factor factor)]))
 
+  (define cellophane
+    (case-lambda
+     [(p alpha-factor)
+      (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)))]))
+
   (define inset/clip
     (case-lambda
      [(p l t r b)

src/mred/gc2/Makefile.in

@@ -1583,3 +1583,4 @@ gen-deps:
 @INCLUDEDEP@ wxs_tabc.dd
 @INCLUDEDEP@ wxs_win.dd
 @INCLUDEDEP@ wxscheme.dd
+@INCLUDEDEP@ wxJPEG.dd

src/mred/wxs/wxs_dc.cxx

@@ -1107,6 +1107,7 @@ static l_TYPE l_POINT *l_MAKE_ARRAY(Scheme_Object *l, l_INTTYPE *c, char *who)
 
 
 
+
 class os_wxDC : public wxDC {
  public:
 
@@ -1134,6 +1135,49 @@ os_wxDC::~os_wxDC()
     objscheme_destroy(this, (Scheme_Object *) __gc_external);
 }
 
+static Scheme_Object *os_wxDCGetAlpha(int n,  Scheme_Object *p[])
+{
+  WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
+  REMEMBER_VAR_STACK();
+  double r;
+  objscheme_check_valid(os_wxDC_class, "get-alpha in dc<%>", n, p);
+
+  SETUP_VAR_STACK_REMEMBERED(1);
+  VAR_STACK_PUSH(0, p);
+
+  
+
+  
+  r = WITH_VAR_STACK(((wxDC *)((Scheme_Class_Object *)p[0])->primdata)->GetAlpha());
+
+  
+  
+  READY_TO_RETURN;
+  return WITH_REMEMBERED_STACK(scheme_make_double(r));
+}
+
+static Scheme_Object *os_wxDCSetAlpha(int n,  Scheme_Object *p[])
+{
+  WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
+  REMEMBER_VAR_STACK();
+  objscheme_check_valid(os_wxDC_class, "set-alpha in dc<%>", n, p);
+  double x0;
+
+  SETUP_VAR_STACK_REMEMBERED(1);
+  VAR_STACK_PUSH(0, p);
+
+  
+  x0 = WITH_VAR_STACK(objscheme_unbundle_double(p[POFFSET+0], "set-alpha in dc<%>"));
+
+  
+  WITH_VAR_STACK(((wxDC *)((Scheme_Class_Object *)p[0])->primdata)->SetAlpha(x0));
+
+  
+  
+  READY_TO_RETURN;
+  return scheme_void;
+}
+
 static Scheme_Object *os_wxDCGlyphAvailable(int n,  Scheme_Object *p[])
 {
   WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
@@ -2513,8 +2557,10 @@ void objscheme_setup_wxDC(Scheme_Env *env)
   wxREGGLOB(os_wxDC_class);
   wxREGGLOB(os_wxDC_interface);
 
-  os_wxDC_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "dc%", "object%", NULL, 49));
+  os_wxDC_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "dc%", "object%", NULL, 51));
 
+  WITH_VAR_STACK(scheme_add_method_w_arity(os_wxDC_class, "get-alpha" " method", (Scheme_Method_Prim *)os_wxDCGetAlpha, 0, 0));
+  WITH_VAR_STACK(scheme_add_method_w_arity(os_wxDC_class, "set-alpha" " method", (Scheme_Method_Prim *)os_wxDCSetAlpha, 1, 1));
   WITH_VAR_STACK(scheme_add_method_w_arity(os_wxDC_class, "glyph-exists?" " method", (Scheme_Method_Prim *)os_wxDCGlyphAvailable, 1, 2));
   WITH_VAR_STACK(scheme_add_method_w_arity(os_wxDC_class, "end-page" " method", (Scheme_Method_Prim *)os_wxDCEndPage, 0, 0));
   WITH_VAR_STACK(scheme_add_method_w_arity(os_wxDC_class, "end-doc" " method", (Scheme_Method_Prim *)os_wxDCEndDoc, 0, 0));

src/mred/wxs/wxs_dc.xc

@@ -720,6 +720,9 @@ START_XFORM_SKIP;
 
 @ "glyph-exists?" : bool GlyphAvailable(mzchar,wxFont^=NULL) : : /CheckOk[METHODNAME("dc<%>","glyph-exists?")]
 
+@ "set-alpha" : void SetAlpha(double);
+@ "get-alpha" : double GetAlpha();
+
 @END
 
 @GLOBAL wxDCGlobal

src/wxmac/include/base/wb_dc.h

@@ -67,6 +67,8 @@ class wxbDC: public wxObject
   double user_scale_x;
   double user_scale_y;
 
+  double current_alpha;
+
   int mapping_mode;
 
   double min_x;          // bounding box
@@ -213,6 +215,8 @@ class wxbDC: public wxObject
   int GetAntiAlias();
   virtual void SetAntiAlias(int v);
 
+  virtual void SetAlpha(double d);
+  double GetAlpha();
 };
 
 // Conversion

src/wxmac/include/mac/wx_dccan.h

@@ -188,6 +188,7 @@ class wxCanvasDC: public wxbCanvasDC
   void DrawTabBase(double x, double y, double w, double h, int state);
   void DrawTab(char *str, double x, double y, double w, double h, int state);
 
+  virtual void SetAlpha(double d);
 };
 
 long wxTextFontInfo(int font, int size, int face, FontInfo *finfo, char *str, int d = 0, int len = -1);
@@ -196,7 +197,7 @@ double wxDrawUnicodeText(const char *text, int d, int len = -1, int ucs4 = FALSE
 			 double scale_x = 1.0, double scale_y = 1.0,
 			 int use_start = 0, double start_x = 0.0, double start_y = 0.0,
 			 double device_dx = 0.0, double device_dy = 0.0,
-			 int is_sym = 0);
+			 int is_sym = 0, double current_alpha = 1.0);
 void wxGetUnicodeTextWidth(const char *text, int d, int theStrlen, 
 			   short txFont, short txSize, short txFace,
 			   int ucs4, double scale_y,

src/wxmac/src/base/wb_dc.cc

@@ -43,6 +43,7 @@ wxbDC::wxbDC(void)
   clipping = FALSE;
   autoSetting = TRUE ;
   current_bk_mode = wxTRANSPARENT;
+  current_alpha = 1.0;
 }
 
 wxbDC::~wxbDC(void)
@@ -181,6 +182,16 @@ void wxbDC::SetAntiAlias(Bool v)
   anti_alias = v;
 }
 
+void wxbDC::SetAlpha(double a)
+{
+  current_alpha = a;
+}
+
+double wxbDC::GetAlpha()
+{
+  return current_alpha;
+}
+
 
 wxbCanvasDC::wxbCanvasDC(void)
 {

src/wxmac/src/mac/wx_dccan1.cc

@@ -990,6 +990,8 @@ CGContextRef wxCanvasDC::GetCG()
     CGContextScaleCTM(cg, user_scale_x, user_scale_y);
   }
 
+  CGContextSetAlpha(cg, current_alpha);
+
   return cg;
 }
 
@@ -998,6 +1000,18 @@ Bool wxCanvasDC::AlignSmoothing()
   return (anti_alias == 2);
 }
 
+void wxCanvasDC::SetAlpha(double a)
+{
+  CGContextRef cg;
+
+  wxbDC::SetAlpha(a);
+  
+  cg = cMacDC->GetCG(TRUE);
+  
+  if (cg)
+    CGContextSetAlpha(cg, current_alpha);
+}
+
 double wxCanvasDC::GetPenSmoothingOffset()
 {
   int pw;

src/wxmac/src/mac/wx_dccan3.cc

@@ -82,7 +82,8 @@ static double DrawMeasUnicodeText(const char *text, int d, int theStrlen, int uc
 				  double angle, int sym_map,
 				  double scale_x, double scale_y,
 				  double pen_delta_x, int with_delta,
-				  double pen_start_x, double pen_start_y, double ddx, double ddy, int with_start);
+				  double pen_start_x, double pen_start_y, double ddx, double ddy, int with_start,
+                                  double current_alpha);
 
 #ifndef DoubleToFixed
 # define DoubleToFixed(a) ((Fixed)((double) (a) * fixed1)) 
@@ -341,7 +342,8 @@ void wxCanvasDC::DrawText(const char* text, double x, double y, Bool combine, Bo
 			  y + (fontInfo.ascent * cos(angle)) - logical_origin_y, 
 			  device_origin_x + SetOriginX,
 			  device_origin_y + SetOriginY,
-			  font->GetFamily());
+			  font->GetFamily(),
+                          current_alpha);
   }
   
   ReleaseCurrentDC();
@@ -426,7 +428,7 @@ void wxCheckATSUCapability()
 
 double wxDrawUnicodeText(const char *text, int d, int theStrlen, int ucs4, Bool qd_spacing, int smoothing, double angle,
 			 double scale_x, double scale_y, int use_start, double start_x, double start_y, double ddx, double ddy,
-			 int is_sym)
+			 int is_sym, double current_alpha)
 {
   int i;
   int again = 0;
@@ -507,7 +509,8 @@ double wxDrawUnicodeText(const char *text, int d, int theStrlen, int ucs4, Bool
 				       qd_spacing, smoothing, angle, is_sym,
 				       scale_x, scale_y,
 				       pen_delta, move_pen_at_end || use_start,
-				       start_x, start_y, ddx, ddy, use_start);
+				       start_x, start_y, ddx, ddy, use_start,
+                                       current_alpha);
 	  
       d += amt;
       theStrlen -= amt;
@@ -587,7 +590,7 @@ void wxGetUnicodeTextWidth(const char *text, int d, int theStrlen,
 			       txFont, txSize, txFace,
 			       0, qd_spacing, wxSMOOTHING_DEFAULT, 0.0, is_sym,
 			       scale_x, scale_y,
-			       0.0, 0, 0.0, 0.0, 0.0, 0.0, 0);
+			       0.0, 0, 0.0, 0.0, 0.0, 0.0, 0, 0.0);
       *x = dx;
     } else {
       /* Need to split the string into parts */
@@ -624,7 +627,7 @@ void wxGetUnicodeTextWidth(const char *text, int d, int theStrlen,
 				      again, qd_spacing,
 				      wxSMOOTHING_DEFAULT, 0.0, is_sym,
 				      scale_x, scale_y, 
-				      0.0, 0, 0.0, 0.0, 0.0, 0.0, 0);
+				      0.0, 0, 0.0, 0.0, 0.0, 0.0, 0, 0.0);
 	  d += amt;
 	  theStrlen -= amt;
 	  again = 1;
@@ -697,7 +700,8 @@ static double DrawMeasUnicodeText(const char *text, int d, int theStrlen, int uc
 				  double angle, int is_sym,
 				  double scale_x, double scale_y,
 				  double pen_delta, int use_pen_delta,
-				  double start_x, double start_y, double ddx, double ddy, int with_start)
+				  double start_x, double start_y, double ddx, double ddy, int with_start,
+                                  double current_alpha)
 {
   ATSUTextLayout layout = NULL, *layouts;
   UniCharCount ulen, one_ulen, delta;
@@ -989,6 +993,9 @@ static double DrawMeasUnicodeText(const char *text, int d, int theStrlen, int uc
 			     (double)textColor.green / 65535.0,
 			     (double)textColor.blue / 65535.0,
 			     1.0);
+
+    /* set alpha */
+    CGContextSetAlpha(cgctx, current_alpha);
   }
 
   END_TIME(ctx);

src/wxwindow/include/base/wb_dc.h

@@ -59,6 +59,8 @@ class wxbDC: public wxObject
   double logical_scale_x;
   double logical_scale_y;
 
+  double current_alpha;
+
   int mapping_mode;
   int scaling_mode;
 
@@ -206,6 +208,9 @@ class wxbDC: public wxObject
  
   Bool GetAntiAlias();
   virtual void SetAntiAlias(Bool v);
+
+  virtual void SetAlpha(double d);
+  double GetAlpha();
 };
 
 /*

src/wxwindow/include/msw/wx_dc.h

@@ -196,6 +196,8 @@ class wxDC: public wxbDC
   double SmoothingXFormYB(double y);
   double SmoothingXFormWL(double w, double x);
   double SmoothingXFormHL(double h, double y);
+
+  void SetAlpha(double d);
 };
 
 // This class specific to Windows 3.1

src/wxwindow/src/base/wb_dc.cxx

@@ -25,6 +25,7 @@ wxbDC::wxbDC(void)
   autoSetting = TRUE;
   dcOptimize = TRUE;
   current_bk_mode = wxTRANSPARENT;
+  current_alpha = 1.0;
 }
 
 wxbDC::~wxbDC(void)
@@ -161,6 +162,16 @@ void wxbDC::SetAntiAlias(Bool v)
   anti_alias = v;
 }
 
+void wxbDC::SetAlpha(double a)
+{
+  current_alpha = a;
+}
+
+double wxbDC::GetAlpha()
+{
+  return current_alpha;
+}
+
 wxbMemoryDC::wxbMemoryDC(void) { }
 wxbMemoryDC::wxbMemoryDC(wxCanvasDC *WXUNUSED(old_dc)) { }
 wxbMemoryDC::~wxbMemoryDC(void) { }

src/wxwindow/src/msw/wx_dc.cxx

@@ -2847,6 +2847,11 @@ void wxDC::GetSizeMM(double *width, double *height)
   DoneDC(dc);
 }
 
+void wxDC::SetAlpha(double a)
+{
+  wxbDC:::SetAlpha(a);
+}
+
 wxCanvasDC::wxCanvasDC(void)
 {
   __type = wxTYPE_DC_CANVAS;

src/wxxt/src/DeviceContexts/DC.cc

@@ -247,6 +247,17 @@ void wxDC::SetAntiAlias(int v)
     anti_alias = v;
 }
 
+void wxDC::SetAlpha(double a)
+{
+  current_alpha = a;
+}
+
+double wxDC::GetAlpha()
+{
+  return current_alpha;
+}
+
+
 //-----------------------------------------------------------------------------
 // wxDC::DrawOpenSpline(wxList *pts), may be virtually overridden by any child
 //-----------------------------------------------------------------------------

src/wxxt/src/DeviceContexts/DC.h

@@ -228,9 +228,13 @@ public:
     int GetAntiAlias();
     virtual void SetAntiAlias(int v);  
 
+    virtual void SetAlpha(double d);
+    double GetAlpha();
+
     // public data members
     Bool  Colour;
     int   device;
+    double current_alpha;
 protected:
     Bool  auto_setting, optimize, ok;
     // everything needed for sizing

src/wxxt/src/DeviceContexts/WindowDC.cc

@@ -1153,7 +1153,9 @@ void wxWindowDC::Clear(void)
     r = c->Red();
     g = c->Green();
     b = c->Blue();
-    cairo_set_rgb_color(CAIRO_DEV, r / 255.0, g / 255.0, b / 255.0);    
+    cairo_set_source_rgba(CAIRO_DEV, 
+                          r / 255.0, g / 255.0, b / 255.0,
+                          current_alpha);
 
     cairo_new_path(CAIRO_DEV);
     cairo_move_to(CAIRO_DEV, 0, 0);
@@ -2325,7 +2327,7 @@ void wxWindowDC::DrawText(char *orig_text, double x, double y,
     col.color.green = (v << 8) | v;
     v = current_text_fg->Blue();
     col.color.blue = (v << 8) | v;
-    col.color.alpha = 0xFFFF;
+    col.color.alpha = (int)(current_alpha * 0xFFFF);
 
     if ((angle == 0.0) && (current_text_bgmode == wxSOLID)) {
       /* For B & W target, XftDrawRect doesn't seem to work right. */
@@ -2340,7 +2342,7 @@ void wxWindowDC::DrawText(char *orig_text, double x, double y,
 	bg.color.green = (v << 8) | v;
 	v = current_text_bg->Blue();
 	bg.color.blue = (v << 8) | v;
-	bg.color.alpha = 0xFFFF;
+	bg.color.alpha = (int)(current_alpha * 0xFFFF);
 	XftDrawRect(XFTDRAW, &bg, dev_x, dev_y, rw, xfontinfo->ascent + xfontinfo->descent);
       } else {
 	unsigned long pixel;
@@ -3702,6 +3704,7 @@ void wxWindowDC::InitCairoDev()
     cairo_translate(CAIRO_DEV, device_origin_x, device_origin_y);
     cairo_scale(CAIRO_DEV, scale_x, scale_y);
   }
+  
 }
 
 void wxWindowDC::ReleaseCairoDev()
@@ -3732,7 +3735,9 @@ Bool wxWindowDC::SetCairoPen()
     r = c->Red();
     g = c->Green();
     b = c->Blue();
-    cairo_set_rgb_color(CAIRO_DEV, r / 255.0, g / 255.0, b / 255.0);
+    cairo_set_source_rgba(CAIRO_DEV, 
+                          r / 255.0, g / 255.0, b / 255.0,
+                          current_alpha);
 
     pw = current_pen->GetWidthF();
     if (AlignSmoothing()) {
@@ -3800,7 +3805,9 @@ Bool wxWindowDC::SetCairoBrush()
     r = c->Red();
     g = c->Green();
     b = c->Blue();
-    cairo_set_rgb_color(CAIRO_DEV, r / 255.0, g / 255.0, b / 255.0);
+    cairo_set_source_rgba(CAIRO_DEV, 
+                          r / 255.0, g / 255.0, b / 255.0,
+                          current_alpha);
     return TRUE;
   } else
     return FALSE;
@@ -3816,6 +3823,11 @@ void wxWindowDC::SetAntiAlias(int v)
   wxDC::SetAntiAlias(v);
 }
 
+void wxWindowDC::SetAlpha(double d)
+{
+  wxDC::SetAlpha(d);
+}
+
 Bool wxWindowDC::AlignSmoothing()
 {
   return (anti_alias == 2);

src/wxxt/src/DeviceContexts/WindowDC.h

@@ -208,6 +208,8 @@ public:
 
   void SetAntiAlias(int v);
 
+  void SetAlpha(double d);
+
   Bool AlignSmoothing();
   double GetPenSmoothingOffset();
   double SmoothingXFormX(double x);