Перевод блога 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", "L"]}, 0.01, 10, 
  Appearance -> "Labeled"},
 {{f, 145, 
   Row[{Subscript["k", "L"], "/", 
     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

Комментарии (3)


  1. Colorbit
    22.12.2017 23:12

    Спасибо за перевод. В очередной раз поражаюсь огромными возможностями и гибкостью языка Wolfram. Хотелось бы узнать, возможно ли в Mathematica выполнить преобразование .waw в midi?


    1. galinawri Автор
      23.12.2017 00:00

      На сколько я понимаю, это довольно сложный процесс. Вопрос обсуждался на Stackoverflow: stackoverflow.com/questions/2126193/wav-to-midi-conversion


  1. berezuev
    23.12.2017 12:24

    del