From db6ac7f0a6a800ef2d434b6ece9f483f749acd88 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 16 Nov 2005 01:16:58 +0000
Subject: [PATCH] improved Java example boxes

svn: r1325
---
 collects/embedded-gui/doc.txt                |  2 +-
 collects/embedded-gui/private/button-snip.ss | 53 +++++++++++++++++++-
 collects/embedded-gui/private/cue-text.ss    |  5 +-
 collects/profjBoxes/private/example-box.ss   |  6 ++-
 4 files changed, 59 insertions(+), 7 deletions(-)

diff --git a/collects/embedded-gui/doc.txt b/collects/embedded-gui/doc.txt
index 1e23ff99e7..6b76c3377f 100644
--- a/collects/embedded-gui/doc.txt
+++ b/collects/embedded-gui/doc.txt
@@ -84,7 +84,7 @@ _alignment-parent<%>_s implement the following methods.
 
 The pasteboard that this alignment is being displayed to
       
-> (send an-alignment-parent add-child) -> void
+> (send an-alignment-parent add-child child) -> void
   child : (is-a?/c alignment<%>)
   after : (union (is-a?/c alignment<%>) false?) = false
 
diff --git a/collects/embedded-gui/private/button-snip.ss b/collects/embedded-gui/private/button-snip.ss
index ac8f345fd5..426e90be49 100644
--- a/collects/embedded-gui/private/button-snip.ss
+++ b/collects/embedded-gui/private/button-snip.ss
@@ -90,6 +90,12 @@
       (super-new)
       (load-file image)))
   
+  (define BUTTON-H-SPACE 5)
+  (define BUTTON-V-SPACE 2)
+
+  (define UNCLICKED-COLOR (make-object color% 220 220 175))
+  (define CLICKED-COLOR (make-object color% 100 100 50))
+
   ;; a textual button of the same type
   (define text-button-snip%
     (class string-snip%
@@ -99,21 +105,64 @@
        [got-click? false]
        [inside? false])
 
+      (define/private (inc b v)
+	(when b
+	  (set-box! b (+ v (unbox b)))))
+
+      (define/override get-extent 
+	(opt-lambda (dc x y [w #f] [h #f] [db #f] [dt #f] [dl #f] [dr #f])
+	  (super get-extent dc (+ x BUTTON-H-SPACE) (+ y BUTTON-V-SPACE) w h db dt dl dr)
+	  (inc w (* 2 BUTTON-H-SPACE))
+	  (inc h (* 2 BUTTON-V-SPACE))
+	  (inc db BUTTON-V-SPACE)
+	  (inc dt BUTTON-V-SPACE)
+	  (inc dl BUTTON-H-SPACE)
+	  (inc dr BUTTON-H-SPACE)))
+
+      (define/override (draw dc x y t l r b dx dy caret)
+	(let ([p (send dc get-pen)]
+	      [b (send dc get-brush)]
+	      [smoothing (send dc get-smoothing)])
+	  (send dc set-pen "black" 1 'solid)
+	  (send dc set-brush 
+		(if got-click? CLICKED-COLOR UNCLICKED-COLOR)
+		'solid)
+	  (send dc set-smoothing 'aligned)
+	  (let ([w (box 0)]
+		[h (box 0)])
+	    (get-extent dc x y w h)
+	    (send dc draw-rounded-rectangle x y (unbox w) (unbox h) BUTTON-H-SPACE))
+	  (send dc set-pen p)
+	  (send dc set-brush b)
+	  (send dc set-smoothing smoothing))
+	(super draw dc (+ x BUTTON-H-SPACE) (+ y BUTTON-V-SPACE) 
+	       t l r b 
+	       (+ dx BUTTON-H-SPACE) (+ dy BUTTON-V-SPACE)
+	       caret))
+
       (define/override (on-event dc x y editorx editory event)
         (case (send event get-event-type)
           [(left-down)
            (set! got-click? true)
-           (set! inside? true)]
+           (set! inside? true)
+	   (refresh)]
           [(left-up)
            (when (and got-click? inside?)
              (callback this event))
            (set! got-click? false)
-           (set! inside? false)]
+           (set! inside? false)
+	   (refresh)]
           [(enter)
            (set! inside? true)]
           [(leave)
            (set! inside? false)]
           [else (void)]))
+
+      (inherit get-admin)
+      (define/private (refresh)
+	(let ([a (get-admin)])
+	  (when a
+	    (send a needs-update this 0 0 1000 100))))
       
       (super-make-object label)
       (inherit set-style)
diff --git a/collects/embedded-gui/private/cue-text.ss b/collects/embedded-gui/private/cue-text.ss
index a8f874354f..14fb8d9459 100644
--- a/collects/embedded-gui/private/cue-text.ss
+++ b/collects/embedded-gui/private/cue-text.ss
@@ -19,7 +19,7 @@
   
   (define cue-text-mixin
     (mixin ((class->interface text%)) ()
-      (inherit insert change-style erase)
+      (inherit insert change-style erase clear-undos)
       (init [cue-text ""]
             [color "gray"])
       (init-field
@@ -31,7 +31,8 @@
       (define (clear-cue-text)
         (when first-focus?
           (set! first-focus? false)
-          (erase)))
+          (erase)
+	  (clear-undos)))
       
       #;(boolean? . -> . void)
       ;; Called when this text% gains or loses focus
diff --git a/collects/profjBoxes/private/example-box.ss b/collects/profjBoxes/private/example-box.ss
index de854632f4..bb35937d1c 100644
--- a/collects/profjBoxes/private/example-box.ss
+++ b/collects/profjBoxes/private/example-box.ss
@@ -30,7 +30,7 @@
       
       ;; A readable-snip<%> of an examples box to allow GUI contruction of data examples.
       (define example-box%
-        (class* editor-snip% (readable-snip<%>)
+        (class* (decorated-editor-snip-mixin editor-snip%) (readable-snip<%>)
           (inherit set-snipclass)
           
           (init [examples-to-copy #f])
@@ -117,6 +117,8 @@
           ;;;;;;;;;;
           ;; Layout
           
+          (define/override (get-color) "purple")
+
           (field [pb (new aligned-pasteboard%)])
           (send pb lock-alignment true)
           (field [main (new vertical-alignment% (parent pb))]
@@ -233,7 +235,7 @@
           (new horizontal-alignment% (parent this)) ; spacer
           (new embedded-text-button%
                (parent this)
-               (label "Del")
+               (label "Delete")
                (callback (lambda (b e) (send (get-parent) delete-child this))))
           (send (get-pasteboard) lock-alignment false)
           ))