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

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

@ -1,15 +1,15 @@
(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)
@ -17,7 +17,7 @@
(cb dc))))) (cb dc)))))
(define moods (define moods
'(unhappiest '(unhappiest
unhappier unhappier
unhappy unhappy
@ -29,9 +29,10 @@
embarassed embarassed
badly-embarassed badly-embarassed
mad mad
mean)) mean
surprised))
(new button% (new button%
(label "Face Color...") (label "Face Color...")
(parent f) (parent f)
(callback (lambda (b e) (callback (lambda (b e)
@ -39,7 +40,7 @@
(when c (when c
(set! face-color c) (set! face-color c)
(new-face-callback)))))) (new-face-callback))))))
(new choice% (new choice%
(label #f) (label #f)
(choices (append (map symbol->string moods) (list "Custom"))) (choices (append (map symbol->string moods) (list "Custom")))
(parent f) (parent f)
@ -49,8 +50,8 @@
(list-ref moods v))) (list-ref moods v)))
(new-face-callback))))) (new-face-callback)))))
(define custom-panel (new group-box-panel% (label "Custom") (parent f))) (define custom-panel (new group-box-panel% (label "Custom") (parent f)))
(let ([choices '(none normal worried angry raised)]) (let ([choices '(none normal worried angry raised)])
(new choice% (new choice%
(label "Eyebrows") (label "Eyebrows")
(choices (map symbol->string choices)) (choices (map symbol->string choices))
@ -58,7 +59,7 @@
(callback (lambda (c e) (callback (lambda (c e)
(set! face-eyebrow-kind (list-ref choices (send c get-selection))) (set! face-eyebrow-kind (list-ref choices (send c get-selection)))
(new-face-callback))))) (new-face-callback)))))
(let ([choices '(plain narrow medium large huge grimace)]) (let ([choices '(plain narrow medium large huge absurd grimace oh tongue)])
(new choice% (new choice%
(label "Mouth") (label "Mouth")
(choices (map symbol->string choices)) (choices (map symbol->string choices))
@ -66,13 +67,13 @@
(callback (lambda (c e) (callback (lambda (c e)
(set! face-mouth-kind (list-ref choices (send c get-selection))) (set! face-mouth-kind (list-ref choices (send c get-selection)))
(new-face-callback))))) (new-face-callback)))))
(new check-box% (new check-box%
(label "Frown") (label "Frown")
(parent custom-panel) (parent custom-panel)
(callback (lambda (c e) (callback (lambda (c e)
(set! face-frown? (send c get-value)) (set! face-frown? (send c get-value))
(new-face-callback)))) (new-face-callback))))
(new slider% (new slider%
(label "Eye Inset") (label "Eye Inset")
(parent custom-panel) (parent custom-panel)
(min-value 0) (min-value 0)
@ -80,7 +81,7 @@
(callback (lambda (s e) (callback (lambda (s e)
(set! face-eye-inset (send s get-value)) (set! face-eye-inset (send s get-value))
(new-face-callback)))) (new-face-callback))))
(new slider% (new slider%
(label "Eyebrow Y") (label "Eyebrow Y")
(parent custom-panel) (parent custom-panel)
(min-value -5) (min-value -5)
@ -89,7 +90,7 @@
(callback (lambda (s e) (callback (lambda (s e)
(set! face-eyebrow-dy (send s get-value)) (set! face-eyebrow-dy (send s get-value))
(new-face-callback)))) (new-face-callback))))
(let ([pupils (let ([pupils
(lambda (label setter hi) (lambda (label setter hi)
(new slider% (new slider%
(label label) (label label)
@ -104,23 +105,23 @@
(pupils "Pupil Y" (lambda (v) (set! face-pupils-dy v)) 15)) (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-color default-face-color)
(define face-mood (car moods)) (define face-mood (car moods))
(define face-eyebrow-kind 'none) (define face-eyebrow-kind 'none)
(define face-mouth-kind 'plain) (define face-mouth-kind 'plain)
(define face-frown? #f) (define face-frown? #f)
(define face-eye-inset 0) (define face-eye-inset 0)
(define face-eyebrow-dy 0) (define face-eyebrow-dy 0)
(define face-pupils-dx 0) (define face-pupils-dx 0)
(define face-pupils-dy 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) (define (new-face-callback)
(send custom-panel enable (not face-mood)) (send custom-panel enable (not face-mood))
(set! the-pict (if face-mood (set! the-pict (if face-mood
(face face-mood face-color) (face face-mood face-color)
@ -131,9 +132,11 @@
face-pupils-dx face-pupils-dy))) face-pupils-dx face-pupils-dy)))
(send c on-paint)) (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))))) (define (cb dc) (draw-pict the-pict dc 0 0))
(send c min-height (inexact->exact (floor (* canvas-scale (pict-height the-pict)))))
(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))

16
collects/texpict/face.ss
View File

@ -247,6 +247,19 @@
(* 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)]))))