(module face-demo mzscheme
(require (lib "mred.ss" "mred")
	 (lib "class.ss")
	 (lib "utils.ss" "texpict")
	 (lib "mrpict.ss" "texpict")
         (lib "face.ss" "texpict"))

(define f (new frame% (label "frame")))

(define canvas-scale 1)

(define c (new canvas%
	       (parent f)
	       (paint-callback
		(lambda (x dc) 
                  (send dc set-scale canvas-scale canvas-scale)
                  (cb dc)))))


(define moods
  '(unhappiest
    unhappier
    unhappy
    sortof-unhappy
    sortof-happy
    happy
    happier
    happiest
    embarassed
    badly-embarassed
    mad
    mean))

(new button%
     (label "Face Color...")
     (parent f)
     (callback (lambda (b e) 
                 (let ([c (get-color-from-user "Face Color" f face-color)])
                   (when c
                     (set! face-color c)
                     (new-face-callback))))))
(new choice%
     (label #f)
     (choices (append (map symbol->string moods) (list "Custom")))
     (parent f)
     (callback (lambda (c e) 
                 (let ([v (send c get-selection)])
                   (set! face-mood (and (v . < . (length moods))
                                        (list-ref moods v)))
                   (new-face-callback)))))

(define custom-panel (new group-box-panel% (label "Custom") (parent f)))
(let ([choices '(none normal worried angry raised)])
  (new choice%
       (label "Eyebrows")
       (choices (map symbol->string choices)) 
       (parent custom-panel)
       (callback (lambda (c e)
                   (set! face-eyebrow-kind (list-ref choices (send c get-selection)))
                   (new-face-callback)))))
(let ([choices '(plain narrow medium large huge grimace)])
  (new choice%
       (label "Mouth")
       (choices (map symbol->string choices)) 
       (parent custom-panel)
       (callback (lambda (c e)
                   (set! face-mouth-kind (list-ref choices (send c get-selection)))
                   (new-face-callback)))))
(new check-box%
     (label "Frown")
     (parent custom-panel)
     (callback (lambda (c e)
                 (set! face-frown? (send c get-value))
                 (new-face-callback))))
(new slider%
     (label "Eye Inset")
     (parent custom-panel)
     (min-value 0)
     (max-value 10)
     (callback (lambda (s e)
                 (set! face-eye-inset (send s get-value))
                 (new-face-callback))))
(new slider%
     (label "Eyebrow Y")
     (parent custom-panel)
     (min-value -5)
     (max-value 5)
     (init-value 0)
     (callback (lambda (s e)
                 (set! face-eyebrow-dy (send s get-value))
                 (new-face-callback))))
(let ([pupils
       (lambda (label setter hi)
         (new slider%
              (label label)
              (parent custom-panel)
              (min-value (- hi))
              (max-value hi)
              (init-value 0)
              (callback (lambda (s e)
                          (setter (send s get-value))
                          (new-face-callback)))))])
  (pupils "Pupil X" (lambda (v) (set! face-pupils-dx v)) 10)
  (pupils "Pupil Y" (lambda (v) (set! face-pupils-dy v)) 15))


(send custom-panel enable #f)

(dc-for-text-size (send c get-dc))

(define face-color default-face-color)
(define face-mood (car moods))
(define face-eyebrow-kind 'none)
(define face-mouth-kind 'plain)
(define face-frown? #f)
(define face-eye-inset 0)
(define face-eyebrow-dy 0)
(define face-pupils-dx 0)
(define face-pupils-dy 0)

(define the-pict (face face-mood face-color))

(define (new-face-callback)
  (send custom-panel enable (not face-mood))
  (set! the-pict (if face-mood
		     (face face-mood face-color)
		     (face* face-eyebrow-kind
			    face-mouth-kind face-frown?
			    face-color
			    face-eye-inset face-eyebrow-dy
			    face-pupils-dx face-pupils-dy)))
  (send c on-paint))

(define (cb dc) (draw-pict the-pict dc 0 0))

(send c min-width (inexact->exact (floor (* canvas-scale (pict-width the-pict)))))
(send c min-height (inexact->exact (floor (* canvas-scale (pict-height the-pict)))))

(send f show #t))