#lang scheme/gui

  (require "mrpict.ss")

  ;; Utilities for use with mrpict
  
  (provide cons-colorized-picture
	   color-frame
	   round-frame
	   color-round-frame
	   color-dash-frame

	   arrow
	   arrowhead
	   arrowhead/offset
	   arrow-line
	   arrows-line
	   pip-line
	   pip-arrow-line
	   pip-arrows-line
	   
           ellipse
           filled-ellipse
	   circle
	   disk
           rectangle
           filled-rectangle
	   rounded-rectangle
           filled-rounded-rectangle
           
	   cloud
	   file-icon
	   jack-o-lantern
	   angel-wing
	   desktop-machine
	   standard-fish
           
	   add-line
	   add-arrow-line
	   add-arrows-line

	   bitmap
	   bitmap-draft-mode

           find-pen
           find-brush
           
           color-series
           scale-color
	   scale/improve-new-text
           
           cellophane

	   inset/clip
           clip

	   hyperlinkize)
  
  (define (pict-path? p)
    (or (pict? p) 
        (and (pair? p)
             (list? p)
             (andmap pict? p))))
  
  (provide/contract 
   [scale (case-> (-> pict? number? number? pict?)
                  (-> pict? number? pict?))]
   [pin-line (->* (pict?
                   pict-path? (-> pict? pict-path? (values number? number?))
                   pict-path? (-> pict? pict-path? (values number? number?)))
                  ((or/c false/c number?)
                   (or/c false/c string?)
                   boolean?)
                  pict?)]
   [pin-arrow-line (->* (number?
                         pict?
                         pict-path? (-> pict? pict-path? (values number? number?))
                         pict-path? (-> pict? pict-path? (values number? number?)))
                        ((or/c false/c number?) 
                         (or/c false/c string?)
                         boolean?
                         boolean?
                         #:hide-arrowhead? any/c)
                        pict?)]
   [pin-arrows-line (->* (number? pict?
                           pict-path? (-> pict? pict-path? (values number? number?))
                           pict-path? (-> pict? pict-path? (values number? number?)))
                          ((or/c false/c number?)
                           (or/c false/c string?)
                           boolean?
                           boolean?
                           #:hide-arrowhead? any/c)
                          pict?)])



  (define (re-pict box naya)
    (let ([w (pict-width box)]
	  [h (pict-height box)]
	  [d (pict-descent box)]
	  [a (pict-ascent box)])
      (make-pict (pict-draw naya)
		 w h
		 a d
		 (list (make-child box 0 0 1 1))
		 #f
                 (pict-last box))))
  
  (define cons-colorized-picture
    (lambda (p color cmds)
      (re-pict
       p
       (cc-superimpose
	p
	(colorize
	 (cons-picture
	  (ghost (launder p))
	  cmds)
	 color)))))

  (define (round-frame p radius)
    (re-pict
     p
     (cc-superimpose
      p
      (let ([w (pict-width p)]
	    [h (pict-height p)])
	(dc (lambda (dc x y)
	      (let ([b (send dc get-brush)])
		(send dc set-brush (send the-brush-list find-or-create-brush
					 "white" 'transparent))
		(send dc draw-rounded-rectangle x y w h radius)
		(send dc set-brush b)))
	    (pict-width p) (pict-height p))))))

  ;; FIXME: abstract common part of color-frame, etc.

  (define color-frame
    (case-lambda
     [(p color w)
      (re-pict
       p
       (cc-superimpose
	p
	(let ([p2 (colorize (frame (ghost (launder p))) color)])
	  (if w
	      (linewidth w p2)
	      p2))))]
     [(p color) (color-frame p color #f)]))
  
  (define color-round-frame
    (case-lambda
     [(p radius color w)
      (re-pict
       p
       (cc-superimpose
	p
	(let ([p2 (colorize (round-frame (ghost (launder p)) radius) color)])
	  (if w
	      (linewidth w p2)
	      p2))))]
     [(p radius color) (color-round-frame p radius color #f)]))  

  (define color-dash-frame
    (case-lambda
     [(p seg-length color w)
      (re-pict
       p
       (cc-superimpose
	p
	(let ([p2 (colorize (dash-frame (ghost (launder p)) seg-length) color)])
	  (if w
	      (linewidth w p2)
	      p2))))]
     [(p seg-length color) (color-dash-frame p seg-length color #f)]))  

  ;; Returns three values: pict dx dy
  ;;  dx is in [-size, 0] and dy is in [0, size]
  (define (generic-arrow stem? solid? size angle pen-thickness)
    (values
     (dc
      (lambda (dc x y)
	(define (pt->xform-obj p)
	  (let* ([x (car p)]
		 [y (cadr p)]
		 [d (sqrt (+ (* x x) (* y y)))]
		 [a (atan y x)])
	    (make-object point% 
              (* d size 1/2 (cos (+ a angle)))
              (* d size 1/2 (- (sin (+ a angle)))))))
	(let ([b (send dc get-brush)]
	      [p (send dc get-pen)])
	  (send dc set-pen (send the-pen-list
				 find-or-create-pen
				 (send p get-color)
				 (if solid? 0 (send p get-width))
				 'solid))
	  (send dc set-brush (send the-brush-list
				   find-or-create-brush
				   (if solid? (send p get-color) "white")
				   'solid))
	  (send dc draw-polygon 
		(map pt->xform-obj
		     (if stem?
			 `((1 0)
			   (0 -1)
			   (0 -1/2)
			   (-1 -1/2)
			   (-1 1/2)
			   (0 1/2)
			   (0 1))
			 `((1 0)
			   (-1 -1)
			   (-1/2 0)
			   (-1 1))))
		(+ x (/ size 2)) (+ y (/ size 2)))
	  (send dc set-brush b)
	  (send dc set-pen p)))
      size size)
     (- (- 0 (* 1/2 size (cos angle))) (/ size 2))
     (- (+ (* 1/2 size) (- (* 1/2 size (sin angle)))) size)))

  (define (arrow/delta size angle)
    (generic-arrow #t #t size angle 0))
  (define (arrow size angle)
    (let-values ([(p dx dy) (arrow/delta size angle)])
      p))

  (define (arrowhead/delta pen-thickness size angle solid-head?)
    (generic-arrow #f solid-head? size angle pen-thickness))
  (define (arrowhead size angle)
    (let-values ([(p dx dy) (arrowhead/delta 0 size angle #t)])
      p))
  (define (arrowhead/offset size angle)
    (arrowhead/delta 0 size angle #t))

  (define (pip-line dx dy size)
    (picture
     0 0
     `((connect 0 0 ,dx ,(- dy)))))

  (define (arrow-line dx dy size)
    (let-values ([(a adx ady) (arrowhead/delta 0 size (atan dy dx) #t)])
      (picture
       0 0
       `((connect 0 0 ,dx ,dy)
	 (place ,(+ dx adx) ,(+ ady dy) ,a)))))

  (define (pip-arrow-line dx dy size)
    (arrow-line dx (- dy) size))

  (define (arrows-line dx dy size)
    (picture
     0 0
     `((place 0 0 ,(arrow-line dx dy size))
       (place ,dx ,dy ,(arrow-line (- dx) (- dy) size)))))

  (define (pip-arrows-line dx dy size)
    (arrows-line dx (- dy) size))

  (define (filled-rectangle w h #:draw-border? [draw-border? #t])
    (dc
     (lambda (dc x y)
       (let ([b (send dc get-brush)]
             [p (send dc get-pen)])
         (send dc set-brush (send the-brush-list find-or-create-brush
                                  (send p get-color)
                                  'solid))
         (unless draw-border?
           (send dc set-pen "black" 1 'transparent))
	 (send dc draw-rectangle x y w h)
         (send dc set-brush b)
         (send dc set-pen p)))
     w
     h))
  
  (define (rectangle w h)
    (dc
     (lambda (dc x y)
       (let ([b (send dc get-brush)])
         (send dc set-brush (send the-brush-list find-or-create-brush
                                  "white" 'transparent))
         (send dc draw-rectangle x y w h)
         (send dc set-brush b)))
     w
     h))
  
  (define (rounded-rectangle w h [corner-radius -0.25] #:angle [angle 0])
    (let ([dc-path (new dc-path%)])
      (send dc-path rounded-rectangle 0 0 w h corner-radius)
      (send dc-path rotate angle)
      (let-values ([(x y w h) (send dc-path get-bounding-box)])
        (dc (λ (dc dx dy) 
              (let ([brush (send dc get-brush)])
                (send dc set-brush (send the-brush-list find-or-create-brush
                                         "white" 'transparent))
                (send dc draw-path dc-path (- dx x) (- dy y))
                (send dc set-brush brush)))
            w
            h))))
  
  (define (filled-rounded-rectangle w h [corner-radius -0.25] #:angle [angle 0])
    (let ([dc-path (new dc-path%)])
      (send dc-path rounded-rectangle 0 0 w h corner-radius)
      (send dc-path rotate angle)
      (let-values ([(x y w h) (send dc-path get-bounding-box)])
        (dc (λ (dc dx dy) 
              (let ([brush (send dc get-brush)])
                (send dc set-brush (send the-brush-list find-or-create-brush
                                         (send (send dc get-pen) get-color)
                                         'solid))
                (send dc draw-path dc-path (- dx x) (- dy y))
                (send dc set-brush brush)))
            w
            h))))
  
  (define (circle size) (ellipse size size))
  
  (define (ellipse width height)
    (dc (lambda (dc x y)
	  (let ([b (send dc get-brush)])
	    (send dc set-brush (send the-brush-list find-or-create-brush
				     "white" 'transparent))
	    (send dc draw-ellipse x y width height)
	    (send dc set-brush b)))
	width height))

  (define (disk size) (filled-ellipse size size))
  
  (define (filled-ellipse width height)
    (dc (lambda (dc x y)
	  (let ([b (send dc get-brush)])
	    (send dc set-brush (send the-brush-list find-or-create-brush
				     (send (send dc get-pen) get-color)
				     'solid))
	    (send dc draw-ellipse x y width height)
	    (send dc set-brush b)))
	width height))

  (define cloud
    (case-lambda
     [(w h) (cloud w h "gray")]
     [(w h color)
      (dc
       (lambda (dc x y)
	 (let ([b (send dc get-brush)]
	       [p (send dc get-pen)])
	   (send dc set-pen (send the-pen-list
				  find-or-create-pen
				  "white" 0 'transparent))
	   (send dc set-brush (send the-brush-list
				    find-or-create-brush
				    color
				    'solid))
	   (send dc draw-ellipse
		 x (+ y (* 1/4 h))
		 (* 1/2 w) (* 1/2 h))
	   (send dc draw-ellipse
		 (+ x (* 1/5 w)) y
		 (* 3/5 w) (add1 (* 2/5 h)))
	   (send dc draw-ellipse
		 (+ x (* 1/5 w)) (+ y (* 1/3 h))
		 (* 3/5 w) (* 2/3 h))
	   (send dc draw-ellipse
		 (+ x (* 3/5 w)) (+ y (* 1/4 h))
		 (* 2/5 w) (* 1/3 h))
	   (send dc draw-ellipse
		 (+ x (* 3/5 w)) (+ y (* 1/2 h))
		 (* 2/5 w) (* 1/3 h))

	   (send dc set-brush b)
	   (send dc set-pen p)))
       w h)]))

  (define file-icon
    (lambda (w h gray [fancy? #f])
      (dc
       (let* ([sw (lambda (x) (* (/ w 110) x))]
	      [sh (lambda (y) (* (/ h 150) y))]
	      [->pt (lambda (l)
		      (map (lambda (p)
			     (make-object point% 
					  (sw (car p))
					  (sh (cadr p))))
			   l))])
	 (lambda (dc x y)
	   (define p (send dc get-pen))
	   (define b (send dc get-brush))

	   (let* ([bg-color (cond
                                 [(or (string? gray) (is-a? gray color%)) gray]
                                 [gray (make-object color% 200 200 255)]
                                 [else "white"])]
                  [line-color (if fancy?
                                  (scale-color 0.6 bg-color)
                                  "black")]
                  [color (send the-brush-list
                               find-or-create-brush
                               bg-color
                               'solid)])

	     (send dc set-pen (send the-pen-list 
				    find-or-create-pen 
                                    line-color
				    (send p get-width)
				    'solid))
	     (send dc set-brush color)
	     
	     (send dc draw-polygon 
		   (->pt '((0 0)
			   (0 150)
			   (110 150)
			   (110 20)
			   (90 0)))
		   x y)

             (send dc draw-line (+ x (sw 90)) (+ y 1) (+ x (sw 90)) (+ y (sh 20)))
             (send dc draw-line (+ x (sw 90)) (+ y (sh 20)) (+ x (sw 110) -1) (+ y (sh 20))))
	   
           (send dc set-brush b)
	   (send dc set-pen p)))
       w h)))

  (define angel-wing
    (lambda (w h left?)
      (dc
       (lambda (dc x y)
	 (let-values ([(sx sy) (send dc get-scale)]
		      [(dx dy) (send dc get-origin)])
	   (let ([nsx (* sx (/ w 54))]
		 [nsy (* sy (/ h 110))])
	     (send dc set-origin (+ dx (* x sx) (* (- 16) nsx)) (+ dy (* y sy) (* (- 20) nsy)))
	     (send dc set-scale nsx nsy)

	     (let ([wing
		    (list
		     
		     (list 70 (+ 50 40)  35 65     20 20)
		     (list 20 20    (- 20 5) (+ 20 30)    (+ 20 5) (+ 20 60))
		     (list (+ 20 5) (+ 20 60)    50 100    70 (+ 50 45))
		     
		     (list 22 70   (- 30 5) (+ 65 30)   (+ 30 5) (+ 65 40))
		     (list (+ 30 5) (+ 65 40)  50 110     70 (+ 50 50))
		     
		     (list 32 102   (- 40 5) (+ 65 50)   (+ 40 5) (+ 65 58))
		     (list (+ 40 5) (+ 65 58)   60  130    70 (+ 50 52)))])
	       (when left?
		 (for-each
		  (lambda (spline)
		    (send dc draw-spline . spline))
		  wing))
	       (unless left?
		 (for-each
		  (lambda (spline)
		    (let-values ([(x1 y1 x2 y2 x3 y3) (apply values spline)])
		      (send dc draw-spline (- 87 x1) y1 (- 86 x2) y2 (- 86 x3) y3)))
		  wing)))

	     (send dc set-origin dx dy)
	     (send dc set-scale sx sy))))
       w h)))

  (define desktop-machine
    (lambda (s [style null])
      (define icon
	(let ([bm (if (and (list? style) (memq 'plt style))
		      (make-object bitmap% (build-path (collection-path "icons") "plt-small-shield.gif"))
		      #f)])
	  (dc (lambda (dc x y)
		(let-values ([(sx sy) (send dc get-scale)]
			     [(dx dy) (send dc get-origin)]
			     [(op) (send dc get-pen)]
			     [(ob) (send dc get-brush)])
		  (send dc set-origin (+ dx (* sx x) (* s sx 10)) (+ dy (* sy y) (* s sy 15)))
		  (send dc set-scale (* sx s) (* sy s))
		  
		  (let ([gray (send the-brush-list
				    find-or-create-brush
				    "gray"
				    'solid)])
		    (send dc set-brush gray)
		    (send dc draw-polygon (list
					   (make-object point% 10 60)
					   (make-object point% 0 80)
					   (make-object point% 80 80)
					   (make-object point% 100 60)
					   (make-object point% 100 0)
					   (make-object point% 20 0)
					   (make-object point% 10 5))))
		  (send dc draw-line 80 80 90 60)
		  (send dc draw-rectangle 10 5 80 55)
		  (send dc set-brush (send the-brush-list
					   find-or-create-brush
					   "white"
					   'solid))
		  (send dc draw-rounded-rectangle 15 10 70 45 5)

		  (when (and (list? style) 
			     (or (memq 'devil style)
				 (memq 'binary style)))
		    (send dc set-font (make-object font% 12 'modern 'normal 'normal))
		    (let-values ([(w h d a) (send dc get-text-extent "101010")])
		      (let ([dx (+ (/ (- 70 w) 2) 15)]
			    [dy (+ (/ (- 45 (* 2 h) 2) 2) 10)])
			(send dc draw-text "101010" dx dy)
			(send dc draw-text "010101" dx (+ dy h 2))))
		    
		    (when (memq 'devil style)
		      (send dc set-brush (send the-brush-list
					       find-or-create-brush
					       "red"
					       'solid))
		      (let ([horn (list
				   (make-object point% 0 17)
				   (make-object point% 2 0)
				   (make-object point% 4 17))])
			(send dc draw-polygon horn 30 -15)
			(send dc draw-polygon horn 70 -15))
		      
		      (send dc draw-polygon (list
					     (make-object point% 0 0)
					     (make-object point% 10 2)
					     (make-object point% 0 6))
			    115 32)
		      
		      (send dc set-pen (send the-pen-list
					     find-or-create-pen
					     "red"
					     2
					     'solid))
		      (send dc draw-line 101 55 110 55)
		      (send dc draw-spline 110 55   130 50    110  45)
		      (send dc draw-spline 110 45   90 40    115  35)))
		    
		  (send dc set-origin dx dy)

		  (send dc set-pen op)
		  (send dc set-brush ob)

		  (send dc set-scale (* sx s 2/3) (* sy s 2/3))

		  (when (and (list? style) (memq 'plt style))
		    (when (send bm ok?)
		      (let ([w (send bm get-width)]
			    [h (send bm get-height)])
			(send dc draw-bitmap bm 
			      (/ (+ x (/ (- (* s 70) (* w 2/3 s)) 2) (* s 25)) (* 2/3 s))
			      (/ (+ y (/ (- (* s 45) (* h 2/3 s)) 2) (* s 25)) (* 2/3 s))))))

		  (send dc set-scale sx sy)))
	      (* s 120) (* s 115))))
      (if (pict? style)
	  (lt-superimpose
	   icon
	   (inset
	    (cc-superimpose (blank (* s 70) (* s 45)) style)
	    (* s 25) (* s 25) 0 0))
	  icon)))

  (define jack-o-lantern
    (lambda (size [pumpkin-color "orange"] [face-color "black"] [stem-color "brown"])
      (dc (lambda (dc x y)
	    (let ([b (send dc get-brush)]
		  [p (send dc get-pen)]
		  [set-brush (lambda (c)
			       (send dc set-brush 
				     (send the-brush-list
					   find-or-create-brush
					   c 'solid)))]
		  [r (make-object region% dc)]
		  [path (make-object dc-path%)]
		  [c (send dc get-clipping-region)])
	      (send dc set-pen (send the-pen-list
				     find-or-create-pen
				     "white" 1 'transparent))

	      ;; Stem ----------------------------------------
	      (send path arc
		    (+ x (* 0.42 size)) (- y (*  0.2 size))
		    size size
		    (* 0.8 pi) pi)
	      (send path arc
		    (+ x (* 0.52 size)) (- y (* 0.1 size))
		    (* 0.8 size) (* 0.8 size)
		    pi (* 0.8 pi) #f)
	      (send r set-path path)
	      (send dc set-clipping-region r)
	      (set-brush stem-color)
	      (send dc draw-rectangle x y size size)

	      ;; Body ----------------------------------------
	      (send dc set-clipping-region c)
	      (set-brush pumpkin-color)

	      (send dc draw-ellipse 
		    x (+ y (* 0.2 size))
		    (* 0.4 size) (* 0.8 size))
	      (send dc draw-ellipse 
		    (+ x (* 0.6 size)) (+ y (* 0.2 size))
		    (* 0.4 size) (* 0.8 size))

	      (send dc draw-ellipse 
		    (+ x (* 0.2 size)) (+ y (* 0.15 size))
		    (* 0.4 size) (* 0.9 size))
	      (send dc draw-ellipse 
		    (+ x (* 0.4 size)) (+ y (* 0.15 size))
		    (* 0.4 size) (* 0.9 size))

	      ;; Smile ----------------------------------------

	      (send r set-rectangle x (+ y (* 0.4 size)) size (* 0.7 size))
	      (send dc set-clipping-region r)

	      (set-brush face-color)
	      (send dc draw-ellipse
		    (+ x (* 0.15 size)) (+ y (* 0.2 size))
		    (* 0.7 size) (* 0.7 size))
	      
	      (set-brush pumpkin-color)
	      (send dc draw-ellipse
		    (+ x (* 0.15 size)) (sub1 (+ y (* 0.2 size)))
		    (* 0.7 size) (* 0.5 size))
	      (send dc draw-rectangle
		    (+ x (* 0.35 size)) (+ y (* 0.55 size))
		    (* 0.1 size) (* 0.2 size))
	      
	      ;; Eyes ----------------------------------------
	      (send dc set-clipping-region c)
	      (set-brush face-color)

	      (send dc draw-ellipse
		    (+ x (* 0.25 size)) (+ y (* 0.3 size))
		    (* 0.175 size) (* 0.25 size))
	      (send dc draw-ellipse
		    (+ x (* (- 0.75 0.175) size)) (+ y (* 0.3 size))
		    (* 0.175 size) (* 0.25 size))

	      (set-brush pumpkin-color)

	      (send dc draw-polygon
		    (list
		     (make-object point%
				  (* 0.5 size)
				  (* 0.45 size))
		     (make-object point%
				  (* 0.2 size)
				  (* 0.25 size))
		     (make-object point%
				  (* 0.8 size)
				  (* 0.25 size)))
		    x y)
	      
	      (send dc set-brush b)
	      (send dc set-pen p)))
	  size (* 1.1 size))))

  (define standard-fish 
    (lambda (w h [direction 'left] [c "blue"] [ec #f] [mouth-open #f])
      (define no-pen (send the-pen-list find-or-create-pen "black" 1 'transparent))
      (define color (if (string? c) (make-object color% c) c))
      (define dark-color (scale-color 0.8 color))
      (define eye-color (and ec (if (string? ec) (make-object color% ec) ec)))
      (define dark-eye-color color)
      (define mouth-open? (and mouth-open
                               (or (not (number? mouth-open))
                                   (not (zero? mouth-open)))))
      (define mouth-open-amt (if (number? mouth-open)
                                 mouth-open
                                 (if mouth-open 1.0 0.0)))
      (dc (lambda (dc x y)
            (let ([rgn (make-object region% dc)]
                  [old-rgn (send dc get-clipping-region)]
                  [old-pen (send dc get-pen)]
                  [old-brush (send dc get-brush)]
                  [flip-rel (lambda (x0) 
                              (if (eq? direction 'left)
                                  x0
                                  (- w x0)))]
                  [flip (lambda (x0 w0) 
                          (if (eq? direction 'left)
                              x0
                              (+ x (- w (- x0 x) w0))))]
		  [set-rgn (lambda (rgn flip?)
			     (let ([dy (if flip? (/ h 2) 0)])
			       (if mouth-open?
				   (send rgn set-polygon
					 (list (make-object point% 0 dy)
					       (make-object point% w dy)
					       (make-object point% w (- (* 1/2 h) dy))
					       (make-object point% (* 1/6 w) (- (* 1/2 h) dy))
					       (make-object point% 0 (if flip?
                                                                         (* 1/6 mouth-open-amt h)
                                                                         (+ (* 1/3 h)
                                                                            (* 1/6 (- 1 mouth-open-amt) h)))))
					 x (+ y dy))
				   (send rgn set-rectangle 
					 x (+ y dy)
					 w (/ h 2)))))])
              (send dc set-pen no-pen)
              (color-series
               dc 4 1
               dark-color color
               (lambda (ii)
		 (define i (* ii (min 1 (* w 1/100))))

                 (send dc draw-polygon (list (make-object point% (flip-rel (+ (* 1/2 w) i)) (* 1/10 h))
                                             (make-object point% (flip-rel (- (* 3/4 w) i)) (+ 0 i))
                                             (make-object point% (flip-rel (- (* 3/4 w) i)) (- (* 2/10 h) i)))
                       x y)
                 (send dc draw-polygon (list (make-object point% (flip-rel (+ (* 1/2 w) i)) (* 9/10 h))
                                             (make-object point% (flip-rel (- (* 3/4 w) i)) (- h i))
                                             (make-object point% (flip-rel (- (* 3/4 w) i)) (+ (* 8/10 h) i)))
                       x y)
                 (send dc draw-polygon (list (make-object point% (flip-rel (+ (* 3/4 w) i)) (/ h 2))
                                             (make-object point% (flip-rel (- w i)) (+ (* 1/10 h) i))
                                             (make-object point% (flip-rel (- w i)) (- (* 9/10 h) i)))
                       x y))
               #f #t)

	      (set-rgn rgn #f)
	      (send dc set-clipping-region rgn)
              (color-series
               dc 4 1
               dark-color color
               (lambda (i)
                 (send dc draw-ellipse (+ (- x (* 1/4 w)) i) (+ y i)
                       (- (* 6/4 w) (* 2 i)) (- (* 4 h) (* 2 i))))
               #f #t)
              (send dc set-clipping-region old-rgn)

              (set-rgn rgn #t)
              (send dc set-clipping-region rgn)
              (color-series
               dc 4 1
               dark-color color
               (lambda (i)
                 (send dc draw-ellipse (+ (- x (* 1/4 w)) i) (+ (- y (* 3 h)) i)
                       (- (* 6/4 w) (* 2 i)) (- (* 4 h) (* 2 i))))
               #f #t)
              (send dc set-clipping-region old-rgn)

              (when mouth-open?
                ;; Repaint border, just in case round-off does weird things
                (send dc set-pen color 1 'solid)
                (let ([y (+ y (/ h 2))])
                  (send dc draw-line 
                        (+ x (* 1/6 w)) y 
                        (+ x w -6) y))
                (send dc set-pen no-pen))

              (color-series
               dc 4 1
               dark-color color
               (lambda (ii)
		 (define i (* ii (min 1 (* w 1/100))))
		 (send dc draw-polygon (list (make-object point% (flip-rel (+ (* 1/2 w) i)) (/ h 2))
					     (make-object point% (flip-rel (- (* 5/8 w) i)) (+ (* 1/4 h) i))
					     (make-object point% (flip-rel (- (* 5/8 w) i)) (- (* 3/4 h) i)))
		       x y))
               #f #t)
              (when eye-color
		(if (eq? eye-color 'x)
		    (begin
		      (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'solid))
		      (let* ([ew (* 1/10 w)]
			     [eh (* 1/10 h)]
			     [x0 (flip (+ x (* 1/5 w)) ew)]
			     [x1 (flip (+ x (* 1/5 w) ew) ew)]
			     [y0 (+ y (* 2/3 h))]
			     [y1 (- (+ y (* 2/3 h)) eh)])
			(send dc draw-line x0 y0 x1 y1)
			(send dc draw-line x0 y1 x1 y0))
		      )
		    (color-series
		     dc
		     1/20 1/80
		     dark-eye-color eye-color
		     (lambda (s)
		       (let ([ew (* (- 1/10 s) w)])
			 (send dc draw-ellipse 
			       (flip (+ x (* 1/5 w) (* s 1/2 w)) ew)
			       (+ y (* 1/3 h) (* (* s 4/2) 1/2 h))
			       ew
			       (* (- 1/10 s) 4/2 h))))
		     #f #t)))
              (send dc set-pen old-pen)
              (send dc set-brush old-brush)))
          w h)))

  (define (-add-line base src find-src dest find-dest thickness color arrow-size arrow2-size under? solid-head?
                     #:hide-arrowhead? [hide-arrowhead? #f])
    (let-values ([(sx sy) (find-src base src)]
                 [(dx dy) (find-dest base dest)])
      (let ([arrows
             (let ([p (cons-picture
                       (ghost (launder base))
                       `(,(let* ([angle (atan (- sy dy) 
                                              (- sx dx))]
                                 [cosa (cos angle)]
                                 [sina (sin angle)]
                                 ;; If there's an arrow, line goes only half-way in
                                 [ddx (* (or arrow-size 0) 0.5 cosa)]
                                 [ddy (* (or arrow-size 0) 0.5 sina)]
                                 [dsx (* (or arrow2-size 0) 0.5 (- cosa))]
                                 [dsy (* (or arrow2-size 0) 0.5 (- sina))])
                            `(connect ,(+ sx dsx) ,(+ sy dsy) ,(+ dx ddx) ,(+ dy ddy)))
                         ,@(if (and arrow-size
                                    (not hide-arrowhead?))
                               (let-values ([(arrow xo yo)
                                             (arrowhead/delta
                                              (or thickness 0)
                                              arrow-size 
                                              (atan (- dy sy) 
                                                    (- dx sx))
                                              solid-head?)])
                                 `((place ,(+ dx xo) ,(+ dy yo) ,arrow)))
                               null)
                         ,@(if (and arrow2-size
                                    (not hide-arrowhead?))
                               (let-values ([(arrow xo yo)
                                             (arrowhead/delta
                                              (or thickness 0)
                                              arrow-size 
                                              (atan (- sy dy) 
                                                    (- sx dx))
                                              solid-head?)])
                                 `((place ,(+ sx xo) ,(+ sy yo) ,arrow)))
                               null)))])
               (let ([p2 (if thickness
                             (linewidth thickness p)
                             p)])
                 (if color
                     (colorize p2 color)
                     p2)))])
        (refocus
         (if under?
             (cc-superimpose arrows base)
             (cc-superimpose base arrows))
         base))))

  (define add-line
    (lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
      (-add-line base src find-src dest find-dest thickness color #f #f under? #t)))
  
  (define add-arrow-line
    (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]
                        #:hide-arrowhead? [hide-arrowhead? #f])
      (-add-line base src find-src dest find-dest thickness color arrow-size #f under? #t
                 #:hide-arrowhead? hide-arrowhead?)))
  
  (define add-arrows-line
    (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f]
                        #:hide-arrowhead? [hide-arrowhead? #f])
      (-add-line base src find-src dest find-dest thickness color arrow-size arrow-size under? #t
                 #:hide-arrowhead? hide-arrowhead?)))

  (define (flip-find-y find-)
    (lambda (base path)
      (let-values ([(x y) (find- base path)])
	(values x (- (pict-height base) y)))))

  (define pin-line
    (lambda (base src find-src dest find-dest [thickness #f] [color #f] [under? #f])
      (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
                 thickness color #f #f under? #t)))

  (define pin-arrow-line
    (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t]
                        #:hide-arrowhead? [hide-arrowhead? #f])
      (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
		 thickness color arrow-size #f under? solid-head?
                 #:hide-arrowhead? hide-arrowhead?)))
  
  (define pin-arrows-line
    (lambda (arrow-size base src find-src dest find-dest [thickness #f] [color #f] [under? #f] [solid-head? #t]
                        #:hide-arrowhead? [hide-arrowhead? #f])
      (-add-line base src (flip-find-y find-src) dest (flip-find-y find-dest)
                 thickness color arrow-size arrow-size under? solid-head?
                 #:hide-arrowhead? hide-arrowhead?)))
  
  (define black-color (make-object color% 0 0 0))

  (define bitmap-draft-mode (make-parameter #f (lambda (x) (and x #t))))

  (define (bitmap filename)
    (let ([bm (cond
	       [(bitmap-draft-mode) #f]
	       [(filename . is-a? . bitmap%) filename]
	       [(filename . is-a? . image-snip%) (send filename get-bitmap)]
	       [else (make-object bitmap% filename 'unknown/mask)])])
      (if (and bm (send bm ok?))
	  (let ([w (send bm get-width)]
		[h (send bm get-height)])
	    (dc
	     (lambda (dc x y)
	       (send dc draw-bitmap bm x y 'solid black-color (send bm get-loaded-mask)))
	     w h))
	  (frame (inset (colorize (text "bitmap failed") "red") 2)))))
  
  (define find-brush
    (lambda (color [style 'solid])
      (send the-brush-list find-or-create-brush color style)))
  (define find-pen
    (lambda (color [size 1] [style 'solid])
      (send the-pen-list find-or-create-pen color size style)))  

  (define (color-series dc steps dstep start-c end-c f pen? brush?)
    (let ([start-c (if (string? start-c)
		       (make-object color% start-c)
		       start-c)]
	  [end-c (if (string? end-c)
		       (make-object color% end-c)
		       end-c)])
      (let ([sr (send start-c red)]
	    [sg (send start-c green)]
	    [sb (send start-c blue)]
	    [er (send end-c red)]
	    [eg (send end-c green)]
	    [eb (send end-c blue)]
	    [c (make-object color%)]
	    [s (lambda (start end i)
                 (if (= steps 0)
                     end
                     (floor (+ start (* (- end start) (/ i steps))))))])
	(let loop ([i 0])
	  (send c set (s sr er i) (s sg eg i) (s sb eb i))
	  (when brush?
	    (send dc set-brush (find-brush c)))
	  (when pen?
	    (send dc set-pen (find-pen c)))
	  (f i)
	  (unless (= i steps)
	    (loop (+ dstep i)))))))
  
  (define (scale-color s c)
    (let ([c (if (string? c)
                 (make-object color% c)
                 c)])
      (let ([s (lambda (v)
                 (if (> s 1)
                     (- 255 (inexact->exact (floor (/ (- 255 v) s))))
                     (min 255 (inexact->exact (floor (* v s))))))])
        (make-object color%
          (s (send c red))
          (s (send c green))
          (s (send c blue))))))
  
  (define scale
    (case-lambda
     [(p x-factor y-factor)
      (let ([drawer (make-pict-drawer p)])
	(let ([new
	       (dc
		(lambda (dc x y)
		  (let-values ([(xs ys) (send dc get-scale)])
		    (send dc set-scale (* xs x-factor) (* ys y-factor))
		    (drawer dc
			    (/ x x-factor)
			    (/ y y-factor))
		    (send dc set-scale xs ys)))
		(* (pict-width p) x-factor)
		(* (pict-height p) y-factor)
		(* (pict-ascent p) y-factor)
		(* (pict-descent p) y-factor))])
	  (make-pict (pict-draw new)
		     (pict-width new)
		     (pict-height new)
		     (pict-ascent new)
		     (pict-descent new)
		     (list (make-child p 0 0 x-factor y-factor))
		     #f
                     (pict-last p))))]
     [(p factor) (scale p factor factor)]))

  (define cellophane
    (case-lambda
     [(p alpha-factor)
      (cond
       [(= 1.0 alpha-factor)
        (inset p 0)]
       [(zero? alpha-factor)
        (ghost p)]
       [else
        (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
                       (pict-last p))))])]))

  (define inset/clip
    (case-lambda
     [(p l t r b)
      (let* ([p (inset p l t r b)]
	     [drawer (make-pict-drawer p)]
	     [w (pict-width p)]
	     [h (pict-height p)])
	(let ([new
	       (dc
		(lambda (dc x y)
		  (let ([rgn (make-object region% dc)])
		    (send rgn set-rectangle x y w h)
		    (let ([r (send dc get-clipping-region)])
		      (when r
			(send rgn intersect r))
		      (send dc set-clipping-region rgn)
		      (drawer dc x y)
		      (send dc set-clipping-region r))))
		w h (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
                     (pict-last p))))]
     [(p h v) (inset/clip p h v h v)]
     [(p a) (inset/clip p a a a a)]))
  
  (define (clip p) (inset/clip p 0))
  
  (define-syntax scale/improve-new-text
    (syntax-rules ()
      [(_ expr s)
       (scale/improve-new-text expr s s)]
      [(_ expr sx sy)
       (let ([xs sx]
	     [ys sy])
	 (parameterize ([current-expected-text-scale
			 (let ([s (current-expected-text-scale)])
			   (list (* xs (car s)) (* ys (cadr s))))])
	   (scale expr xs ys)))]))

  (define (hyperlinkize r)
    (colorize (inset
	       (place-over r
			   0 (pict-height r)
			   (linewidth 2 (hline (pict-width r) 1)))
	       0 0 0 2)
	      "blue"))
  
  
  (provide/contract [explode-star
                     (-> number? number?  number? number? (or/c (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)))
