From 2f3cdfa3024a0684f091ca26657bede757fc72f0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 17 Apr 2006 21:13:59 +0000 Subject: [PATCH] added surprised faces, 'oh mouths, and cleaned up a few things svn: r2696 --- collects/texpict/doc.txt | 3 +- collects/texpict/face-demo.ss | 269 +++++++++++++++++----------------- collects/texpict/face.ss | 20 ++- 3 files changed, 156 insertions(+), 136 deletions(-) diff --git a/collects/texpict/doc.txt b/collects/texpict/doc.txt index f5ae1e5c87..13e8ade896 100644 --- a/collects/texpict/doc.txt +++ b/collects/texpict/doc.txt @@ -1027,13 +1027,14 @@ implements an interactive browser for face configurations. 'unhappiest - (face* 'normal 'huge #t default-face-color 0 -3) 'mad - (face* 'angry 'grimace #t default-face-color 0) 'mean - (face* 'angry 'narrow #f default-face-color 0) + 'surprised - (face* 'worried 'oh #t default-face-color -4 -3 2) > (face* eyebrow-kind mouth-kind frown? [color eye-inset eyebrow-dy pupil-dx pupil-dy]) - returns a pict for a configured face: - eyebrow-kind is one of 'none, 'normal, 'worried, or 'angry - mouth-kind is one of 'plain, 'narrow, 'medium, 'large, 'huge, - 'grimace, or 'tongue + 'grimace, 'oh, or 'tongue - frown? determines whether the mouth is up or down - color is either a color string or a color% object - eye-inset adjusts the eye size; recommend values: between 0 and 10 diff --git a/collects/texpict/face-demo.ss b/collects/texpict/face-demo.ss index a53810b266..fdeaf198f7 100644 --- a/collects/texpict/face-demo.ss +++ b/collects/texpict/face-demo.ss @@ -1,139 +1,142 @@ (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)]) + (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 + surprised)) + + (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 "Eyebrows") - (choices (map symbol->string choices)) + (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 absurd grimace oh tongue)]) + (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-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)) + (set! face-frown? (send c get-value)) + (new-face-callback)))) + (new slider% + (label "Eye Inset") (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)) + (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)) + + (send (send c get-dc) set-smoothing 'aligned) + + (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 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)) + (send f show #t)) diff --git a/collects/texpict/face.ss b/collects/texpict/face.ss index df272d31a2..40d883c5a9 100644 --- a/collects/texpict/face.ss +++ b/collects/texpict/face.ss @@ -82,7 +82,7 @@ (eyebrows dy -0.3)) (define (smile sw sh i da path dy flip?) - ;; Either draw or set path. + ;; Either draw or set path. ((if path (lambda (x y w h s e) (send path arc x y w h s e)) @@ -246,7 +246,20 @@ (* 0.8 w) (* h 0.9) (* 0.08 pi) (* 1.0 w) (* h 0.75) (- (* 0.01 pi)) flip? 0)) - + + (define (oh) + (series dc 5 + face-edge-color + (make-object color% "black") + (lambda (i) + (let ([sw (* w 7/20)] + [sh (* h 8/20)]) + (send dc draw-ellipse + (+ x i (/ (- w sw) 2)) + (+ y i (* h 1/4) (* h -1/16) (/ (- h sh) 2)) + (- sw (* i 2)) + (- sh (* i 2))))) + #t #t)) (define (draw-eyes inset) ;; Draw eyes @@ -290,6 +303,7 @@ [(large) (large-smile frown?)] [(huge) (largest-smile frown?)] [(grimace) (medium-grimace frown?)] + [(oh) (oh)] [(tongue) (plain-smile frown? #t)]) (send dc set-brush old-brush) @@ -323,4 +337,6 @@ (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 (error 'face "unknown mood: ~e" mood)]))))