Перевод блога O Tannenbaum Майкла Тротта, директора Wolfram|Alpha.
В этом ноутбуке описывается, как создать анимацию украшенной елки, которая перемещает свои ветви синхронизированно с голосами музыки немецкой песни O Tannenbaum 16-го века (английская версия — O Christmas Tree). Одна выделенная ветвь дерева будет действовать как дирижер, а свеча будет дирижёрской палочкой. Это делает анимацию интересной во всех куплетах. Мы также добавим немного снега и несколько веселых движений дерева во второй половине песни. Чтобы увидеть окончательный дизайн, просмотрите это видео на YouTube:
Я реализую анимацию с помощью следующих этапов:
- Построить елку с изогнутыми ветвями, где ветви можно перемещать плавно вверх, вниз, влево и вправо.
- Добавить украшения (цветные шарики, пятиконечные звезды) и свечи разного цвета к ветвям. Позволить украшениям перемещаться относительно окончаниям веток.
- Преобразовать 4 голоса музыки в 2D-движение на основе частот звука. Смоделировать движения дирижера синхронизированными с музыкой.
- Моделировать движения украшений в виде вынужденного сферического маятника. Учет трения орнаментов с использованием диссипативной функции Рэлея.
- Добавить снег для белого рождества.
- Создать анимацию веток по отношению к музыке.
Особая благодарность моему коллеге Эндрю Штайхачеру за выбор и анализ музыки, чтобы получить данные для движения дерева (ниже раздел «От музыки к движениям»). И благодаря Эми Янг для превращения анимационных кадров и музыки в один видеоклип.
Создание елки
Параметры дерева
Размеры дерева, общая форма дерева и количество ветвей. Названия переменных делают их смысл очевидным.
(* radial branch count *)
radialBranchCount = 3;
(* vertical branch count *)
verticalBranchCount = 5;
(* tree height *)
treeHeight = 12;
(* tree width *)
treeWidth = 6;
(* plot points for the B-spline surfaces forming the branches *)
{μ, ν} = {6, 8}; Цвета ствола и ветвей.
stemColor = Directive[Darker[Brown], Lighting -> "Neutral", Specularity[Brown, 20]];
branchTopColor = RGBColor[0., 0.6, 0.6];
branchBottomColor = RGBColor[0., 0.4, 0.4];
branchSideColor = RGBColor[0.4, 0.8, 0.];Построение движущейся ветки дерева
Каждая ветвь имеет поперечное сечение прямоугольника с изменяющейся размерностью (в зависимости от расстояния от ствола). Кончик ветки должен слегка указывать вверх, чтобы иметь знакомый вид елки. В его самом широком размере ветвь лежит близко к конусу (стволу). Переменная τ определяет вверх-вниз и переменная σ лево-право положения кончика ветки. Я строю ветку с четырех поверхностей B-сплайна (сверху, снизу, слева, справа), чтобы иметь гладкий вид с небольшим количеством точек, определяющих поверхность.
branchTopBottom[
tp_, {hb_, ht_}, {φ1_, φ2_}, {rb_, rt_},
R_, {σ_, τ_}] :=
Module[{A = -0.6, β = 1/2, φm, Pm, dirR,
dirφ, r, P1, P, \[ScriptN], \[ScriptP], x,
y, ω, ℛ, ξ, \[ScriptH]s, \[ScriptH]},
φm = Mean[{φ1, φ2}];
Pm = R {Cos[φm], Sin[φm]};
dirR = 1. {Cos[φm], Sin[φm]};
dirφ = Reverse[dirR] {-1, 1};
r = If[tp == "top", rt, rb];
(* move cross section radially away from the stem and contract it *)
Table[P1 = {r Cos[φ], r Sin[φ]};
Table[P = P1 + s/ν (Pm - P1);
\[ScriptN] = dirφ.P; \[ScriptP] = dirR.P;
{x,
y} = \[ScriptN] Cos[
s/ν Pi/2]^2 dirφ + \[ScriptP] dirR;
ω = σ*
1. s/ν Abs[φ2 - φ1]/
radialBranchCount;
ℛ = {{Cos[ω],
Sin[ω]}, {-Sin[ω], Cos[ω]}};
{x, y} = ℛ.{x, y};
ξ = R s/ν;
\[ScriptH]s = {ht,
hb} + {ξ (A R (R - ξ) - (hb - ht) (β -
1) ξ), (ht - hb) ξ^2 β}/R^2;
\[ScriptH] =
If[tp == "top", \[ScriptH]s[[1]], \[ScriptH]s[[2]]] ;
{x, y, \[ScriptH] + τ s/ν (ht - hb)},
{s, 0, ν}],
{φ, φ1, φ2, (φ2 - φ1)/μ}] // N
]Радиус на высоте h представляет собой только линейную интерполяцию максимального радиуса ствола и радиуса 0 в верхней части.
stemRadius[h_, H_] := (H - h)/HСтороны ветки — это только соединительные элементы между верхней и нижней поверхностями.
branchOnStem[{{hb_, ht_}, {φ1_, φ2_},
R_}, {τ_, σ_}] :=
Module[{tBranch, bBranch, sideBranches},
{bBranch, tBranch} =
Table[branchTopBottom[p, {hb, ht}, {φ1, φ2},
stemRadius[{hb, ht}, treeHeight],
R, {τ, σ}], {p, {"top", "bottom"}}];
sideBranches =
Table[BSplineSurface[{tBranch[[j]],
bBranch[[j]]}], {j, {1, -1}}];
{branchTopColor, BSplineSurface[tBranch],
branchBottomColor, BSplineSurface[bBranch],
branchSideColor, sideBranches}
]Для последующего использования давайте определим функцию только для позиции конца ветки.
branchOnStemEndPoint[ {{hb_, ht_}, {φ1_, φ2_},
R_}, {σ_, τ_}] :=
Module[{A = -0.6, β = 1/2, Pm, dirR, dirφ,
P, \[ScriptN], \[ScriptP], x,
y, ω, ξ, \[ScriptH]s, \[ScriptH],
φ = φ1, φm =
Mean[{φ1, φ2}]},
Pm = R {Cos[φm], Sin[φm]};
dirR = {Cos[φm], Sin[φm]};
{x, y} = dirR.Pm dirR;
ω =
1. σ Abs[φ2 - φ1]/radialBranchCount;
{x, y} = {{Cos[ω], Sin[ω]}, {-Sin[ω],
Cos[ω]}}.{x, y};
\[ScriptH]s = {ht, hb} + (ht - hb) {β - 1., 1};
{x, y, \[ScriptH]s[[1]] + τ (ht - hb)} ]Интерактивная демонстрация, позволяющая ветке и ее окончанию двигаться как функция от {σ, τ}.
Manipulate[
Graphics3D[{branchOnStem[{{0, 1}, {Pi/2 - 1/2, Pi/2 + 1/2},
1 + ρ}, στ],
Red,
Sphere[branchOnStemEndPoint[{{0, 1}, {Pi/2 - 1/2, Pi/2 + 1/2},
1 + ρ}, στ], 0.05]},
PlotRange -> {{-2, 2}, {0, 4}, {-1, 2}},
ViewPoint -> {3.17, 0.85, 0.79}],
{{ρ, 1.6, "branch length"}, 0, 2, ImageSize -> Small},
{{στ, {0, 0},
"branch\nleft/right\nup/down"}, {-1, -1}, {1, 1}},
ControlPlacement -> Left, SaveDefinitions -> True]
Добавление ветвей к стволу
Ствол — это всего лишь конус, вершиной которого является вершина дерева.
stem = Cone[{{0, 0, 0}, {0, 0, treeHeight}}, 1];Размеры ветвей уменьшаются с высотой, становясь геометрически меньше. Общее количество всех уровней ветвей равно высоте дерева минус часть шага внизу.
heightList1 =
Module[{α = 0.8, hs, sol},
hs = Prepend[Table[C α^k, {k, 0, verticalBranchCount - 1}],
0];
sol = Solve[Total[hs] == 10, C, Reals];
Accumulate[hs /. sol[[1]]]]{0, 2.97477, 5.35459, 7.25845, 8.78153, 10.}
treeWidthOfHeight[h_] := treeWidth (treeHeight - h)/treeHeightВетви плотно прилегают к стволу, без промежутков между ними.
Graphics3D[{{stemColor, stem},
{Darker[Green],
Table[Table[
branchOnStem[{2 +
heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/
radialBranchCount ,
treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0,
0}], {k, 0, 1}] ,
{j, 1, verticalBranchCount}]}},
ViewPoint -> {2.48, -2.28, 0.28}]
Graphics3D[{{stemColor, stem},
{Darker[Green],
Table[Table[
branchOnStem[{2 +
heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/
radialBranchCount ,
treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0,
0}], {k, 0, radialBranchCount - 1}] ,
{j, 1, verticalBranchCount}]}},
ViewPoint -> {2.48, -2.28, 0.28}]
Можно переместить ветки, чтобы получить более реалистичную форму дерева. Это то дерево, которое я буду использовать в последующем. Изменить параметры дерева и использовать другое дерево довольно просто.
heightList2 = {2/3, 1/3}.# & /@ Partition[heightList1, 2, 1];
Graphics3D[{{Darker[Brown], stem},
{EdgeForm[],
Table[
Table[branchOnStem[ {2 +
heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/
radialBranchCount ,
treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0,
0}], {k, 0, radialBranchCount - 1}] ,
{j, 1, verticalBranchCount}],
Table[Table[
branchOnStem[{2 +
heightList2[[{j, j + 1}]], {k , k + 1} 2 Pi/
radialBranchCount + Pi/radialBranchCount,
treeWidthOfHeight[Mean[heightList2[[{j, j + 1}]]]]}, {0,
0}], {k, 0, radialBranchCount - 1}] ,
{j, 1, verticalBranchCount - 1}]}},
ViewPoint -> {2.48, -2.28, 0.28}]
Можно было бы легко сделать деревья еще плотнее с большим количеством ветвей.
Graphics3D[{{Darker[Brown], stem},
{EdgeForm[],
Table[Table[branchOnStem[ {2 + heightList1[[{j, j + 1}]],
{k , k + 1} 2 Pi/(2 radialBranchCount) ,
treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0,
0}], {k, 0, (2 radialBranchCount) - 1}] , {j, 1,
verticalBranchCount}],
Table[Table[branchOnStem[{2 + heightList2[[{j, j + 1}]],
{k , k + 1} 2 Pi/(2 radialBranchCount) +
Pi/(2 radialBranchCount),
treeWidthOfHeight[Mean[heightList2[[{j, j + 1}]]]]}, {0,
0}], {k, 0, 2 radialBranchCount - 1}] ,
{j, 1, verticalBranchCount - 1}]}},
ViewPoint -> {2.48, -2.28, 0.28}]
Украшение дерева
Теперь давайте построим несколько украшений, чтобы построить красиво наряженную елку. Я добавлю блестящие шарики, пятиконечные звезды и свечи. Я рекомендую оригинальные шары Тюрингии Лауша для вашей елки. (Вы можете найти их здесь)
Украшения, свечи и верхушка
Цветные шары
На каждом дереве должны быть какие-то блестящие стеклянные сферы, игрушки.
coloredBall[p_, size_, color_, {ϕ_, θ_}] :=
Module[{\[ScriptD] = {Cos[ϕ] Sin[θ],
Sin[ϕ] Sin[θ], -Cos[θ]}},
{EdgeForm[], GrayLevel[0.4], Specularity[Yellow, 20],
Cylinder[{p, p + 1.5 size \[ScriptD]}, 0.02 size ],
color, Specularity[Yellow, 10],
Sphere[p + (1.5 size + 0.6 size) \[ScriptD] , 0.6 size]
}]
Graphics3D[{coloredBall[{1, 2, 3}, 1, Red, {0, 0}],
coloredBall[{3, 2, 3}, 1, Darker[Blue], {1, 0.2}]}, Axes -> True]
branchOnStemWithBall[{{hb_, ht_}, {φ1_, φ2_},
R_}, {σ_, τ_}, color_, {ϕ_, θ_}] :=
{branchOnStem[{{hb, ht}, {φ1, φ2},
R}, {σ, τ}] ,
coloredBall[
branchOnStemEndPoint[{{hb, ht}, {φ1, φ2},
R}, {σ, τ}], 0.45 (ht - hb)/2,
color, {ϕ, θ}]}Вот ветка с игрушкой. Переменные {σ, τ} позволяют изменить положение шара относительно кончика ветки.
Manipulate[
Graphics3D[{branchOnStemWithBall[{{0, 1}, {Pi/2 - 1/2, Pi/2 + 1/2},
1 + ρ}, στ, Red, ϕθ]},
PlotRange -> {{-2, 2}, {0, 4}, {-2, 2}},
ViewPoint -> {3.17, 0.85, 0.79}],
{{ρ, 1.6, "branch length"}, 0, 2, ImageSize -> Small},
{{στ, {0.6, 0.26},
"branch\nleft/right\nup/down"}, {-1, -1}, {1, 1}},
{{ϕθ, {2.57, 1.88}, "ball angles"}, {0, -Pi}, {Pi, Pi}},
ControlPlacement -> Left, SaveDefinitions -> True]
Вот дерево с шарами весящими в основном прямо вниз. Я буду использовать случайные цвета для шаров.
Graphics3D[{{Darker[Brown],
stem}, {Table[
Table[branchOnStemWithBall[{2 +
heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/
radialBranchCount ,
treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0},
RandomColor[], {0, 0}], {k, 0,
radialBranchCount - 1}] ,
{j, 1, verticalBranchCount}]
}}, ViewPoint -> {2.48, -2.28, 0.28}, Axes -> True]
Дерево с шарами в случайных направлениях. Если позже ветви будут перемещены, то мы вычислим естественные движения (что означает решение соответствующих уравнений движения) шаров.
Graphics3D[{{Darker[Brown],
stem}, {Table[
Table[branchOnStemWithBall[{2 +
heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/
radialBranchCount ,
treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0},
RandomColor[], {RandomReal[{-Pi, Pi}],
RandomReal[{0, Pi}]}], {k, 0, radialBranchCount - 1}] ,
{j, 1, verticalBranchCount}]}},
ViewPoint -> {2.48, -2.28, 0.28}, Axes -> True]
Пятиконечные звезды
Сейчас построим несколько пятиконечных звезд. Поскольку этот орнамент не имеет вращательной симметрии, я допущу угол ориентации относительно нити на которой он висит.
coloredFiveStar[p_, size_, dir_,
color_, α_, {ϕ_, θ_}] :=
Module[{\[ScriptD] = {Cos[ϕ] Sin[θ],
Sin[ϕ] Sin[θ], -Cos[θ]}, points, P1, P2, d1,
d2, d3, dP, dP2},
d2 = Normalize[dir - dir.\[ScriptD] \[ScriptD]];
d3 = Cross[\[ScriptD], d2];
{EdgeForm[], GrayLevel[0.4], Specularity[Pink, 20],
Cylinder[{p, p + (1.5 size + 0.6 size) \[ScriptD]}, 0.02 size ],
color, Specularity[Hue[.125], 5],
dP = Sin[α] d2 + Cos[α] d3;
dP2 = Cross[\[ScriptD], dP];
points =
Table[p + (1.5 size + 0.6 size) \[ScriptD] +
size If[EvenQ[j], 1, 1/2] *
(Cos[j 2 Pi/10 ] \[ScriptD] +
Sin[j 2 Pi/10] dP), {j, 0, 10}];
P1 = p + (1.5 size + 0.6 size) \[ScriptD] + size/3 dP2;
P2 = p + (1.5 size + 0.6 size) \[ScriptD] - size/3 dP2;
{P1, P2} = (p + (1.5 size + 0.6 size) \[ScriptD] + # size/
3 dP2) & /@ {+1, -1};
Polygon[
Join @@ (Function[a,
Append[#, a] & /@ Partition[points, 2, 1]] /@ {P1, P2})]
}]
Graphics3D[{coloredFiveStar[{1, 2, 3}, 0.2, {0, -1, 0}, Darker[Red],
0, {0, 0}],
coloredFiveStar[{1.5, 2, 3}, 0.2, {0, -1, 0}, Darker[Purple],
Pi/3, {1, 0.4}]}]
branchOnStemWithFiveStar[{{hb_, ht_}, {φ1_, φ2_},
R_}, {σ_, τ_},
color_, α_, {ϕ_, θ_}] :=
Module[{dir =
Append[Normalize[
Mean[{{Cos[φ1],
Sin[φ1]}, {Cos[φ2],
Sin[φ2]}}]], 0]},
{branchOnStem[{{hb, ht}, {φ1, φ2},
R}, {σ, τ}] ,
coloredFiveStar[
branchOnStemEndPoint[{{hb, ht}, {φ1, φ2},
R}, {σ, τ}], 0.4 (ht - hb)/2, dir,
color, α, {ϕ, θ}]} ]Елка украшена пятиконечными звездами.
Graphics3D[{{Darker[Brown],
stem}, {Table[
Table[branchOnStemWithFiveStar[{2 +
heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/
radialBranchCount ,
treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0},
RandomColor[],
RandomReal[{-Pi, Pi}], {RandomReal[{-Pi, Pi}],
RandomReal[0.1 {-1, 1}]}], {k, 0, radialBranchCount - 1}] ,
{j, 1, verticalBranchCount}]
}}, ViewPoint -> {2.48, -2.28, 0.28}, Axes -> True]
Свечи
Построим их начиная с ножки, которая прикрепляется к окончаниям веток, с воскоподобным телом, почерневшем фитилем и огнем. Чтобы облегчить анимацию и избежать пожара, я буду использовать электрические свечи, чтобы пламя не изменялось, когда двигаются ветви.
flamePoints =
Table[{0.2 Sin[Pi z]^2 Cos[φ],
0.2 Sin[Pi z]^2 Sin[φ], z}, {z, 0, 1,
1/1/12}, {φ, Pi/2, 5/2 Pi, 2 Pi/24}]
litCandle[p_, size_, color_] :=
{EdgeForm[], color,
Cylinder[{p + {0, 0, size 0.001}, p + {0, 0, size 0.5}}, size 0.04],
GrayLevel[0.1], Specularity[Orange, 20],
Cylinder[{p, p + {0, 0, size 0.05}}, size 0.06],
Black, Glow[Black],
Cylinder[{ p + {0, 0, size 0.5}, p + {0, 0, size 0.5 + 0.05 size}},
size 0.008],
Glow[Orange], Specularity[Hue[.125], 5],
BSplineSurface[
Map[(p + {0, 0, size 0.5} + 0.3 size #) &, flamePoints, {2}],
SplineClosed -> {True, False}]
}Белая и красная свечи.
Graphics3D[{litCandle[{0, 0, 0}, 1,
Directive[White, Glow[GrayLevel[0.3]], Specularity[Yellow, 20]]],
litCandle[{0.5, 0, 0}, 1,
Directive[Red, Glow[GrayLevel[0.1]], Specularity[Yellow, 20]]]}]
Позже я буду использовать удлиненную ветку со свечой, чтобы она была дирижером, поэтому я позволю свечи наклониться от ветви.
branchOnStemWithCandle[{{hb_, ht_}, {φ1_, φ2_},
R_}, {σ_, τ_}, color_, α_] :=
{branchOnStem[{{hb, ht}, {φ1, φ2},
R}, {σ, τ}] ,
If[α == 0,
litCandle[
branchOnStemEndPoint[{{hb, ht}, {φ1, φ2},
0.98 R}, {σ, τ}], 0.66 (ht - hb) , color],
Module[{P =
branchOnStemEndPoint[{{hb, ht}, {φ1, φ2},
0.98 R}, {σ, τ}], dir},
dir = Append[Reverse[Take[P, 2]] {-1, 1}, 0];
Rotate[
litCandle[
branchOnStemEndPoint[{{hb, ht}, {φ1, φ2},
0.98 R}, {σ, τ}], 0.66 (ht - hb) ,
color], α, dir, P]]]}
Manipulate[
Graphics3D[{branchOnStemWithCandle[{{0, 1}, {Pi/2 - 1/2, Pi/2 + 1/2},
1 + ρ}, στ, Red, α]},
PlotRange -> {{-2, 2}, {0, 4}, {-2, 2}},
ViewPoint -> {3.17, 0.85, 0.79}],
{{ρ, 1.6, "branch length"}, 0, 2, ImageSize -> Small},
{{στ, {0, 0},
"branch\nleft/right\nup/down"}, {-1, -1}, {1, 1}},
{{α, Pi/4, "candle angle"}, -Pi, Pi},
ControlPlacement -> Left, SaveDefinitions -> True]И вот ель со свечой на каждой ветке.
Graphics3D[{{Darker[Brown],
stem}, {Table[
Table[branchOnStemWithCandle[{2 +
heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/
radialBranchCount ,
treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0, 0},
White, 0], {k, 0,
radialBranchCount - 1}] ,
{j, 1, verticalBranchCount}]
}}, ViewPoint -> {2.48, -2.28, 0.28}, Axes -> True]
Верхушка елки
Для полной радости я добавляю вращающийся спайки на верху.
spikey = Cases[
N@Entity["Polyhedron", "RhombicHexecontahedron"][
"Image"], _GraphicsComplex, ∞][[1]];
top = {Gray, Specularity[Red, 25],
Cone[{{0, 0, 0.9 treeHeight}, {0, 0, 1.08 treeHeight}},
treeWidth/240],
Orange, EdgeForm[Darker[Orange]], Specularity[Hue[.125], 5],
MapAt[((0.24 # + {0, 0, 1.08 treeHeight}) & /@ #) &, spikey, 1]
}
Graphics3D[{{Darker[Brown], stem},
{Table[
Table[branchOnStem[{2 +
heightList1[[{j, j + 1}]], {k , k + 1} 2 Pi/
radialBranchCount ,
treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {0,
0} ], {k, 0, radialBranchCount - 1}] ,
{j, 1, verticalBranchCount}],
top}}, ViewPoint -> {2.48, -2.28, 0.28}, Axes -> True]
Украшение дерева
Мы выделим одну ветку в качестве дирижера. Оставшиеся ветки мы случайным образом разделим на четыре группы и украсим их игрушками двух цветов, пятиконечными звездами и свечами.
Теперь давайте добавим украшение или свечу на каждую ветку дерева. Я буду использовать вышеупомянутое дерево с 27 ветками. Я начинаю ветки по высоте на стебле и азимутальным углом.
allBranches =
Flatten[Riffle[
Table[Table[{2 +
heightList1[[{j, j + 1}]], {k , k + 1} 2. Pi/
radialBranchCount ,
treeWidthOfHeight[Mean[heightList1[[{j, j + 1}]]]]}, {k, 0,
radialBranchCount - 1}] ,
{j, 1, verticalBranchCount}],
Table[Table[{2 +
heightList2[[{j, j + 1}]], {k , k + 1} 2. Pi/
radialBranchCount + Pi/radialBranchCount,
treeWidthOfHeight[Mean[heightList2[[{j, j + 1}]]]]}, {k, 0,
radialBranchCount - 1}] ,
{j, 1, verticalBranchCount - 1}]], 1]
Length[allBranches]27
Раскрасим ветки по порядку, начиная с красного внизу и до фиолетового на верху.
Graphics3D[{{Darker[Brown], stem},
MapIndexed[(branchOnStem[#1, {0, 0}] /. _RGBColor :>
Hue[#2[[1]]/36]) &, allBranches],
top}, ViewPoint -> {2, 1, -0.2}]
Разделим все ветки на 4 группы для голосов и одну для роли дирижера.
conductorBranch = 7;
SeedRandom[12];
voiceBranches = (Last /@ #) & /@
GroupBy[{RandomChoice[{1, 2, 3, 4}], #} & /@
Delete[Range[27], {conductorBranch}], First]<|1 -> {1, 4, 5, 6, 12, 18, 20}, 3 -> {2, 8, 10, 11, 14, 22, 23, 25}, 2 -> {3, 13, 15, 16, 21, 26}, 4 -> {9, 17, 19, 24, 27}|>
voiceBranches = <|1 -> {2, 9, 14, 17, 19, 24, 27},
2 -> {3, 13, 15, 16, 21, 26}, 3 -> {1, 4, 5, 12, 18, 20},
4 -> {6, 8, 10, 11, 22, 23, 25}|><|1 -> {2, 9, 14, 17, 19, 24, 27}, 2 -> {3, 13, 15, 16, 21, 26}, 3 -> {1, 4, 5, 12, 18, 20}, 4 -> {6, 8, 10, 11, 22, 23, 25}|>
Вот иллюстрация веток, окрашенных в соответствии с тем, какой голос они представляют.
Graphics3D[{{Darker[Brown], stem},
branchOnStem[#1, {0, 0}] & /@
allBranches[[voiceBranches[[1]]]] /. _RGBColor :> Yellow,
branchOnStem[#1, {0, 0}] & /@
allBranches[[voiceBranches[[2]]]] /. _RGBColor :> White,
branchOnStem[#1, {0, 0}] & /@
allBranches[[voiceBranches[[3]]]] /. _RGBColor :> LightBlue,
branchOnStem[#1, {0, 0}] & /@
allBranches[[voiceBranches[[4]]]] /. _RGBColor :> Pink,
branchOnStem[
allBranches[[conductorBranch]] {1, 1, 1.5}, {0,
0}] /. _RGBColor :> Red,
top}, ViewPoint -> {2, 1, -0.2}]
Завершенное дерево с расположением окончания веток в качестве параметров. Также позволим украшениям на кончиках веток сидеть под наклоном и быть разноцветными.
christmasTree[{{σ1_, τ1_}, {σ2_, τ2_}, {σ3_, τ3_}, {σ4_, τ4_}, {σc_, τc_}},
{{ϕ1_, θ1_}, {ϕ2_, θ2_}, {ϕ3_, θ3_}},
{colBall1_, colBall2_, col5Star_},
conductorEnhancementFactor : fc_,
conductorCandleAngle : ωc_, topRotationAngle : ω_] :=
{{Darker[Brown], stem},
branchOnStemWithBall[#, {σ1, τ1},
colBall1, {ϕ1, θ1}] & /@
allBranches[[voiceBranches[[1]]]],
branchOnStemWithBall[#, {σ2, τ2},
colBall2, {ϕ2, θ2}] & /@
allBranches[[voiceBranches[[2]]]],
branchOnStemWithFiveStar[#, {σ3, τ3}, col5Star,
Pi/4, {ϕ3, θ3}] & /@
allBranches[[voiceBranches[[3]]]],
branchOnStemWithCandle[#, {σ4, τ4},
Directive[White, Glow[GrayLevel[0.3]], Specularity[Yellow, 20]],
0] & /@ allBranches[[voiceBranches[[4]]]],
branchOnStemWithCandle[
allBranches[[conductorBranch]] {1, 1,
1 + fc}, {σc, τc},
Directive[Red, Glow[GrayLevel[0.1]],
Specularity[Yellow, 20]], ωc],
Rotate[top, ω, {0, 0, 1}]
};
Начальное положение всех ветвей и удлиненной ветки дирижера, где ее свеча наклонена.
Graphics3D[christmasTree[{{0, 0}, {0, 0}, {0, 0}, {0, 0}, {0, 0}},
{{0, 0}, {0,0}, {0, 0}}, {Red, Darker[Yellow], Pink}, 0.8, Pi/4, 0],
ImageSize -> 600, ViewPoint -> {3.06, 1.28, 0.27},
PlotRange -> {{-7, 7}, {-7, 7}, {0, 15}}]
Три ели со всеми параметрами, выбранными случайным образом.
SeedRandom[1]
Table[Graphics3D[christmasTree[RandomReal[1.5 {-1, 1}, {5, 2}],
Table[{RandomReal[{-Pi, Pi}], RandomReal[{0, Pi}]}, 3],
RandomColor[3],
RandomReal[], RandomReal[Pi/2], 0], ImageSize -> 200,
ViewPoint -> {3.06, 1.28, 0.27},
PlotRange -> {{-7, 7}, {-7, 7}, {-2, 15}}], {3}] // Row
Следующие интерактивные демонстрации позволяют перемещать ветки, перемещать украшения вокруг окончаний веток и окрашивать украшения по вашему усмотрению.
Manipulate[
Graphics3D[
christmasTree[{στ1, στ2, στ3, στ4, στc},
{ϕθ1, ϕθ2, ϕθ3}, {col1, col2, col3},
l, ωc, ω],
ImageSize -> 400,
ViewPoint -> {2.61, 1.99, 0.80},
PlotRange -> {{-7, 7}, {-7, 7}, {-2, 15}}],
"conductor",
{{l, 0.6, "branch length"}, 0, 1, ImageSize -> Small},
{{ωc, Pi/4, "candle angle"}, 0, Pi, ImageSize -> Small},
{{στc, {0, 0}, "movement"}, {-1, -1}, {1, 1},
ImageSize -> Small},
Delimiter,
"voice 1 (balls)",
Grid[{{"movement", "ornament"},
{Control[{{στ1, {0, 0}, ""}, {-1, -1}, {1, 1},
ImageSize -> Small}],
Control[{{ϕθ1, {0, 0}, ""}, {-Pi, 0}, {Pi, Pi},
ImageSize -> Small}]}}],
{{col1, Red, ""}, Red, ImageSize -> Tiny},
Delimiter,
"voice 2 (balls)",
Grid[{{"movement", "ornament"},
{Control[{{στ2, {0, 0}, ""}, {-1, -1}, {1, 1},
ImageSize -> Small}],
Control[{{ϕθ2, {0, 0}, ""}, {-Pi, 0}, {Pi, Pi},
ImageSize -> Small}]}}],
{{col2, Darker[Yellow], ""}, Red, ImageSize -> Tiny},
Delimiter,
"voice 3 (5-star)",
Grid[{{"movement", "ornament"},
{Control[{{στ3, {0, 0}, ""}, {-1, -1}, {1, 1},
ImageSize -> Small}],
Control[{{ϕθ3, {0, 0}, ""}, {-Pi, 0}, {Pi, Pi},
ImageSize -> Small}]}}],
{{col3, Pink, ""}, Red, ImageSize -> Tiny},
Delimiter,
"voice 4 (white candles)",
Control[{{στ4, {0, 0}, "movement"}, {-1, -1}, {1, 1},
ImageSize -> Small}],
Delimiter,
Delimiter,
{{ω, 0, "top rotation"}, 0, 1, ImageSize -> Small},
ControlPlacement -> Left, SaveDefinitions -> True]
От музыки к движению
Итак, теперь, когда я закончил изготовлением параметризованной рождественской елки с подвижными ветками и украшениями, я должен заняться соотношением музыки к движениям веток (и, в свою очередь, украшений).
Получите 4 голоса как звук
Используйте MIDI-файл песни.
{ohTannenBaum // Head, ohTannenBaum // ByteCount}{Sound, 287816}
Извлеките 4 голоса.
voices = AssociationThread[{"Soprano", "Alto", "Tenor", "Bass"},
ImportString[
ExportString[ohTannenBaum, "MIDI"], {"MIDI", "SoundNotes"}]];
Sound[Take[#, 10]] & /@ voices
Голос в частоту
frequencyRules = <|"A1" -> 55., "A2" -> 110., "A3" -> 220.,
"A4" -> 440., "B1" -> 61.74, "B2" -> 123.5, "B3" -> 246.9,
"B4" -> 493.9, "C2" -> 65.41, "C3" -> 130.8, "C4" -> 261.6,
"C5" -> 523.3, "D2" -> 73.42, "D#4" -> 311.13, "D4" -> 293.7,
"D5" -> 587.3, "E2" -> 82.41, "E4" -> 329.6, "E5" -> 659.3,
"F#2" -> 92.50, "F#4" -> 370.0, "G2" -> 98.00, "G#4" -> 415.3,
"G4" -> 392.0|>;
{minf, maxf} = MinMax[frequencyRules]{55., 659.3}
Временной график первого голоса.
pw[t_] = Piecewise[{frequencyRules[#1], #2[[1]] <= t <= #2[[2]]} & @@@
voices[[1]]];
Plot[pw[t], {t, 0, 100}, PlotRange -> {200, All}, Filling -> Axis,
PlotLabel -> "Soprano",
Frame -> True, FrameLabel -> {"time in sec", "frequency in Hz"},
AxesOrigin -> {0, 200}]
Для представления частот в движениях я сглажу кривые.
spline = BSplineFunction[Table[{t, pw[t]}, {t, 0, 100, 0.5}],
SplineDegree -> 2]
ParametricPlot[spline[t], {t, 0, 100}, AspectRatio -> 0.5,
PlotPoints -> 1000]
tMax = 100;
Do[
With[{j = j},
pwf[j][t_] =
Piecewise[{frequencyRules[#1], #2[[1]] <= t <= #2[[2]]} & @@@
voices[[j]]];
splineFunction[j] =
BSplineFunction[Table[{t, pwf[j][t]}, {t, 0, 100, 0.5}],
SplineDegree -> 2];
voiceFunction[j][t_Real] :=
If[0 < t < tMax, splineFunction[j][t/tMax][[2]]/maxf, 0]],
{j, 4}]Частоты четырех голосов.
Plot[Evaluate[Reverse@Table[pwf[j][t], {j, 4}]], {t, 0, 100},
Frame -> True, FrameLabel -> {"time in sec", "frequency in Hz"},
AspectRatio -> 0.3]
Сглаженные масштабированные частоты четырех голосов.
Plot[Evaluate[Table[voiceFunction[j][t], {j, 4}]], {t, 0, 100},
Frame -> True, FrameLabel -> {"time in sec", "scaled frequency"},
AspectRatio -> 0.3]
Вот график (сглаженных) первых трех голосов в 3D.
ParametricPlot3D[{voiceFunction[1][t], voiceFunction[2][t],
voiceFunction[3][t]}, {t, 0, 100}, AspectRatio -> Automatic,
PlotPoints -> 1000, BoxRatios -> {1, 1, 1}]
Show[% /. Line[pts_] :> Tube[pts, 0.002],
Method -> {"TubePoints" -> 4}]
Получить закономерность колебания
Привязка к определенным фразам для создания всех отбиваний такта.
{firstBeat, secondBeat, lastBeat} =
voices["Soprano"][[{1, 2, -1}, 2, 1]]{1.33522, 2.00568, 98.7727}
anchorDataOChristmasTree = SequenceCases[
voices["Soprano"],
(* pattern for "O Christmas Tree, O Christmas Tree..." *)
{
SoundNote["D4", {pickupStart_, _}, "Trumpet", ___],
SoundNote["G4", {beatOne_, _}, "Trumpet", ___],
SoundNote["G4", {_, _}, "Trumpet", ___],
SoundNote["G4", {beatTwo_, _}, "Trumpet", ___],
SoundNote["A4", {beatThree_, _}, "Trumpet", ___],
SoundNote["B4", {beatFour_, _}, "Trumpet", ___],
SoundNote["B4", {_, _}, "Trumpet", ___],
SoundNote["B4", {beatFive_, _}, "Trumpet", ___]
} :> <|
"PhraseName" -> "O Christmas Tree",
"PickupBeat" -> pickupStart,
"TargetMeasureBeats" -> {beatOne, beatTwo, beatThree},
"BeatLength" ->
Mean@Differences[{pickupStart, beatOne, beatTwo, beatThree,
beatFour, beatFive}]
|>
];
anchorDataYourBoughsSoGreen = SequenceCases[
voices["Soprano"],
(* "Your boughs so green in summertime..." *)
{
SoundNote["D5", {pickupBeatAnd_, _}, "Trumpet", ___],
SoundNote["D5", {beatOne_, _}, "Trumpet", ___],
SoundNote["B4", {_, _}, "Trumpet", ___],
SoundNote["E5", {beatTwo_, _}, "Trumpet", ___],
SoundNote["D5", {beatThreeAnd_, _}, "Trumpet", ___],
SoundNote["D5", {beatFour_, _}, "Trumpet", ___],
SoundNote["C5", {_, _}, "Trumpet", ___],
SoundNote["C5", {beatFive_, _}, "Trumpet", ___]
} :> With[
{
(* the offbeat nature of this phrase requires some manual work
to get things lined up in terms of actual beats *)
pickupBeatStart = pickupBeatAnd - (beatOne - pickupBeatAnd),
beatThree = beatThreeAnd - (beatFour - beatThreeAnd)
},
<|
"PhraseName" -> "Your boughs so green in summertime",
"PickupBeat" -> pickupBeatStart,
"TargetMeasureBeats" -> {beatOne, beatTwo, beatThree},
"BeatLength" ->
Mean@Differences[{pickupBeatStart, beatOne, beatTwo, beatThree,
beatFour, beatFive}]
|>
]
];
anchorData0 =
Join[anchorDataOChristmasTree, anchorDataYourBoughsSoGreen] //
SortBy[#PickupBeat &];
meanBeatLength = Mean[anchorData0[[All, "BeatLength"]]];
(* add enough beats to fill the end of the song, which ends on beat 2 *)
anchorData =
Append[anchorData0, <|
"TargetMeasureBeats" -> (lastBeat + {-1, 0, 1}*
Last[anchorData0]["BeatLength"]),
"BeatLength" -> Last[anchorData0]["BeatLength"]|>];
anchorData =
Append[anchorData, <|
"TargetMeasureBeats" -> (lastBeat + ({-1, 0, 1} + 3)*
Last[anchorData]["BeatLength"]),
"BeatLength" -> Last[anchorData]["BeatLength"]|>];Интерполируйте ритм между и во время фраз:
interpolateAnchor = Apply[
Function[{currentAnchor, nextAnchor},
With[
{targetMeasureLastBeat =
Last[currentAnchor["TargetMeasureBeats"]],
nextMeasureFirstBeat =
First[nextAnchor["TargetMeasureBeats"]]},
DeleteDuplicates@Join[
currentAnchor["TargetMeasureBeats"],
Range[targetMeasureLastBeat,
nextMeasureFirstBeat - currentAnchor["BeatLength"]/4.,
Mean[{currentAnchor["BeatLength"], nextAnchor["BeatLength"]}]]]
]]];
measureBeats = Flatten@BlockMap[interpolateAnchor, anchorData, 2, 1];
measureBeats // Length144
Ритм незначительно меняется, и, если не принимать во внимание вышеописанный метод привязки, это может привести к фазированию между движением и звуком:
Histogram[Differences[measureBeats], PlotTheme -> "Detailed", PlotRange -> Full]
(* add pickup beat at start *)
swayControlPoints =
Prepend[Join @@ (Partition[measureBeats, 3, 3, 1, {}] //
MapIndexed[
Function[{times, index}, {#, (-1)^(Mod[index[[1]], 2] + 1)} & /@
times]]), {firstBeat, -1}];
swayControlPointPlot =
ListPlot[swayControlPoints, Joined -> True, Mesh -> All,
AspectRatio -> 1/6, PlotStyle ->
{Darker[Purple]}, PlotTheme -> "Detailed",
MeshStyle -> PointSize[0.008], ImageSize -> 600,
Epilog -> {Darker[Green], Thick,
InfiniteLine[{{#, -1}, {#, 1}}] & /@ {firstBeat, secondBeat,
lastBeat}}];
sway = BSplineFunction[
Join[{{0, 0}},
Select[swayControlPoints, #[[1]] < tMax &], {{100, 0}}],
SplineDegree -> 3];
sh = Show[{swayControlPointPlot,
ParametricPlot[sway[t], {t, 0, tMax}, PlotPoints -> 2500]}]
{Show[sh, PlotRange -> {{0, 10}, All}], Show[sh, PlotRange -> {{90, 105}, All}]}
Теперь небольшое отступление: Интерполяция с B-сплайнами дает приятные гладкие кривые. В отличие от Interpolation, фактические данные не находятся на результирующей кривой. Это выглядит красиво и гладко, и это то, что мы хотим для визуальных целей этой анимации. Но интерполяция — для пары точек. Это означает, что для данного аргумента (между 0 и 1) функции B-сплайна мы не получаем линейную интерполяцию по первому аргументу. В место этого, нужно инвертировать интерполяцию, чтобы получить время как функцию переменной параметра интерполяции. Принимая во внимание этот эффект, важно правильно согласовать музыку с движениями веток.
swayTimeCoordinate = Interpolation[Table[{t, sway[t/100][[1]]}, {t, 0, 100, 0.1}], InterpolationOrder -> 1]
Этот график показывает разницу между интерполяцией и измененным параметром функции B-сплайна.
Plot[swayTimeCoordinate[t] - t, {t, 0, 100}]
swayOfTime[t_] := sway[swayTimeCoordinate[t]/100][[2]]
Plot[swayOfTime[t], {t, 0, 10}]
Визуализируйте фразы и их отношение к движению с помощью всплывающей подсказки и цветных прямоугольников:
phraseGraphics = BlockMap[
Apply[
Function[{currentAnchor, nextAnchor},
With[
{phraseStart = currentAnchor["PickupBeat"],
phraseEnd =
nextAnchor["PickupBeat"] - currentAnchor["BeatLength"]},
{Switch[currentAnchor["PhraseName"],
"O Christmas Tree", Opacity[0.25, Gray],
"Your boughs so green in summertime",
Opacity[0.25, Darker@Green],
_, Black],
Tooltip[
Polygon[
{{phraseStart, -10}, {phraseStart, 10}, {phraseEnd,
10}, {phraseEnd, -10}}],
Grid[{{currentAnchor["PhraseName"], SpanFromLeft},
{"Phrase Start:", phraseStart}, {"Phrase End:", phraseEnd}
}]]}]]],
Append[anchorData0, <|"PickupBeat" -> lastBeat + meanBeatLength|>],
2, 1];
Show[swayControlPointPlot,
ParametricPlot[sway[t], {t, 0, Last[measureBeats]},
ImageSize -> Full, PlotPoints -> 800, AspectRatio -> 1/8,
PlotTheme -> "Detailed", PlotRangePadding -> Scaled[.02]],
Prolog -> phraseGraphics]
Движения дирижера
Дирижер выполняет простое периодическое движение, синхронизированное с музыкой.
threePatternPoints = {{0, -1}, {-1, -0}, {0, 1}};
threePatternBackground = ListPlot[
MapIndexed[
Callout[#1, StringTemplate["Beat #`` @ ``"][First@#2, #1], Left] &,
threePatternPoints],
PlotTheme -> "Minimal", Axes -> False, AspectRatio -> 1,
PlotStyle -> Directive[Black, PointSize[0.025]],
PlotRange -> {{-2, 0.75}, {-1.5, 1.5}}];
conductorControlTimes = swayControlPoints[[All, 1]];
(* basic conductor control points for interpolation *)
conductorControlPoints =
MapIndexed[{conductorControlTimes[[First[#2]]], #1} &,
Join @@ ConstantArray[RotateRight[threePatternPoints, 1],
Floor@(Length[conductorControlTimes]/3)]];
(* the shape is okay, but not perfect *)
conductor = Interpolation[conductorControlPoints];
(* adding pauses before/after the beat improves the shape of the
curves and makes the beats more obvious *)
conductorControlPointsWithPauses =
Join @@
({# - {meanBeatLength/8., -0.15*
Normalize[
Mean[threePatternPoints] - #[[
2]]]}, #, # + {meanBeatLength/8.,
0.15*Normalize[
Mean[threePatternPoints] - #[[
2]]]}} & /@
conductorControlPoints); На этот раз я использую Interpolation.
conductorWithPauses =
Interpolation[conductorControlPointsWithPauses,
InterpolationOrder -> 5];Вот результирующая форма дирижерской палочки.
Manipulate[
Show[threePatternBackground,
ParametricPlot[
conductorWithPauses[t], {t,
Max[firstBeat,(*tmax-2*meanBeatLength*)0], tmax},
PerformanceGoal -> "Quality"],
Epilog -> {Red, PointSize[Large], Point[conductorWithPauses[tmax]]},
ImageSize -> Large], {{tmax, lastBeat, "t"}, firstBeat + 0.0001,
lastBeat, Appearance -> "Labeled"},
SaveDefinitions -> True]
Движения веток по отношению к голосам
Существуют различные способы перевода звука в движения ветвей. Мы дадим два варианта: один связанный с частотой звуков, а другой — на основе нот.
Вариант 1
Первый перевод с голоса на 2D движения: вертикальное движение: сглаженная частота горизонтального движения голоса: различие текущей сглаженной частоты голоса до чуть более ранней частоты
δDelay = 0.3;
voiceστ[j_][time_] :=
If[0 < time < tMax,(* smoothing factor *)
Sin[Pi time/tMax]^0.25 {voiceFunction[j][1. time] -
voiceFunction[j][time - δDelay],
voiceFunction[j][1. time]}, {0, 0}]
ParametricPlot[voiceστ[1][t], {t, 0, tMax},
AspectRatio -> 1, PlotRange -> All, Frame -> True, Axes -> False,
PlotStyle -> Thickness[0.002]]
Вариант 2
Первый перевод с голоса на 2D движения: вертикальное движение: заметим изменение горизонтального движения: качание
value = -1;
interpolateDance[{{t1_, t2_}, {t3_, t4_}}, t_] :=
With[{y1 = value, y2 = value = -value},
{{y1, t1 < t < t2}, {((y1 - y2) t - (t3 y1 - t2 y2))/(t2 - t3),
t2 < t < t3}}];
dancingPositionPiecewise[notes : {__SoundNote}] :=
With[{noteTimes =
Cases[notes,
SoundNote[_, times : {startTime_, endTime_}, ___] :> times]},
value = -1;
Quiet[Piecewise[
DeleteDuplicatesBy[
Join @@ BlockMap[interpolateDance[#, t] &, noteTimes, 2, 1],
Last], 0]
]];
tEnd = Max[voices[[All, All, 2]]];
dancingPositions = dancingPositionPiecewise /@ voices;
Plot[Evaluate[KeyValueMap[Legended[#2, #1] &, dancingPositions]], {t,
0, 50},
PlotRangePadding -> Scaled[.05], PlotRange -> {All, {-1, 1}},
ImageSize -> Large, PlotTheme -> "Detailed", PlotLegends -> None]
dancingPositionPiecewiseList = Normal[dancingPositions][[All, 2]];
bsp = BSplineFunction[
Table[Evaluate[{t, dancingPositionPiecewiseList[[2]]}], {t, 0, 100,
0.2}]]ParametricPlot[bsp[t], {t, 0, 1}, AspectRatio -> 1/4,
PlotPoints -> 2000]
Do[voiceIF[j] =
BSplineFunction[
Table[Evaluate[{t, dancingPositionPiecewiseList[[j]]}], {t, 0, 100,
0.2}]],
{j, 4}]
Do[With[{j = j},
voiceTimeCoordinate[j] =
Interpolation[Table[{t, voiceIF[j][t/100][[1]]}, {t, 0, 100, 0.1}],
InterpolationOrder -> 1]],
{j, 4}]Окончательные движения концов веток с квадратом σ-τ [-1,1] * [- 1,1].
Clear[voiceστ];
voiceστ[j_][time_] :=
If[0 < time < tMax,(* smoothing factor *) Sin[Pi time/tMax]^0.25*
{sway[swayTimeCoordinate[time]/tMax][[2]],
voiceIF[j][voiceTimeCoordinate[j][time]/tMax][[2]]}, {0, 0}]
Table[ListPlot[Table[ voiceστ[j][t], {t, 0, 105, 0.01}],
Joined -> True, AspectRatio -> 1,
PlotStyle -> Thickness[0.002]], {j, 4}]
Моделирование движений украшений
Теперь настало время (наконец) немного поработать с физикой. Украшения (шарик, пятиконечная звезда) я буду моделировать как вынужденный сферический маятник с трением. Форсирование реализуется через положение кончиков веток, которое, в свою очередь, происходит от voiceστ [j] [time].
Вынужденный сферический маятник
Сформируем Лагранжиан вынужденного сферического маятника в сферических координатах.
Clear[r, ρ, R, X, Y, Z]
R[t_] := {X[t], Y[t], Z[t]}
r[t_] := R[t] +
L {Cos[ϕ[t]] Sin[θ[t]],
Sin[ϕ[t]] Sin[θ[t]], -Cos[θ[t]]}
ℒ = 1/2 r'[t].r'[t] - g r[t][[3]]-g (-L Cos[θ[t]] + Z[t]) + 1/2 ((Derivative[1][Z][t] + L Sin[θ[t]] Derivative[1][θ][t])^2 + (Derivative[ 1][Y][t] + L Cos[θ[t]] Sin[ϕ[t]] Derivative[1][θ][t] + L Cos[ϕ[t]] Sin[θ[t]] Derivative[1][ϕ][ t])^2 + (Derivative[1][X][t] + L Cos[θ[t]] Cos[ϕ[t]] Derivative[1][θ][t] — L Sin[θ[t]] Sin[ϕ[t]] Derivative[1][ϕ][t])^2)
Добавим функцию диссипации Рэлея ℱ для учета трения.
ℱ = 1/2 (\[ScriptF]ϕ ϕ'[t]^2 + \[ScriptF]θ θ'[t]^2);
eoms = {D[D[ℒ, ϕ'[t]], t] -
D[ℒ, ϕ[t]] == -D[ℱ, ϕ'[t]],
D[D[ℒ, θ'[t]], t] -
D[ℒ, θ[t]] == -D[ℱ, θ'[
t]]} // Simplify{([ScriptF]ϕ + L^2 Sin[2 θ[t]] Derivative[1][θ][t]) Derivative[ 1][ϕ][t] + L Sin[θ[t]] (-Sinϕ[t]t] + Cos[ϕ[t][t] + L Sinθ[t][t]) == 0, [ScriptF]θ Derivative[1][θ][t] + L (g Sin[θ[t]] — L Cos[θ[t]] Sin[θ[t]] Derivative[1][ϕ][t]^2 + Cos[θ[t]] Cosϕ[t]t] + Cos[θ[t]] Sin[ϕ[t]t] + Sin[θ[t][t] + L (θ^′′)[t]) == 0}
Пример, показывающий, что колебания быстро затухают с соответствующими значениями параметра [ScriptF] φ, [ScriptF] θ.
paramRules = { g -> 10,
L -> 1, \[ScriptF]ϕ -> 1, \[ScriptF]θ -> 1};
In[126]:= X[t_] := If[2 Pi < t < 4 Pi, 8 Cos[t], 8];
Y[t_] := If[2 Pi < t < 4 Pi, 4 Sin[t], 0];
Z[t_] := 0;
nds = NDSolve[{eoms /. paramRules, ϕ[0] == 1, ϕ'[0] ==
0, θ[0] == 0.001, θ'[0] == 0},
{ϕ, θ}, {t, 0, 20}, PrecisionGoal -> 3, AccuracyGoal -> 3] 
Plot[Evaluate[{\[Phi][t], \[Theta][t]} /. nds[[1]]], {t, 0,
nds[[1, 2, 2, 1, 1, 2]]}, PlotRange -> All]
Graphics3D[
Table[With[{P = r[t] - R[t] /. nds[[1]] /. paramRules}, {Black,
Sphere[{0, 0, 0}, 0.02], Gray, Cylinder[{{0, 0, 0}, P}, 0.005],
Darker[Blue], Sphere[P, 0.02]}],
{t, 0, 20, 0.05}], PlotRange -> All]
Рассчитать движения украшений
Получите направление δ и τ точек окончаний веток, интерполированных как функцию времени.
branchToVoice =
Association[
Flatten[Function[{v, bs}, (# -> v) & /@ bs] @@@
Normal[voiceBranches]]]<|2 -> 1, 9 -> 1, 14 -> 1, 17 -> 1, 19 -> 1, 24 -> 1, 27 -> 1, 3 -> 2, 13 -> 2, 15 -> 2, 16 -> 2, 21 -> 2, 26 -> 2, 1 -> 3, 4 -> 3, 5 -> 3,
12 -> 3, 18 -> 3, 20 -> 3, 6 -> 4, 8 -> 4, 10 -> 4, 11 -> 4, 22 -> 4, 23 -> 4, 25 -> 4|>
tValues = Table[1. t , {t, -5, 110, 0.1}];
Do[στValues =
Table[voiceστ[j][t] , {t, -5, 110, 0.1}];
ifσ[j] =
Interpolation[
Transpose[{tValues, στValues[[All, 1]]}]];
ifτ[j] =
Interpolation[
Transpose[{tValues, στValues[[All, 2]]}]],
{j, 4}]Вычислите движение украшений, смоделированных как сферический маятник. Чтобы получить некоторые изменения в передвижениях, я использую небольшие случайные отклонения от вертикали в качестве начальных условий для украшений (моделирование некоторых случайных движений теплового воздуха).
Для временного диапазона во второй половине я использую другую амплитуду (соответствующую более громкой музыке) для амплитуд усиления.
changeTimeList = {17.6, 42.2, 66.8, 83.1};
loudness[t_] :=
With[{λ1 = 0.2, λ2 = 0.8, δt = 1.5},
Which[t <= changeTimeList[[3]] - δt, λ1,
changeTimeList[[3]] - δt <= t <=
changeTimeList[[3]] + δt,
λ1 + (λ2 -
1 λ1) (1 -
Cos[Pi (t - (changeTimeList[[
3]] - δt))/(2 δt)])/2,
changeTimeList[[3]] + δt <= t <=
changeTimeList[[4]] - δt , λ2,
changeTimeList[[4]] - δt <= t <=
changeTimeList[[4]] + δt,
λ1 + (λ2 -
1 λ1) (1 +
Cos[Pi (t - (changeTimeList[[
4]] - δt))/(2 δt)])/2,
t >= changeTimeList[[3]] + 1.5, λ1]
]
Plot[loudness[t], {t, 1, 100}, AxesOrigin -> {0, 0}, PlotRange -> All]
Off[General::stop];
SeedRandom[111];
Monitor[
Do[
branchEnd[j, {σ_, τ_}] =
branchOnStemEndPoint[ allBranches[[j]], {τ, σ}];
If[j =!= conductorBranch,
With[{v = branchToVoice[j]},
tipPosition[t_] =
branchEnd[j, loudness[t] {ifσ[v][t], ifτ[v][t]}]];
{X[t_], Y[t_], Z[t_] } = tipPosition[t];
paramRules = { g -> 20,
L -> 1, \[ScriptF]ϕ -> 1, \[ScriptF]θ -> 1};
While[ Check[
pendulumϕθ[j][t_] =
NDSolveValue[{eoms /. paramRules,
ϕ[0] == RandomReal[{-Pi, Pi}], ϕ'[0] ==
0.01 RandomReal[{-1, 1}],
θ[0] == 0.01 RandomReal[{-1, 1}], θ'[0] ==
0.01 RandomReal[{-1, 1}]},
{ϕ[t], θ[t]}, {t, 0, 105}, PrecisionGoal -> 4,
AccuracyGoal -> 4,
MaxStepSize -> 0.01, MaxSteps -> 100000, Method -> "BDF"];
False, True]] // Quiet],
{j, Length[allBranches]}], j]Вот сферические координатные углы для случайно выбранного украшения. Мы видим увеличение амплитуды колебаний при включении громкой музыки.
Plot[pendulum\[Phi]\[Theta][51][t][[2]], {t, 0, 105},
AspectRatio -> 1/4, PlotRange -> All]
Танцующая рождественская елка
Добавим несколько цветов для пятиконечных звездочек.
SeedRandom[11];
Do[randomColor[j] = RandomColor[];
randomAngle[j] = RandomReal[{-Pi/2, Pi/2}],
{j, Length[allBranches]}]Быстрое вертикальное начало и медленное окончание движений дирижера.
conductorστ[t_] :=
Piecewise[
{{{0, 0},
t <= firstBeat/
2}, {(t - firstBeat/2)/(firstBeat/2) conductorControlPointsWithPauses[[
1, 2]], firstBeat/2 < t <= firstBeat}, {conductorWithPauses[t],
firstBeat < t <=
lastBeat}, {(tMax - t)/(tMax -
lastBeat) conductorControlPointsWithPauses[[-1, 2]],
lastBeat < t < tMax},
{{0, 0}, t >= tMax}}]Начало движения дирижера.
ListPlot[{Table[{t, conductorστ[t][[1]]}, {t, -1, 3, 0.01}],
Table[{t, conductorστ[t][[2]]}, {t, -1, 3, 0.01}]},
PlotRange -> All, Joined -> True]
With[{animationType = 2},
scalefactors[1][t_] :=
Switch[animationType, 1, {0.8, 1} , 2, loudness[t]];
scalefactors[2][t_] :=
Switch[animationType, 1, {1, 1} , 2, loudness[t]];
scalefactors[3][t_] :=
Switch[animationType, 1, {1, 1} , 2, loudness[t]];
scalefactors[4][t_] :=
Switch[animationType, 1, {1, 1} , 2, loudness[t]]
]
christmasTreeWithSwingingOrnaments[t_,
conductorEnhancementFactor : fc_,
conductorCandleAngle : ωc_, topRotationAngle : ω_,
opts___] :=
Graphics3D[{{Darker[Brown], stem},
(* first voice *)
branchOnStemWithBall[allBranches[[#]],
scalefactors[1][t] voiceστ[1][t],
Darker[Yellow, -0.1],
If[t < 0, {0, 0}, pendulumϕθ[#][t]]] & /@
voiceBranches[[1]],
(* second voice *)
branchOnStemWithBall[allBranches[[#]],
scalefactors[2] [t] voiceστ[2][t],
Blend[{Red, Pink}],
If[t < 0, {0, 0}, pendulumϕθ[#][t]]] & /@
voiceBranches[[2]],
(* third voice *)
branchOnStemWithFiveStar[allBranches[[#]],
scalefactors[3][t] voiceστ[3][t], randomColor[#],
Pi/4, If[t < 0, {0, 0}, pendulumϕθ[#][t]]] & /@
voiceBranches[[3]],
(* fourth voice *)
branchOnStemWithCandle[#,
scalefactors[4][t] voiceστ[4][t],
Directive[White, Glow[GrayLevel[0.3]], Specularity[Yellow, 20]],
0] & /@ allBranches[[voiceBranches[[4]]]],
(* conductor *)
branchOnStemWithCandle[
allBranches[[conductorBranch]] {1, 1, 1 + fc},
conductorστ[t],
Directive[Red, Glow[GrayLevel[0.1]],
Specularity[Yellow, 20]], ωc],
Rotate[top, ω, {0, 0, 1}]
}, opts, ViewPoint -> {2.8, 1.79, 0.1},
PlotRange -> {{-8, 8}, {-8, 8}, {-2, 15}},
Background -> RGBColor[0.998, 1., 0.867] ]Используйте низкую точку зрения, поскольку деревья обычно выше людей.
Show[christmasTreeWithSwingingOrnaments[70, 0.5, 0.8, 2],
PlotRange -> All, Boxed -> False]
Пусть идет снег!
Немного снега является обязательным для классического (белого) Рождества. Итак, давайте построим несколько 3D-снежинок, а затем заставим их падать. Вместо того, чтобы решать PDE (http://psoup.math.wisc.edu/papers/h3l.pdf), мы будем использовать клеточные автоматы на гексагональных сетках для создания некоторых форм, похожих на снежинки, с гексагональной симметрией.
Снежинки (2D)
Давайте возьмем какой-то код из демонстрации Эд Пегга «Снежинки-подобные шаблоны». Я просто импортирую ноутбук и программно извлекаю соответствующие ячейки, которые определяют переменные hex и snowflake.
ReleaseHold /@ (MakeExpression[#[[1]], StandardForm] & /@
Take[Cases[
Import["http://demonstrations.wolfram.com/downloadauthornb.cgi?\
name=SnowflakeLikePatterns"], Cell[_, "Input", ___], ∞], 2]);
makeSnowflake[rule_, steps_] :=
Polygon[hex[#] & /@ Select[Position[Reverse[CellularAutomaton[
{snowflakes[[
rule]], {2, {{0, 2, 2}, {2, 1, 2}, {2, 2, 0}}}, {1,
1}}, {{{1}},
0}, {{{steps}}, {-steps, steps}, {-steps, steps}}]],
0], -steps - 1 < -#[[1]] + #[[2]] < steps + 1 &]]
SeedRandom[33];
Table[Graphics[{Darker[Blue],
makeSnowflake[RandomInteger[{1, 3888}],
RandomInteger[{10, 60}]]}], {4}]
Поскольку некоторые снежинки не работают, я выбираю те, которые интересны. Меня интересуют только снежинки, которые достаточно сложны.
denseFlakeQ[mr_MeshRegion] :=
With[{c = RegionCentroid[mr], pts = MeshCoordinates[mr]},
( Divide @@ MinMax[EuclideanDistance[c, #] & /@ pts]) < 1/3]
randomSnowflakes[] :=
Module[{sf},
While[(sf = Module[{},
TimeConstrained[
hexagons =
makeSnowflake[RandomInteger[{1, 3888}],
RandomInteger[{10, 60}]];
(Select[ConnectedMeshComponents[DiscretizeRegion[hexagons]],
(Area[#] > 120 && Perimeter[#]/Area[#] < 2 &&
denseFlakeQ[#]) &] /.
\
_ConnectedMeshComponents :> {}) // Quiet, 20, {}]]) === {}]; sf]
randomSnowflakes[n_] :=
Take[NestWhile[Join[#, randomSnowflakes[]] &, {}, Length[#] < n &], n]
SeedRandom[22];
randomSnowflakes[4]
normalizeFlake[mr_MeshRegion] :=
Module[{coords, center, coords1, size, coords2},
coords = MeshCoordinates[mr];
center = Mean[coords];
coords1 = (# - center) & /@ coords;
size = Max[Norm /@ coords1];
coords2 = coords1/size;
GraphicsComplex[coords2, {EdgeForm[], MeshCells[mr, 2]}]]Вот пять снежинок для дальнейшего использования.
Снежинки (3D)
Я добавляю эффект 2D снежинкам, дающий плоским телам иллюзию трёхмерности путём добавления к ним дополнительных поверхностей, чтобы получить 3D снежинки.
make3DFlake[flake2D_] :=
Module[{grc, reg, boundary, h, bc, rb, polys, pts},
grc = flake2D[[1]];
reg = MeshRegion @@ (grc /. _EdgeForm :> Nothing);
boundary = (MeshPrimitives[#, 1] &@RegionBoundary[reg])[[All, 1]];
h = RandomReal[{0.05, 0.15}];
bc =
Join[#1, Reverse[#2]] & @@@
Transpose[{Map[Append[#, 0] &, boundary, {-2}],
Map[Append[#, h] &, boundary, {-2}]}];
rb = RegionBoundary[reg];
boundary = (MeshCells[#, 1] &@rb)[[All, 1]];
polys =
Polygon[Join[#1, Reverse[#2]] & @@@
Transpose[{boundary, boundary + Max[boundary]}]];
pts =
Join[Append[#, 0] & /@ MeshCoordinates[rb],
Append[#, h] & /@ MeshCoordinates[rb]];
{GraphicsComplex[Developer`ToPackedArray[pts], polys],
MapAt[Developer`ToPackedArray[Append[#, 0]] & /@ # &, flake2D[[1]],
1],
MapAt[Developer`ToPackedArray[Append[#, h]] & /@ # &, flake2D[[1]],
1]}
]
listOfSnowflakes3D = make3DFlake /@ listOfSnowflakes;
Graphics3D[{EdgeForm[], #}, Boxed -> False,
Method -> {"ShrinkWrap" -> True}, ImageSize -> 120,
Lighting -> {{"Ambient", Hue[.58, .5, 1]}, {"Directional",
GrayLevel[.3], ImageScaled[{1, 1, 0}]}}] & /@ listOfSnowflakes3D
Модель падающего листа
Простая двумерная модель падающих листов была сделана Танабе и Канеко в 1994 году. Поэтому, чтобы получить некоторую интуицию о возможных формах падения, мы реализуем модель как интерактивную демонстрацию.
Manipulate[
Module[{eqs, nds, tmax, g = 10, α, sign, V, x, y, u,
v, θ, ω, kpar = kperp/f, ρ = 10^ρexp},
α = ArcTan[u[t], v[t]];
sign = Piecewise[{{1, (v[t] < 0 &&
0 <= α + θ[t] <= Pi) || (v[t] >
0 && -Pi <= α + θ[t] <= 0)}}, -1];
V = Sqrt[u[t]^2 + v[t]^2];
eqs =
{D[x[t], t] == u[t],
D[y[t], t] == v[t],
D[u[t],
t] == -(kperp Sin[θ[t]]^2 + kpar Cos[θ[t]]^2) u[
t] +
(kperp - kpar) Sin[θ[
t]] Cos[θ[t]] v[t] -
sign Pi ρ V^2 Cos[α + θ[t]] Cos[α],
D[v[t],
t] == -(kperp Cos[θ[t]]^2 + kpar Sin[θ[t]]^2) v[
t] +
(kperp - kpar) Sin[θ[
t]] Cos[θ[t]] u[t] +
sign Pi ρ V^2 Cos[α + θ[
t]] Sin[α] - g,
D[ω[t],
t] == -kperp ω[
t] - (3 Pi ρ V^2/l) Cos[α + θ[
t]] Sin[α + θ[t]],
D[θ[t], t] == ω[t]} /. kpar -> kperp/f;
nds = NDSolve[
Join[eqs, {x[0] == 0, y[0] == 0, u[0] == 0,
v[0] == 0.01, ω[0] == 0, θ[0] == θ0}],
{x, y, u, v, θ, ω}, {t, 0,
T}, MaxSteps -> 2000] // Quiet;
tmax = nds[[1, 2, 2, 1, 1, 2]];
Graphics[{Thickness[0.002], Gray,
Table[Evaluate[
Line[{{x[t], y[t]} - l/2 {Cos[θ[t]], Sin[θ[t]]},
{x[t],
y[t]} + l/2 {Cos[θ[t]], Sin[θ[t]]}}] /.
nds[[1]]],
{t, 0, tmax, tmax/n}],
Blue,
Line[Table[
Evaluate[{x[t], y[t]} /. nds[[1]]], {t, 0, tmax, tmax/200}]]},
AspectRatio -> ar, Frame -> True,
PlotRange -> All]],
"system parameters",
{{kperp, 5.1, Subscript["k", "∟"]}, 0.01, 10,
Appearance -> "Labeled"},
{{f, 145,
Row[{Subscript["k", "∟"], "/",
Subscript["k", "∥"]}]}, 0.01, 200,
Appearance -> "Labeled"},
{{ρexp, -0.45, Log["ρ"]}, -3, 1, Appearance -> "Labeled"},
{{l, 0.63}, 0.01, 10, Appearance -> "Labeled"} ,
Delimiter,
"fall parameters",
{{θ0, 1, Subscript["θ", "0"]}, -Pi, Pi,
Appearance -> "Labeled"},
{{T, 2, "falling time"}, 0, 10, Appearance -> "Labeled"} ,
Delimiter,
"plot",
{{ar, 1, "aspect ratio"}, {1, Automatic}},
{{n, 200, "snapshots"}, 2, 500, 1}]
Я буду моделировать процесс падения феноменологически и эвристически, а не через решение дифференциальных уравнений. Со значениями плотности снежинок и воздуха вместе с их отношением толщина / площадь они падают в основном прямо вниз, с небольшими боковыми движениями и внутренними вращениями.
Падение снежинок
Моделируем внутренние вращения вокруг центра масс, а также некоторые небольшие боковые движения.
randomParametrizedRotationMatrix[n_, τ_] := Function @@ {τ,
Module[{phi, s, c},
Do[phi[i] =
Sum[RandomReal[{-1, 1}] Sin[
RandomReal[{0, n}] τ + 2 Pi RandomReal[]], {n}];
{c[i], s[i]} = {Cos[phi[i]], Sin[phi[i]]}, {i, 3}];
{{c[1], s[1], 0}, {-s[1], c[1], 0}, {0, 0, 1}}.
{{c[2], 0, s[2]}, {0, 1, 0}, {-s[2], 0, c[2]}}.
{{1, 0, 0}, {0, c[3], s[3]}, {0, -s[3], c[3]}}]};
randomParametrizedPathFunction := Function[t,
Evaluate[{RandomReal[{-5, 5}] +
Sum[RandomReal[{-1, 1}]/# Cos[2 Pi # t] &[
RandomReal[{1, 4}]], {k, 5}],
RandomReal[{-5, 5}] +
Sum[RandomReal[{-1, 1}]/# Cos[2 Pi # t] &[
RandomReal[{1, 4}]], {k, 5}],
RandomReal[{2, 12}] - RandomReal[{1.5, 2.5}] t}]]
SeedRandom[55];
Do[rotMat[j] = randomParametrizedRotationMatrix[3, τ];
trans[j] = randomParametrizedPathFunction;
snowflakeColor[
j] = {{"Ambient",
Hue[RandomReal[{0.55, 0.6}], RandomReal[{0.48, 0.52}],
RandomReal[{0.95, 1}]]}, {"Directional",
GrayLevel[RandomReal[{0.28, 0.32}]],
ImageScaled[{1, 1, 0}]}}, {j, Length[listOfSnowflakes]}]
fallingSnowflake[flake_, {t_, ℛ_}] :=
flake /. GraphicsComplex[cs_, rest__] :>
GraphicsComplex[(ℛ.# + t) & /@ cs, rest]
Manipulate[
Graphics3D[{EdgeForm[],
Table[{Lighting -> snowflakeColor[k],
fallingSnowflake[
listOfSnowflakes3D[[k]], {trans[k][t], rotMat[k][t]}]}, {k,
Length[listOfSnowflakes3D]}] },
PlotRange -> 6, ViewPoint -> {0, -10, 0}, ImageSize -> 400],
{{t, 3.2}, -5, 20}]
Для полной анимации использовалось несколько сотен снежинок.
Создание анимационных кадров
Теперь запустите анимацию, вытянув ветвь дирижера, а также поверните верхнюю часть во время воспроизведения музыки. Затем мы послушаем и рассмотрим один стих. После, мы двинемся один раз вокруг дерева и добавим немного снегопада. И затем приходит интересная часть, где дерево качает вокруг своими украшениями, потом успокаивается и убирает свою ветвь дирижера. Я генерирую 24 кадра для каждой секунды звука.
conductorBranchMaxfactor = 0.5;
conductorBranchLength[t_] :=
conductorBranchMaxfactor*
Which[t < -3, 0, -3 < t <= 0, (t + 3)/3., 0 <= t <= tMax, 1,
tMax < t < tMax + 3, (1 - (t - tMax)/3), True, 0];
topRotation[t_] :=
Which[t < -3 || t > tMax + 3, 0,
True, (1. - Cos[(t + 3)/(tMax + 6)]) 20 2 Pi];
viewPoint[t_] :=
With[{vp = {2.8, 1.79, 0.1}},
Which[t < changeTimeList[[1]] || t > changeTimeList[[2]], vp,
changeTimeList[[1]] <= t <= changeTimeList[[2]],
Module[{t0 = changeTimeList[[1]],
Δt =
changeTimeList[[2]] - changeTimeList[[1]], ωvp},
ωvp = -Pi (1 -
Cos[ Pi (t - t0)/Δt]); {{Cos[ωvp],
Sin[ωvp], 0}, {-Sin[ωvp], Cos[ωvp],
0}, {0, 0, 1}}.vp +
{0, 0, 2 Sin[Pi (t - t0)/Δt]^4 }]]]
ParametricPlot3D[
viewPoint[t], {t, changeTimeList[[1]], changeTimeList[[2]]},
BoxRatios -> {1, 1, 1}]
animationFrame[t_] :=
Show[christmasTreeWithSwingingOrnaments[t, conductorBranchLength[t],
1.4 conductorBranchLength[t], topRotation[t]],
Background -> None, Boxed -> False, SphericalRegion -> True,
ViewPoint -> viewPoint[t]]
Последний тест перед запуском экспорта кадров, который займет несколько часов:
animationFrame[35]
framesPerSecond = 24;
animationFrameDirectory =
"/Users/mtrott/Desktop/ConductingChristmasTreeAnimationFrames/";
Monitor[
Do[
With[{t = -3 + 1/framesPerSecond (frame - 1)}, gr = animationFrame[t];
Export[animationFrameDirectory <> IntegerString[frame, 10, 4] <> ".png", gr,
ImageSize -> 1800, Background -> None]
],
{frame, 1, framesPerSecond (100 + 2 3)}],
Row[{frame, " | ", Round[MemoryInUse[]/1024^2], "\[ThinSpace]MB" }]
]Теперь используйте свое любимое программное обеспечение для редактирования фильмов (например, Adobe After Effects) и поместите движущееся дерево, звук и снегопад вместе.
По вопросам приобретения лицензий обращайтесь info-russia@wolfram.com
Бесплатная триал версия Mathematica
Бесплатный триал Wolfram|One
