From de05280acfe58f567c8da2e8656db3585c017fb4 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Wed, 31 Aug 2005 02:24:21 +0000
Subject: [PATCH] added flash

svn: r711
---
 collects/texpict/code.ss  | 11 ++++++---
 collects/texpict/doc.txt  | 29 +++++++++++++++++++++++
 collects/texpict/flash.ss | 50 +++++++++++++++++++++++++++++++++++++++
 3 files changed, 87 insertions(+), 3 deletions(-)
 create mode 100644 collects/texpict/flash.ss

diff --git a/collects/texpict/code.ss b/collects/texpict/code.ss
index 4962381615..3c264b0f3c 100644
--- a/collects/texpict/code.ss
+++ b/collects/texpict/code.ss
@@ -45,7 +45,8 @@
      code-align current-code-tt
      current-keyword-list current-const-list code-colorize-enabled
      current-comment-color current-keyword-color 
-     current-base-color current-id-color current-literal-color))
+     current-base-color current-id-color current-literal-color
+     current-open-paren current-close-paren))
 
   (define-signature code-params^
     (current-font-size 
@@ -101,6 +102,8 @@
       (define current-literal-color (make-parameter literal-color))
       (define comment-color (current-base-color))
       (define current-comment-color (make-parameter comment-color))
+      (define current-open-paren (make-parameter #f))
+      (define current-close-paren (make-parameter #f))
       
       (define-computed open-paren-p (colorize (tt "(") (current-base-color)))
       (define-computed close-paren-p (colorize (tt ")") (current-base-color)))
@@ -121,7 +124,8 @@
 	  [(literal) close-paren/lit-p]
 	  [(template comment) close-paren/tmpl-p]
 	  [(cond template-cond local) close-sq-p]
-	  [else close-paren-p]))
+	  [else (or (current-close-paren)
+		    close-paren-p)]))
 
       (define (get-open mode)
 	(case mode
@@ -129,7 +133,8 @@
 	  [(template comment) open-paren/tmpl-p]
 	  [(contract line) (blank)]
 	  [(cond template-cond local) open-sq-p]
-	  [else open-paren-p]))
+	  [else (or (current-open-paren)
+		    open-paren-p)]))
       
       (define (add-close p closes)
 	(cond
diff --git a/collects/texpict/doc.txt b/collects/texpict/doc.txt
index c927915107..0085fab24b 100644
--- a/collects/texpict/doc.txt
+++ b/collects/texpict/doc.txt
@@ -1027,6 +1027,35 @@ implements an interactive browser for face configurations.
       - pupil-dx adjusts the pupil; recommend values: between -10 and 10
       - pupil-dy adjusts the pupil; recommend values: between -15 and 15
 
+------------------------------------------------------------
+_flash.ss_
+------------------------------------------------------------
+
+> (filled-flash width height [points spike-fraction rotation])
+  - returns a pict for a "flash" (a spiky oval, like the
+    yellow background that goes behind a "New!" logo).
+  
+    The `height' and `width' arguments determine the size of the oval
+    in which the flash is drawn, prior to rotation. The actual height
+    and width may be smaller if `points' is not a multiple of 4, and
+    the actuall height and width will be different if the flash is
+    rotated.
+
+    The `points' argument defaults to 10, and it determines
+    the number of points on the flash. 
+
+    The `spike-fraction' argument determines how big the flash spikes
+    are compared to the bounding oval. It should be a value between 0
+    and 1 (exclusive), and the default is 0.25.
+
+    The `rotation' argument specifies an angle in radians for
+    counter-clockwise rotation.
+
+    The flash is drawn in the default color.
+
+> (outline-flash width height [points spike-fraction rotation])
+   - like `filled-flash', but drawing only the outline.
+
 ------------------------------------------------------------
 _code.ss_
 ------------------------------------------------------------
diff --git a/collects/texpict/flash.ss b/collects/texpict/flash.ss
new file mode 100644
index 0000000000..51c39e253f
--- /dev/null
+++ b/collects/texpict/flash.ss
@@ -0,0 +1,50 @@
+
+(module flash mzscheme
+  (require "mrpict.ss"
+	   (lib "math.ss")
+	   (lib "etc.ss")
+           (lib "mred.ss" "mred")
+           (lib "class.ss"))
+
+  (provide filled-flash
+	   outline-flash)
+
+  (define-syntax define-flash
+    (syntax-rules ()
+      [(_ id filled?)
+       (define id
+	 (opt-lambda (w h [points 10] [spike-fraction 0.25] [rotation 0])
+	   (do-flash filled? w h points spike-fraction rotation)))]))
+
+  (define-flash filled-flash #t)
+  (define-flash outline-flash #f)
+
+  (define no-brush
+    (send the-brush-list find-or-create-brush "white" 'transparent))
+
+  (define do-flash
+    (lambda (filled? w h points spike-fraction rotation)
+      (let ([p (new dc-path%)]
+            [delta (/ pi points)]
+            [in (- 1 spike-fraction)])
+        (send p move-to 1 0)
+        (let loop ([angle delta][points (sub1 points)])
+          (send p line-to (* in (cos angle)) (* in (sin angle)))
+          (unless (zero? points)
+            (let ([angle (+ angle delta)])
+              (send p line-to (cos angle) (sin angle))
+              (loop (+ angle delta) (sub1 points)))))
+        (send p close)
+        (send p scale (/ w 2) (/ h 2))
+        (unless (zero? rotation)
+          (send p rotate rotation))        
+        (let-values ([(bx by bw bh) (send p get-bounding-box)])
+          (send p translate (- bx) (- by))
+          (dc (lambda (dc x y)
+		(let ([b (or filled? (send dc get-brush))])
+		  (unless filled?
+		    (send dc set-brush no-brush))
+		  (send dc draw-path p x y)
+		  (unless filled?
+		    (send dc set-brush b))))
+              bw bh))))))