388 lines
16 KiB
Racket
388 lines
16 KiB
Racket
(module face mzscheme
|
|
(require mred
|
|
texpict/mrpict
|
|
texpict/utils
|
|
mzlib/class
|
|
mzlib/math
|
|
mzlib/etc
|
|
mzlib/kw)
|
|
|
|
(provide face face* default-face-color)
|
|
|
|
(define no-brush (find-brush "white" 'transparent))
|
|
(define no-pen (find-pen "white" 1 'transparent))
|
|
|
|
(define (series dc steps start-c end-c f pen? brush?)
|
|
(color-series dc steps #e0.5 start-c end-c f pen? brush?))
|
|
|
|
(define default-face-color (make-object color% "orange"))
|
|
|
|
(define face*
|
|
(lambda/kw (eyebrows-kind
|
|
mouth-kind
|
|
frown?
|
|
#:optional
|
|
[in-face-color default-face-color]
|
|
[eye-inset 0]
|
|
[eyebrow-dy 0]
|
|
[eye-dx 0]
|
|
[eye-dy 0]
|
|
#:key
|
|
(mouth-shading? #t)
|
|
(eye-shading? #t)
|
|
(eyebrow-shading? #t)
|
|
(tongue-shading? #t)
|
|
(face-background-shading? #t)
|
|
(teeth? #t))
|
|
|
|
(define face-color (if (string? in-face-color)
|
|
(make-object color% in-face-color)
|
|
in-face-color))
|
|
(define face-bright-edge-color (scale-color #e1.6 face-color))
|
|
(define face-edge-color (scale-color #e0.8 face-color))
|
|
(define face-dark-edge-color (scale-color #e0.6 face-color))
|
|
(define face-hard-edge-color (scale-color #e0.8 face-edge-color))
|
|
(let ([w 300]
|
|
[h 300])
|
|
(dc (lambda (dc x y)
|
|
(define old-pen (send dc get-pen))
|
|
(define old-brush (send dc get-brush))
|
|
|
|
(define (one-eye l? p? dd look?)
|
|
(define s (if p? 1/3 1))
|
|
(define sdd (if p? 1 1/2))
|
|
(define dx (+ (if p? (* 1/5 w 1/3) 0) (if look? eye-dx 0)))
|
|
(define dy (+ (if p? (* 1/4 w 1/3) 0) (if look? eye-dy 0)))
|
|
(send dc draw-ellipse
|
|
(+ x (* w (if l? 1/5 3/5)) dx (* dd sdd)) (+ y (* h 1/5) dy (* dd sdd))
|
|
(- (* w 1/5 s) (* 2 dd)) (- (* h 1/4 s) (* 2 dd))))
|
|
|
|
(define (one-eye-brow l? dd dy dr)
|
|
(send dc draw-arc
|
|
(+ x (* w (if l? 1/5 3/5)))
|
|
(+ y (* h 3/20) dd dy)
|
|
(* w 1/5)
|
|
(* h 1/4)
|
|
((if l? + -) (* pi 1/3) dr) ((if l? + -) (* pi 2/3) dr)))
|
|
|
|
(define (eye-series steps start-c end-c p? extra-inset look?)
|
|
(series dc
|
|
(if eye-shading? steps 0)
|
|
start-c end-c
|
|
(lambda (i)
|
|
(one-eye #t p? (+ extra-inset i) look?)
|
|
(one-eye #f p? (+ extra-inset i) look?))
|
|
#f #t))
|
|
|
|
(define (eyebrows dy dr)
|
|
(send dc set-brush no-brush)
|
|
(series dc
|
|
(if eyebrow-shading? 3 0)
|
|
face-hard-edge-color
|
|
face-edge-color
|
|
(lambda (i)
|
|
(one-eye-brow #t i dy dr)
|
|
(one-eye-brow #f i dy dr))
|
|
#t #f)
|
|
(send dc set-pen no-pen))
|
|
|
|
(define (normal-eyebrows dy)
|
|
(eyebrows dy 0))
|
|
|
|
(define (worried-eyebrows dy)
|
|
(eyebrows dy 0.3))
|
|
|
|
(define (angry-eyebrows dy)
|
|
(eyebrows dy -0.3))
|
|
|
|
(define (smile sw sh i da path dy flip?)
|
|
;; Either draw or set path.
|
|
((if path
|
|
(lambda (x y w h s e)
|
|
(send path arc x y w h s e))
|
|
(lambda (x y w h s e)
|
|
(send dc draw-arc x y w h s e)))
|
|
(+ x (/ (- w sw) 2) (* 1/6 sw))
|
|
(+ y (/ (- sh h) 2) (* 1/8 h) dy (if flip? i 0) (if flip? (- (* h 1/2) (- sh h)) 0))
|
|
(* sw 2/3) (+ (if flip? 0 i) (* h 2/3))
|
|
(- (* pi (- 5/4 (if flip? 1 0))) da) (+ (* pi (- 7/4 (if flip? 1 0))) da)))
|
|
|
|
(define (plain-smile flip? tongue? narrow?)
|
|
(send dc set-brush no-brush)
|
|
(series dc
|
|
(if mouth-shading? 3 0)
|
|
(make-object color% "black")
|
|
face-edge-color
|
|
(lambda (i)
|
|
(let ([da (if narrow? (* pi -1/8) 0)])
|
|
(smile w h i da #f 0 flip?)
|
|
(smile w h (+ 1 (- i)) da #f 0 flip?)))
|
|
#t #f)
|
|
(when tongue?
|
|
(let ([path (new dc-path%)]
|
|
[rgn (make-object region% dc)])
|
|
(smile w h 2 0 path 0 flip?)
|
|
(send path line-to (+ w x) (+ h y))
|
|
(send path line-to x (+ h y))
|
|
(send rgn set-path path)
|
|
(send dc set-clipping-region rgn)
|
|
(send dc set-pen no-pen)
|
|
(let ([dx (+ x (if flip?
|
|
(* 1/3 w)
|
|
(* 1/2 w)))]
|
|
[dy (+ y (if flip?
|
|
(* 1/2 h)
|
|
(* 13/20 h)))]
|
|
[tw (* 1/5 w)]
|
|
[th (* 1/4 h)])
|
|
(series dc
|
|
(if tongue-shading? 3 0)
|
|
face-color
|
|
(make-object color% "red")
|
|
(lambda (i)
|
|
(send dc draw-ellipse dx dy (- tw i) (- th i)))
|
|
#f #t)
|
|
(series dc
|
|
(if tongue-shading? 4 0)
|
|
(make-object color% "black")
|
|
(scale-color 0.6 (make-object color% "red"))
|
|
(lambda (i)
|
|
(send dc draw-line (- (+ dx i) (* tw 1/10)) dy (+ dx (* tw 0.65)) (+ dy (* th 0.75))))
|
|
#t #f)
|
|
(send dc set-clipping-region #f)))))
|
|
|
|
(define (teeth)
|
|
;; Assumes clipping region is set
|
|
(send dc set-brush (find-brush "white"))
|
|
(send dc draw-ellipse x y w h)
|
|
(when teeth?
|
|
(series dc
|
|
5
|
|
(make-object color% "darkgray")
|
|
(make-object color% "lightgray")
|
|
(lambda (i)
|
|
(let loop ([j 0][delta 0][tw (* w 1/10)])
|
|
(unless (= j 5)
|
|
(send dc draw-rectangle
|
|
(+ x (* w 1/2) delta 1) y
|
|
(- tw i 1) h)
|
|
(send dc draw-rectangle
|
|
(+ x (* w 1/2) (- delta) (- tw) 1) y
|
|
(- tw i 1) h)
|
|
(loop (add1 j) (+ delta tw) (* 8/10 tw)))))
|
|
#f #t)))
|
|
|
|
(define (toothy-smile tw th ta bw bh ba flip? ddy)
|
|
(let-values ([(path) (make-object dc-path%)]
|
|
[(tmp-rgn1) (make-object region% dc)]
|
|
[(dy) (+ ddy (/ (- h (if flip? (+ th (abs (- bh th))) th)) 2))])
|
|
;; Teeth:
|
|
(smile tw th 0 ta path dy flip?)
|
|
(send path reverse)
|
|
(smile bw bh 0 ba path dy flip?)
|
|
(send tmp-rgn1 set-path path)
|
|
(send dc set-clipping-region tmp-rgn1)
|
|
(teeth)
|
|
(send dc set-clipping-region #f)
|
|
|
|
;; Smile edges:
|
|
(send dc set-brush no-brush)
|
|
(series dc
|
|
(if mouth-shading? 3 0)
|
|
(if flip? face-bright-edge-color face-hard-edge-color)
|
|
(if flip? face-color face-edge-color)
|
|
(lambda (i)
|
|
(smile bw bh (if flip? i (- i)) ba #f dy flip?))
|
|
#t #f)
|
|
(series dc
|
|
(if mouth-shading? 3 0)
|
|
(if flip? face-hard-edge-color face-bright-edge-color)
|
|
(if flip? face-edge-color face-color)
|
|
(lambda (i)
|
|
(smile tw th (if flip? (- i) i) ta #f dy flip?))
|
|
#t #f)))
|
|
|
|
(define (grimace tw th ta flip?)
|
|
(let-values ([(path) (make-object dc-path%)]
|
|
[(tmp-rgn1) (make-object region% dc)]
|
|
[(dy) (/ (- h th) 2)]
|
|
[(elx ely) (values (+ x (* w 0.27)) (+ y (* h 0.65) (if flip? 3 1)))])
|
|
;; Teeth:
|
|
(smile tw th 0 ta path (+ (if flip? -30 0) dy) flip?)
|
|
(send path arc elx ely 30 30 (* 1/2 pi) (* 3/2 pi) #t)
|
|
(send path reverse)
|
|
(send path arc (- (+ x w) (- elx x) 30) ely 30 30 (* 1/2 pi) (* 3/2 pi) #f)
|
|
(smile tw th 0 ta path (+ (if flip? 0 -30) dy) flip?)
|
|
(send tmp-rgn1 set-path path)
|
|
(send dc set-clipping-region tmp-rgn1)
|
|
(teeth)
|
|
(send dc set-clipping-region #f)
|
|
|
|
;; Smile edges:
|
|
(send dc set-brush no-brush)
|
|
(let ([sides (lambda (top? i)
|
|
(send dc draw-arc (- elx (/ i 2)) (- ely (/ i 2)) 30 (+ 30 i)
|
|
(* pi (if top? 1 1/2)) (* pi (if top? 3/2 1)))
|
|
(send dc draw-arc (+ (- (+ x w) (- elx x) 30) (/ i 2)) (- ely (/ i 2)) 30 (+ 30 i)
|
|
(* pi (if top? -1/2 0)) (* pi (if top? 0 1/2))))])
|
|
(series dc
|
|
(if mouth-shading? 3 0)
|
|
(if flip? face-bright-edge-color face-hard-edge-color)
|
|
(if flip? face-color face-edge-color)
|
|
(lambda (i)
|
|
(sides flip? i)
|
|
(smile tw th (if flip? i (- i)) ta #f (+ (if flip? -2 -30) dy) flip?))
|
|
#t #f)
|
|
(series dc
|
|
(if mouth-shading? 3 0)
|
|
(if flip? face-hard-edge-color face-bright-edge-color)
|
|
(if flip? face-edge-color face-color)
|
|
(lambda (i)
|
|
(sides (not flip?) i)
|
|
(smile tw th (if flip? (- i) i) ta #f (+ (if flip? -30 0) dy) flip?))
|
|
#t #f))))
|
|
|
|
(define (medium-grimace flip?)
|
|
(grimace
|
|
(* 1.2 w) (* h 0.9) (- (* 0.1 pi))
|
|
flip?))
|
|
|
|
(define (narrow-grimace flip?)
|
|
(grimace
|
|
(* 1.2 w) (* h 0.9) (- (* 0.1 pi))
|
|
flip?))
|
|
|
|
(define (large-smile flip?)
|
|
(toothy-smile
|
|
w (* 1.05 h) (* 0.10 pi)
|
|
(* 1.1 w) (* h 0.95) (* 0.05 pi)
|
|
flip? 0))
|
|
|
|
(define (largest-smile flip?)
|
|
(toothy-smile
|
|
w (* 1.1 h) (* 0.14 pi)
|
|
(* 1.2 w) (* h 0.9) (* 0.05 pi)
|
|
flip? (if flip? (* h 0.1) 0)))
|
|
|
|
(define (narrow-smile flip?)
|
|
(toothy-smile
|
|
(* 0.8 w) (* h 0.7) (- (* 0.00 pi))
|
|
(* 1.0 w) (* h 0.6) (- (* 0.06 pi))
|
|
flip? (if flip? (- (* h 0.2)) 0)))
|
|
|
|
(define (medium-smile flip?)
|
|
(toothy-smile
|
|
(* 0.8 w) (* h 0.9) (* 0.08 pi)
|
|
(* 1.0 w) (* h 0.75) (- (* 0.01 pi))
|
|
flip? 0))
|
|
|
|
(define (oh)
|
|
(let ([do-draw
|
|
(λ (i)
|
|
(let ([sw (* w 7/20)]
|
|
[sh (* h 8/20)])
|
|
(send dc draw-ellipse
|
|
(+ x i (/ (- w sw) 2))
|
|
(+ y (* i .75) (* h 1/4) (* h -1/16) (/ (- h sh) 2))
|
|
(- sw (* i 2))
|
|
(- sh (* i 2)))))])
|
|
(series dc
|
|
(if mouth-shading? 5 0)
|
|
face-color
|
|
face-dark-edge-color
|
|
do-draw
|
|
#t #t)
|
|
(send dc set-brush (find-brush "black"))
|
|
(send dc set-pen no-pen)
|
|
(do-draw 9)))
|
|
|
|
(define (draw-eyes inset)
|
|
;; Draw eyes
|
|
(eye-series 10
|
|
(make-object color% "lightgray")
|
|
(make-object color% "white")
|
|
#f
|
|
inset
|
|
#f)
|
|
|
|
;; Draw pupils
|
|
(eye-series 3
|
|
(make-object color% 220 220 220)
|
|
(make-object color% "black")
|
|
#t
|
|
0
|
|
#t))
|
|
|
|
(send dc set-pen no-pen)
|
|
|
|
;; Draw face background
|
|
(series dc
|
|
(if face-background-shading? 3 0)
|
|
face-edge-color
|
|
face-color
|
|
(lambda (i)
|
|
(send dc draw-ellipse
|
|
(+ x (/ i 2)) (+ y (/ i 2))
|
|
(- w (* 2 i)) (- h (* 2 i))))
|
|
#f #t)
|
|
|
|
(draw-eyes eye-inset)
|
|
(case eyebrows-kind
|
|
[(normal) (normal-eyebrows eyebrow-dy)]
|
|
[(worried) (worried-eyebrows eyebrow-dy)]
|
|
[(angry) (angry-eyebrows eyebrow-dy)]
|
|
[(none) (void)])
|
|
(case mouth-kind
|
|
[(plain) (plain-smile frown? #f #f)]
|
|
[(smaller) (plain-smile frown? #f #t)]
|
|
[(narrow) (narrow-smile frown?)]
|
|
[(medium) (medium-smile frown?)]
|
|
[(large) (large-smile frown?)]
|
|
[(huge) (largest-smile frown?)]
|
|
[(grimace) (medium-grimace frown?)]
|
|
[(oh) (oh)]
|
|
[(tongue) (plain-smile frown? #t #f)])
|
|
|
|
(send dc set-brush old-brush)
|
|
(send dc set-pen old-pen))
|
|
w h 0 0))))
|
|
|
|
(define-syntax (case/good-error-message stx)
|
|
(syntax-case stx (else)
|
|
[(_ test [(sym ...) e] ... [else x last-e])
|
|
(syntax
|
|
(case test
|
|
[(sym ...) e] ...
|
|
[else (let ([x (apply append '((sym ...) ...))]) last-e)]))]))
|
|
|
|
(define face
|
|
(opt-lambda (mood [face-color default-face-color])
|
|
(case/good-error-message mood
|
|
[(unhappy)
|
|
(face* 'none 'plain #t face-color 6)]
|
|
[(sortof-happy)
|
|
(face* 'worried 'medium #f face-color 6)]
|
|
[(sortof-unhappy)
|
|
(face* 'worried 'grimace #t face-color 6)]
|
|
[(happy)
|
|
(face* 'none 'plain #f face-color 6)]
|
|
[(happier)
|
|
(face* 'none 'large #f face-color 3)]
|
|
[(embarassed)
|
|
(face* 'worried 'medium #f face-color 3)]
|
|
[(badly-embarassed)
|
|
(face* 'worried 'medium #t face-color 3)]
|
|
[(unhappier)
|
|
(face* 'normal 'large #t face-color 3)]
|
|
[(happiest)
|
|
(face* 'normal 'huge #f face-color 0 -3)]
|
|
[(unhappiest)
|
|
(face* 'normal 'huge #t face-color 0 -3)]
|
|
[(mad)
|
|
(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 all-ids (error 'face "unknown mood: ~e, expected one of ~s" mood all-ids)]))))
|