suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added surprised faces, 'oh mouths, and cleaned up a few things

Browse Source 
svn: r2696
This commit is contained in:
Robby Findler 2006-04-17 21:13:59 +00:00
parent a847101855
commit 2f3cdfa302
3 changed files with 156 additions and 136 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/texpict/doc.txt
View File

@ -1027,13 +1027,14 @@ implements an interactive browser for face configurations.
'unhappiest - (face* 'normal 'huge #t default-face-color 0 -3) 'unhappiest - (face* 'normal 'huge #t default-face-color 0 -3)
'mad - (face* 'angry 'grimace #t default-face-color 0) 'mad - (face* 'angry 'grimace #t default-face-color 0)
'mean - (face* 'angry 'narrow #f 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]) > (face* eyebrow-kind mouth-kind frown? [color eye-inset eyebrow-dy pupil-dx pupil-dy])
- returns a pict for a configured face: - returns a pict for a configured face:
- eyebrow-kind is one of 'none, 'normal, 'worried, or 'angry - eyebrow-kind is one of 'none, 'normal, 'worried, or 'angry
- mouth-kind is one of 'plain, 'narrow, 'medium, 'large, 'huge, - 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 - frown? determines whether the mouth is up or down
- color is either a color string or a color% object - color is either a color string or a color% object
- eye-inset adjusts the eye size; recommend values: between 0 and 10 - eye-inset adjusts the eye size; recommend values: between 0 and 10

269
collects/texpict/face-demo.ss
View File

@ -1,139 +1,142 @@
(module face-demo mzscheme (module face-demo mzscheme
(require (lib "mred.ss" "mred") (require (lib "mred.ss" "mred")
(lib "class.ss") (lib "class.ss")
(lib "utils.ss" "texpict") (lib "utils.ss" "texpict")
(lib "mrpict.ss" "texpict") (lib "mrpict.ss" "texpict")
(lib "face.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% (define c (new canvas%
(parent f) (parent f)
(paint-callback (paint-callback
(lambda (x dc) (lambda (x dc)
(send dc set-scale canvas-scale canvas-scale) (send dc set-scale canvas-scale canvas-scale)
(cb dc))))) (cb dc)))))
(define moods (define moods
'(unhappiest '(unhappiest
unhappier unhappier
unhappy unhappy
sortof-unhappy sortof-unhappy
sortof-happy sortof-happy
happy happy
happier happier
happiest happiest
embarassed embarassed
badly-embarassed badly-embarassed
mad mad
mean)) mean
surprised))
(new button%
(label "Face Color...") (new button%
(parent f) (label "Face Color...")
(callback (lambda (b e) (parent f)
(let ([c (get-color-from-user "Face Color" f face-color)]) (callback (lambda (b e)
(when c (let ([c (get-color-from-user "Face Color" f face-color)])
(set! face-color c) (when c
(new-face-callback)))))) (set! face-color c)
(new choice% (new-face-callback))))))
(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% (new choice%
(label "Eyebrows") (label #f)
(choices (map symbol->string choices)) (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) (parent custom-panel)
(callback (lambda (c e) (callback (lambda (c e)
(set! face-eyebrow-kind (list-ref choices (send c get-selection))) (set! face-frown? (send c get-value))
(new-face-callback))))) (new-face-callback))))
(let ([choices '(plain narrow medium large huge grimace)]) (new slider%
(new choice% (label "Eye Inset")
(label "Mouth")
(choices (map symbol->string choices))
(parent custom-panel) (parent custom-panel)
(callback (lambda (c e) (min-value 0)
(set! face-mouth-kind (list-ref choices (send c get-selection))) (max-value 10)
(new-face-callback))))) (callback (lambda (s e)
(new check-box% (set! face-eye-inset (send s get-value))
(label "Frown") (new-face-callback))))
(parent custom-panel) (new slider%
(callback (lambda (c e) (label "Eyebrow Y")
(set! face-frown? (send c get-value)) (parent custom-panel)
(new-face-callback)))) (min-value -5)
(new slider% (max-value 5)
(label "Eye Inset") (init-value 0)
(parent custom-panel) (callback (lambda (s e)
(min-value 0) (set! face-eyebrow-dy (send s get-value))
(max-value 10) (new-face-callback))))
(callback (lambda (s e) (let ([pupils
(set! face-eye-inset (send s get-value)) (lambda (label setter hi)
(new-face-callback)))) (new slider%
(new slider% (label label)
(label "Eyebrow Y") (parent custom-panel)
(parent custom-panel) (min-value (- hi))
(min-value -5) (max-value hi)
(max-value 5) (init-value 0)
(init-value 0) (callback (lambda (s e)
(callback (lambda (s e) (setter (send s get-value))
(set! face-eyebrow-dy (send s get-value)) (new-face-callback)))))])
(new-face-callback)))) (pupils "Pupil X" (lambda (v) (set! face-pupils-dx v)) 10)
(let ([pupils (pupils "Pupil Y" (lambda (v) (set! face-pupils-dy v)) 15))
(lambda (label setter hi)
(new slider%
(label label) (send custom-panel enable #f)
(parent custom-panel)
(min-value (- hi)) (dc-for-text-size (send c get-dc))
(max-value hi)
(init-value 0) (define face-color default-face-color)
(callback (lambda (s e) (define face-mood (car moods))
(setter (send s get-value)) (define face-eyebrow-kind 'none)
(new-face-callback)))))]) (define face-mouth-kind 'plain)
(pupils "Pupil X" (lambda (v) (set! face-pupils-dx v)) 10) (define face-frown? #f)
(pupils "Pupil Y" (lambda (v) (set! face-pupils-dy v)) 15)) (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 f show #t))
(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))

20
collects/texpict/face.ss
View File

@ -82,7 +82,7 @@
(eyebrows dy -0.3)) (eyebrows dy -0.3))
(define (smile sw sh i da path dy flip?) (define (smile sw sh i da path dy flip?)
;; Either draw or set path. ;; Either draw or set path.
((if path ((if path
(lambda (x y w h s e) (lambda (x y w h s e)
(send path arc 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) (* 0.8 w) (* h 0.9) (* 0.08 pi)
(* 1.0 w) (* h 0.75) (- (* 0.01 pi)) (* 1.0 w) (* h 0.75) (- (* 0.01 pi))
flip? 0)) 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) (define (draw-eyes inset)
;; Draw eyes ;; Draw eyes
@ -290,6 +303,7 @@
[(large) (large-smile frown?)] [(large) (large-smile frown?)]
[(huge) (largest-smile frown?)] [(huge) (largest-smile frown?)]
[(grimace) (medium-grimace frown?)] [(grimace) (medium-grimace frown?)]
[(oh) (oh)]
[(tongue) (plain-smile frown? #t)]) [(tongue) (plain-smile frown? #t)])
(send dc set-brush old-brush) (send dc set-brush old-brush)
@ -323,4 +337,6 @@
(face* 'angry 'grimace #t face-color 0)] (face* 'angry 'grimace #t face-color 0)]
[(mean) [(mean)
(face* 'angry 'narrow #f face-color 0)] (face* 'angry 'narrow #f face-color 0)]
[(surprised)
(face* 'worried 'oh #t face-color -4 -3 2)]
[else (error 'face "unknown mood: ~e" mood)])))) [else (error 'face "unknown mood: ~e" mood)]))))