Создание рождественской анимации с помощью Wolfram Language

http://community.wolfram.com/groups/-/m/t/1248938
  • Перевод
  • Tutorial


Перевод блога O Tannenbaum Майкла Тротта, директора Wolfram|Alpha.



В этом ноутбуке описывается, как создать анимацию украшенной елки, которая перемещает свои ветви синхронизированно с голосами музыки немецкой песни O Tannenbaum 16-го века (английская версия — O Christmas Tree). Одна выделенная ветвь дерева будет действовать как дирижер, а свеча будет дирижёрской палочкой. Это делает анимацию интересной во всех куплетах. Мы также добавим немного снега и несколько веселых движений дерева во второй половине песни. Чтобы увидеть окончательный дизайн, просмотрите это видео на YouTube:



Я реализую анимацию с помощью следующих этапов:

  1. Построить елку с изогнутыми ветвями, где ветви можно перемещать плавно вверх, вниз, влево и вправо.
  2. Добавить украшения (цветные шарики, пятиконечные звезды) и свечи разного цвета к ветвям. Позволить украшениям перемещаться относительно окончаниям веток.
  3. Преобразовать 4 голоса музыки в 2D-движение на основе частот звука. Смоделировать движения дирижера синхронизированными с музыкой.
  4. Моделировать движения украшений в виде вынужденного сферического маятника. Учет трения орнаментов с использованием диссипативной функции Рэлея.
  5. Добавить снег для белого рождества.
  6. Создать анимацию веток по отношению к музыке.

Особая благодарность моему коллеге Эндрю Штайхачеру за выбор и анализ музыки, чтобы получить данные для движения дерева (ниже раздел «От музыки к движениям»). И благодаря Эми Янг для превращения анимационных кадров и музыки в один видеоклип.

Создание елки


Параметры дерева


Размеры дерева, общая форма дерева и количество ветвей. Названия переменных делают их смысл очевидным.

(* 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 // Length

144

Ритм незначительно меняется, и, если не принимать во внимание вышеописанный метод привязки, это может привести к фазированию между движением и звуком:

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

Wolfram Research

77,08

Wolfram Language, Mathematica, Wolfram Alpha и др.

Поделиться публикацией
Комментарии 4
    +1
    Спасибо за перевод. В очередной раз поражаюсь огромными возможностями и гибкостью языка Wolfram. Хотелось бы узнать, возможно ли в Mathematica выполнить преобразование .waw в midi?
      0
      На сколько я понимаю, это довольно сложный процесс. Вопрос обсуждался на Stackoverflow: stackoverflow.com/questions/2126193/wav-to-midi-conversion
        0
        Ответ инженера:

        I think the answer is No, since they are substantially different types of files. This can be checked with

        In[1]:= Import[«ExampleData/rule30.wav»,«Elements»]
        Out[1]= {Audio,AudioChannels,AudioEncoding,AudioFile,Data,Duration,Length,MetaInformation,SampleDepth,SampledSoundList,
        SampleRate,Sound}
        Import[«ExampleData/rule30.wav», «Sound»]

        In[149]:= Export[«rule30.mid»,%]

        During evaluation of In[149]:= Export::nodta: Sound[SampledSoundList[{{0.,-0.0078125,-0.0078125,-0.015625,-0.015625,-0.0078125,-0.0078125,-0.0078125,-0.0078125,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,-0.0078125,-0.0078125,-0.0078125,-0.0078125,-0.0078125,-0.0078125,0.,0.,0.,-0.0078125,-0.0078125,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.,0.00781274,0.00781274,0.00781274,0.00781274,0.,0.,0.,0.,<<79330>>}},44100]] contains no data that can be exported to the MIDI format.
        Out[149]= $Failed

        In[150]:= Import[«ExampleData/rule30.wav»]

        In[151]:= Export[«rule30.mid»,%]

        During evaluation of In[151]:= Export::nodta: Audio[RawArray[Data Type: Integer16
        Dimensions: {1,79380}], SignedInteger16,Appearance->Automatic,AudioOutputDevice->Automatic,SampleRate->44100, SoundVolume->1] contains no data that can be exported to the MIDI format.
        Out[151]= $Failed

        The nature of the two files is quite different. WAV files are for storing Audio information and are expressed as Sound[SampledSoundList[...]] whereas MIDI files are for storing the individual SoundNotes that provide information about the actual notes, their duration and the instruments they are played upon. In short MIDI files can be converted into Music scores whereas WAV files are digital Audio representations. So one can take MIDI files that contain score information and convert them to Audio files as in

        In[1]:= Import[«ExampleData/scaleprogression.mid»]

        In[2]:= Export[«scaleprogression.wav»,%]
        Out[2]= scaleprogression.wav

        But it is very difficult to go the other way, from the SampledSoundList to it's musical score representation. I don't know of any programs that do this, but I haven't looked into it for a number of years when I used to use the music program Sibelius. In fact the mapping from sound to score would only be a one-to-one mapping if there is one or a few Audio Channels but is more likely to be one-to-many or injective for a large number of channels because the same or similar sound could be represented by a number of different scores where multiple orchestrations result in very similar sounds.
        0
        del

        Только полноправные пользователи могут оставлять комментарии. Войдите, пожалуйста.

        Самое читаемое