(module face mzscheme
  (require racket/draw
           texpict/mrpict
           texpict/utils
           mzlib/class
           mzlib/math
           mzlib/etc
           mzlib/kw)

  (provide face face* default-face-color)
  
  (define no-brush (find-brush "white" 'transparent))
  (define no-pen (find-pen "white" 1 'transparent))

  (define (series dc steps start-c end-c f pen? brush?)
    (color-series dc steps #e0.5 start-c end-c f pen? brush?))

  (define default-face-color (make-object color% "orange"))

  (define face*
    (lambda/kw (eyebrows-kind
                mouth-kind
                frown?
                #:optional
                [in-face-color default-face-color]
                [eye-inset 0]
                [eyebrow-dy 0]
                [eye-dx 0]
                [eye-dy 0]
                #:key
                (mouth-shading? #t)
                (eye-shading? #t)
                (eyebrow-shading? #t)
                (tongue-shading? #t)
                (face-background-shading? #t)
                (teeth? #t))
               
      (define face-color (if (string? in-face-color)
                             (make-object color% in-face-color)
                             in-face-color))
      (define face-bright-edge-color (scale-color #e1.6 face-color))
      (define face-edge-color (scale-color #e0.8 face-color))
      (define face-dark-edge-color (scale-color #e0.6 face-color))
      (define face-hard-edge-color (scale-color #e0.8 face-edge-color))
      (let ([w 300]
            [h 300])
          (dc (lambda (dc x y)
                (define old-pen (send dc get-pen))
                (define old-brush (send dc get-brush))
                
                (define (one-eye l? p? dd look?)
                  (define s (if p? 1/3 1))
                  (define sdd (if p? 1 1/2))
                  (define dx (+ (if p? (* 1/5 w 1/3) 0) (if look? eye-dx 0)))
                  (define dy (+ (if p? (* 1/4 w 1/3) 0) (if look? eye-dy 0)))
                  (send dc draw-ellipse
                        (+ x (* w (if l? 1/5 3/5)) dx (* dd sdd)) (+ y (* h 1/5) dy (* dd sdd))
                        (- (* w 1/5 s) (* 2 dd)) (- (* h 1/4 s) (* 2 dd))))
                
                (define (one-eye-brow l? dd dy dr)
                  (send dc draw-arc
                        (+ x (* w (if l? 1/5 3/5)))
                        (+ y (* h 3/20) dd dy)
                        (* w 1/5) 
                        (* h 1/4)
                        ((if l? + -) (* pi 1/3) dr) ((if l? + -) (* pi 2/3) dr)))
                
                (define (eye-series steps start-c end-c p? extra-inset look?)
                  (series dc
                          (if eye-shading? steps 0)
                          start-c end-c
                          (lambda (i)
                            (one-eye #t p? (+ extra-inset i) look?)
                            (one-eye #f p? (+ extra-inset i) look?))
                          #f #t))
                
                (define (eyebrows dy dr)
                  (send dc set-brush no-brush)
                  (series dc
                          (if eyebrow-shading? 3 0)
                          face-hard-edge-color
                          face-edge-color
                          (lambda (i)
                            (one-eye-brow #t i dy dr)
                            (one-eye-brow #f i dy dr))
                          #t #f)
                  (send dc set-pen no-pen))
                
                (define (normal-eyebrows dy)
                  (eyebrows dy 0))
                
                (define (worried-eyebrows dy)
                  (eyebrows dy 0.3))
                
                (define (angry-eyebrows dy)
                  (eyebrows dy -0.3))
                
                (define (smile sw sh i da path dy flip?)
                  ;; Either draw or set path.
                  ((if path 
                       (lambda (x y w h s e)
			 (send path arc x y w h s e))
                       (lambda (x y w h s e)
                         (send dc draw-arc x y w h s e)))
                   (+ x (/ (- w sw) 2) (* 1/6 sw)) 
                   (+ y (/ (- sh h) 2) (* 1/8 h) dy (if flip? i 0) (if flip? (- (* h 1/2) (- sh h)) 0))
                   (* sw 2/3) (+ (if flip? 0 i) (* h 2/3))
                   (- (* pi (- 5/4 (if flip? 1 0))) da) (+ (* pi (- 7/4 (if flip? 1 0))) da)))
                
                (define (plain-smile flip? tongue? narrow?)
		  (send dc set-brush no-brush)
		  (series dc 
                          (if mouth-shading? 3 0)
                          (make-object color% "black")
                          face-edge-color
                          (lambda (i)
                            (let ([da (if narrow? (* pi -1/8) 0)])
                              (smile w h i da #f 0 flip?)
                              (smile w h (+ 1 (- i)) da #f 0 flip?)))
                          #t #f)
		  (when tongue?
		    (let ([path (new dc-path%)]
			  [rgn (make-object region% dc)])
		      (smile w h 2 0 path 0 flip?)
		      (send path line-to (+ w x) (+ h y))
		      (send path line-to x (+ h y))
		      (send rgn set-path path)
		      (send dc set-clipping-region rgn)
		      (send dc set-pen no-pen)
		      (let ([dx (+ x (if flip?
					 (* 1/3 w)
					 (* 1/2 w)))]
			    [dy (+ y (if flip?
					 (* 1/2 h)
					 (* 13/20 h)))]
			    [tw (* 1/5 w)]
			    [th (* 1/4 h)])
			(series dc
                                (if tongue-shading? 3 0)
				face-color
				(make-object color% "red")
				(lambda (i)
				  (send dc draw-ellipse dx dy (- tw i) (- th i)))
				#f #t)
			(series dc 
                                (if tongue-shading? 4 0)
				(make-object color% "black")
				(scale-color 0.6 (make-object color% "red"))
				(lambda (i)
				  (send dc draw-line (- (+ dx i) (* tw 1/10)) dy (+ dx (* tw 0.65)) (+ dy (* th 0.75))))
				#t #f)
			(send dc set-clipping-region #f)))))
                
                (define (teeth)
                  ;; Assumes clipping region is set
                  (send dc set-brush (find-brush "white"))
                  (send dc draw-ellipse x y w h)
                  (when teeth?
                    (series dc 
                            5
                            (make-object color% "darkgray")
                            (make-object color% "lightgray")
                            (lambda (i)
                              (let loop ([j 0][delta 0][tw (* w 1/10)])
                                (unless (= j 5)
                                  (send dc draw-rectangle
                                        (+ x (* w 1/2) delta 1) y
                                        (- tw i 1) h)
                                  (send dc draw-rectangle
                                        (+ x (* w 1/2) (- delta) (- tw) 1) y
                                        (- tw i 1) h)
                                  (loop (add1 j) (+ delta tw) (* 8/10 tw)))))
                            #f #t)))
                
                (define (toothy-smile tw th ta bw bh ba flip? ddy)
                  (let-values ([(path) (make-object dc-path%)]
			       [(tmp-rgn1) (make-object region% dc)]
                               [(dy) (+ ddy (/ (- h (if flip? (+ th (abs (- bh th))) th)) 2))])
                    ;; Teeth:
                    (smile tw th 0 ta path dy flip?)
		    (send path reverse)
                    (smile bw bh 0 ba path dy flip?)
		    (send tmp-rgn1 set-path path)
                    (send dc set-clipping-region tmp-rgn1)
                    (teeth)
                    (send dc set-clipping-region #f)
                    
                    ;; Smile edges:
                    (send dc set-brush no-brush)
                    (series dc 
                            (if mouth-shading? 3 0)
                            (if flip? face-bright-edge-color face-hard-edge-color)
                            (if flip? face-color face-edge-color)
                            (lambda (i)
                              (smile bw bh (if flip? i (- i)) ba #f dy flip?))
                            #t #f)
                    (series dc
                            (if mouth-shading? 3 0)
                            (if flip? face-hard-edge-color face-bright-edge-color)
                            (if flip? face-edge-color face-color)
                            (lambda (i)
                              (smile tw th (if flip? (- i) i) ta #f dy flip?))
                            #t #f)))
                
                (define (grimace tw th ta flip?)
                  (let-values ([(path) (make-object dc-path%)]
                               [(tmp-rgn1) (make-object region% dc)]
                               [(dy) (/ (- h th) 2)]
                               [(elx ely) (values (+ x (* w 0.27)) (+ y (* h 0.65) (if flip? 3 1)))])
                    ;; Teeth:
		    (smile tw th 0 ta path (+ (if flip? -30 0) dy) flip?)
		    (send path arc elx ely 30 30 (* 1/2 pi) (* 3/2 pi) #t)
		    (send path reverse)
		    (send path arc (- (+ x w) (- elx x) 30) ely 30 30 (* 1/2 pi) (* 3/2 pi) #f)
		    (smile tw th 0 ta path (+ (if flip? 0 -30) dy) flip?)
                    (send tmp-rgn1 set-path path)
                    (send dc set-clipping-region tmp-rgn1)
		    (teeth)
                    (send dc set-clipping-region #f)
		    
                    ;; Smile edges:
                    (send dc set-brush no-brush)
                    (let ([sides (lambda (top? i)
                                   (send dc draw-arc (- elx (/ i 2)) (- ely (/ i 2)) 30 (+ 30 i) 
                                         (* pi (if top? 1 1/2)) (* pi (if top? 3/2 1)))
                                   (send dc draw-arc (+ (- (+ x w) (- elx x) 30) (/ i 2)) (- ely (/ i 2)) 30 (+ 30 i) 
                                         (* pi (if top? -1/2 0)) (* pi (if top? 0 1/2))))])
                      (series dc 
                              (if mouth-shading? 3 0)
                              (if flip? face-bright-edge-color face-hard-edge-color)
                              (if flip? face-color face-edge-color)
                              (lambda (i)
                                (sides flip? i)
                                (smile tw th (if flip? i (- i)) ta #f (+ (if flip? -2 -30) dy) flip?))
                              #t #f)
                      (series dc 
                              (if mouth-shading? 3 0)
                              (if flip? face-hard-edge-color face-bright-edge-color)
                              (if flip? face-edge-color face-color)
                              (lambda (i)
                                (sides (not flip?) i)
                                (smile tw th (if flip? (- i) i) ta #f (+ (if flip? -30 0) dy) flip?))
                              #t #f))))
                
                (define (medium-grimace flip?)
                  (grimace
                   (* 1.2 w) (* h 0.9) (- (* 0.1 pi)) 
                   flip?))
                
                (define (narrow-grimace flip?)
                  (grimace
                   (* 1.2 w) (* h 0.9) (- (* 0.1 pi))
                   flip?))
                
                (define (large-smile flip?)
                  (toothy-smile
                   w (* 1.05 h) (* 0.10 pi)
                   (* 1.1 w) (* h 0.95) (* 0.05 pi)
                   flip? 0))
                
                (define (largest-smile flip?)            
                  (toothy-smile
                   w (* 1.1 h) (* 0.14 pi)
                   (* 1.2 w) (* h 0.9) (* 0.05 pi)
                   flip? (if flip? (* h 0.1) 0)))
                
                (define (narrow-smile flip?)
                  (toothy-smile
                   (* 0.8 w) (* h 0.7) (- (* 0.00 pi))
                   (* 1.0 w) (* h 0.6) (- (* 0.06 pi))
                   flip? (if flip? (- (* h 0.2)) 0)))
                
                (define (medium-smile flip?)
                  (toothy-smile
                   (* 0.8 w) (* h 0.9) (* 0.08 pi)
                   (* 1.0 w) (* h 0.75) (- (* 0.01 pi))
                   flip? 0))
                
                (define (oh)
                  (let ([do-draw
                         (λ (i)
                           (let ([sw (* w 7/20)]
                                 [sh (* h 8/20)])
                             (send dc draw-ellipse
                                   (+ x i (/ (- w sw) 2))
                                   (+ y (* i .75) (* h 1/4) (* h -1/16) (/ (- h sh) 2))
                                   (- sw (* i 2))
                                   (- sh (* i 2)))))])
                    (series dc 
                            (if mouth-shading? 5 0)
                            face-color
                            face-dark-edge-color
                            do-draw
                            #t #t)
                    (send dc set-brush (find-brush "black"))
                    (send dc set-pen no-pen)
                    (do-draw 9)))
                
                (define (draw-eyes inset)
                  ;; Draw eyes
                  (eye-series 10 
                              (make-object color% "lightgray")
                              (make-object color% "white")
                              #f
                              inset
                              #f)
                  
                  ;; Draw pupils
                  (eye-series 3
                              (make-object color% 220 220 220)
                              (make-object color% "black")
                              #t
                              0
                              #t))
                
                (send dc set-pen no-pen)
                
                ;; Draw face background
                (series dc
                        (if face-background-shading? 3 0)
                        face-edge-color
                        face-color
                        (lambda (i)
                          (send dc draw-ellipse 
                                (+ x (/ i 2)) (+ y (/ i 2))
                                (- w (* 2 i)) (- h (* 2 i))))
                        #f #t)

		(draw-eyes eye-inset)
		(case eyebrows-kind
		  [(normal) (normal-eyebrows eyebrow-dy)]
		  [(worried) (worried-eyebrows eyebrow-dy)]
		  [(angry) (angry-eyebrows eyebrow-dy)]
		  [(none) (void)])
		(case mouth-kind
		  [(plain) (plain-smile frown? #f #f)]
		  [(smaller) (plain-smile frown? #f #t)]
                  [(narrow) (narrow-smile frown?)]
		  [(medium) (medium-smile frown?)]
		  [(large) (large-smile frown?)]
		  [(huge) (largest-smile frown?)]
		  [(grimace) (medium-grimace frown?)]
                  [(oh) (oh)]
		  [(tongue) (plain-smile frown? #t #f)])
                
                (send dc set-brush old-brush)
                (send dc set-pen old-pen))
              w h 0 0))))

  (define-syntax (case/good-error-message stx)
    (syntax-case stx (else)
      [(_ test [(sym ...) e] ... [else x last-e])
       (syntax
        (case test 
          [(sym ...) e]  ...
          [else (let ([x (apply append '((sym ...) ...))]) last-e)]))]))
      
  (define face
    (opt-lambda (mood [face-color default-face-color])
      (case/good-error-message mood
	[(unhappy)
	 (face* 'none 'plain #t face-color 6)]
	[(sortof-happy)
	 (face* 'worried 'medium #f face-color 6)]
	[(sortof-unhappy)
	 (face* 'worried 'grimace #t face-color 6)]
	[(happy)
	 (face* 'none 'plain #f face-color 6)]
	[(happier)
	 (face* 'none 'large #f face-color 3)]
	[(embarrassed embarassed) ; keep older misspelled name
	 (face* 'worried 'medium #f face-color 3)]
	[(badly-embarrassed badly-embarassed) ; here too
	 (face* 'worried 'medium #t face-color 3)]
	[(unhappier)
	 (face* 'normal 'large #t face-color 3)]
	[(happiest)
	 (face* 'normal 'huge #f face-color 0 -3)]
	[(unhappiest)
	 (face* 'normal 'huge #t face-color 0 -3)]
        [(mad)
         (face* 'angry 'grimace #t face-color 0)]
        [(mean)
         (face* 'angry 'narrow #f face-color 0)]
        [(surprised)
         (face* 'worried 'oh #t face-color -4 -3 2)]
	[else all-ids (error 'face "unknown mood: ~e, expected one of ~s" mood all-ids)]))))