From 26294f0232940fb8fdb7ae3adbeea065d5db24c1 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Thu, 30 Mar 2006 02:30:57 +0000
Subject: [PATCH] added explode-star

svn: r2541
---
 collects/texpict/doc.txt  |  9 +++++++
 collects/texpict/utils.ss | 57 +++++++++++++++++++++++++++++++++++++--
 2 files changed, 64 insertions(+), 2 deletions(-)

diff --git a/collects/texpict/doc.txt b/collects/texpict/doc.txt
index e69f2f304c..f5ae1e5c87 100644
--- a/collects/texpict/doc.txt
+++ b/collects/texpict/doc.txt
@@ -341,6 +341,15 @@ Basic Constructors:
    Creates a fish, swimming either 'left or 'right.
       [MrEd only, in utils.ss]
 
+> (explode-star small-rad large-rad points line-size line-color)
+
+  Creates a star-shaped explosion thingy. The points are
+  aligned on two radii, one for the beginning of the points
+  and one for the end, large-rad and small-rad. points is
+  the number of spikes sitcking out, and line-size and
+  line-color are the thickness of the lines and the lines
+  color.
+
 
 Combiners:
 ----------
diff --git a/collects/texpict/utils.ss b/collects/texpict/utils.ss
index 0c1f8dd497..e56efb2313 100644
--- a/collects/texpict/utils.ss
+++ b/collects/texpict/utils.ss
@@ -3,7 +3,8 @@
   (require (lib "class.ss")
 	   (lib "math.ss")
 	   (lib "etc.ss")
-	   (lib "mred.ss" "mred"))
+	   (lib "contract.ss")
+           (lib "mred.ss" "mred"))
 
   (require "mrpict.ss")
 
@@ -39,7 +40,7 @@
 	   angel-wing
 	   desktop-machine
 	   standard-fish
-
+           
 	   pin-line
 	   pin-arrow-line
            pin-arrows-line
@@ -934,4 +935,56 @@
 	       0 0 0 2)
 	      "blue"))
   
+  
+  (provide/contract [explode-star
+                     (-> number? number?  number? number? (union (is-a?/c color%) string?) pict?)])
+  ;; abstract-explosion number number number number color -> pict
+  (define (explode-star small-rad large-rad points line-size line-color)
+    (define (find-xy radius theta)
+      (values (* radius (cos theta))
+              (* radius (sin theta))))
+    (let ([roff (floor (/ large-rad 2))]
+          [fx #f]
+          [fy #f])
+      (dc
+       (lambda (dc dx dy)
+         (let ([old-pen (send dc get-pen)])
+           (send dc set-pen (send the-pen-list find-or-create-pen line-color line-size 'solid))
+           (let loop ([i points]
+                      [lx #f]
+                      [ly #f])
+             (cond
+               [(zero? i) (when (and lx ly)
+                            (send dc draw-line
+                                  (+ dx large-rad lx)
+                                  (+ dy large-rad ly)
+                                  (+ dx large-rad fx)
+                                  (+ dy large-rad fy)))]
+               [else (let* ([this-p (- i 1)]
+                            [theta1 (* 2 pi (/ this-p points))]
+                            [theta2 (* 2 pi (/ (- this-p 1/2) points))])
+                       (let-values ([(x1 y1) (find-xy small-rad theta1)]
+                                    [(x2 y2) (find-xy large-rad theta2)])
+                         (unless (and fx fy)
+                           (set! fx x1)
+                           (set! fy y1))
+                         (when (and lx ly)
+                           (send dc draw-line
+                                 (+ dx large-rad lx)
+                                 (+ dy large-rad ly)
+                                 (+ dx large-rad x1)
+                                 (+ dy large-rad y1)))
+                         (send dc draw-line
+                               (+ dx large-rad x1)
+                               (+ dy large-rad y1)
+                               (+ dx large-rad x2)
+                               (+ dy large-rad y2))
+                         (loop (- i 1)
+                               x2
+                               y2)))]))
+           (send dc set-pen old-pen)))
+       (* large-rad 2)
+       (* large-rad 2)
+       0
+       0)))
   )