# How to create a smile animation in Mathematica?

I want to create a yellow smile, with normal mouth which smiles in cycle. I only know that I need to use CDF player and Manipulate, but do not have any idea how to do that.

Thanks!

• With or without teeth? Jun 2, 2015 at 12:40
• It would be great to have teeth :) But actually I'd like to learn how to do both. Jun 2, 2015 at 12:54
• Okay, so a Yellow Disk[], two Point[]s with the appropriate PointSize[] set, and then use a ParametricPlot[] to make a transitioning set of circle arcs… Jun 2, 2015 at 12:59
• A better idea for a simple smile: use a symmetric Bézier curve, and just shift the central control points vertically… Jun 2, 2015 at 13:11
• @J.M. Without teeth: demonstrations.wolfram.com/SmileyChanger Jun 2, 2015 at 14:05

Here's one without teeth, but it does have eyebrows, the eyes can change size, and the mouth smiles (or not):

Manipulate[
eyeMat = {{1/(eyeRadius - pupilRadius/2), 0}, {0,
1/(0.15 + eyes - pupilRadius/2)}};
If[Norm[eyeMat.(pup - eyeCenter[[left]])] < 1,
pupNow = pup - eyeCenter[[left]];];
If[Norm[eyeMat.(pup - eyeCenter[[right]])] < 1,
pupNow = pup - eyeCenter[[right]];];
Graphics[{face, eye[left, eyes], eye[right, eyes], Blue,
pupil[left, pupNow, eyes], pupil[right, pupNow, eyes], Black,
browDraw[left, brows, eyes], browDraw[right, brows, eyes],
Inset[mouthDraw[mouth], {0, -0.5}]}, ImageSize -> {400, 450}],
{{brows, {-Pi/20, 0}}, {-0.6, 0}, {0.6, 0.15},
ControlPlacement -> Left},
{{eyes, 0}, -0.07, 0.07, ControlPlacement -> Left,
ControlType -> VerticalSlider},
{{mouth, 0.15}, -0.401, 0.4, 0.01, ControlPlacement -> Left,
ControlType -> VerticalSlider},
{{pup, {0, 0}}, Locator, Appearance -> None},
Initialization :> (face = Circle[{0, 0}, {1, 1.2}]; pupNow = {0, 0};
left = 1; right = 2;
eyeRadius = 0.18; eyeCenter = {{-0.4, 0.15}, {0.4, 0.15}};
browUp = 0.25; browW = 0.2; browAng = Pi/20;
eye[side_, eccen_] := {Black,
Circle[eyeCenter[[side]], {eyeRadius + 0.05, eyeRadius + eccen}]};
pupil[side_, pup_,
eccen_] := {Disk[eyeCenter[[side]] + pup + {0, pup[[2]] eccen},
pupilRadius + Max[0, eccen/3]], Black,
Disk[eyeCenter[[side]] + pup + {0, pup[[2]] eccen}, 0.03]};
browDraw[side_, {browAng_, browLift_}, eccen_] :=
Rotate[{Thickness[0.01],
Line[{{eyeCenter[[side]] + {-browW,
browLift + browUp + 0.5 eccen},
eyeCenter[[side]] + {browW,
browLift + browUp + 0.5 eccen}}}]}, 2 (side - 1.5) browAng];
mouthDraw[s_] :=
ParametricPlot[{Cos[u], -s Sin[u]}, {u, Pi/6, Pi - Pi/6},
Axes -> False, PlotStyle -> {Red, Thickness[0.02]},
PlotRange -> All];)]


As suggested by "Guess who it is", you can make the face yellow by changing the first line of the Initialization to

face = {Yellow, Disk[{0, 0}, {1, 1.2}]};