added surprised faces, 'oh mouths, and cleaned up a few things
svn: r2696
This commit is contained in:
Robby Findler
parent
a847101855
commit
2f3cdfa302
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"))
|
||||
(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 f (new frame% (label "frame")))
|
||||
|
||||
(define canvas-scale 1)
|
||||
(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 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))
|
||||
(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 #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 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)
|
||||
(send custom-panel enable #f)
|
||||
|
||||
(dc-for-text-size (send c get-dc))
|
||||
(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 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 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 (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 (send c get-dc) set-smoothing 'aligned)
|
||||
|
||||
(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)))))
|
||||
(define (cb dc) (draw-pict the-pict dc 0 0))
|
||||
|
||||
(send f show #t))
|
||||
(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))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
@ -247,6 +247,19 @@
|
|||
(* 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)]))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user